diff --git a/Makefile b/Makefile index 4bef498..1556053 100644 --- a/Makefile +++ b/Makefile @@ -1,18 +1,16 @@ # # make file to automate cloning svn externals into the git based cesm repo. # -CAM_SVN = https://svn-ccsm-models.cgd.ucar.edu/cam1/branches/newtesting/models/atm/cam -CISM_SVN = https://svn-ccsm-models.cgd.ucar.edu/glc/branches/newtesting -CICE_SVN = https://svn-ccsm-models.cgd.ucar.edu/cice/branches/newtesting -CLM_SVN = https://svn-ccsm-models.cgd.ucar.edu/clm2/branches/newtesting/models/lnd/clm -POP_SVN = https://svn-ccsm-models.cgd.ucar.edu/pop2/branches/newtesting -RTM_SVN = https://svn-ccsm-models.cgd.ucar.edu/rivrtm/branches/newtesting -PIO_SVN = https://parallelio.googlecode.com/svn/trunk_tags/pio1_9_10/pio -WW3_SVN = https://svn-ccsm-models.cgd.ucar.edu/ww3/branches/newtesting - -# arbitrary starting point to speed up clones -SVN_HIST=65000 -GIT_SVN_CLONE = git svn clone --no-follow-parent --no-minimize-url -r$(SVN_HIST):HEAD + +CAM_SVN := $(shell perl -ne 'next LINE unless /^(.*)\s+(.*cam1.*)/; print "$$2 $$1"' SVN_EXTERNAL_DIRECTORIES) +CISM_SVN :=$(shell perl -ne 'next LINE unless /^(.*)\s+(.*u\/glc.*)/; print "$$2 $$1"' SVN_EXTERNAL_DIRECTORIES) +CICE_SVN :=$(shell perl -ne 'next LINE unless /^(.*)\s+(.*u\/cice.*)/; print "$$2 $$1"' SVN_EXTERNAL_DIRECTORIES) +CLM_SVN := $(shell perl -ne 'next LINE unless /^(.*)\s+(.*clm2.*)/; print "$$2 $$1"' SVN_EXTERNAL_DIRECTORIES) +POP_SVN := $(shell perl -ne 'next LINE unless /^(.*)\s+(.*u\/pop2.*)/; print "$$2 $$1"' SVN_EXTERNAL_DIRECTORIES) +RTM_SVN :=$(shell perl -ne 'next LINE unless /^(.*)\s+(.*rivrtm.*)/; print "$$2 $$1"' SVN_EXTERNAL_DIRECTORIES) +PIO_SVN := $(shell perl -ne 'next LINE unless /^(.*)\s+(.*parallelio.*)/; print "$$2 $$1"' SVN_EXTERNAL_DIRECTORIES) +WW3_SVN := $(shell perl -ne 'next LINE unless /^(.*)\s+(.*u\/ww3.*)/; print "$$2 $$1"' SVN_EXTERNAL_DIRECTORIES) + SVN_CO = svn co @@ -20,45 +18,53 @@ SVN_CO = svn co # command using --trunk, --tags, --branches to pull in CESM specific # layout. -CI_GIT = https://github.com/CESM-Development/CoupledInfrastructure.git -MCT_GIT = https://github.com/MCSclimate/MCT.git - +CI_GIT := $(shell perl -ne 'next LINE unless /^(.*)\s+(.*CoupledInfrastructure.*)/; print "$$1 $$2"' SVN_EXTERNAL_DIRECTORIES) +MCT_GIT := $(shell perl -ne 'next LINE unless /^(.*)\s+(.*MCT.*)/; print "$$1 $$2"' SVN_EXTERNAL_DIRECTORIES) +CMAKE_GIT := $(shell perl -ne 'next LINE unless /^(.*)\s+(.*CMake_Fortran.*)/; print "$$1 $$2"' SVN_EXTERNAL_DIRECTORIES) +GPTL_GIT := $(shell perl -ne 'next LINE unless /^(.*)\s+(.*jmrosinski.*)/; print "$$1 $$2"' SVN_EXTERNAL_DIRECTORIES) +default: git-subtrees clone-svn clone-svn : cam-svn cism-svn cice-svn clm-svn pop-svn rtm-svn pio-svn ww3-svn cam-svn : FORCE - $(SVN_CO) $(CAM_SVN) cesm/models/atm/cam + $(SVN_CO) $(CAM_SVN) cism-svn : FORCE - $(SVN_CO) $(CISM_SVN) cesm/models/glc/cism + $(SVN_CO) $(CISM_SVN) cice-svn : FORCE - $(SVN_CO) $(CICE_SVN) cesm/models/ice/cice + $(SVN_CO) $(CICE_SVN) clm-svn : FORCE - $(SVN_CO) $(CLM_SVN) cesm/models/lnd/clm + $(SVN_CO) $(CLM_SVN) pop-svn : FORCE - $(SVN_CO) $(POP_SVN) cesm/models/ocn/pop2 + $(SVN_CO) $(POP_SVN) rtm-svn : FORCE - $(SVN_CO) $(RTM_SVN) cesm/models/rof/rtm + $(SVN_CO) $(RTM_SVN) pio-svn : FORCE - $(SVN_CO) $(PIO_SVN) cesm/models/utils/pio + $(SVN_CO) $(PIO_SVN) ww3-svn : FORCE - $(SVN_CO) $(WW3_SVN) cesm/models/wav/ww3 + $(SVN_CO) $(WW3_SVN) # I think these were just one-off commands that don't have to be # rerun, but I'm putting them here for documentation. -git-subtrees : coupled-infrastructure-git mct-git +git-subtrees : coupled-infrastructure-git mct-git cmake-git gptl-git coupled-infrastructure-git : - git subtree add --prefix cesm $(CI_GIT) master + git subtree add --prefix $(CI_GIT) mct-git : - git subtree add --prefix cesm/models/utils/mct $(MCT_GIT) NagFix_MCT_2.8.3 + git subtree add --prefix $(MCT_GIT) + +cmake-git : + git subtree add --prefix $(CMAKE_GIT) + +gptl-git : + git subtree add --prefix $(GPTL_GIT) # null rule to force things to happen FORCE : diff --git a/SVN_EXTERNAL_DIRECTORIES b/SVN_EXTERNAL_DIRECTORIES new file mode 100644 index 0000000..406a338 --- /dev/null +++ b/SVN_EXTERNAL_DIRECTORIES @@ -0,0 +1,12 @@ +cesm https://github.com/CESM-Development/CoupledInfrastructure/trunk +cesm/models/atm/cam https://svn-ccsm-models.cgd.ucar.edu/cam1/branches/newtesting/models/atm/cam +cesm/models/glc/cism https://svn-ccsm-models.cgd.ucar.edu/glc/branches/newtesting +cesm/models/ice/cice https://svn-ccsm-models.cgd.ucar.edu/cice/branches/newtesting +cesm/models/lnd/clm https://svn-ccsm-models.cgd.ucar.edu/clm2/branches/newtesting/models/lnd/clm +cesm/models/ocn/pop2 https://svn-ccsm-models.cgd.ucar.edu/pop2/branches/newtesting +cesm/models/rof/rtm https://svn-ccsm-models.cgd.ucar.edu/rivrtm/branches/newtesting +cesm/models/utils/mct https://github.com/MCSclimate/MCT/tags/NagFix_MCT_2.8.3 +cesm/models/utils/pio https://parallelio.googlecode.com/svn/trunk_tags/pio1_9_10/pio +cesm/models/wav/ww3 https://svn-ccsm-models.cgd.ucar.edu/ww3/branches/newtesting +cesm/scripts/ccsm_utils/CMake https://github.com/CESM-Development/CMake_Fortran_utils/tags/CMake_Fortran_utils_141210b +cesm/models/utils/timing/gptl https://github.com/jmrosinski/GPTL/tags/v5.4.3 \ No newline at end of file diff --git a/cesm/models/utils/mct/.gitignore b/cesm/models/utils/mct/.gitignore deleted file mode 100644 index 6e04052..0000000 --- a/cesm/models/utils/mct/.gitignore +++ /dev/null @@ -1,9 +0,0 @@ -Makefile.conf -config.log -config.status -config.h -autom4te.cache -*.o -*.mod -lib*.a -data diff --git a/cesm/models/utils/mct/COPYRIGHT b/cesm/models/utils/mct/COPYRIGHT deleted file mode 100644 index 58d0606..0000000 --- a/cesm/models/utils/mct/COPYRIGHT +++ /dev/null @@ -1,51 +0,0 @@ - Modeling Coupling Toolkit (MCT) Software - -Copyright © 2011, UChicago Argonne, LLC as Operator of Argonne National Laboratory. -All rights reserved. - -Redistribution and use in source and binary forms, with or without modification, -are permitted provided that the following conditions are met: - - -1. Redistributions of source code must retain the above copyright notice, this list of conditions - and the following disclaimer. - -2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions - and the following disclaimer in the documentation and/or other materials provided with the distribution. - -3. The end-user documentation included with the redistribution, if any, must include the following - acknowledgment: - - "This product includes software developed by the UChicago Argonne, LLC, as Operator of Argonne - National Laboratory." - - Alternately, this acknowledgment may appear in the software itself, if and wherever such third-party - acknowledgments normally appear. - -This software was authored by: - -Argonne National Laboratory Climate Modeling Group -Robert Jacob, tel: (630) 252-2983, E-mail: jacob@mcs.anl.gov -Jay Larson, E-mail: larson@mcs.anl.gov -Everest Ong -Ray Loy -Mathematics and Computer Science Division -Argonne National Laboratory, Argonne IL 60439 - - -4. WARRANTY DISCLAIMER. THE SOFTWARE IS SUPPLIED "AS IS" WITHOUT WARRANTY OF ANY KIND. THE COPYRIGHT HOLDER, - THE UNITED STATES, THE UNITED STATES DEPARTMENT OF ENERGY, AND THEIR EMPLOYEES: (1) DISCLAIM ANY - WARRANTIES, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO ANY IMPLIED WARRANTIES OF MERCHANTABILITY, - FITNESS FOR A PARTICULAR PURPOSE, TITLE OR NON-INFRINGEMENT, (2) DO NOT ASSUME ANY LEGAL LIABILITY OR - RESPONSIBILITY FOR THE ACCURACY, COMPLETENESS, OR USEFULNESS OF THE SOFTWARE, (3) DO NOT REPRESENT THAT - USE OF THE SOFTWARE WOULD NOT INFRINGE PRIVATELY OWNED RIGHTS, (4) DO NOT WARRANT THAT THE SOFTWARE WILL - FUNCTION UNINTERRUPTED, THAT IT IS ERROR-FREE OR THAT ANY ERRORS WILL BE CORRECTED. - -5. LIMITATION OF LIABILITY. IN NO EVENT WILL THE COPYRIGHT HOLDER, THE UNITED STATES, THE UNITED STATES - DEPARTMENT OF ENERGY, OR THEIR EMPLOYEES: BE LIABLE FOR ANY INDIRECT, INCIDENTAL, CONSEQUENTIAL, SPECIAL - OR PUNITIVE DAMAGES OF ANY KIND OR NATURE, INCLUDING BUT NOT LIMITED TO LOSS OF PROFITS OR LOSS OF - DATA, FOR ANY REASON WHATSOEVER, WHETHER SUCH LIABILITY IS ASSERTED ON THE BASIS OF CONTRACT, TORT - (INCLUDING NEGLIGENCE OR STRICT LIABILITY), OR OTHERWISE, EVEN IF ANY OF SAID PARTIES HAS BEEN WARNED - OF THE POSSIBILITY OF SUCH LOSS OR DAMAGES. - - diff --git a/cesm/models/utils/mct/Makefile b/cesm/models/utils/mct/Makefile deleted file mode 100644 index 6b5bfe7..0000000 --- a/cesm/models/utils/mct/Makefile +++ /dev/null @@ -1,33 +0,0 @@ - -SHELL = /bin/sh - -include Makefile.conf - -SUBDIRS = $(MPISERPATH) $(MPEUPATH) $(MCTPATH) - -# TARGETS -subdirs: - @set -e; for dir in $(SUBDIRS); do \ - cd $$dir; \ - $(MAKE); \ - cd $(abs_top_builddir); \ - done - -clean: - @set -e; for dir in $(SUBDIRS); do \ - cd $$dir; \ - $(MAKE) clean; \ - cd $(abs_top_builddir); \ - done - -install: subdirs - @set -e; for dir in $(SUBDIRS); do \ - cd $$dir; \ - $(MAKE) install; \ - cd $(abs_top_builddir); \ - done - -examples: subdirs - @cd $(EXAMPLEPATH) && $(MAKE) - - diff --git a/cesm/models/utils/mct/Makefile.conf.in b/cesm/models/utils/mct/Makefile.conf.in deleted file mode 100644 index a65a386..0000000 --- a/cesm/models/utils/mct/Makefile.conf.in +++ /dev/null @@ -1,89 +0,0 @@ -# Source location -SRCDIR = @abs_srcdir@ -FDEPENDS=$(SRCDIR)/fdepends.awk - -# COMPILER, LIBRARY, AND MACHINE MAKE VARIABLES - -# FORTRAN COMPILER VARIABLES # - -# FORTRAN COMPILER COMMAND -FC = @MPIFC@ - -# FORTRAN AND FORTRAN90 COMPILER FLAGS -FCFLAGS = @OPT@ @DEBUG@ @FCFLAGS@ @BIT64@ - -FC_DEFINE = @FC_DEFINE@ - -# FORTRAN COMPILE FLAG FOR AUTOPROMOTION -# OF NATIVE REAL TO 8 BIT REAL -REAL8 = @REAL8@ - -# FORTRAN COMPILE FLAGS FOR EXAMPLE PROGRAMS -PROGFCFLAGS = @PROGFCFLAGS@ - -# FORTRAN COMPILE FLAG FOR CHANGING BYTE ORDERING -ENDIAN = @ENDIAN@ - -# INCLUDE FLAG FOR LOCATING MODULES (-I, -M, or -p) -INCFLAG = @INCLUDEFLAG@ - -# INCLUDE PATHS (PREPEND INCLUDE FLAGS -I, -M or -p) -INCPATH = @INCLUDEPATH@ @MPIHEADER@ - -# MPI LIBRARIES (USUALLY -lmpi) -MPILIBS = @MPILIBS@ - -# PREPROCESSOR VARIABLES # - -# COMPILER AND OS DEFINE FLAGS -CPPDEFS = @CPPDEFS@ - -FPPDEFS=$(patsubst -D%,$(FC_DEFINE)%,$(CPPDEFS)) - -# C COMPILER VARIABLES # - -# C COMPILER -CC = @CC@ - -# C COMPILER FLAGS - APPEND CFLAGS -CFLAGS = @CFLAGS@ -CPPFLAGS = @CPPFLAGS@ - -# LIBRARY SPECIFIC VARIABLES # - -# USED BY MCT BABEL BINDINGS -COMPILER_ROOT = @COMPILER_ROOT@ -BABELROOT = @BABELROOT@ -PYTHON = @PYTHON@ -PYTHONOPTS = @PYTHONOPTS@ - -# USED BY MPI-SERIAL LIBRARY - -# SIZE OF FORTRAN REAL AND DOUBLE -FORT_SIZE = @FORT_SIZE@ - - -# INSTALLATION VARIABLES # - -# INSTALL COMMANDS -INSTALL = @abs_top_builddir@/install-sh -c -MKINSTALLDIRS = @abs_top_builddir@/mkinstalldirs - -# INSTALLATION DIRECTORIES -abs_top_builddir= @abs_top_builddir@ -MCTPATH = @abs_top_builddir@/mct -MPEUPATH = @abs_top_builddir@/mpeu -EXAMPLEPATH = @abs_top_builddir@/examples -MPISERPATH = @MPISERPATH@ -libdir = @prefix@/lib -includedir = @prefix@/include - -# OTHER COMMANDS # -RANLIB = @RANLIB@ -AR = @AR@ -RM = rm -f - - - - - diff --git a/cesm/models/utils/mct/README b/cesm/models/utils/mct/README deleted file mode 100644 index 768b4bc..0000000 --- a/cesm/models/utils/mct/README +++ /dev/null @@ -1,208 +0,0 @@ -###################################################################### - - -- Mathematics + Computer Science Div. / Argonne National Laboratory - - Model Coupling Toolkit (MCT) - - Jay Larson - Robert Jacob - Everest Ong - Ray Loy - - For more information, see http://www.mcs.anl.gov/mct - - See MCT/COPYRIGHT for license. - -###################################################################### - - This is version 2.8 of the Model Coupling Toolkit (MCT). - - Our purpose in creating this toolkit is to support the construction - of highly portable and extensible high-performance couplers - for distributed memory parallel coupled models. - -###################################################################### - - - Current Contents of the directory MCT: - - README -- this file - - COPYRIGHT - copyright statement and license. - - mct/ -- Source code for the Model Coupling Toolkit. - - mpeu/ -- Source code for the message-passing environment utilities - library (MPEU), which provides support for MCT - - mpi-serial/ -- Source code for optional mpi replacement library. - - examples/-- Source code for examples which demonstrate the use of MCT. - - doc/ -- documentation for MCT - - protex/ -- tool for constructing documentation from source code - - data/ -- input data for running example programs. Not needed to - compile the library. - - m4/ -- files for autoconf (not needed to build). - -Optional Contents available - - babel/ -- multi language interface for MCT using BABEL. - See babel/README for more information. - -###################################################################### - REQUIREMENTS: - - Building MCT requires a Fortran90 compiler. - - An MPI library is now optional. To compile without MPI, add - --enable-mpiserial to the configure command below. Note that - not all the examples will work without MPI. See mpi-serial/README - for more information. - - - The MCT library builds and the examples run on the following - platforms/compilers: - - Linux: Portland Group, Intel, gfortran, Absoft, Pathscale, Lahey, NAG - MacOSX: gfortran - IBM (AIX) xlf - IBM BlueGene (see PLATFORM NOTE below) - SGI Altix - Cray XT/XK - Compaq Compaq Fortran Compiler (X5.5-2801-48CAG or later) - SUN (Solaris) f90 WorkShop - NEC - Fujitsu - - Running some of the examples requires a parallel platform. - Memory requirements are modest. - -###################################################################### - BUILD INSTRUCTIONS: - - In the top level directory (the location of this README): - > ./configure - > make - - "make examples" will build the example programs. - - BUILD HELP: - Try "./configure -help" for a list of options. - - The correct Fortran90 compiler must be in your current path. - A frequent problem on Linux is when more than one F90 compiler - is in your path and configure finds one and later finds mpif90 - for another. - - Example: If configure has trouble finding the correct F90 compiler: - > ./configure FC=pgf90. - - You can also direct configure through environment variables: - > setenv FC xlf90 - > ./configure - - If the build fails, please do the following: - > ./configure >& config.out - > make >& make.out - and send us config.out, make.out and config.log (which is produced by the - configure command) - - PLATFORM NOTES: - On a BlueGene/P, use: - > ./configure FC=bgxlf90_r CC=mpixlc_r MPIFC=mpixlf90_r (can also use versions without _r) - At ALCF, one can just type "./configure". - - On the Cray X* (e.g. jaguar) use: - > ./configure --host=Linux FC=ftn MPIFC=ftn - -###################################################################### - INSTALLATION INSTRUCTIONS: - - "make install" will copy the .mod files to the /usr/include directory - and the *lib.a files to /usr/lib. To override these choices, use - "-prefix" when running configure: - > ./configure --prefix=/home/$USER - With the above option, "make install" will place .mod's in /home/$USER/include - and *lib.a's in /home/$USER/lib - -###################################################################### - BUILDING AND RUNNING THE EXAMPLES - - The programs in MCT/examples/simple require no input. - - The programs in MCT/examples/climate_concur1 and MCT/examples/climate_sequen1 - require some input data in a directory called MCT/data. The dataset is available with MCT - or separately from the website. - - To build them, type "make examples" in the top level directory or - cd to examples and type "make". - -###################################################################### - - Both MCT and MPEU source code are self-documenting. All modules - and routines contain prologues that can be extracted and processed - into LaTeX source code by the public-domain tool ProTeX. ProTeX is - available by anonymous ftp from: - - Software: - ftp://dao.gsfc.nasa.gov/pub/papers/sawyer/protex1.4.tar.Z - Documentation: - ftp://dao.gsfc.nasa.gov/pub/office_notes/on9711r0.ps.Z - - You can build the documentation with protex and latex by following - the directions in the doc directory. - -###################################################################### - - REVISION HISTORY: - - 18 Oct, 2000 -- Initial prototype - 09 Feb, 2001 -- working MxN transfer - 27 Apr, 2001 -- Sparse Matrix Multiply - 13 Jun, 2001 -- General Grid - 23 Aug, 2001 -- Linux PGF90 port - 14 Dec, 2001 -- PCM support - 29 Mar, 2002 -- Rearranger - 14 Nov, 2002 -- version 1.0.0 -- first public release - 11 Feb, 2003 -- version 1.0.4 - 12 Mar, 2003 -- version 1.0.5 - 02 Apr, 2003 -- version 1.0.7 - 03 Jul, 2003 -- version 1.0.9 - 26 Aug, 2003 -- version 1.0.12 - 12 Sep, 2003 -- version 1.0.14 - 21 Jan, 2004 -- version 1.4.0 - 05 Feb, 2004 -- version 1.6.0 - 23 Apr, 2004 -- version 2.0.0 - 18 May, 2004 -- version 2.0.1 - 11 Jul, 2004 -- version 2.0.2 - 19 Oct, 2004 -- version 2.0.3 (not released) - 21 Jan, 2005 -- version 2.1.0 - 01 Dec, 2005 -- version 2.2.0 - 22 Apr, 2006 -- version 2.2.1 (not released) - 08 Sep, 2006 -- version 2.2.2 - 16 Oct, 2006 -- version 2.2.3 - 10 Jan, 2007 -- version 2.3.0 - 17 Aug, 2007 -- version 2.4.0 - 21 Nov, 2007 -- version 2.4.1 - 20 Dec, 2007 -- version 2.4.2 (not released) - 21 Jan, 2008 -- version 2.4.3 (not released) - 28 Jan, 2008 -- version 2.5.0 - 20 May, 2008 -- version 2.5.1 - 05 Mar, 2009 -- version 2.6.0 - 05 Jan, 2010 -- version 2.7.0 (released only in CCSM4) - 28 Feb, 2010 -- version 2.7.1 (released only in CESM1) - 30 Nov, 2010 -- version 2.7.2 (released only in CESM1.0.3) - 25 Jan, 2011 -- version 2.7.3 (not released) - 07 Mar, 2012 -- version 2.7.4 (not released) - 30 Apr, 2012 -- version 2.8.0 - 05 Jul, 2012 -- version 2.8.1 (not released) - 12 Sep, 2012 -- version 2.8.2 (not released) - 16 Dec, 2012 -- version 2.8.3 - -Tag $Name$ -$Id$ - diff --git a/cesm/models/utils/mct/aclocal.m4 b/cesm/models/utils/mct/aclocal.m4 deleted file mode 100644 index ae3d396..0000000 --- a/cesm/models/utils/mct/aclocal.m4 +++ /dev/null @@ -1,16 +0,0 @@ -# generated automatically by aclocal 1.10 -*- Autoconf -*- - -# Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, -# 2005, 2006 Free Software Foundation, Inc. -# This file is free software; the Free Software Foundation -# gives unlimited permission to copy and/or distribute it, -# with or without modifications, as long as this notice is preserved. - -# This program is distributed in the hope that it will be useful, -# but WITHOUT ANY WARRANTY, to the extent permitted by law; without -# even the implied warranty of MERCHANTABILITY or FITNESS FOR A -# PARTICULAR PURPOSE. - -m4_include([m4/acx_mpi.m4]) -m4_include([m4/ax_fc_version.m4]) -m4_include([m4/fortran.m4]) diff --git a/cesm/models/utils/mct/benchmarks/.gitignore b/cesm/models/utils/mct/benchmarks/.gitignore deleted file mode 100644 index 1c6273f..0000000 --- a/cesm/models/utils/mct/benchmarks/.gitignore +++ /dev/null @@ -1,4 +0,0 @@ -importBench -RouterTestDis -RouterTestOvr -fort.* diff --git a/cesm/models/utils/mct/benchmarks/Makefile b/cesm/models/utils/mct/benchmarks/Makefile deleted file mode 100644 index b7b7cb9..0000000 --- a/cesm/models/utils/mct/benchmarks/Makefile +++ /dev/null @@ -1,58 +0,0 @@ - -SHELL = /bin/sh - -# SOURCE FILES - -SRCS_F90 = importBench.F90 RouterTestDis.F90 RouterTestOvr.F90 - -OBJS_ALL = $(SRCS_F90:.F90=.o) - -# MACHINE AND COMPILER FLAGS - -include ../Makefile.conf - -# ADDITIONAL FLAGS SPECIFIC FOR UTMCT COMPILATION - -MCTLIBS = -L$(MPEUPATH) -L$(MCTPATH) -lmct -lmpeu -UTLDFLAGS = $(REAL8) -UTCMPFLAGS = $(REAL8) $(INCFLAG)$(MPEUPATH) $(INCFLAG)$(MCTPATH) - -# TARGETS - -all: importBench RouterTestDis RouterTestOvr - -importBench: importBench.o - $(FC) -o $@ importBench.o $(FCFLAGS) $(UTLDFLAGS) $(MCTLIBS) $(MPILIBS) - -RouterTestDis: RouterTestDis.o - $(FC) -o $@ RouterTestDis.o $(FCFLAGS) $(UTLDFLAGS) $(MCTLIBS) $(MPILIBS) - -RouterTestOvr: RouterTestOvr.o - $(FC) -o $@ RouterTestOvr.o $(FCFLAGS) $(UTLDFLAGS) $(MCTLIBS) $(MPILIBS) - -# RULES - -.SUFFIXES: -.SUFFIXES: .F90 .o - -.F90.o: - $(FC) -c $(INCPATH) $(FPPDEFS) $(FCFLAGS) $(MCTFLAGS) $(UTCMPFLAGS) $< - - -clean: - ${RM} *.o *.mod importBench RouterTestDis RouterTestOvr - -# DEPENDENCIES: - -$(OBJS_ALL): $(MCTPATH)/libmct.a - - - - - - - - - - - diff --git a/cesm/models/utils/mct/benchmarks/RouterTestDis.F90 b/cesm/models/utils/mct/benchmarks/RouterTestDis.F90 deleted file mode 100644 index ece4efe..0000000 --- a/cesm/models/utils/mct/benchmarks/RouterTestDis.F90 +++ /dev/null @@ -1,200 +0,0 @@ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!----------------------------------------------------------------------- -!BOP ------------------------------------------------------------------- -! -! !PROGRAM: RouterTestDis - Test building a router. -! -! -! !DESCRIPTION: Test building a router from output GSMaps on -! 2 disjoint sets of processors. -! -program RouterTestDis - -! -! !USES: -! - - use m_GlobalSegMap,only: GlobalSegMap - use m_GlobalSegMap,only: GSMap_init => init - use m_GlobalSegMap,only: GSMap_lsize => lsize - - use m_Router,only: Router - use m_Router,only: Router_init => init - - use m_MCTWorld,only: MCTWorld_init => init - use m_ioutil, only : luavail - use m_stdio, only : stdout,stderr - use m_die, only : die - use m_mpif90 - use m_zeit - - implicit none - - include "mpif.h" - -! -!EOP ------------------------------------------------------------------- - -! local variables - - character(len=*), parameter :: myname_='RouterTestDis' - - integer,dimension(:),pointer :: comps ! array with component ids - - - - type(GlobalSegMap) :: comp1GSMap - type(GlobalSegMap) :: comp2GSMap - type(Router) :: myRout - -! other variables - integer :: comm1, comm2, rank, nprocs,compid, myID, ier,color - integer :: mdev1, mdev2, nprocs1,nprocs2,ngseg,gsize - character*24 :: filename1, filename2 - integer :: lrank,newcomm,n,junk - integer, dimension(:), allocatable :: root_start, root_length, root_pe_loc - -!----------------------------------------------------------------------- -! The Main program. -! -! This main program initializes MCT - -! Initialize MPI - call MPI_INIT(ier) - -! Get basic MPI information - call MPI_COMM_SIZE(MPI_COMM_WORLD,nprocs,ier) - call MPI_COMM_RANK(MPI_COMM_WORLD,rank,ier) - - filename1="T42.8pR" - filename2="T42.8pC" - -! open up the two files with the GSMap information. - - if(rank == 0) then - mdev1 = luavail() - open(mdev1,file=trim(filename1),status='old') - - mdev2 = luavail() - open(mdev2,file=trim(filename2),status='old') - - - read(mdev1,*) nprocs1 - read(mdev2,*) nprocs2 - - -! This is the disjoint test so need to have enough processors. - if(nprocs1+nprocs2 .ne. nprocs) then - write(0,*)"Wrong processor count for exactly 2 disjoint communicators." - write(0,*)"Need",nprocs1+nprocs2,"got",nprocs - call die("main","nprocs check") - endif - close(mdev1) - close(mdev2) - endif - - call MPI_BCAST(nprocs1,1,MP_INTEGER,0,MPI_COMM_WORLD,ier) - call MPI_BCAST(nprocs2,1,MP_INTEGER,0,MPI_COMM_WORLD,ier) - -! Split world into 2 pieces for each component - color=0 - if(rank < nprocs1) color=1 - - call MPI_COMM_SPLIT(MPI_COMM_WORLD,color,rank,newcomm,ier) - -! ******************************* -! Component 1 -! ******************************* - if(color == 0) then - call MPI_COMM_RANK(newcomm,lrank,ier) - -! build an MCTWorld with 2 components - call MCTWorld_init(2,MPI_COMM_WORLD,newcomm,1) - -! on non-root proccessors, allocate with length 1 - if(lrank .ne. 0) then - - allocate(root_start(1), root_length(1), & - root_pe_loc(1), stat=ier) - if (ier /= 0) then - call die(myname_, 'allocate((non)root_start...',ier) - endif - endif - - if(lrank == 0) then - mdev1 = luavail() - open(mdev1,file=trim(filename1),status='old') - read(mdev1,*) junk - read(mdev1,*) junk - read(mdev1,*) ngseg - read(mdev1,*) gsize - allocate(root_start(ngseg), root_length(ngseg), & - root_pe_loc(ngseg), stat=ier) - if (ier /= 0) then - call die(myname_, 'allocate((non)root_start...',ier) - endif - do n=1,ngseg - read(mdev1,*) root_start(n),root_length(n), & - root_pe_loc(n) - enddo - endif - -! initalize the GSMap from root - call GSMap_init(comp1GSMap, ngseg, root_start, root_length, & - root_pe_loc, 0, newcomm, 1) - - -! initalize the Router with component 2 - call Router_init(2,comp1GSMap,newcomm,myRout,"Dis1") - call zeit_allflush(newcomm,0,6) - -! ******************************* -! Component 2 -! ******************************* - else - call MPI_COMM_RANK(newcomm,lrank,ier) - -! build an MCTWorld with 2 components - call MCTWorld_init(2,MPI_COMM_WORLD,newcomm,2) -! on non-root proccessors, allocate with length 1 - if(lrank .ne. 0) then - - allocate(root_start(1), root_length(1), & - root_pe_loc(1), stat=ier) - if (ier /= 0) then - call die(myname_, 'allocate((non)root_start...',ier) - endif - endif - - if(lrank == 0) then - mdev2 = luavail() - open(mdev2,file=trim(filename2),status='old') - read(mdev2,*) junk - read(mdev2,*) junk - read(mdev2,*) ngseg - read(mdev2,*) gsize - allocate(root_start(ngseg), root_length(ngseg), & - root_pe_loc(ngseg), stat=ier) - if (ier /= 0) then - call die(myname_, 'allocate((non)root_start...',ier) - endif - do n=1,ngseg - read(mdev2,*) root_start(n),root_length(n), & - root_pe_loc(n) - enddo - endif - -! initalize the GSMap from root - call GSMap_init(comp2GSMap, ngseg, root_start, root_length, & - root_pe_loc, 0, newcomm, 2) - -! initalize the Router with component 1 - call Router_init(1,comp2GSMap,newcomm,myRout,"Dis2") - call zeit_allflush(newcomm,0,6) - endif - - call MPI_Finalize(ier) - -end program RouterTestDis diff --git a/cesm/models/utils/mct/benchmarks/RouterTestOvr.F90 b/cesm/models/utils/mct/benchmarks/RouterTestOvr.F90 deleted file mode 100644 index a415b2c..0000000 --- a/cesm/models/utils/mct/benchmarks/RouterTestOvr.F90 +++ /dev/null @@ -1,195 +0,0 @@ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!----------------------------------------------------------------------- -!BOP ------------------------------------------------------------------- -! -! !PROGRAM: RouterTestOvr - Test building a router. -! -! -! !DESCRIPTION: Test building a router from output GSMaps on -! overlapping processors -! -program RouterTestOvr - -! -! !USES: -! - - use m_GlobalSegMap,only: GlobalSegMap - use m_GlobalSegMap,only: GSMap_init => init - use m_GlobalSegMap,only: GSMap_lsize => lsize - - use m_Router,only: Router - use m_Router,only: Router_init => init - - use m_MCTWorld,only: MCTWorld_init => init - use m_ioutil, only : luavail - use m_stdio, only : stdout,stderr - use m_die, only : die - use m_mpif90 - - implicit none - - include "mpif.h" - -! -!EOP ------------------------------------------------------------------- - -! local variables - - character(len=*), parameter :: myname_='RouterTestOvr' - - integer :: ncomps = 2 ! Must know total number of - ! components in coupled system - - integer,dimension(:),pointer :: comps ! array with component ids - - type(GlobalSegMap) :: comp1GSMap - type(GlobalSegMap) :: comp2GSMap - type(Router) :: myRout - -! other variables - integer :: comm1, comm2, rank, nprocs,compid, myID, ier,color - integer :: mdev1, mdev2, nprocs1,nprocs2,ngseg,gsize - character*24 :: filename1, filename2 - integer :: lrank,newcomm,n,junk - integer, dimension(:), allocatable :: root_start, root_length, root_pe_loc - -!----------------------------------------------------------------------- -! The Main program. -! -! This main program initializes MCT - -! Initialize MPI - call MPI_INIT(ier) - -! Get basic MPI information - call MPI_COMM_SIZE(MPI_COMM_WORLD,nprocs,ier) - call MPI_COMM_RANK(MPI_COMM_WORLD,rank,ier) - - filename1="gx1.8pR" - filename2="gx1.8pC" - -! open up the two files with the GSMap information. -! and read the total number of processors needed - - if(rank == 0) then - mdev1 = luavail() - open(mdev1,file=trim(filename1),status='old') - - mdev2 = luavail() - open(mdev2,file=trim(filename2),status='old') - - - read(mdev1,*) nprocs1 - read(mdev2,*) nprocs2 - - -! Need to have enough processors. - if(nprocs .lt. max(nprocs1,nprocs2)) then - write(0,*)"Wrong processor count for 2 overlapping communicators." - write(0,*)"Need",max(nprocs1,nprocs2),"got",nprocs - call die("main","nprocs check") - endif - close(mdev1) - close(mdev2) - endif - - call MPI_BCAST(nprocs1,1,MP_INTEGER,0,MPI_COMM_WORLD,ier) - call MPI_BCAST(nprocs2,1,MP_INTEGER,0,MPI_COMM_WORLD,ier) - - call mpi_comm_dup(MPI_COMM_WORLD,comm1,ier) - call mpi_comm_dup(MPI_COMM_WORLD,comm2,ier) - -! Initialize MCT - allocate(comps(ncomps),stat=ier) - comps(1)=1 - comps(2)=2 - call MCTWorld_init(ncomps,MPI_COMM_WORLD,comm1,myids=comps) - - - -! ******************************* -! Component 1 -! ******************************* - call MPI_COMM_RANK(comm1,lrank,ier) - -! on non-root proccessors, allocate with length 1 - if(lrank .ne. 0) then - - allocate(root_start(1), root_length(1), & - root_pe_loc(1), stat=ier) - if (ier /= 0) then - call die(myname_, 'allocate((non)root_start...',ier) - endif - endif - - if(lrank == 0) then - mdev1 = luavail() - open(mdev1,file=trim(filename1),status='old') - read(mdev1,*) junk - read(mdev1,*) junk - read(mdev1,*) ngseg - read(mdev1,*) gsize - allocate(root_start(ngseg), root_length(ngseg), & - root_pe_loc(ngseg), stat=ier) - if (ier /= 0) then - call die(myname_, 'allocate((non)root_start...',ier) - endif - do n=1,ngseg - read(mdev1,*) root_start(n),root_length(n), & - root_pe_loc(n) - enddo - endif - -! initalize the GSMap from root - call GSMap_init(comp1GSMap, ngseg, root_start, root_length, & - root_pe_loc, 0, comm1, 1) - - deallocate(root_start,root_length,root_pe_loc) - -! ******************************* -! Component 2 -! ******************************* - call MPI_COMM_RANK(comm2,lrank,ier) - -! on non-root proccessors, allocate with length 1 - if(lrank .ne. 0) then - - allocate(root_start(1), root_length(1), & - root_pe_loc(1), stat=ier) - if (ier /= 0) then - call die(myname_, 'allocate((non)root_start...',ier) - endif - endif - - if(lrank == 0) then - mdev2 = luavail() - open(mdev2,file=trim(filename2),status='old') - read(mdev2,*) junk - read(mdev2,*) junk - read(mdev2,*) ngseg - read(mdev2,*) gsize - allocate(root_start(ngseg), root_length(ngseg), & - root_pe_loc(ngseg), stat=ier) - if (ier /= 0) then - call die(myname_, 'allocate((non)root_start...',ier) - endif - do n=1,ngseg - read(mdev2,*) root_start(n),root_length(n), & - root_pe_loc(n) - enddo - endif - -! initalize the GSMap from root - call GSMap_init(comp2GSMap, ngseg, root_start, root_length, & - root_pe_loc, 0, comm2, 2) - -! now initialize the Router - call Router_init(comp1GSMap,comp2GSMap,comm1,myRout,"Over") - - - call MPI_Finalize(ier) - -end program RouterTestOvr diff --git a/cesm/models/utils/mct/benchmarks/T42.8pC b/cesm/models/utils/mct/benchmarks/T42.8pC deleted file mode 100644 index f80c0b8..0000000 --- a/cesm/models/utils/mct/benchmarks/T42.8pC +++ /dev/null @@ -1,516 +0,0 @@ - 8 - 1 - 512 - 8192 - 1 16 0 - 129 16 0 - 257 16 0 - 385 16 0 - 513 16 0 - 641 16 0 - 769 16 0 - 897 16 0 - 1025 16 0 - 1153 16 0 - 1281 16 0 - 1409 16 0 - 1537 16 0 - 1665 16 0 - 1793 16 0 - 1921 16 0 - 2049 16 0 - 2177 16 0 - 2305 16 0 - 2433 16 0 - 2561 16 0 - 2689 16 0 - 2817 16 0 - 2945 16 0 - 3073 16 0 - 3201 16 0 - 3329 16 0 - 3457 16 0 - 3585 16 0 - 3713 16 0 - 3841 16 0 - 3969 16 0 - 4097 16 0 - 4225 16 0 - 4353 16 0 - 4481 16 0 - 4609 16 0 - 4737 16 0 - 4865 16 0 - 4993 16 0 - 5121 16 0 - 5249 16 0 - 5377 16 0 - 5505 16 0 - 5633 16 0 - 5761 16 0 - 5889 16 0 - 6017 16 0 - 6145 16 0 - 6273 16 0 - 6401 16 0 - 6529 16 0 - 6657 16 0 - 6785 16 0 - 6913 16 0 - 7041 16 0 - 7169 16 0 - 7297 16 0 - 7425 16 0 - 7553 16 0 - 7681 16 0 - 7809 16 0 - 7937 16 0 - 8065 16 0 - 17 16 1 - 145 16 1 - 273 16 1 - 401 16 1 - 529 16 1 - 657 16 1 - 785 16 1 - 913 16 1 - 1041 16 1 - 1169 16 1 - 1297 16 1 - 1425 16 1 - 1553 16 1 - 1681 16 1 - 1809 16 1 - 1937 16 1 - 2065 16 1 - 2193 16 1 - 2321 16 1 - 2449 16 1 - 2577 16 1 - 2705 16 1 - 2833 16 1 - 2961 16 1 - 3089 16 1 - 3217 16 1 - 3345 16 1 - 3473 16 1 - 3601 16 1 - 3729 16 1 - 3857 16 1 - 3985 16 1 - 4113 16 1 - 4241 16 1 - 4369 16 1 - 4497 16 1 - 4625 16 1 - 4753 16 1 - 4881 16 1 - 5009 16 1 - 5137 16 1 - 5265 16 1 - 5393 16 1 - 5521 16 1 - 5649 16 1 - 5777 16 1 - 5905 16 1 - 6033 16 1 - 6161 16 1 - 6289 16 1 - 6417 16 1 - 6545 16 1 - 6673 16 1 - 6801 16 1 - 6929 16 1 - 7057 16 1 - 7185 16 1 - 7313 16 1 - 7441 16 1 - 7569 16 1 - 7697 16 1 - 7825 16 1 - 7953 16 1 - 8081 16 1 - 33 16 2 - 161 16 2 - 289 16 2 - 417 16 2 - 545 16 2 - 673 16 2 - 801 16 2 - 929 16 2 - 1057 16 2 - 1185 16 2 - 1313 16 2 - 1441 16 2 - 1569 16 2 - 1697 16 2 - 1825 16 2 - 1953 16 2 - 2081 16 2 - 2209 16 2 - 2337 16 2 - 2465 16 2 - 2593 16 2 - 2721 16 2 - 2849 16 2 - 2977 16 2 - 3105 16 2 - 3233 16 2 - 3361 16 2 - 3489 16 2 - 3617 16 2 - 3745 16 2 - 3873 16 2 - 4001 16 2 - 4129 16 2 - 4257 16 2 - 4385 16 2 - 4513 16 2 - 4641 16 2 - 4769 16 2 - 4897 16 2 - 5025 16 2 - 5153 16 2 - 5281 16 2 - 5409 16 2 - 5537 16 2 - 5665 16 2 - 5793 16 2 - 5921 16 2 - 6049 16 2 - 6177 16 2 - 6305 16 2 - 6433 16 2 - 6561 16 2 - 6689 16 2 - 6817 16 2 - 6945 16 2 - 7073 16 2 - 7201 16 2 - 7329 16 2 - 7457 16 2 - 7585 16 2 - 7713 16 2 - 7841 16 2 - 7969 16 2 - 8097 16 2 - 49 16 3 - 177 16 3 - 305 16 3 - 433 16 3 - 561 16 3 - 689 16 3 - 817 16 3 - 945 16 3 - 1073 16 3 - 1201 16 3 - 1329 16 3 - 1457 16 3 - 1585 16 3 - 1713 16 3 - 1841 16 3 - 1969 16 3 - 2097 16 3 - 2225 16 3 - 2353 16 3 - 2481 16 3 - 2609 16 3 - 2737 16 3 - 2865 16 3 - 2993 16 3 - 3121 16 3 - 3249 16 3 - 3377 16 3 - 3505 16 3 - 3633 16 3 - 3761 16 3 - 3889 16 3 - 4017 16 3 - 4145 16 3 - 4273 16 3 - 4401 16 3 - 4529 16 3 - 4657 16 3 - 4785 16 3 - 4913 16 3 - 5041 16 3 - 5169 16 3 - 5297 16 3 - 5425 16 3 - 5553 16 3 - 5681 16 3 - 5809 16 3 - 5937 16 3 - 6065 16 3 - 6193 16 3 - 6321 16 3 - 6449 16 3 - 6577 16 3 - 6705 16 3 - 6833 16 3 - 6961 16 3 - 7089 16 3 - 7217 16 3 - 7345 16 3 - 7473 16 3 - 7601 16 3 - 7729 16 3 - 7857 16 3 - 7985 16 3 - 8113 16 3 - 65 16 4 - 193 16 4 - 321 16 4 - 449 16 4 - 577 16 4 - 705 16 4 - 833 16 4 - 961 16 4 - 1089 16 4 - 1217 16 4 - 1345 16 4 - 1473 16 4 - 1601 16 4 - 1729 16 4 - 1857 16 4 - 1985 16 4 - 2113 16 4 - 2241 16 4 - 2369 16 4 - 2497 16 4 - 2625 16 4 - 2753 16 4 - 2881 16 4 - 3009 16 4 - 3137 16 4 - 3265 16 4 - 3393 16 4 - 3521 16 4 - 3649 16 4 - 3777 16 4 - 3905 16 4 - 4033 16 4 - 4161 16 4 - 4289 16 4 - 4417 16 4 - 4545 16 4 - 4673 16 4 - 4801 16 4 - 4929 16 4 - 5057 16 4 - 5185 16 4 - 5313 16 4 - 5441 16 4 - 5569 16 4 - 5697 16 4 - 5825 16 4 - 5953 16 4 - 6081 16 4 - 6209 16 4 - 6337 16 4 - 6465 16 4 - 6593 16 4 - 6721 16 4 - 6849 16 4 - 6977 16 4 - 7105 16 4 - 7233 16 4 - 7361 16 4 - 7489 16 4 - 7617 16 4 - 7745 16 4 - 7873 16 4 - 8001 16 4 - 8129 16 4 - 81 16 5 - 209 16 5 - 337 16 5 - 465 16 5 - 593 16 5 - 721 16 5 - 849 16 5 - 977 16 5 - 1105 16 5 - 1233 16 5 - 1361 16 5 - 1489 16 5 - 1617 16 5 - 1745 16 5 - 1873 16 5 - 2001 16 5 - 2129 16 5 - 2257 16 5 - 2385 16 5 - 2513 16 5 - 2641 16 5 - 2769 16 5 - 2897 16 5 - 3025 16 5 - 3153 16 5 - 3281 16 5 - 3409 16 5 - 3537 16 5 - 3665 16 5 - 3793 16 5 - 3921 16 5 - 4049 16 5 - 4177 16 5 - 4305 16 5 - 4433 16 5 - 4561 16 5 - 4689 16 5 - 4817 16 5 - 4945 16 5 - 5073 16 5 - 5201 16 5 - 5329 16 5 - 5457 16 5 - 5585 16 5 - 5713 16 5 - 5841 16 5 - 5969 16 5 - 6097 16 5 - 6225 16 5 - 6353 16 5 - 6481 16 5 - 6609 16 5 - 6737 16 5 - 6865 16 5 - 6993 16 5 - 7121 16 5 - 7249 16 5 - 7377 16 5 - 7505 16 5 - 7633 16 5 - 7761 16 5 - 7889 16 5 - 8017 16 5 - 8145 16 5 - 97 16 6 - 225 16 6 - 353 16 6 - 481 16 6 - 609 16 6 - 737 16 6 - 865 16 6 - 993 16 6 - 1121 16 6 - 1249 16 6 - 1377 16 6 - 1505 16 6 - 1633 16 6 - 1761 16 6 - 1889 16 6 - 2017 16 6 - 2145 16 6 - 2273 16 6 - 2401 16 6 - 2529 16 6 - 2657 16 6 - 2785 16 6 - 2913 16 6 - 3041 16 6 - 3169 16 6 - 3297 16 6 - 3425 16 6 - 3553 16 6 - 3681 16 6 - 3809 16 6 - 3937 16 6 - 4065 16 6 - 4193 16 6 - 4321 16 6 - 4449 16 6 - 4577 16 6 - 4705 16 6 - 4833 16 6 - 4961 16 6 - 5089 16 6 - 5217 16 6 - 5345 16 6 - 5473 16 6 - 5601 16 6 - 5729 16 6 - 5857 16 6 - 5985 16 6 - 6113 16 6 - 6241 16 6 - 6369 16 6 - 6497 16 6 - 6625 16 6 - 6753 16 6 - 6881 16 6 - 7009 16 6 - 7137 16 6 - 7265 16 6 - 7393 16 6 - 7521 16 6 - 7649 16 6 - 7777 16 6 - 7905 16 6 - 8033 16 6 - 8161 16 6 - 113 16 7 - 241 16 7 - 369 16 7 - 497 16 7 - 625 16 7 - 753 16 7 - 881 16 7 - 1009 16 7 - 1137 16 7 - 1265 16 7 - 1393 16 7 - 1521 16 7 - 1649 16 7 - 1777 16 7 - 1905 16 7 - 2033 16 7 - 2161 16 7 - 2289 16 7 - 2417 16 7 - 2545 16 7 - 2673 16 7 - 2801 16 7 - 2929 16 7 - 3057 16 7 - 3185 16 7 - 3313 16 7 - 3441 16 7 - 3569 16 7 - 3697 16 7 - 3825 16 7 - 3953 16 7 - 4081 16 7 - 4209 16 7 - 4337 16 7 - 4465 16 7 - 4593 16 7 - 4721 16 7 - 4849 16 7 - 4977 16 7 - 5105 16 7 - 5233 16 7 - 5361 16 7 - 5489 16 7 - 5617 16 7 - 5745 16 7 - 5873 16 7 - 6001 16 7 - 6129 16 7 - 6257 16 7 - 6385 16 7 - 6513 16 7 - 6641 16 7 - 6769 16 7 - 6897 16 7 - 7025 16 7 - 7153 16 7 - 7281 16 7 - 7409 16 7 - 7537 16 7 - 7665 16 7 - 7793 16 7 - 7921 16 7 - 8049 16 7 - 8177 16 7 diff --git a/cesm/models/utils/mct/benchmarks/T42.8pR b/cesm/models/utils/mct/benchmarks/T42.8pR deleted file mode 100644 index 5f3cd20..0000000 --- a/cesm/models/utils/mct/benchmarks/T42.8pR +++ /dev/null @@ -1,12 +0,0 @@ - 8 - 1 - 8 - 8192 - 1 1024 0 - 1025 1024 1 - 2049 1024 2 - 3073 1024 3 - 4097 1024 4 - 5121 1024 5 - 6145 1024 6 - 7169 1024 7 diff --git a/cesm/models/utils/mct/benchmarks/gx1.8pC b/cesm/models/utils/mct/benchmarks/gx1.8pC deleted file mode 100644 index a183292..0000000 --- a/cesm/models/utils/mct/benchmarks/gx1.8pC +++ /dev/null @@ -1,3076 +0,0 @@ - 8 - 2 - 3072 - 122880 - 1 40 0 - 321 40 0 - 641 40 0 - 961 40 0 - 1281 40 0 - 1601 40 0 - 1921 40 0 - 2241 40 0 - 2561 40 0 - 2881 40 0 - 3201 40 0 - 3521 40 0 - 3841 40 0 - 4161 40 0 - 4481 40 0 - 4801 40 0 - 5121 40 0 - 5441 40 0 - 5761 40 0 - 6081 40 0 - 6401 40 0 - 6721 40 0 - 7041 40 0 - 7361 40 0 - 7681 40 0 - 8001 40 0 - 8321 40 0 - 8641 40 0 - 8961 40 0 - 9281 40 0 - 9601 40 0 - 9921 40 0 - 10241 40 0 - 10561 40 0 - 10881 40 0 - 11201 40 0 - 11521 40 0 - 11841 40 0 - 12161 40 0 - 12481 40 0 - 12801 40 0 - 13121 40 0 - 13441 40 0 - 13761 40 0 - 14081 40 0 - 14401 40 0 - 14721 40 0 - 15041 40 0 - 15361 40 0 - 15681 40 0 - 16001 40 0 - 16321 40 0 - 16641 40 0 - 16961 40 0 - 17281 40 0 - 17601 40 0 - 17921 40 0 - 18241 40 0 - 18561 40 0 - 18881 40 0 - 19201 40 0 - 19521 40 0 - 19841 40 0 - 20161 40 0 - 20481 40 0 - 20801 40 0 - 21121 40 0 - 21441 40 0 - 21761 40 0 - 22081 40 0 - 22401 40 0 - 22721 40 0 - 23041 40 0 - 23361 40 0 - 23681 40 0 - 24001 40 0 - 24321 40 0 - 24641 40 0 - 24961 40 0 - 25281 40 0 - 25601 40 0 - 25921 40 0 - 26241 40 0 - 26561 40 0 - 26881 40 0 - 27201 40 0 - 27521 40 0 - 27841 40 0 - 28161 40 0 - 28481 40 0 - 28801 40 0 - 29121 40 0 - 29441 40 0 - 29761 40 0 - 30081 40 0 - 30401 40 0 - 30721 40 0 - 31041 40 0 - 31361 40 0 - 31681 40 0 - 32001 40 0 - 32321 40 0 - 32641 40 0 - 32961 40 0 - 33281 40 0 - 33601 40 0 - 33921 40 0 - 34241 40 0 - 34561 40 0 - 34881 40 0 - 35201 40 0 - 35521 40 0 - 35841 40 0 - 36161 40 0 - 36481 40 0 - 36801 40 0 - 37121 40 0 - 37441 40 0 - 37761 40 0 - 38081 40 0 - 38401 40 0 - 38721 40 0 - 39041 40 0 - 39361 40 0 - 39681 40 0 - 40001 40 0 - 40321 40 0 - 40641 40 0 - 40961 40 0 - 41281 40 0 - 41601 40 0 - 41921 40 0 - 42241 40 0 - 42561 40 0 - 42881 40 0 - 43201 40 0 - 43521 40 0 - 43841 40 0 - 44161 40 0 - 44481 40 0 - 44801 40 0 - 45121 40 0 - 45441 40 0 - 45761 40 0 - 46081 40 0 - 46401 40 0 - 46721 40 0 - 47041 40 0 - 47361 40 0 - 47681 40 0 - 48001 40 0 - 48321 40 0 - 48641 40 0 - 48961 40 0 - 49281 40 0 - 49601 40 0 - 49921 40 0 - 50241 40 0 - 50561 40 0 - 50881 40 0 - 51201 40 0 - 51521 40 0 - 51841 40 0 - 52161 40 0 - 52481 40 0 - 52801 40 0 - 53121 40 0 - 53441 40 0 - 53761 40 0 - 54081 40 0 - 54401 40 0 - 54721 40 0 - 55041 40 0 - 55361 40 0 - 55681 40 0 - 56001 40 0 - 56321 40 0 - 56641 40 0 - 56961 40 0 - 57281 40 0 - 57601 40 0 - 57921 40 0 - 58241 40 0 - 58561 40 0 - 58881 40 0 - 59201 40 0 - 59521 40 0 - 59841 40 0 - 60161 40 0 - 60481 40 0 - 60801 40 0 - 61121 40 0 - 61441 40 0 - 61761 40 0 - 62081 40 0 - 62401 40 0 - 62721 40 0 - 63041 40 0 - 63361 40 0 - 63681 40 0 - 64001 40 0 - 64321 40 0 - 64641 40 0 - 64961 40 0 - 65281 40 0 - 65601 40 0 - 65921 40 0 - 66241 40 0 - 66561 40 0 - 66881 40 0 - 67201 40 0 - 67521 40 0 - 67841 40 0 - 68161 40 0 - 68481 40 0 - 68801 40 0 - 69121 40 0 - 69441 40 0 - 69761 40 0 - 70081 40 0 - 70401 40 0 - 70721 40 0 - 71041 40 0 - 71361 40 0 - 71681 40 0 - 72001 40 0 - 72321 40 0 - 72641 40 0 - 72961 40 0 - 73281 40 0 - 73601 40 0 - 73921 40 0 - 74241 40 0 - 74561 40 0 - 74881 40 0 - 75201 40 0 - 75521 40 0 - 75841 40 0 - 76161 40 0 - 76481 40 0 - 76801 40 0 - 77121 40 0 - 77441 40 0 - 77761 40 0 - 78081 40 0 - 78401 40 0 - 78721 40 0 - 79041 40 0 - 79361 40 0 - 79681 40 0 - 80001 40 0 - 80321 40 0 - 80641 40 0 - 80961 40 0 - 81281 40 0 - 81601 40 0 - 81921 40 0 - 82241 40 0 - 82561 40 0 - 82881 40 0 - 83201 40 0 - 83521 40 0 - 83841 40 0 - 84161 40 0 - 84481 40 0 - 84801 40 0 - 85121 40 0 - 85441 40 0 - 85761 40 0 - 86081 40 0 - 86401 40 0 - 86721 40 0 - 87041 40 0 - 87361 40 0 - 87681 40 0 - 88001 40 0 - 88321 40 0 - 88641 40 0 - 88961 40 0 - 89281 40 0 - 89601 40 0 - 89921 40 0 - 90241 40 0 - 90561 40 0 - 90881 40 0 - 91201 40 0 - 91521 40 0 - 91841 40 0 - 92161 40 0 - 92481 40 0 - 92801 40 0 - 93121 40 0 - 93441 40 0 - 93761 40 0 - 94081 40 0 - 94401 40 0 - 94721 40 0 - 95041 40 0 - 95361 40 0 - 95681 40 0 - 96001 40 0 - 96321 40 0 - 96641 40 0 - 96961 40 0 - 97281 40 0 - 97601 40 0 - 97921 40 0 - 98241 40 0 - 98561 40 0 - 98881 40 0 - 99201 40 0 - 99521 40 0 - 99841 40 0 - 100161 40 0 - 100481 40 0 - 100801 40 0 - 101121 40 0 - 101441 40 0 - 101761 40 0 - 102081 40 0 - 102401 40 0 - 102721 40 0 - 103041 40 0 - 103361 40 0 - 103681 40 0 - 104001 40 0 - 104321 40 0 - 104641 40 0 - 104961 40 0 - 105281 40 0 - 105601 40 0 - 105921 40 0 - 106241 40 0 - 106561 40 0 - 106881 40 0 - 107201 40 0 - 107521 40 0 - 107841 40 0 - 108161 40 0 - 108481 40 0 - 108801 40 0 - 109121 40 0 - 109441 40 0 - 109761 40 0 - 110081 40 0 - 110401 40 0 - 110721 40 0 - 111041 40 0 - 111361 40 0 - 111681 40 0 - 112001 40 0 - 112321 40 0 - 112641 40 0 - 112961 40 0 - 113281 40 0 - 113601 40 0 - 113921 40 0 - 114241 40 0 - 114561 40 0 - 114881 40 0 - 115201 40 0 - 115521 40 0 - 115841 40 0 - 116161 40 0 - 116481 40 0 - 116801 40 0 - 117121 40 0 - 117441 40 0 - 117761 40 0 - 118081 40 0 - 118401 40 0 - 118721 40 0 - 119041 40 0 - 119361 40 0 - 119681 40 0 - 120001 40 0 - 120321 40 0 - 120641 40 0 - 120961 40 0 - 121281 40 0 - 121601 40 0 - 121921 40 0 - 122241 40 0 - 122561 40 0 - 41 40 1 - 361 40 1 - 681 40 1 - 1001 40 1 - 1321 40 1 - 1641 40 1 - 1961 40 1 - 2281 40 1 - 2601 40 1 - 2921 40 1 - 3241 40 1 - 3561 40 1 - 3881 40 1 - 4201 40 1 - 4521 40 1 - 4841 40 1 - 5161 40 1 - 5481 40 1 - 5801 40 1 - 6121 40 1 - 6441 40 1 - 6761 40 1 - 7081 40 1 - 7401 40 1 - 7721 40 1 - 8041 40 1 - 8361 40 1 - 8681 40 1 - 9001 40 1 - 9321 40 1 - 9641 40 1 - 9961 40 1 - 10281 40 1 - 10601 40 1 - 10921 40 1 - 11241 40 1 - 11561 40 1 - 11881 40 1 - 12201 40 1 - 12521 40 1 - 12841 40 1 - 13161 40 1 - 13481 40 1 - 13801 40 1 - 14121 40 1 - 14441 40 1 - 14761 40 1 - 15081 40 1 - 15401 40 1 - 15721 40 1 - 16041 40 1 - 16361 40 1 - 16681 40 1 - 17001 40 1 - 17321 40 1 - 17641 40 1 - 17961 40 1 - 18281 40 1 - 18601 40 1 - 18921 40 1 - 19241 40 1 - 19561 40 1 - 19881 40 1 - 20201 40 1 - 20521 40 1 - 20841 40 1 - 21161 40 1 - 21481 40 1 - 21801 40 1 - 22121 40 1 - 22441 40 1 - 22761 40 1 - 23081 40 1 - 23401 40 1 - 23721 40 1 - 24041 40 1 - 24361 40 1 - 24681 40 1 - 25001 40 1 - 25321 40 1 - 25641 40 1 - 25961 40 1 - 26281 40 1 - 26601 40 1 - 26921 40 1 - 27241 40 1 - 27561 40 1 - 27881 40 1 - 28201 40 1 - 28521 40 1 - 28841 40 1 - 29161 40 1 - 29481 40 1 - 29801 40 1 - 30121 40 1 - 30441 40 1 - 30761 40 1 - 31081 40 1 - 31401 40 1 - 31721 40 1 - 32041 40 1 - 32361 40 1 - 32681 40 1 - 33001 40 1 - 33321 40 1 - 33641 40 1 - 33961 40 1 - 34281 40 1 - 34601 40 1 - 34921 40 1 - 35241 40 1 - 35561 40 1 - 35881 40 1 - 36201 40 1 - 36521 40 1 - 36841 40 1 - 37161 40 1 - 37481 40 1 - 37801 40 1 - 38121 40 1 - 38441 40 1 - 38761 40 1 - 39081 40 1 - 39401 40 1 - 39721 40 1 - 40041 40 1 - 40361 40 1 - 40681 40 1 - 41001 40 1 - 41321 40 1 - 41641 40 1 - 41961 40 1 - 42281 40 1 - 42601 40 1 - 42921 40 1 - 43241 40 1 - 43561 40 1 - 43881 40 1 - 44201 40 1 - 44521 40 1 - 44841 40 1 - 45161 40 1 - 45481 40 1 - 45801 40 1 - 46121 40 1 - 46441 40 1 - 46761 40 1 - 47081 40 1 - 47401 40 1 - 47721 40 1 - 48041 40 1 - 48361 40 1 - 48681 40 1 - 49001 40 1 - 49321 40 1 - 49641 40 1 - 49961 40 1 - 50281 40 1 - 50601 40 1 - 50921 40 1 - 51241 40 1 - 51561 40 1 - 51881 40 1 - 52201 40 1 - 52521 40 1 - 52841 40 1 - 53161 40 1 - 53481 40 1 - 53801 40 1 - 54121 40 1 - 54441 40 1 - 54761 40 1 - 55081 40 1 - 55401 40 1 - 55721 40 1 - 56041 40 1 - 56361 40 1 - 56681 40 1 - 57001 40 1 - 57321 40 1 - 57641 40 1 - 57961 40 1 - 58281 40 1 - 58601 40 1 - 58921 40 1 - 59241 40 1 - 59561 40 1 - 59881 40 1 - 60201 40 1 - 60521 40 1 - 60841 40 1 - 61161 40 1 - 61481 40 1 - 61801 40 1 - 62121 40 1 - 62441 40 1 - 62761 40 1 - 63081 40 1 - 63401 40 1 - 63721 40 1 - 64041 40 1 - 64361 40 1 - 64681 40 1 - 65001 40 1 - 65321 40 1 - 65641 40 1 - 65961 40 1 - 66281 40 1 - 66601 40 1 - 66921 40 1 - 67241 40 1 - 67561 40 1 - 67881 40 1 - 68201 40 1 - 68521 40 1 - 68841 40 1 - 69161 40 1 - 69481 40 1 - 69801 40 1 - 70121 40 1 - 70441 40 1 - 70761 40 1 - 71081 40 1 - 71401 40 1 - 71721 40 1 - 72041 40 1 - 72361 40 1 - 72681 40 1 - 73001 40 1 - 73321 40 1 - 73641 40 1 - 73961 40 1 - 74281 40 1 - 74601 40 1 - 74921 40 1 - 75241 40 1 - 75561 40 1 - 75881 40 1 - 76201 40 1 - 76521 40 1 - 76841 40 1 - 77161 40 1 - 77481 40 1 - 77801 40 1 - 78121 40 1 - 78441 40 1 - 78761 40 1 - 79081 40 1 - 79401 40 1 - 79721 40 1 - 80041 40 1 - 80361 40 1 - 80681 40 1 - 81001 40 1 - 81321 40 1 - 81641 40 1 - 81961 40 1 - 82281 40 1 - 82601 40 1 - 82921 40 1 - 83241 40 1 - 83561 40 1 - 83881 40 1 - 84201 40 1 - 84521 40 1 - 84841 40 1 - 85161 40 1 - 85481 40 1 - 85801 40 1 - 86121 40 1 - 86441 40 1 - 86761 40 1 - 87081 40 1 - 87401 40 1 - 87721 40 1 - 88041 40 1 - 88361 40 1 - 88681 40 1 - 89001 40 1 - 89321 40 1 - 89641 40 1 - 89961 40 1 - 90281 40 1 - 90601 40 1 - 90921 40 1 - 91241 40 1 - 91561 40 1 - 91881 40 1 - 92201 40 1 - 92521 40 1 - 92841 40 1 - 93161 40 1 - 93481 40 1 - 93801 40 1 - 94121 40 1 - 94441 40 1 - 94761 40 1 - 95081 40 1 - 95401 40 1 - 95721 40 1 - 96041 40 1 - 96361 40 1 - 96681 40 1 - 97001 40 1 - 97321 40 1 - 97641 40 1 - 97961 40 1 - 98281 40 1 - 98601 40 1 - 98921 40 1 - 99241 40 1 - 99561 40 1 - 99881 40 1 - 100201 40 1 - 100521 40 1 - 100841 40 1 - 101161 40 1 - 101481 40 1 - 101801 40 1 - 102121 40 1 - 102441 40 1 - 102761 40 1 - 103081 40 1 - 103401 40 1 - 103721 40 1 - 104041 40 1 - 104361 40 1 - 104681 40 1 - 105001 40 1 - 105321 40 1 - 105641 40 1 - 105961 40 1 - 106281 40 1 - 106601 40 1 - 106921 40 1 - 107241 40 1 - 107561 40 1 - 107881 40 1 - 108201 40 1 - 108521 40 1 - 108841 40 1 - 109161 40 1 - 109481 40 1 - 109801 40 1 - 110121 40 1 - 110441 40 1 - 110761 40 1 - 111081 40 1 - 111401 40 1 - 111721 40 1 - 112041 40 1 - 112361 40 1 - 112681 40 1 - 113001 40 1 - 113321 40 1 - 113641 40 1 - 113961 40 1 - 114281 40 1 - 114601 40 1 - 114921 40 1 - 115241 40 1 - 115561 40 1 - 115881 40 1 - 116201 40 1 - 116521 40 1 - 116841 40 1 - 117161 40 1 - 117481 40 1 - 117801 40 1 - 118121 40 1 - 118441 40 1 - 118761 40 1 - 119081 40 1 - 119401 40 1 - 119721 40 1 - 120041 40 1 - 120361 40 1 - 120681 40 1 - 121001 40 1 - 121321 40 1 - 121641 40 1 - 121961 40 1 - 122281 40 1 - 122601 40 1 - 81 40 2 - 401 40 2 - 721 40 2 - 1041 40 2 - 1361 40 2 - 1681 40 2 - 2001 40 2 - 2321 40 2 - 2641 40 2 - 2961 40 2 - 3281 40 2 - 3601 40 2 - 3921 40 2 - 4241 40 2 - 4561 40 2 - 4881 40 2 - 5201 40 2 - 5521 40 2 - 5841 40 2 - 6161 40 2 - 6481 40 2 - 6801 40 2 - 7121 40 2 - 7441 40 2 - 7761 40 2 - 8081 40 2 - 8401 40 2 - 8721 40 2 - 9041 40 2 - 9361 40 2 - 9681 40 2 - 10001 40 2 - 10321 40 2 - 10641 40 2 - 10961 40 2 - 11281 40 2 - 11601 40 2 - 11921 40 2 - 12241 40 2 - 12561 40 2 - 12881 40 2 - 13201 40 2 - 13521 40 2 - 13841 40 2 - 14161 40 2 - 14481 40 2 - 14801 40 2 - 15121 40 2 - 15441 40 2 - 15761 40 2 - 16081 40 2 - 16401 40 2 - 16721 40 2 - 17041 40 2 - 17361 40 2 - 17681 40 2 - 18001 40 2 - 18321 40 2 - 18641 40 2 - 18961 40 2 - 19281 40 2 - 19601 40 2 - 19921 40 2 - 20241 40 2 - 20561 40 2 - 20881 40 2 - 21201 40 2 - 21521 40 2 - 21841 40 2 - 22161 40 2 - 22481 40 2 - 22801 40 2 - 23121 40 2 - 23441 40 2 - 23761 40 2 - 24081 40 2 - 24401 40 2 - 24721 40 2 - 25041 40 2 - 25361 40 2 - 25681 40 2 - 26001 40 2 - 26321 40 2 - 26641 40 2 - 26961 40 2 - 27281 40 2 - 27601 40 2 - 27921 40 2 - 28241 40 2 - 28561 40 2 - 28881 40 2 - 29201 40 2 - 29521 40 2 - 29841 40 2 - 30161 40 2 - 30481 40 2 - 30801 40 2 - 31121 40 2 - 31441 40 2 - 31761 40 2 - 32081 40 2 - 32401 40 2 - 32721 40 2 - 33041 40 2 - 33361 40 2 - 33681 40 2 - 34001 40 2 - 34321 40 2 - 34641 40 2 - 34961 40 2 - 35281 40 2 - 35601 40 2 - 35921 40 2 - 36241 40 2 - 36561 40 2 - 36881 40 2 - 37201 40 2 - 37521 40 2 - 37841 40 2 - 38161 40 2 - 38481 40 2 - 38801 40 2 - 39121 40 2 - 39441 40 2 - 39761 40 2 - 40081 40 2 - 40401 40 2 - 40721 40 2 - 41041 40 2 - 41361 40 2 - 41681 40 2 - 42001 40 2 - 42321 40 2 - 42641 40 2 - 42961 40 2 - 43281 40 2 - 43601 40 2 - 43921 40 2 - 44241 40 2 - 44561 40 2 - 44881 40 2 - 45201 40 2 - 45521 40 2 - 45841 40 2 - 46161 40 2 - 46481 40 2 - 46801 40 2 - 47121 40 2 - 47441 40 2 - 47761 40 2 - 48081 40 2 - 48401 40 2 - 48721 40 2 - 49041 40 2 - 49361 40 2 - 49681 40 2 - 50001 40 2 - 50321 40 2 - 50641 40 2 - 50961 40 2 - 51281 40 2 - 51601 40 2 - 51921 40 2 - 52241 40 2 - 52561 40 2 - 52881 40 2 - 53201 40 2 - 53521 40 2 - 53841 40 2 - 54161 40 2 - 54481 40 2 - 54801 40 2 - 55121 40 2 - 55441 40 2 - 55761 40 2 - 56081 40 2 - 56401 40 2 - 56721 40 2 - 57041 40 2 - 57361 40 2 - 57681 40 2 - 58001 40 2 - 58321 40 2 - 58641 40 2 - 58961 40 2 - 59281 40 2 - 59601 40 2 - 59921 40 2 - 60241 40 2 - 60561 40 2 - 60881 40 2 - 61201 40 2 - 61521 40 2 - 61841 40 2 - 62161 40 2 - 62481 40 2 - 62801 40 2 - 63121 40 2 - 63441 40 2 - 63761 40 2 - 64081 40 2 - 64401 40 2 - 64721 40 2 - 65041 40 2 - 65361 40 2 - 65681 40 2 - 66001 40 2 - 66321 40 2 - 66641 40 2 - 66961 40 2 - 67281 40 2 - 67601 40 2 - 67921 40 2 - 68241 40 2 - 68561 40 2 - 68881 40 2 - 69201 40 2 - 69521 40 2 - 69841 40 2 - 70161 40 2 - 70481 40 2 - 70801 40 2 - 71121 40 2 - 71441 40 2 - 71761 40 2 - 72081 40 2 - 72401 40 2 - 72721 40 2 - 73041 40 2 - 73361 40 2 - 73681 40 2 - 74001 40 2 - 74321 40 2 - 74641 40 2 - 74961 40 2 - 75281 40 2 - 75601 40 2 - 75921 40 2 - 76241 40 2 - 76561 40 2 - 76881 40 2 - 77201 40 2 - 77521 40 2 - 77841 40 2 - 78161 40 2 - 78481 40 2 - 78801 40 2 - 79121 40 2 - 79441 40 2 - 79761 40 2 - 80081 40 2 - 80401 40 2 - 80721 40 2 - 81041 40 2 - 81361 40 2 - 81681 40 2 - 82001 40 2 - 82321 40 2 - 82641 40 2 - 82961 40 2 - 83281 40 2 - 83601 40 2 - 83921 40 2 - 84241 40 2 - 84561 40 2 - 84881 40 2 - 85201 40 2 - 85521 40 2 - 85841 40 2 - 86161 40 2 - 86481 40 2 - 86801 40 2 - 87121 40 2 - 87441 40 2 - 87761 40 2 - 88081 40 2 - 88401 40 2 - 88721 40 2 - 89041 40 2 - 89361 40 2 - 89681 40 2 - 90001 40 2 - 90321 40 2 - 90641 40 2 - 90961 40 2 - 91281 40 2 - 91601 40 2 - 91921 40 2 - 92241 40 2 - 92561 40 2 - 92881 40 2 - 93201 40 2 - 93521 40 2 - 93841 40 2 - 94161 40 2 - 94481 40 2 - 94801 40 2 - 95121 40 2 - 95441 40 2 - 95761 40 2 - 96081 40 2 - 96401 40 2 - 96721 40 2 - 97041 40 2 - 97361 40 2 - 97681 40 2 - 98001 40 2 - 98321 40 2 - 98641 40 2 - 98961 40 2 - 99281 40 2 - 99601 40 2 - 99921 40 2 - 100241 40 2 - 100561 40 2 - 100881 40 2 - 101201 40 2 - 101521 40 2 - 101841 40 2 - 102161 40 2 - 102481 40 2 - 102801 40 2 - 103121 40 2 - 103441 40 2 - 103761 40 2 - 104081 40 2 - 104401 40 2 - 104721 40 2 - 105041 40 2 - 105361 40 2 - 105681 40 2 - 106001 40 2 - 106321 40 2 - 106641 40 2 - 106961 40 2 - 107281 40 2 - 107601 40 2 - 107921 40 2 - 108241 40 2 - 108561 40 2 - 108881 40 2 - 109201 40 2 - 109521 40 2 - 109841 40 2 - 110161 40 2 - 110481 40 2 - 110801 40 2 - 111121 40 2 - 111441 40 2 - 111761 40 2 - 112081 40 2 - 112401 40 2 - 112721 40 2 - 113041 40 2 - 113361 40 2 - 113681 40 2 - 114001 40 2 - 114321 40 2 - 114641 40 2 - 114961 40 2 - 115281 40 2 - 115601 40 2 - 115921 40 2 - 116241 40 2 - 116561 40 2 - 116881 40 2 - 117201 40 2 - 117521 40 2 - 117841 40 2 - 118161 40 2 - 118481 40 2 - 118801 40 2 - 119121 40 2 - 119441 40 2 - 119761 40 2 - 120081 40 2 - 120401 40 2 - 120721 40 2 - 121041 40 2 - 121361 40 2 - 121681 40 2 - 122001 40 2 - 122321 40 2 - 122641 40 2 - 121 40 3 - 441 40 3 - 761 40 3 - 1081 40 3 - 1401 40 3 - 1721 40 3 - 2041 40 3 - 2361 40 3 - 2681 40 3 - 3001 40 3 - 3321 40 3 - 3641 40 3 - 3961 40 3 - 4281 40 3 - 4601 40 3 - 4921 40 3 - 5241 40 3 - 5561 40 3 - 5881 40 3 - 6201 40 3 - 6521 40 3 - 6841 40 3 - 7161 40 3 - 7481 40 3 - 7801 40 3 - 8121 40 3 - 8441 40 3 - 8761 40 3 - 9081 40 3 - 9401 40 3 - 9721 40 3 - 10041 40 3 - 10361 40 3 - 10681 40 3 - 11001 40 3 - 11321 40 3 - 11641 40 3 - 11961 40 3 - 12281 40 3 - 12601 40 3 - 12921 40 3 - 13241 40 3 - 13561 40 3 - 13881 40 3 - 14201 40 3 - 14521 40 3 - 14841 40 3 - 15161 40 3 - 15481 40 3 - 15801 40 3 - 16121 40 3 - 16441 40 3 - 16761 40 3 - 17081 40 3 - 17401 40 3 - 17721 40 3 - 18041 40 3 - 18361 40 3 - 18681 40 3 - 19001 40 3 - 19321 40 3 - 19641 40 3 - 19961 40 3 - 20281 40 3 - 20601 40 3 - 20921 40 3 - 21241 40 3 - 21561 40 3 - 21881 40 3 - 22201 40 3 - 22521 40 3 - 22841 40 3 - 23161 40 3 - 23481 40 3 - 23801 40 3 - 24121 40 3 - 24441 40 3 - 24761 40 3 - 25081 40 3 - 25401 40 3 - 25721 40 3 - 26041 40 3 - 26361 40 3 - 26681 40 3 - 27001 40 3 - 27321 40 3 - 27641 40 3 - 27961 40 3 - 28281 40 3 - 28601 40 3 - 28921 40 3 - 29241 40 3 - 29561 40 3 - 29881 40 3 - 30201 40 3 - 30521 40 3 - 30841 40 3 - 31161 40 3 - 31481 40 3 - 31801 40 3 - 32121 40 3 - 32441 40 3 - 32761 40 3 - 33081 40 3 - 33401 40 3 - 33721 40 3 - 34041 40 3 - 34361 40 3 - 34681 40 3 - 35001 40 3 - 35321 40 3 - 35641 40 3 - 35961 40 3 - 36281 40 3 - 36601 40 3 - 36921 40 3 - 37241 40 3 - 37561 40 3 - 37881 40 3 - 38201 40 3 - 38521 40 3 - 38841 40 3 - 39161 40 3 - 39481 40 3 - 39801 40 3 - 40121 40 3 - 40441 40 3 - 40761 40 3 - 41081 40 3 - 41401 40 3 - 41721 40 3 - 42041 40 3 - 42361 40 3 - 42681 40 3 - 43001 40 3 - 43321 40 3 - 43641 40 3 - 43961 40 3 - 44281 40 3 - 44601 40 3 - 44921 40 3 - 45241 40 3 - 45561 40 3 - 45881 40 3 - 46201 40 3 - 46521 40 3 - 46841 40 3 - 47161 40 3 - 47481 40 3 - 47801 40 3 - 48121 40 3 - 48441 40 3 - 48761 40 3 - 49081 40 3 - 49401 40 3 - 49721 40 3 - 50041 40 3 - 50361 40 3 - 50681 40 3 - 51001 40 3 - 51321 40 3 - 51641 40 3 - 51961 40 3 - 52281 40 3 - 52601 40 3 - 52921 40 3 - 53241 40 3 - 53561 40 3 - 53881 40 3 - 54201 40 3 - 54521 40 3 - 54841 40 3 - 55161 40 3 - 55481 40 3 - 55801 40 3 - 56121 40 3 - 56441 40 3 - 56761 40 3 - 57081 40 3 - 57401 40 3 - 57721 40 3 - 58041 40 3 - 58361 40 3 - 58681 40 3 - 59001 40 3 - 59321 40 3 - 59641 40 3 - 59961 40 3 - 60281 40 3 - 60601 40 3 - 60921 40 3 - 61241 40 3 - 61561 40 3 - 61881 40 3 - 62201 40 3 - 62521 40 3 - 62841 40 3 - 63161 40 3 - 63481 40 3 - 63801 40 3 - 64121 40 3 - 64441 40 3 - 64761 40 3 - 65081 40 3 - 65401 40 3 - 65721 40 3 - 66041 40 3 - 66361 40 3 - 66681 40 3 - 67001 40 3 - 67321 40 3 - 67641 40 3 - 67961 40 3 - 68281 40 3 - 68601 40 3 - 68921 40 3 - 69241 40 3 - 69561 40 3 - 69881 40 3 - 70201 40 3 - 70521 40 3 - 70841 40 3 - 71161 40 3 - 71481 40 3 - 71801 40 3 - 72121 40 3 - 72441 40 3 - 72761 40 3 - 73081 40 3 - 73401 40 3 - 73721 40 3 - 74041 40 3 - 74361 40 3 - 74681 40 3 - 75001 40 3 - 75321 40 3 - 75641 40 3 - 75961 40 3 - 76281 40 3 - 76601 40 3 - 76921 40 3 - 77241 40 3 - 77561 40 3 - 77881 40 3 - 78201 40 3 - 78521 40 3 - 78841 40 3 - 79161 40 3 - 79481 40 3 - 79801 40 3 - 80121 40 3 - 80441 40 3 - 80761 40 3 - 81081 40 3 - 81401 40 3 - 81721 40 3 - 82041 40 3 - 82361 40 3 - 82681 40 3 - 83001 40 3 - 83321 40 3 - 83641 40 3 - 83961 40 3 - 84281 40 3 - 84601 40 3 - 84921 40 3 - 85241 40 3 - 85561 40 3 - 85881 40 3 - 86201 40 3 - 86521 40 3 - 86841 40 3 - 87161 40 3 - 87481 40 3 - 87801 40 3 - 88121 40 3 - 88441 40 3 - 88761 40 3 - 89081 40 3 - 89401 40 3 - 89721 40 3 - 90041 40 3 - 90361 40 3 - 90681 40 3 - 91001 40 3 - 91321 40 3 - 91641 40 3 - 91961 40 3 - 92281 40 3 - 92601 40 3 - 92921 40 3 - 93241 40 3 - 93561 40 3 - 93881 40 3 - 94201 40 3 - 94521 40 3 - 94841 40 3 - 95161 40 3 - 95481 40 3 - 95801 40 3 - 96121 40 3 - 96441 40 3 - 96761 40 3 - 97081 40 3 - 97401 40 3 - 97721 40 3 - 98041 40 3 - 98361 40 3 - 98681 40 3 - 99001 40 3 - 99321 40 3 - 99641 40 3 - 99961 40 3 - 100281 40 3 - 100601 40 3 - 100921 40 3 - 101241 40 3 - 101561 40 3 - 101881 40 3 - 102201 40 3 - 102521 40 3 - 102841 40 3 - 103161 40 3 - 103481 40 3 - 103801 40 3 - 104121 40 3 - 104441 40 3 - 104761 40 3 - 105081 40 3 - 105401 40 3 - 105721 40 3 - 106041 40 3 - 106361 40 3 - 106681 40 3 - 107001 40 3 - 107321 40 3 - 107641 40 3 - 107961 40 3 - 108281 40 3 - 108601 40 3 - 108921 40 3 - 109241 40 3 - 109561 40 3 - 109881 40 3 - 110201 40 3 - 110521 40 3 - 110841 40 3 - 111161 40 3 - 111481 40 3 - 111801 40 3 - 112121 40 3 - 112441 40 3 - 112761 40 3 - 113081 40 3 - 113401 40 3 - 113721 40 3 - 114041 40 3 - 114361 40 3 - 114681 40 3 - 115001 40 3 - 115321 40 3 - 115641 40 3 - 115961 40 3 - 116281 40 3 - 116601 40 3 - 116921 40 3 - 117241 40 3 - 117561 40 3 - 117881 40 3 - 118201 40 3 - 118521 40 3 - 118841 40 3 - 119161 40 3 - 119481 40 3 - 119801 40 3 - 120121 40 3 - 120441 40 3 - 120761 40 3 - 121081 40 3 - 121401 40 3 - 121721 40 3 - 122041 40 3 - 122361 40 3 - 122681 40 3 - 161 40 4 - 481 40 4 - 801 40 4 - 1121 40 4 - 1441 40 4 - 1761 40 4 - 2081 40 4 - 2401 40 4 - 2721 40 4 - 3041 40 4 - 3361 40 4 - 3681 40 4 - 4001 40 4 - 4321 40 4 - 4641 40 4 - 4961 40 4 - 5281 40 4 - 5601 40 4 - 5921 40 4 - 6241 40 4 - 6561 40 4 - 6881 40 4 - 7201 40 4 - 7521 40 4 - 7841 40 4 - 8161 40 4 - 8481 40 4 - 8801 40 4 - 9121 40 4 - 9441 40 4 - 9761 40 4 - 10081 40 4 - 10401 40 4 - 10721 40 4 - 11041 40 4 - 11361 40 4 - 11681 40 4 - 12001 40 4 - 12321 40 4 - 12641 40 4 - 12961 40 4 - 13281 40 4 - 13601 40 4 - 13921 40 4 - 14241 40 4 - 14561 40 4 - 14881 40 4 - 15201 40 4 - 15521 40 4 - 15841 40 4 - 16161 40 4 - 16481 40 4 - 16801 40 4 - 17121 40 4 - 17441 40 4 - 17761 40 4 - 18081 40 4 - 18401 40 4 - 18721 40 4 - 19041 40 4 - 19361 40 4 - 19681 40 4 - 20001 40 4 - 20321 40 4 - 20641 40 4 - 20961 40 4 - 21281 40 4 - 21601 40 4 - 21921 40 4 - 22241 40 4 - 22561 40 4 - 22881 40 4 - 23201 40 4 - 23521 40 4 - 23841 40 4 - 24161 40 4 - 24481 40 4 - 24801 40 4 - 25121 40 4 - 25441 40 4 - 25761 40 4 - 26081 40 4 - 26401 40 4 - 26721 40 4 - 27041 40 4 - 27361 40 4 - 27681 40 4 - 28001 40 4 - 28321 40 4 - 28641 40 4 - 28961 40 4 - 29281 40 4 - 29601 40 4 - 29921 40 4 - 30241 40 4 - 30561 40 4 - 30881 40 4 - 31201 40 4 - 31521 40 4 - 31841 40 4 - 32161 40 4 - 32481 40 4 - 32801 40 4 - 33121 40 4 - 33441 40 4 - 33761 40 4 - 34081 40 4 - 34401 40 4 - 34721 40 4 - 35041 40 4 - 35361 40 4 - 35681 40 4 - 36001 40 4 - 36321 40 4 - 36641 40 4 - 36961 40 4 - 37281 40 4 - 37601 40 4 - 37921 40 4 - 38241 40 4 - 38561 40 4 - 38881 40 4 - 39201 40 4 - 39521 40 4 - 39841 40 4 - 40161 40 4 - 40481 40 4 - 40801 40 4 - 41121 40 4 - 41441 40 4 - 41761 40 4 - 42081 40 4 - 42401 40 4 - 42721 40 4 - 43041 40 4 - 43361 40 4 - 43681 40 4 - 44001 40 4 - 44321 40 4 - 44641 40 4 - 44961 40 4 - 45281 40 4 - 45601 40 4 - 45921 40 4 - 46241 40 4 - 46561 40 4 - 46881 40 4 - 47201 40 4 - 47521 40 4 - 47841 40 4 - 48161 40 4 - 48481 40 4 - 48801 40 4 - 49121 40 4 - 49441 40 4 - 49761 40 4 - 50081 40 4 - 50401 40 4 - 50721 40 4 - 51041 40 4 - 51361 40 4 - 51681 40 4 - 52001 40 4 - 52321 40 4 - 52641 40 4 - 52961 40 4 - 53281 40 4 - 53601 40 4 - 53921 40 4 - 54241 40 4 - 54561 40 4 - 54881 40 4 - 55201 40 4 - 55521 40 4 - 55841 40 4 - 56161 40 4 - 56481 40 4 - 56801 40 4 - 57121 40 4 - 57441 40 4 - 57761 40 4 - 58081 40 4 - 58401 40 4 - 58721 40 4 - 59041 40 4 - 59361 40 4 - 59681 40 4 - 60001 40 4 - 60321 40 4 - 60641 40 4 - 60961 40 4 - 61281 40 4 - 61601 40 4 - 61921 40 4 - 62241 40 4 - 62561 40 4 - 62881 40 4 - 63201 40 4 - 63521 40 4 - 63841 40 4 - 64161 40 4 - 64481 40 4 - 64801 40 4 - 65121 40 4 - 65441 40 4 - 65761 40 4 - 66081 40 4 - 66401 40 4 - 66721 40 4 - 67041 40 4 - 67361 40 4 - 67681 40 4 - 68001 40 4 - 68321 40 4 - 68641 40 4 - 68961 40 4 - 69281 40 4 - 69601 40 4 - 69921 40 4 - 70241 40 4 - 70561 40 4 - 70881 40 4 - 71201 40 4 - 71521 40 4 - 71841 40 4 - 72161 40 4 - 72481 40 4 - 72801 40 4 - 73121 40 4 - 73441 40 4 - 73761 40 4 - 74081 40 4 - 74401 40 4 - 74721 40 4 - 75041 40 4 - 75361 40 4 - 75681 40 4 - 76001 40 4 - 76321 40 4 - 76641 40 4 - 76961 40 4 - 77281 40 4 - 77601 40 4 - 77921 40 4 - 78241 40 4 - 78561 40 4 - 78881 40 4 - 79201 40 4 - 79521 40 4 - 79841 40 4 - 80161 40 4 - 80481 40 4 - 80801 40 4 - 81121 40 4 - 81441 40 4 - 81761 40 4 - 82081 40 4 - 82401 40 4 - 82721 40 4 - 83041 40 4 - 83361 40 4 - 83681 40 4 - 84001 40 4 - 84321 40 4 - 84641 40 4 - 84961 40 4 - 85281 40 4 - 85601 40 4 - 85921 40 4 - 86241 40 4 - 86561 40 4 - 86881 40 4 - 87201 40 4 - 87521 40 4 - 87841 40 4 - 88161 40 4 - 88481 40 4 - 88801 40 4 - 89121 40 4 - 89441 40 4 - 89761 40 4 - 90081 40 4 - 90401 40 4 - 90721 40 4 - 91041 40 4 - 91361 40 4 - 91681 40 4 - 92001 40 4 - 92321 40 4 - 92641 40 4 - 92961 40 4 - 93281 40 4 - 93601 40 4 - 93921 40 4 - 94241 40 4 - 94561 40 4 - 94881 40 4 - 95201 40 4 - 95521 40 4 - 95841 40 4 - 96161 40 4 - 96481 40 4 - 96801 40 4 - 97121 40 4 - 97441 40 4 - 97761 40 4 - 98081 40 4 - 98401 40 4 - 98721 40 4 - 99041 40 4 - 99361 40 4 - 99681 40 4 - 100001 40 4 - 100321 40 4 - 100641 40 4 - 100961 40 4 - 101281 40 4 - 101601 40 4 - 101921 40 4 - 102241 40 4 - 102561 40 4 - 102881 40 4 - 103201 40 4 - 103521 40 4 - 103841 40 4 - 104161 40 4 - 104481 40 4 - 104801 40 4 - 105121 40 4 - 105441 40 4 - 105761 40 4 - 106081 40 4 - 106401 40 4 - 106721 40 4 - 107041 40 4 - 107361 40 4 - 107681 40 4 - 108001 40 4 - 108321 40 4 - 108641 40 4 - 108961 40 4 - 109281 40 4 - 109601 40 4 - 109921 40 4 - 110241 40 4 - 110561 40 4 - 110881 40 4 - 111201 40 4 - 111521 40 4 - 111841 40 4 - 112161 40 4 - 112481 40 4 - 112801 40 4 - 113121 40 4 - 113441 40 4 - 113761 40 4 - 114081 40 4 - 114401 40 4 - 114721 40 4 - 115041 40 4 - 115361 40 4 - 115681 40 4 - 116001 40 4 - 116321 40 4 - 116641 40 4 - 116961 40 4 - 117281 40 4 - 117601 40 4 - 117921 40 4 - 118241 40 4 - 118561 40 4 - 118881 40 4 - 119201 40 4 - 119521 40 4 - 119841 40 4 - 120161 40 4 - 120481 40 4 - 120801 40 4 - 121121 40 4 - 121441 40 4 - 121761 40 4 - 122081 40 4 - 122401 40 4 - 122721 40 4 - 201 40 5 - 521 40 5 - 841 40 5 - 1161 40 5 - 1481 40 5 - 1801 40 5 - 2121 40 5 - 2441 40 5 - 2761 40 5 - 3081 40 5 - 3401 40 5 - 3721 40 5 - 4041 40 5 - 4361 40 5 - 4681 40 5 - 5001 40 5 - 5321 40 5 - 5641 40 5 - 5961 40 5 - 6281 40 5 - 6601 40 5 - 6921 40 5 - 7241 40 5 - 7561 40 5 - 7881 40 5 - 8201 40 5 - 8521 40 5 - 8841 40 5 - 9161 40 5 - 9481 40 5 - 9801 40 5 - 10121 40 5 - 10441 40 5 - 10761 40 5 - 11081 40 5 - 11401 40 5 - 11721 40 5 - 12041 40 5 - 12361 40 5 - 12681 40 5 - 13001 40 5 - 13321 40 5 - 13641 40 5 - 13961 40 5 - 14281 40 5 - 14601 40 5 - 14921 40 5 - 15241 40 5 - 15561 40 5 - 15881 40 5 - 16201 40 5 - 16521 40 5 - 16841 40 5 - 17161 40 5 - 17481 40 5 - 17801 40 5 - 18121 40 5 - 18441 40 5 - 18761 40 5 - 19081 40 5 - 19401 40 5 - 19721 40 5 - 20041 40 5 - 20361 40 5 - 20681 40 5 - 21001 40 5 - 21321 40 5 - 21641 40 5 - 21961 40 5 - 22281 40 5 - 22601 40 5 - 22921 40 5 - 23241 40 5 - 23561 40 5 - 23881 40 5 - 24201 40 5 - 24521 40 5 - 24841 40 5 - 25161 40 5 - 25481 40 5 - 25801 40 5 - 26121 40 5 - 26441 40 5 - 26761 40 5 - 27081 40 5 - 27401 40 5 - 27721 40 5 - 28041 40 5 - 28361 40 5 - 28681 40 5 - 29001 40 5 - 29321 40 5 - 29641 40 5 - 29961 40 5 - 30281 40 5 - 30601 40 5 - 30921 40 5 - 31241 40 5 - 31561 40 5 - 31881 40 5 - 32201 40 5 - 32521 40 5 - 32841 40 5 - 33161 40 5 - 33481 40 5 - 33801 40 5 - 34121 40 5 - 34441 40 5 - 34761 40 5 - 35081 40 5 - 35401 40 5 - 35721 40 5 - 36041 40 5 - 36361 40 5 - 36681 40 5 - 37001 40 5 - 37321 40 5 - 37641 40 5 - 37961 40 5 - 38281 40 5 - 38601 40 5 - 38921 40 5 - 39241 40 5 - 39561 40 5 - 39881 40 5 - 40201 40 5 - 40521 40 5 - 40841 40 5 - 41161 40 5 - 41481 40 5 - 41801 40 5 - 42121 40 5 - 42441 40 5 - 42761 40 5 - 43081 40 5 - 43401 40 5 - 43721 40 5 - 44041 40 5 - 44361 40 5 - 44681 40 5 - 45001 40 5 - 45321 40 5 - 45641 40 5 - 45961 40 5 - 46281 40 5 - 46601 40 5 - 46921 40 5 - 47241 40 5 - 47561 40 5 - 47881 40 5 - 48201 40 5 - 48521 40 5 - 48841 40 5 - 49161 40 5 - 49481 40 5 - 49801 40 5 - 50121 40 5 - 50441 40 5 - 50761 40 5 - 51081 40 5 - 51401 40 5 - 51721 40 5 - 52041 40 5 - 52361 40 5 - 52681 40 5 - 53001 40 5 - 53321 40 5 - 53641 40 5 - 53961 40 5 - 54281 40 5 - 54601 40 5 - 54921 40 5 - 55241 40 5 - 55561 40 5 - 55881 40 5 - 56201 40 5 - 56521 40 5 - 56841 40 5 - 57161 40 5 - 57481 40 5 - 57801 40 5 - 58121 40 5 - 58441 40 5 - 58761 40 5 - 59081 40 5 - 59401 40 5 - 59721 40 5 - 60041 40 5 - 60361 40 5 - 60681 40 5 - 61001 40 5 - 61321 40 5 - 61641 40 5 - 61961 40 5 - 62281 40 5 - 62601 40 5 - 62921 40 5 - 63241 40 5 - 63561 40 5 - 63881 40 5 - 64201 40 5 - 64521 40 5 - 64841 40 5 - 65161 40 5 - 65481 40 5 - 65801 40 5 - 66121 40 5 - 66441 40 5 - 66761 40 5 - 67081 40 5 - 67401 40 5 - 67721 40 5 - 68041 40 5 - 68361 40 5 - 68681 40 5 - 69001 40 5 - 69321 40 5 - 69641 40 5 - 69961 40 5 - 70281 40 5 - 70601 40 5 - 70921 40 5 - 71241 40 5 - 71561 40 5 - 71881 40 5 - 72201 40 5 - 72521 40 5 - 72841 40 5 - 73161 40 5 - 73481 40 5 - 73801 40 5 - 74121 40 5 - 74441 40 5 - 74761 40 5 - 75081 40 5 - 75401 40 5 - 75721 40 5 - 76041 40 5 - 76361 40 5 - 76681 40 5 - 77001 40 5 - 77321 40 5 - 77641 40 5 - 77961 40 5 - 78281 40 5 - 78601 40 5 - 78921 40 5 - 79241 40 5 - 79561 40 5 - 79881 40 5 - 80201 40 5 - 80521 40 5 - 80841 40 5 - 81161 40 5 - 81481 40 5 - 81801 40 5 - 82121 40 5 - 82441 40 5 - 82761 40 5 - 83081 40 5 - 83401 40 5 - 83721 40 5 - 84041 40 5 - 84361 40 5 - 84681 40 5 - 85001 40 5 - 85321 40 5 - 85641 40 5 - 85961 40 5 - 86281 40 5 - 86601 40 5 - 86921 40 5 - 87241 40 5 - 87561 40 5 - 87881 40 5 - 88201 40 5 - 88521 40 5 - 88841 40 5 - 89161 40 5 - 89481 40 5 - 89801 40 5 - 90121 40 5 - 90441 40 5 - 90761 40 5 - 91081 40 5 - 91401 40 5 - 91721 40 5 - 92041 40 5 - 92361 40 5 - 92681 40 5 - 93001 40 5 - 93321 40 5 - 93641 40 5 - 93961 40 5 - 94281 40 5 - 94601 40 5 - 94921 40 5 - 95241 40 5 - 95561 40 5 - 95881 40 5 - 96201 40 5 - 96521 40 5 - 96841 40 5 - 97161 40 5 - 97481 40 5 - 97801 40 5 - 98121 40 5 - 98441 40 5 - 98761 40 5 - 99081 40 5 - 99401 40 5 - 99721 40 5 - 100041 40 5 - 100361 40 5 - 100681 40 5 - 101001 40 5 - 101321 40 5 - 101641 40 5 - 101961 40 5 - 102281 40 5 - 102601 40 5 - 102921 40 5 - 103241 40 5 - 103561 40 5 - 103881 40 5 - 104201 40 5 - 104521 40 5 - 104841 40 5 - 105161 40 5 - 105481 40 5 - 105801 40 5 - 106121 40 5 - 106441 40 5 - 106761 40 5 - 107081 40 5 - 107401 40 5 - 107721 40 5 - 108041 40 5 - 108361 40 5 - 108681 40 5 - 109001 40 5 - 109321 40 5 - 109641 40 5 - 109961 40 5 - 110281 40 5 - 110601 40 5 - 110921 40 5 - 111241 40 5 - 111561 40 5 - 111881 40 5 - 112201 40 5 - 112521 40 5 - 112841 40 5 - 113161 40 5 - 113481 40 5 - 113801 40 5 - 114121 40 5 - 114441 40 5 - 114761 40 5 - 115081 40 5 - 115401 40 5 - 115721 40 5 - 116041 40 5 - 116361 40 5 - 116681 40 5 - 117001 40 5 - 117321 40 5 - 117641 40 5 - 117961 40 5 - 118281 40 5 - 118601 40 5 - 118921 40 5 - 119241 40 5 - 119561 40 5 - 119881 40 5 - 120201 40 5 - 120521 40 5 - 120841 40 5 - 121161 40 5 - 121481 40 5 - 121801 40 5 - 122121 40 5 - 122441 40 5 - 122761 40 5 - 241 40 6 - 561 40 6 - 881 40 6 - 1201 40 6 - 1521 40 6 - 1841 40 6 - 2161 40 6 - 2481 40 6 - 2801 40 6 - 3121 40 6 - 3441 40 6 - 3761 40 6 - 4081 40 6 - 4401 40 6 - 4721 40 6 - 5041 40 6 - 5361 40 6 - 5681 40 6 - 6001 40 6 - 6321 40 6 - 6641 40 6 - 6961 40 6 - 7281 40 6 - 7601 40 6 - 7921 40 6 - 8241 40 6 - 8561 40 6 - 8881 40 6 - 9201 40 6 - 9521 40 6 - 9841 40 6 - 10161 40 6 - 10481 40 6 - 10801 40 6 - 11121 40 6 - 11441 40 6 - 11761 40 6 - 12081 40 6 - 12401 40 6 - 12721 40 6 - 13041 40 6 - 13361 40 6 - 13681 40 6 - 14001 40 6 - 14321 40 6 - 14641 40 6 - 14961 40 6 - 15281 40 6 - 15601 40 6 - 15921 40 6 - 16241 40 6 - 16561 40 6 - 16881 40 6 - 17201 40 6 - 17521 40 6 - 17841 40 6 - 18161 40 6 - 18481 40 6 - 18801 40 6 - 19121 40 6 - 19441 40 6 - 19761 40 6 - 20081 40 6 - 20401 40 6 - 20721 40 6 - 21041 40 6 - 21361 40 6 - 21681 40 6 - 22001 40 6 - 22321 40 6 - 22641 40 6 - 22961 40 6 - 23281 40 6 - 23601 40 6 - 23921 40 6 - 24241 40 6 - 24561 40 6 - 24881 40 6 - 25201 40 6 - 25521 40 6 - 25841 40 6 - 26161 40 6 - 26481 40 6 - 26801 40 6 - 27121 40 6 - 27441 40 6 - 27761 40 6 - 28081 40 6 - 28401 40 6 - 28721 40 6 - 29041 40 6 - 29361 40 6 - 29681 40 6 - 30001 40 6 - 30321 40 6 - 30641 40 6 - 30961 40 6 - 31281 40 6 - 31601 40 6 - 31921 40 6 - 32241 40 6 - 32561 40 6 - 32881 40 6 - 33201 40 6 - 33521 40 6 - 33841 40 6 - 34161 40 6 - 34481 40 6 - 34801 40 6 - 35121 40 6 - 35441 40 6 - 35761 40 6 - 36081 40 6 - 36401 40 6 - 36721 40 6 - 37041 40 6 - 37361 40 6 - 37681 40 6 - 38001 40 6 - 38321 40 6 - 38641 40 6 - 38961 40 6 - 39281 40 6 - 39601 40 6 - 39921 40 6 - 40241 40 6 - 40561 40 6 - 40881 40 6 - 41201 40 6 - 41521 40 6 - 41841 40 6 - 42161 40 6 - 42481 40 6 - 42801 40 6 - 43121 40 6 - 43441 40 6 - 43761 40 6 - 44081 40 6 - 44401 40 6 - 44721 40 6 - 45041 40 6 - 45361 40 6 - 45681 40 6 - 46001 40 6 - 46321 40 6 - 46641 40 6 - 46961 40 6 - 47281 40 6 - 47601 40 6 - 47921 40 6 - 48241 40 6 - 48561 40 6 - 48881 40 6 - 49201 40 6 - 49521 40 6 - 49841 40 6 - 50161 40 6 - 50481 40 6 - 50801 40 6 - 51121 40 6 - 51441 40 6 - 51761 40 6 - 52081 40 6 - 52401 40 6 - 52721 40 6 - 53041 40 6 - 53361 40 6 - 53681 40 6 - 54001 40 6 - 54321 40 6 - 54641 40 6 - 54961 40 6 - 55281 40 6 - 55601 40 6 - 55921 40 6 - 56241 40 6 - 56561 40 6 - 56881 40 6 - 57201 40 6 - 57521 40 6 - 57841 40 6 - 58161 40 6 - 58481 40 6 - 58801 40 6 - 59121 40 6 - 59441 40 6 - 59761 40 6 - 60081 40 6 - 60401 40 6 - 60721 40 6 - 61041 40 6 - 61361 40 6 - 61681 40 6 - 62001 40 6 - 62321 40 6 - 62641 40 6 - 62961 40 6 - 63281 40 6 - 63601 40 6 - 63921 40 6 - 64241 40 6 - 64561 40 6 - 64881 40 6 - 65201 40 6 - 65521 40 6 - 65841 40 6 - 66161 40 6 - 66481 40 6 - 66801 40 6 - 67121 40 6 - 67441 40 6 - 67761 40 6 - 68081 40 6 - 68401 40 6 - 68721 40 6 - 69041 40 6 - 69361 40 6 - 69681 40 6 - 70001 40 6 - 70321 40 6 - 70641 40 6 - 70961 40 6 - 71281 40 6 - 71601 40 6 - 71921 40 6 - 72241 40 6 - 72561 40 6 - 72881 40 6 - 73201 40 6 - 73521 40 6 - 73841 40 6 - 74161 40 6 - 74481 40 6 - 74801 40 6 - 75121 40 6 - 75441 40 6 - 75761 40 6 - 76081 40 6 - 76401 40 6 - 76721 40 6 - 77041 40 6 - 77361 40 6 - 77681 40 6 - 78001 40 6 - 78321 40 6 - 78641 40 6 - 78961 40 6 - 79281 40 6 - 79601 40 6 - 79921 40 6 - 80241 40 6 - 80561 40 6 - 80881 40 6 - 81201 40 6 - 81521 40 6 - 81841 40 6 - 82161 40 6 - 82481 40 6 - 82801 40 6 - 83121 40 6 - 83441 40 6 - 83761 40 6 - 84081 40 6 - 84401 40 6 - 84721 40 6 - 85041 40 6 - 85361 40 6 - 85681 40 6 - 86001 40 6 - 86321 40 6 - 86641 40 6 - 86961 40 6 - 87281 40 6 - 87601 40 6 - 87921 40 6 - 88241 40 6 - 88561 40 6 - 88881 40 6 - 89201 40 6 - 89521 40 6 - 89841 40 6 - 90161 40 6 - 90481 40 6 - 90801 40 6 - 91121 40 6 - 91441 40 6 - 91761 40 6 - 92081 40 6 - 92401 40 6 - 92721 40 6 - 93041 40 6 - 93361 40 6 - 93681 40 6 - 94001 40 6 - 94321 40 6 - 94641 40 6 - 94961 40 6 - 95281 40 6 - 95601 40 6 - 95921 40 6 - 96241 40 6 - 96561 40 6 - 96881 40 6 - 97201 40 6 - 97521 40 6 - 97841 40 6 - 98161 40 6 - 98481 40 6 - 98801 40 6 - 99121 40 6 - 99441 40 6 - 99761 40 6 - 100081 40 6 - 100401 40 6 - 100721 40 6 - 101041 40 6 - 101361 40 6 - 101681 40 6 - 102001 40 6 - 102321 40 6 - 102641 40 6 - 102961 40 6 - 103281 40 6 - 103601 40 6 - 103921 40 6 - 104241 40 6 - 104561 40 6 - 104881 40 6 - 105201 40 6 - 105521 40 6 - 105841 40 6 - 106161 40 6 - 106481 40 6 - 106801 40 6 - 107121 40 6 - 107441 40 6 - 107761 40 6 - 108081 40 6 - 108401 40 6 - 108721 40 6 - 109041 40 6 - 109361 40 6 - 109681 40 6 - 110001 40 6 - 110321 40 6 - 110641 40 6 - 110961 40 6 - 111281 40 6 - 111601 40 6 - 111921 40 6 - 112241 40 6 - 112561 40 6 - 112881 40 6 - 113201 40 6 - 113521 40 6 - 113841 40 6 - 114161 40 6 - 114481 40 6 - 114801 40 6 - 115121 40 6 - 115441 40 6 - 115761 40 6 - 116081 40 6 - 116401 40 6 - 116721 40 6 - 117041 40 6 - 117361 40 6 - 117681 40 6 - 118001 40 6 - 118321 40 6 - 118641 40 6 - 118961 40 6 - 119281 40 6 - 119601 40 6 - 119921 40 6 - 120241 40 6 - 120561 40 6 - 120881 40 6 - 121201 40 6 - 121521 40 6 - 121841 40 6 - 122161 40 6 - 122481 40 6 - 122801 40 6 - 281 40 7 - 601 40 7 - 921 40 7 - 1241 40 7 - 1561 40 7 - 1881 40 7 - 2201 40 7 - 2521 40 7 - 2841 40 7 - 3161 40 7 - 3481 40 7 - 3801 40 7 - 4121 40 7 - 4441 40 7 - 4761 40 7 - 5081 40 7 - 5401 40 7 - 5721 40 7 - 6041 40 7 - 6361 40 7 - 6681 40 7 - 7001 40 7 - 7321 40 7 - 7641 40 7 - 7961 40 7 - 8281 40 7 - 8601 40 7 - 8921 40 7 - 9241 40 7 - 9561 40 7 - 9881 40 7 - 10201 40 7 - 10521 40 7 - 10841 40 7 - 11161 40 7 - 11481 40 7 - 11801 40 7 - 12121 40 7 - 12441 40 7 - 12761 40 7 - 13081 40 7 - 13401 40 7 - 13721 40 7 - 14041 40 7 - 14361 40 7 - 14681 40 7 - 15001 40 7 - 15321 40 7 - 15641 40 7 - 15961 40 7 - 16281 40 7 - 16601 40 7 - 16921 40 7 - 17241 40 7 - 17561 40 7 - 17881 40 7 - 18201 40 7 - 18521 40 7 - 18841 40 7 - 19161 40 7 - 19481 40 7 - 19801 40 7 - 20121 40 7 - 20441 40 7 - 20761 40 7 - 21081 40 7 - 21401 40 7 - 21721 40 7 - 22041 40 7 - 22361 40 7 - 22681 40 7 - 23001 40 7 - 23321 40 7 - 23641 40 7 - 23961 40 7 - 24281 40 7 - 24601 40 7 - 24921 40 7 - 25241 40 7 - 25561 40 7 - 25881 40 7 - 26201 40 7 - 26521 40 7 - 26841 40 7 - 27161 40 7 - 27481 40 7 - 27801 40 7 - 28121 40 7 - 28441 40 7 - 28761 40 7 - 29081 40 7 - 29401 40 7 - 29721 40 7 - 30041 40 7 - 30361 40 7 - 30681 40 7 - 31001 40 7 - 31321 40 7 - 31641 40 7 - 31961 40 7 - 32281 40 7 - 32601 40 7 - 32921 40 7 - 33241 40 7 - 33561 40 7 - 33881 40 7 - 34201 40 7 - 34521 40 7 - 34841 40 7 - 35161 40 7 - 35481 40 7 - 35801 40 7 - 36121 40 7 - 36441 40 7 - 36761 40 7 - 37081 40 7 - 37401 40 7 - 37721 40 7 - 38041 40 7 - 38361 40 7 - 38681 40 7 - 39001 40 7 - 39321 40 7 - 39641 40 7 - 39961 40 7 - 40281 40 7 - 40601 40 7 - 40921 40 7 - 41241 40 7 - 41561 40 7 - 41881 40 7 - 42201 40 7 - 42521 40 7 - 42841 40 7 - 43161 40 7 - 43481 40 7 - 43801 40 7 - 44121 40 7 - 44441 40 7 - 44761 40 7 - 45081 40 7 - 45401 40 7 - 45721 40 7 - 46041 40 7 - 46361 40 7 - 46681 40 7 - 47001 40 7 - 47321 40 7 - 47641 40 7 - 47961 40 7 - 48281 40 7 - 48601 40 7 - 48921 40 7 - 49241 40 7 - 49561 40 7 - 49881 40 7 - 50201 40 7 - 50521 40 7 - 50841 40 7 - 51161 40 7 - 51481 40 7 - 51801 40 7 - 52121 40 7 - 52441 40 7 - 52761 40 7 - 53081 40 7 - 53401 40 7 - 53721 40 7 - 54041 40 7 - 54361 40 7 - 54681 40 7 - 55001 40 7 - 55321 40 7 - 55641 40 7 - 55961 40 7 - 56281 40 7 - 56601 40 7 - 56921 40 7 - 57241 40 7 - 57561 40 7 - 57881 40 7 - 58201 40 7 - 58521 40 7 - 58841 40 7 - 59161 40 7 - 59481 40 7 - 59801 40 7 - 60121 40 7 - 60441 40 7 - 60761 40 7 - 61081 40 7 - 61401 40 7 - 61721 40 7 - 62041 40 7 - 62361 40 7 - 62681 40 7 - 63001 40 7 - 63321 40 7 - 63641 40 7 - 63961 40 7 - 64281 40 7 - 64601 40 7 - 64921 40 7 - 65241 40 7 - 65561 40 7 - 65881 40 7 - 66201 40 7 - 66521 40 7 - 66841 40 7 - 67161 40 7 - 67481 40 7 - 67801 40 7 - 68121 40 7 - 68441 40 7 - 68761 40 7 - 69081 40 7 - 69401 40 7 - 69721 40 7 - 70041 40 7 - 70361 40 7 - 70681 40 7 - 71001 40 7 - 71321 40 7 - 71641 40 7 - 71961 40 7 - 72281 40 7 - 72601 40 7 - 72921 40 7 - 73241 40 7 - 73561 40 7 - 73881 40 7 - 74201 40 7 - 74521 40 7 - 74841 40 7 - 75161 40 7 - 75481 40 7 - 75801 40 7 - 76121 40 7 - 76441 40 7 - 76761 40 7 - 77081 40 7 - 77401 40 7 - 77721 40 7 - 78041 40 7 - 78361 40 7 - 78681 40 7 - 79001 40 7 - 79321 40 7 - 79641 40 7 - 79961 40 7 - 80281 40 7 - 80601 40 7 - 80921 40 7 - 81241 40 7 - 81561 40 7 - 81881 40 7 - 82201 40 7 - 82521 40 7 - 82841 40 7 - 83161 40 7 - 83481 40 7 - 83801 40 7 - 84121 40 7 - 84441 40 7 - 84761 40 7 - 85081 40 7 - 85401 40 7 - 85721 40 7 - 86041 40 7 - 86361 40 7 - 86681 40 7 - 87001 40 7 - 87321 40 7 - 87641 40 7 - 87961 40 7 - 88281 40 7 - 88601 40 7 - 88921 40 7 - 89241 40 7 - 89561 40 7 - 89881 40 7 - 90201 40 7 - 90521 40 7 - 90841 40 7 - 91161 40 7 - 91481 40 7 - 91801 40 7 - 92121 40 7 - 92441 40 7 - 92761 40 7 - 93081 40 7 - 93401 40 7 - 93721 40 7 - 94041 40 7 - 94361 40 7 - 94681 40 7 - 95001 40 7 - 95321 40 7 - 95641 40 7 - 95961 40 7 - 96281 40 7 - 96601 40 7 - 96921 40 7 - 97241 40 7 - 97561 40 7 - 97881 40 7 - 98201 40 7 - 98521 40 7 - 98841 40 7 - 99161 40 7 - 99481 40 7 - 99801 40 7 - 100121 40 7 - 100441 40 7 - 100761 40 7 - 101081 40 7 - 101401 40 7 - 101721 40 7 - 102041 40 7 - 102361 40 7 - 102681 40 7 - 103001 40 7 - 103321 40 7 - 103641 40 7 - 103961 40 7 - 104281 40 7 - 104601 40 7 - 104921 40 7 - 105241 40 7 - 105561 40 7 - 105881 40 7 - 106201 40 7 - 106521 40 7 - 106841 40 7 - 107161 40 7 - 107481 40 7 - 107801 40 7 - 108121 40 7 - 108441 40 7 - 108761 40 7 - 109081 40 7 - 109401 40 7 - 109721 40 7 - 110041 40 7 - 110361 40 7 - 110681 40 7 - 111001 40 7 - 111321 40 7 - 111641 40 7 - 111961 40 7 - 112281 40 7 - 112601 40 7 - 112921 40 7 - 113241 40 7 - 113561 40 7 - 113881 40 7 - 114201 40 7 - 114521 40 7 - 114841 40 7 - 115161 40 7 - 115481 40 7 - 115801 40 7 - 116121 40 7 - 116441 40 7 - 116761 40 7 - 117081 40 7 - 117401 40 7 - 117721 40 7 - 118041 40 7 - 118361 40 7 - 118681 40 7 - 119001 40 7 - 119321 40 7 - 119641 40 7 - 119961 40 7 - 120281 40 7 - 120601 40 7 - 120921 40 7 - 121241 40 7 - 121561 40 7 - 121881 40 7 - 122201 40 7 - 122521 40 7 - 122841 40 7 diff --git a/cesm/models/utils/mct/benchmarks/gx1.8pR b/cesm/models/utils/mct/benchmarks/gx1.8pR deleted file mode 100644 index c90fd78..0000000 --- a/cesm/models/utils/mct/benchmarks/gx1.8pR +++ /dev/null @@ -1,12 +0,0 @@ - 8 - 2 - 8 - 122880 - 1 15360 0 - 15361 15360 1 - 30721 15360 2 - 46081 15360 3 - 61441 15360 4 - 76801 15360 5 - 92161 15360 6 - 107521 15360 7 diff --git a/cesm/models/utils/mct/benchmarks/importBench.F90 b/cesm/models/utils/mct/benchmarks/importBench.F90 deleted file mode 100644 index ab78ca2..0000000 --- a/cesm/models/utils/mct/benchmarks/importBench.F90 +++ /dev/null @@ -1,215 +0,0 @@ -! Av import/export benchmark -! - program importBench - - use m_MCTWorld,only : MCTWorld_init => init - use m_MCTWorld,only : MCTWorld_clean => clean - use m_MCTWorld,only : ThisMCTWorld - use m_AttrVect,only : AttrVect - use m_AttrVect,only : AttrVect_init => init - use m_AttrVect,only : AttrVect_nRattr => nRattr - use m_AttrVect,only : AttrVect_nIattr => nIattr - use m_AttrVect,only : AttrVect_size => lsize - use m_AttrVect,only : AttrVect_indexRA => indexRA - use m_AttrVect,only : AttrVect_importRA => importRAttr - use m_AttrVect,only : AttrVect_exportRA => exportRAttr - - use m_mpif90 - use m_ioutil, only : luavail - - implicit none - -! declarations - include 'mpif.h' - - character(len=*), parameter :: myname='MCT_importBench' - - integer, parameter :: nTrials=1000 ! Number of timing measurements - ! per test. Keep high WRT - ! value of MaxNumAtts to ensure - ! timings are representative - - integer, parameter :: lmax = 17 ! Maximum AV length = 2**(lmax-1) - ! Don't increase--segv on login.mcs - ! for larger values! - - integer, parameter :: MaxNumAtts = 26 ! maximum number of - ! attributes used in - ! timing tests. Leave - ! fixed for now! - - character(len=2*MaxNumAtts-1) :: dummyAList ! character array for - ! synthetic attribute - ! lists - - integer comm1, mysize,myproc,ier,i - - real*8, dimension(:), pointer :: inputData(:) - real*8, dimension(:), pointer :: outputData(:) - - integer :: currLength, k, l, n - integer :: colInd, lettInd, attInd, charInd - - real*8 :: startTime, finishTime - real*8, dimension(:), pointer :: impTimings - real*8, dimension(:), pointer :: expTimings - real*8 :: impMeanTime, expMeanTime - real*8 :: impStdDevTime, expStdDevTime - - integer :: impAvD, impMinD, impMaxD, impSDD - integer :: expAvD, expMinD, expMaxD, expSDD - - type(AttrVect) :: myAV - -! -! Initialize MPI and copy MPI_COMM_WORLD... -! - call MPI_init(ier) - - call mpi_comm_size(MPI_COMM_WORLD, mysize,ier) - call mpi_comm_rank(MPI_COMM_WORLD, myproc,ier) - write(0,*) myproc, "MPI size proc", mysize - - call mpi_comm_dup(MPI_COMM_WORLD,comm1,ier) - - myproc = 0 - -! create storage impTimings(:) and expTimings(:) -! - allocate(impTimings(nTrials), expTimings(nTrials), stat=ier) - write(0,'(a,2(a,i8))') myname,':: nTrials = ',nTrials,' ier=',ier - -! set up files for timing statistics and open them -! - impAvD = luavail() - open(impAvD, file='benchAV_importAvgTime.d',status='new') - impMinD = luavail() - open(impMinD, file='benchAV_importMinTime.d',status='new') - impMaxD = luavail() - open(impMaxD, file='benchAV_importMaxTime.d',status='new') - impSDD = luavail() - open(impSDD, file='benchAV_importStdDevTime.d',status='new') - expAvD = luavail() - open(expAvD, file='benchAV_exportAvgTime.d',status='new') - expMinD = luavail() - open(expMinD, file='benchAV_exportMinTime.d',status='new') - expMaxD = luavail() - open(expMaxD, file='benchAV_exportMaxTime.d',status='new') - expSDD = luavail() - open(expSDD, file='benchAV_exportStdDevTime.d',status='new') - -! Initialize MCTWorld - call MCTWorld_init(1,MPI_COMM_WORLD,comm1,1) - - dummyAList = '' - do k=1,MaxNumAtts - - ! construct dummy attribute list AttrVect_init() invoked with - ! trim(dummyAList) as a string literal argument for rList (see below) - if(k == 1) then ! bootstrap the process with just a single attribute - dummyAList(k:k) = achar(65) ! the letter 'A' - else - colInd = 2 * (k-1) - lettInd = 2*k - 1 - dummyAList(colInd:colInd) = achar(58) ! a colon ':' - dummyAList(lettInd:lettInd) = achar(64+k) - endif - - do l=1,lmax -! -! Set current AV length currLength, create inputData(:) and outputData(:), -! and initialize entries of inputData(:)... -! - currLength = 2 ** (l-1) - ! write(0,'(a,2(a,i8))') myname,":: l = ",l," currLength = ",currLength - - allocate(inputData(currLength), outputData(currLength),stat=ier) - do i=1,currLength - inputData(i)=real(i) - end do - - ! create an Av with k attributes - call AttrVect_init(myAV, rList=trim(dummyAList), lsize=currLength) - - ! Import/Export timing tests: - impMeanTime = 0. - expMeanTime = 0. - do n=1,nTrials - ! circulate through the k attributes so that we get more-or-less - ! equal representation of the attributes among the import/export - ! calls. Setting nTrials to a large number ensures the disparities - ! among how frequently the attributes are called will be minimal. - attInd = mod(n,k) - charInd = 65 + attInd ! offset from "A" - startTime = MPI_WTIME() - call AttrVect_importRA(myAV, achar(charInd), inputData, currLength) - finishTime = MPI_WTIME() - impTimings(n) = finishTime - startTime - impMeanTime = impMeanTime + impTimings(n) - - startTime = MPI_WTIME() - call AttrVect_exportRA(myAV, achar(charInd), outputData, currLength) - finishTime = MPI_WTIME() - expTimings(n) = finishTime - startTime - expMeanTime = expMeanTime + expTimings(n) - - end do - impMeanTime = impMeanTime / float(nTrials) - expMeanTime = expMeanTime / float(nTrials) - ! Compute Standard Deviation for timings - impStdDevTime = 0. - expStdDevTime = 0. - do n=1,nTrials - impStdDevTime = impStdDevTime + (impTimings(n) - impMeanTime)**2 - expStdDevTime = expStdDevTime + (expTimings(n) - expMeanTime)**2 - end do - impStdDevTime = sqrt(impStdDevTime / float(nTrials-1)) - expStdDevTime = sqrt(expStdDevTime / float(nTrials-1)) - - write(*,'(a,2(a,i8),4(a,g12.6))') myname, & - ":: Import timings for k=",k,"attributes. AV length=", & - currLength," elements: Mean = ",impMeanTime," Min= ", & - minval (impTimings)," Max = ",maxval(impTimings), & - " Std. Dev. = ",impStdDevTime - - write(*,'(a,2(a,i8),4(a,g12.6))') myname, & - ":: Export timings for k=",k,"attributes. AV length=", & - currLength," elements: Mean = ",expMeanTime," Min = ", & - minval(expTimings)," Max = ",maxval(expTimings), & - " Std. Dev. = ",impStdDevTime - - ! Write statistics to individual files for subsequent - ! visualization: - write(impAvD,'(2(i8,2x),g12.6)') l-1, k, impMeanTime - write(impMinD,'(2(i8,2x),g12.6)') l-1, k, minval(impTimings) - write(impMaxD,'(2(i8,2x),g12.6)') l-1, k, maxval(impTimings) - write(impSDD,'(2(i8,2x),g12.6)') l-1, k, impStdDevTime - write(expAvD,'(2(i8,2x),g12.6)') l-1, k, expMeanTime - write(expMinD,'(2(i8,2x),g12.6)') l-1, k, minval(expTimings) - write(expMaxD,'(2(i8,2x),g12.6)') l-1, k, maxval(expTimings) - write(expSDD,'(2(i8,2x),g12.6)') l-1, k, expStdDevTime - - ! Clean up for this value of l: -! write(*,'(2a,i8)') myname,':: cleaning up for l = ',l - deallocate(inputData, outputData,stat=ier) - - end do ! l=1,lmax - end do ! k=1,MaxNumAtts - -! Close output files: - close(impAvD) - close(impMinD) - close(impMaxD) - close(impSDD) - close(expAvD) - close(expMinD) - close(expMaxD) - close(expSDD) - - call MCTWorld_clean -! write(*,'(2a,i8)') myname,':: clean up completed for l = ',l - -! call MPI_FINALIZE(MPI_COMM_WORLD, ier) - - end program importBench - diff --git a/cesm/models/utils/mct/config.h.in b/cesm/models/utils/mct/config.h.in deleted file mode 100644 index 5ea9c79..0000000 --- a/cesm/models/utils/mct/config.h.in +++ /dev/null @@ -1,81 +0,0 @@ -/* config.h.in. Generated from configure.ac by autoheader. */ - -/* Define if building universal (internal helper macro) */ -#undef AC_APPLE_UNIVERSAL_BUILD - -/* Define to dummy `main' function (if any) required to link to the Fortran - libraries. */ -#undef FC_DUMMY_MAIN - -/* Define if F77 and FC dummy `main' functions are identical. */ -#undef FC_DUMMY_MAIN_EQ_F77 - -/* Define to a macro mangling the given C identifier (in lower and upper - case), which must not contain underscores, for linking with Fortran. */ -#undef FC_FUNC - -/* As FC_FUNC, but for C identifiers containing underscores. */ -#undef FC_FUNC_ - -/* Define to 1 if you have the header file. */ -#undef HAVE_INTTYPES_H - -/* Define to 1 if you have the header file. */ -#undef HAVE_MEMORY_H - -/* Define if you have the MPI library. */ -#undef HAVE_MPI - -/* Define to 1 if you have the header file. */ -#undef HAVE_STDINT_H - -/* Define to 1 if you have the header file. */ -#undef HAVE_STDLIB_H - -/* Define to 1 if you have the header file. */ -#undef HAVE_STRINGS_H - -/* Define to 1 if you have the header file. */ -#undef HAVE_STRING_H - -/* Define to 1 if you have the header file. */ -#undef HAVE_SYS_STAT_H - -/* Define to 1 if you have the header file. */ -#undef HAVE_SYS_TYPES_H - -/* Define to 1 if you have the header file. */ -#undef HAVE_UNISTD_H - -/* Define to the address where bug reports for this package should be sent. */ -#undef PACKAGE_BUGREPORT - -/* Define to the full name of this package. */ -#undef PACKAGE_NAME - -/* Define to the full name and version of this package. */ -#undef PACKAGE_STRING - -/* Define to the one symbol short name of this package. */ -#undef PACKAGE_TARNAME - -/* Define to the home page for this package. */ -#undef PACKAGE_URL - -/* Define to the version of this package. */ -#undef PACKAGE_VERSION - -/* Define to 1 if you have the ANSI C header files. */ -#undef STDC_HEADERS - -/* Define WORDS_BIGENDIAN to 1 if your processor stores words with the most - significant byte first (like Motorola and SPARC, unlike Intel). */ -#if defined AC_APPLE_UNIVERSAL_BUILD -# if defined __BIG_ENDIAN__ -# define WORDS_BIGENDIAN 1 -# endif -#else -# ifndef WORDS_BIGENDIAN -# undef WORDS_BIGENDIAN -# endif -#endif diff --git a/cesm/models/utils/mct/configure b/cesm/models/utils/mct/configure deleted file mode 100755 index 2141417..0000000 --- a/cesm/models/utils/mct/configure +++ /dev/null @@ -1,6665 +0,0 @@ -#! /bin/sh -# Guess values for system-dependent variables and create Makefiles. -# Generated by GNU Autoconf 2.69 for MCT 2.8. -# -# -# Copyright (C) 1992-1996, 1998-2012 Free Software Foundation, Inc. -# -# -# This configure script is free software; the Free Software Foundation -# gives unlimited permission to copy, distribute and modify it. -## -------------------- ## -## M4sh Initialization. ## -## -------------------- ## - -# Be more Bourne compatible -DUALCASE=1; export DUALCASE # for MKS sh -if test -n "${ZSH_VERSION+set}" && (emulate sh) >/dev/null 2>&1; then : - emulate sh - NULLCMD=: - # Pre-4.2 versions of Zsh do word splitting on ${1+"$@"}, which - # is contrary to our usage. Disable this feature. - alias -g '${1+"$@"}'='"$@"' - setopt NO_GLOB_SUBST -else - case `(set -o) 2>/dev/null` in #( - *posix*) : - set -o posix ;; #( - *) : - ;; -esac -fi - - -as_nl=' -' -export as_nl -# Printing a long string crashes Solaris 7 /usr/bin/printf. -as_echo='\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\' -as_echo=$as_echo$as_echo$as_echo$as_echo$as_echo -as_echo=$as_echo$as_echo$as_echo$as_echo$as_echo$as_echo -# Prefer a ksh shell builtin over an external printf program on Solaris, -# but without wasting forks for bash or zsh. -if test -z "$BASH_VERSION$ZSH_VERSION" \ - && (test "X`print -r -- $as_echo`" = "X$as_echo") 2>/dev/null; then - as_echo='print -r --' - as_echo_n='print -rn --' -elif (test "X`printf %s $as_echo`" = "X$as_echo") 2>/dev/null; then - as_echo='printf %s\n' - as_echo_n='printf %s' -else - if test "X`(/usr/ucb/echo -n -n $as_echo) 2>/dev/null`" = "X-n $as_echo"; then - as_echo_body='eval /usr/ucb/echo -n "$1$as_nl"' - as_echo_n='/usr/ucb/echo -n' - else - as_echo_body='eval expr "X$1" : "X\\(.*\\)"' - as_echo_n_body='eval - arg=$1; - case $arg in #( - *"$as_nl"*) - expr "X$arg" : "X\\(.*\\)$as_nl"; - arg=`expr "X$arg" : ".*$as_nl\\(.*\\)"`;; - esac; - expr "X$arg" : "X\\(.*\\)" | tr -d "$as_nl" - ' - export as_echo_n_body - as_echo_n='sh -c $as_echo_n_body as_echo' - fi - export as_echo_body - as_echo='sh -c $as_echo_body as_echo' -fi - -# The user is always right. -if test "${PATH_SEPARATOR+set}" != set; then - PATH_SEPARATOR=: - (PATH='/bin;/bin'; FPATH=$PATH; sh -c :) >/dev/null 2>&1 && { - (PATH='/bin:/bin'; FPATH=$PATH; sh -c :) >/dev/null 2>&1 || - PATH_SEPARATOR=';' - } -fi - - -# IFS -# We need space, tab and new line, in precisely that order. Quoting is -# there to prevent editors from complaining about space-tab. -# (If _AS_PATH_WALK were called with IFS unset, it would disable word -# splitting by setting IFS to empty value.) -IFS=" "" $as_nl" - -# Find who we are. Look in the path if we contain no directory separator. -as_myself= -case $0 in #(( - *[\\/]* ) as_myself=$0 ;; - *) as_save_IFS=$IFS; IFS=$PATH_SEPARATOR -for as_dir in $PATH -do - IFS=$as_save_IFS - test -z "$as_dir" && as_dir=. - test -r "$as_dir/$0" && as_myself=$as_dir/$0 && break - done -IFS=$as_save_IFS - - ;; -esac -# We did not find ourselves, most probably we were run as `sh COMMAND' -# in which case we are not to be found in the path. -if test "x$as_myself" = x; then - as_myself=$0 -fi -if test ! -f "$as_myself"; then - $as_echo "$as_myself: error: cannot find myself; rerun with an absolute file name" >&2 - exit 1 -fi - -# Unset variables that we do not need and which cause bugs (e.g. in -# pre-3.0 UWIN ksh). But do not cause bugs in bash 2.01; the "|| exit 1" -# suppresses any "Segmentation fault" message there. '((' could -# trigger a bug in pdksh 5.2.14. -for as_var in BASH_ENV ENV MAIL MAILPATH -do eval test x\${$as_var+set} = xset \ - && ( (unset $as_var) || exit 1) >/dev/null 2>&1 && unset $as_var || : -done -PS1='$ ' -PS2='> ' -PS4='+ ' - -# NLS nuisances. -LC_ALL=C -export LC_ALL -LANGUAGE=C -export LANGUAGE - -# CDPATH. -(unset CDPATH) >/dev/null 2>&1 && unset CDPATH - -# Use a proper internal environment variable to ensure we don't fall - # into an infinite loop, continuously re-executing ourselves. - if test x"${_as_can_reexec}" != xno && test "x$CONFIG_SHELL" != x; then - _as_can_reexec=no; export _as_can_reexec; - # We cannot yet assume a decent shell, so we have to provide a -# neutralization value for shells without unset; and this also -# works around shells that cannot unset nonexistent variables. -# Preserve -v and -x to the replacement shell. -BASH_ENV=/dev/null -ENV=/dev/null -(unset BASH_ENV) >/dev/null 2>&1 && unset BASH_ENV ENV -case $- in # (((( - *v*x* | *x*v* ) as_opts=-vx ;; - *v* ) as_opts=-v ;; - *x* ) as_opts=-x ;; - * ) as_opts= ;; -esac -exec $CONFIG_SHELL $as_opts "$as_myself" ${1+"$@"} -# Admittedly, this is quite paranoid, since all the known shells bail -# out after a failed `exec'. -$as_echo "$0: could not re-execute with $CONFIG_SHELL" >&2 -as_fn_exit 255 - fi - # We don't want this to propagate to other subprocesses. - { _as_can_reexec=; unset _as_can_reexec;} -if test "x$CONFIG_SHELL" = x; then - as_bourne_compatible="if test -n \"\${ZSH_VERSION+set}\" && (emulate sh) >/dev/null 2>&1; then : - emulate sh - NULLCMD=: - # Pre-4.2 versions of Zsh do word splitting on \${1+\"\$@\"}, which - # is contrary to our usage. Disable this feature. - alias -g '\${1+\"\$@\"}'='\"\$@\"' - setopt NO_GLOB_SUBST -else - case \`(set -o) 2>/dev/null\` in #( - *posix*) : - set -o posix ;; #( - *) : - ;; -esac -fi -" - as_required="as_fn_return () { (exit \$1); } -as_fn_success () { as_fn_return 0; } -as_fn_failure () { as_fn_return 1; } -as_fn_ret_success () { return 0; } -as_fn_ret_failure () { return 1; } - -exitcode=0 -as_fn_success || { exitcode=1; echo as_fn_success failed.; } -as_fn_failure && { exitcode=1; echo as_fn_failure succeeded.; } -as_fn_ret_success || { exitcode=1; echo as_fn_ret_success failed.; } -as_fn_ret_failure && { exitcode=1; echo as_fn_ret_failure succeeded.; } -if ( set x; as_fn_ret_success y && test x = \"\$1\" ); then : - -else - exitcode=1; echo positional parameters were not saved. -fi -test x\$exitcode = x0 || exit 1 -test -x / || exit 1" - as_suggested=" as_lineno_1=";as_suggested=$as_suggested$LINENO;as_suggested=$as_suggested" as_lineno_1a=\$LINENO - as_lineno_2=";as_suggested=$as_suggested$LINENO;as_suggested=$as_suggested" as_lineno_2a=\$LINENO - eval 'test \"x\$as_lineno_1'\$as_run'\" != \"x\$as_lineno_2'\$as_run'\" && - test \"x\`expr \$as_lineno_1'\$as_run' + 1\`\" = \"x\$as_lineno_2'\$as_run'\"' || exit 1 -test \$(( 1 + 1 )) = 2 || exit 1" - if (eval "$as_required") 2>/dev/null; then : - as_have_required=yes -else - as_have_required=no -fi - if test x$as_have_required = xyes && (eval "$as_suggested") 2>/dev/null; then : - -else - as_save_IFS=$IFS; IFS=$PATH_SEPARATOR -as_found=false -for as_dir in /bin$PATH_SEPARATOR/usr/bin$PATH_SEPARATOR$PATH -do - IFS=$as_save_IFS - test -z "$as_dir" && as_dir=. - as_found=: - case $as_dir in #( - /*) - for as_base in sh bash ksh sh5; do - # Try only shells that exist, to save several forks. - as_shell=$as_dir/$as_base - if { test -f "$as_shell" || test -f "$as_shell.exe"; } && - { $as_echo "$as_bourne_compatible""$as_required" | as_run=a "$as_shell"; } 2>/dev/null; then : - CONFIG_SHELL=$as_shell as_have_required=yes - if { $as_echo "$as_bourne_compatible""$as_suggested" | as_run=a "$as_shell"; } 2>/dev/null; then : - break 2 -fi -fi - done;; - esac - as_found=false -done -$as_found || { if { test -f "$SHELL" || test -f "$SHELL.exe"; } && - { $as_echo "$as_bourne_compatible""$as_required" | as_run=a "$SHELL"; } 2>/dev/null; then : - CONFIG_SHELL=$SHELL as_have_required=yes -fi; } -IFS=$as_save_IFS - - - if test "x$CONFIG_SHELL" != x; then : - export CONFIG_SHELL - # We cannot yet assume a decent shell, so we have to provide a -# neutralization value for shells without unset; and this also -# works around shells that cannot unset nonexistent variables. -# Preserve -v and -x to the replacement shell. -BASH_ENV=/dev/null -ENV=/dev/null -(unset BASH_ENV) >/dev/null 2>&1 && unset BASH_ENV ENV -case $- in # (((( - *v*x* | *x*v* ) as_opts=-vx ;; - *v* ) as_opts=-v ;; - *x* ) as_opts=-x ;; - * ) as_opts= ;; -esac -exec $CONFIG_SHELL $as_opts "$as_myself" ${1+"$@"} -# Admittedly, this is quite paranoid, since all the known shells bail -# out after a failed `exec'. -$as_echo "$0: could not re-execute with $CONFIG_SHELL" >&2 -exit 255 -fi - - if test x$as_have_required = xno; then : - $as_echo "$0: This script requires a shell more modern than all" - $as_echo "$0: the shells that I found on your system." - if test x${ZSH_VERSION+set} = xset ; then - $as_echo "$0: In particular, zsh $ZSH_VERSION has bugs and should" - $as_echo "$0: be upgraded to zsh 4.3.4 or later." - else - $as_echo "$0: Please tell bug-autoconf@gnu.org about your system, -$0: including any error possibly output before this -$0: message. Then install a modern shell, or manually run -$0: the script under such a shell if you do have one." - fi - exit 1 -fi -fi -fi -SHELL=${CONFIG_SHELL-/bin/sh} -export SHELL -# Unset more variables known to interfere with behavior of common tools. -CLICOLOR_FORCE= GREP_OPTIONS= -unset CLICOLOR_FORCE GREP_OPTIONS - -## --------------------- ## -## M4sh Shell Functions. ## -## --------------------- ## -# as_fn_unset VAR -# --------------- -# Portably unset VAR. -as_fn_unset () -{ - { eval $1=; unset $1;} -} -as_unset=as_fn_unset - -# as_fn_set_status STATUS -# ----------------------- -# Set $? to STATUS, without forking. -as_fn_set_status () -{ - return $1 -} # as_fn_set_status - -# as_fn_exit STATUS -# ----------------- -# Exit the shell with STATUS, even in a "trap 0" or "set -e" context. -as_fn_exit () -{ - set +e - as_fn_set_status $1 - exit $1 -} # as_fn_exit - -# as_fn_mkdir_p -# ------------- -# Create "$as_dir" as a directory, including parents if necessary. -as_fn_mkdir_p () -{ - - case $as_dir in #( - -*) as_dir=./$as_dir;; - esac - test -d "$as_dir" || eval $as_mkdir_p || { - as_dirs= - while :; do - case $as_dir in #( - *\'*) as_qdir=`$as_echo "$as_dir" | sed "s/'/'\\\\\\\\''/g"`;; #'( - *) as_qdir=$as_dir;; - esac - as_dirs="'$as_qdir' $as_dirs" - as_dir=`$as_dirname -- "$as_dir" || -$as_expr X"$as_dir" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ - X"$as_dir" : 'X\(//\)[^/]' \| \ - X"$as_dir" : 'X\(//\)$' \| \ - X"$as_dir" : 'X\(/\)' \| . 2>/dev/null || -$as_echo X"$as_dir" | - sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ - s//\1/ - q - } - /^X\(\/\/\)[^/].*/{ - s//\1/ - q - } - /^X\(\/\/\)$/{ - s//\1/ - q - } - /^X\(\/\).*/{ - s//\1/ - q - } - s/.*/./; q'` - test -d "$as_dir" && break - done - test -z "$as_dirs" || eval "mkdir $as_dirs" - } || test -d "$as_dir" || as_fn_error $? "cannot create directory $as_dir" - - -} # as_fn_mkdir_p - -# as_fn_executable_p FILE -# ----------------------- -# Test if FILE is an executable regular file. -as_fn_executable_p () -{ - test -f "$1" && test -x "$1" -} # as_fn_executable_p -# as_fn_append VAR VALUE -# ---------------------- -# Append the text in VALUE to the end of the definition contained in VAR. Take -# advantage of any shell optimizations that allow amortized linear growth over -# repeated appends, instead of the typical quadratic growth present in naive -# implementations. -if (eval "as_var=1; as_var+=2; test x\$as_var = x12") 2>/dev/null; then : - eval 'as_fn_append () - { - eval $1+=\$2 - }' -else - as_fn_append () - { - eval $1=\$$1\$2 - } -fi # as_fn_append - -# as_fn_arith ARG... -# ------------------ -# Perform arithmetic evaluation on the ARGs, and store the result in the -# global $as_val. Take advantage of shells that can avoid forks. The arguments -# must be portable across $(()) and expr. -if (eval "test \$(( 1 + 1 )) = 2") 2>/dev/null; then : - eval 'as_fn_arith () - { - as_val=$(( $* )) - }' -else - as_fn_arith () - { - as_val=`expr "$@" || test $? -eq 1` - } -fi # as_fn_arith - - -# as_fn_error STATUS ERROR [LINENO LOG_FD] -# ---------------------------------------- -# Output "`basename $0`: error: ERROR" to stderr. If LINENO and LOG_FD are -# provided, also output the error to LOG_FD, referencing LINENO. Then exit the -# script with STATUS, using 1 if that was 0. -as_fn_error () -{ - as_status=$1; test $as_status -eq 0 && as_status=1 - if test "$4"; then - as_lineno=${as_lineno-"$3"} as_lineno_stack=as_lineno_stack=$as_lineno_stack - $as_echo "$as_me:${as_lineno-$LINENO}: error: $2" >&$4 - fi - $as_echo "$as_me: error: $2" >&2 - as_fn_exit $as_status -} # as_fn_error - -if expr a : '\(a\)' >/dev/null 2>&1 && - test "X`expr 00001 : '.*\(...\)'`" = X001; then - as_expr=expr -else - as_expr=false -fi - -if (basename -- /) >/dev/null 2>&1 && test "X`basename -- / 2>&1`" = "X/"; then - as_basename=basename -else - as_basename=false -fi - -if (as_dir=`dirname -- /` && test "X$as_dir" = X/) >/dev/null 2>&1; then - as_dirname=dirname -else - as_dirname=false -fi - -as_me=`$as_basename -- "$0" || -$as_expr X/"$0" : '.*/\([^/][^/]*\)/*$' \| \ - X"$0" : 'X\(//\)$' \| \ - X"$0" : 'X\(/\)' \| . 2>/dev/null || -$as_echo X/"$0" | - sed '/^.*\/\([^/][^/]*\)\/*$/{ - s//\1/ - q - } - /^X\/\(\/\/\)$/{ - s//\1/ - q - } - /^X\/\(\/\).*/{ - s//\1/ - q - } - s/.*/./; q'` - -# Avoid depending upon Character Ranges. -as_cr_letters='abcdefghijklmnopqrstuvwxyz' -as_cr_LETTERS='ABCDEFGHIJKLMNOPQRSTUVWXYZ' -as_cr_Letters=$as_cr_letters$as_cr_LETTERS -as_cr_digits='0123456789' -as_cr_alnum=$as_cr_Letters$as_cr_digits - - - as_lineno_1=$LINENO as_lineno_1a=$LINENO - as_lineno_2=$LINENO as_lineno_2a=$LINENO - eval 'test "x$as_lineno_1'$as_run'" != "x$as_lineno_2'$as_run'" && - test "x`expr $as_lineno_1'$as_run' + 1`" = "x$as_lineno_2'$as_run'"' || { - # Blame Lee E. McMahon (1931-1989) for sed's syntax. :-) - sed -n ' - p - /[$]LINENO/= - ' <$as_myself | - sed ' - s/[$]LINENO.*/&-/ - t lineno - b - :lineno - N - :loop - s/[$]LINENO\([^'$as_cr_alnum'_].*\n\)\(.*\)/\2\1\2/ - t loop - s/-\n.*// - ' >$as_me.lineno && - chmod +x "$as_me.lineno" || - { $as_echo "$as_me: error: cannot create $as_me.lineno; rerun with a POSIX shell" >&2; as_fn_exit 1; } - - # If we had to re-execute with $CONFIG_SHELL, we're ensured to have - # already done that, so ensure we don't try to do so again and fall - # in an infinite loop. This has already happened in practice. - _as_can_reexec=no; export _as_can_reexec - # Don't try to exec as it changes $[0], causing all sort of problems - # (the dirname of $[0] is not the place where we might find the - # original and so on. Autoconf is especially sensitive to this). - . "./$as_me.lineno" - # Exit status is that of the last command. - exit -} - -ECHO_C= ECHO_N= ECHO_T= -case `echo -n x` in #((((( --n*) - case `echo 'xy\c'` in - *c*) ECHO_T=' ';; # ECHO_T is single tab character. - xy) ECHO_C='\c';; - *) echo `echo ksh88 bug on AIX 6.1` > /dev/null - ECHO_T=' ';; - esac;; -*) - ECHO_N='-n';; -esac - -rm -f conf$$ conf$$.exe conf$$.file -if test -d conf$$.dir; then - rm -f conf$$.dir/conf$$.file -else - rm -f conf$$.dir - mkdir conf$$.dir 2>/dev/null -fi -if (echo >conf$$.file) 2>/dev/null; then - if ln -s conf$$.file conf$$ 2>/dev/null; then - as_ln_s='ln -s' - # ... but there are two gotchas: - # 1) On MSYS, both `ln -s file dir' and `ln file dir' fail. - # 2) DJGPP < 2.04 has no symlinks; `ln -s' creates a wrapper executable. - # In both cases, we have to default to `cp -pR'. - ln -s conf$$.file conf$$.dir 2>/dev/null && test ! -f conf$$.exe || - as_ln_s='cp -pR' - elif ln conf$$.file conf$$ 2>/dev/null; then - as_ln_s=ln - else - as_ln_s='cp -pR' - fi -else - as_ln_s='cp -pR' -fi -rm -f conf$$ conf$$.exe conf$$.dir/conf$$.file conf$$.file -rmdir conf$$.dir 2>/dev/null - -if mkdir -p . 2>/dev/null; then - as_mkdir_p='mkdir -p "$as_dir"' -else - test -d ./-p && rmdir ./-p - as_mkdir_p=false -fi - -as_test_x='test -x' -as_executable_p=as_fn_executable_p - -# Sed expression to map a string onto a valid CPP name. -as_tr_cpp="eval sed 'y%*$as_cr_letters%P$as_cr_LETTERS%;s%[^_$as_cr_alnum]%_%g'" - -# Sed expression to map a string onto a valid variable name. -as_tr_sh="eval sed 'y%*+%pp%;s%[^_$as_cr_alnum]%_%g'" - - -test -n "$DJDIR" || exec 7<&0 &1 - -# Name of the host. -# hostname on some systems (SVR3.2, old GNU/Linux) returns a bogus exit status, -# so uname gets run too. -ac_hostname=`(hostname || uname -n) 2>/dev/null | sed 1q` - -# -# Initializations. -# -ac_default_prefix=/usr/local -ac_clean_files= -ac_config_libobj_dir=. -LIBOBJS= -cross_compiling=no -subdirs= -MFLAGS= -MAKEFLAGS= - -# Identity of this package. -PACKAGE_NAME='MCT' -PACKAGE_TARNAME='mct' -PACKAGE_VERSION='2.8' -PACKAGE_STRING='MCT 2.8' -PACKAGE_BUGREPORT='' -PACKAGE_URL='' - -# Factoring default headers for most tests. -ac_includes_default="\ -#include -#ifdef HAVE_SYS_TYPES_H -# include -#endif -#ifdef HAVE_SYS_STAT_H -# include -#endif -#ifdef STDC_HEADERS -# include -# include -#else -# ifdef HAVE_STDLIB_H -# include -# endif -#endif -#ifdef HAVE_STRING_H -# if !defined STDC_HEADERS && defined HAVE_MEMORY_H -# include -# endif -# include -#endif -#ifdef HAVE_STRINGS_H -# include -#endif -#ifdef HAVE_INTTYPES_H -# include -#endif -#ifdef HAVE_STDINT_H -# include -#endif -#ifdef HAVE_UNISTD_H -# include -#endif" - -ac_subst_vars='LTLIBOBJS -LIBOBJS -CPPDEFS -CRULE -FCLIBS -FC_DEFINE -FCFLAGS_F -MPISERPATH -MPIFC -FCFLAGS_F90 -ac_ct_FC -EGREP -GREP -CPP -OBJEXT -EXEEXT -ac_ct_CC -CPPFLAGS -LDFLAGS -CC -PYTHONOPTS -PYTHON -FORT_SIZE -COMPILER_ROOT -BABELROOT -RANLIB -AR -INCLUDEPATH -INCLUDEFLAG -ENDIAN -BIT64 -REAL8 -OPT -DEBUG -CFLAGS -PROGFCFLAGS -FCFLAGS -FC -FPPFLAGS -FPP -MPIHEADER -MPILIBS -target_alias -host_alias -build_alias -LIBS -ECHO_T -ECHO_N -ECHO_C -DEFS -mandir -localedir -libdir -psdir -pdfdir -dvidir -htmldir -infodir -docdir -oldincludedir -includedir -localstatedir -sharedstatedir -sysconfdir -datadir -datarootdir -libexecdir -sbindir -bindir -program_transform_name -prefix -exec_prefix -PACKAGE_URL -PACKAGE_BUGREPORT -PACKAGE_STRING -PACKAGE_VERSION -PACKAGE_TARNAME -PACKAGE_NAME -PATH_SEPARATOR -SHELL' -ac_subst_files='' -ac_user_opts=' -enable_option_checking -enable_mpiserial -enable_debugging -enable_selectedrealkind -enable_sequence -enable_babel -' - ac_precious_vars='build_alias -host_alias -target_alias -MPILIBS -MPIHEADER -FPP -FPPFLAGS -FC -FCFLAGS -PROGFCFLAGS -CFLAGS -DEBUG -OPT -REAL8 -BIT64 -ENDIAN -INCLUDEFLAG -INCLUDEPATH -AR -RANLIB -BABELROOT -COMPILER_ROOT -FORT_SIZE -CC -LDFLAGS -LIBS -CPPFLAGS -CPP -MPIFC' - - -# Initialize some variables set by options. -ac_init_help= -ac_init_version=false -ac_unrecognized_opts= -ac_unrecognized_sep= -# The variables have the same names as the options, with -# dashes changed to underlines. -cache_file=/dev/null -exec_prefix=NONE -no_create= -no_recursion= -prefix=NONE -program_prefix=NONE -program_suffix=NONE -program_transform_name=s,x,x, -silent= -site= -srcdir= -verbose= -x_includes=NONE -x_libraries=NONE - -# Installation directory options. -# These are left unexpanded so users can "make install exec_prefix=/foo" -# and all the variables that are supposed to be based on exec_prefix -# by default will actually change. -# Use braces instead of parens because sh, perl, etc. also accept them. -# (The list follows the same order as the GNU Coding Standards.) -bindir='${exec_prefix}/bin' -sbindir='${exec_prefix}/sbin' -libexecdir='${exec_prefix}/libexec' -datarootdir='${prefix}/share' -datadir='${datarootdir}' -sysconfdir='${prefix}/etc' -sharedstatedir='${prefix}/com' -localstatedir='${prefix}/var' -includedir='${prefix}/include' -oldincludedir='/usr/include' -docdir='${datarootdir}/doc/${PACKAGE_TARNAME}' -infodir='${datarootdir}/info' -htmldir='${docdir}' -dvidir='${docdir}' -pdfdir='${docdir}' -psdir='${docdir}' -libdir='${exec_prefix}/lib' -localedir='${datarootdir}/locale' -mandir='${datarootdir}/man' - -ac_prev= -ac_dashdash= -for ac_option -do - # If the previous option needs an argument, assign it. - if test -n "$ac_prev"; then - eval $ac_prev=\$ac_option - ac_prev= - continue - fi - - case $ac_option in - *=?*) ac_optarg=`expr "X$ac_option" : '[^=]*=\(.*\)'` ;; - *=) ac_optarg= ;; - *) ac_optarg=yes ;; - esac - - # Accept the important Cygnus configure options, so we can diagnose typos. - - case $ac_dashdash$ac_option in - --) - ac_dashdash=yes ;; - - -bindir | --bindir | --bindi | --bind | --bin | --bi) - ac_prev=bindir ;; - -bindir=* | --bindir=* | --bindi=* | --bind=* | --bin=* | --bi=*) - bindir=$ac_optarg ;; - - -build | --build | --buil | --bui | --bu) - ac_prev=build_alias ;; - -build=* | --build=* | --buil=* | --bui=* | --bu=*) - build_alias=$ac_optarg ;; - - -cache-file | --cache-file | --cache-fil | --cache-fi \ - | --cache-f | --cache- | --cache | --cach | --cac | --ca | --c) - ac_prev=cache_file ;; - -cache-file=* | --cache-file=* | --cache-fil=* | --cache-fi=* \ - | --cache-f=* | --cache-=* | --cache=* | --cach=* | --cac=* | --ca=* | --c=*) - cache_file=$ac_optarg ;; - - --config-cache | -C) - cache_file=config.cache ;; - - -datadir | --datadir | --datadi | --datad) - ac_prev=datadir ;; - -datadir=* | --datadir=* | --datadi=* | --datad=*) - datadir=$ac_optarg ;; - - -datarootdir | --datarootdir | --datarootdi | --datarootd | --dataroot \ - | --dataroo | --dataro | --datar) - ac_prev=datarootdir ;; - -datarootdir=* | --datarootdir=* | --datarootdi=* | --datarootd=* \ - | --dataroot=* | --dataroo=* | --dataro=* | --datar=*) - datarootdir=$ac_optarg ;; - - -disable-* | --disable-*) - ac_useropt=`expr "x$ac_option" : 'x-*disable-\(.*\)'` - # Reject names that are not valid shell variable names. - expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null && - as_fn_error $? "invalid feature name: $ac_useropt" - ac_useropt_orig=$ac_useropt - ac_useropt=`$as_echo "$ac_useropt" | sed 's/[-+.]/_/g'` - case $ac_user_opts in - *" -"enable_$ac_useropt" -"*) ;; - *) ac_unrecognized_opts="$ac_unrecognized_opts$ac_unrecognized_sep--disable-$ac_useropt_orig" - ac_unrecognized_sep=', ';; - esac - eval enable_$ac_useropt=no ;; - - -docdir | --docdir | --docdi | --doc | --do) - ac_prev=docdir ;; - -docdir=* | --docdir=* | --docdi=* | --doc=* | --do=*) - docdir=$ac_optarg ;; - - -dvidir | --dvidir | --dvidi | --dvid | --dvi | --dv) - ac_prev=dvidir ;; - -dvidir=* | --dvidir=* | --dvidi=* | --dvid=* | --dvi=* | --dv=*) - dvidir=$ac_optarg ;; - - -enable-* | --enable-*) - ac_useropt=`expr "x$ac_option" : 'x-*enable-\([^=]*\)'` - # Reject names that are not valid shell variable names. - expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null && - as_fn_error $? "invalid feature name: $ac_useropt" - ac_useropt_orig=$ac_useropt - ac_useropt=`$as_echo "$ac_useropt" | sed 's/[-+.]/_/g'` - case $ac_user_opts in - *" -"enable_$ac_useropt" -"*) ;; - *) ac_unrecognized_opts="$ac_unrecognized_opts$ac_unrecognized_sep--enable-$ac_useropt_orig" - ac_unrecognized_sep=', ';; - esac - eval enable_$ac_useropt=\$ac_optarg ;; - - -exec-prefix | --exec_prefix | --exec-prefix | --exec-prefi \ - | --exec-pref | --exec-pre | --exec-pr | --exec-p | --exec- \ - | --exec | --exe | --ex) - ac_prev=exec_prefix ;; - -exec-prefix=* | --exec_prefix=* | --exec-prefix=* | --exec-prefi=* \ - | --exec-pref=* | --exec-pre=* | --exec-pr=* | --exec-p=* | --exec-=* \ - | --exec=* | --exe=* | --ex=*) - exec_prefix=$ac_optarg ;; - - -gas | --gas | --ga | --g) - # Obsolete; use --with-gas. - with_gas=yes ;; - - -help | --help | --hel | --he | -h) - ac_init_help=long ;; - -help=r* | --help=r* | --hel=r* | --he=r* | -hr*) - ac_init_help=recursive ;; - -help=s* | --help=s* | --hel=s* | --he=s* | -hs*) - ac_init_help=short ;; - - -host | --host | --hos | --ho) - ac_prev=host_alias ;; - -host=* | --host=* | --hos=* | --ho=*) - host_alias=$ac_optarg ;; - - -htmldir | --htmldir | --htmldi | --htmld | --html | --htm | --ht) - ac_prev=htmldir ;; - -htmldir=* | --htmldir=* | --htmldi=* | --htmld=* | --html=* | --htm=* \ - | --ht=*) - htmldir=$ac_optarg ;; - - -includedir | --includedir | --includedi | --included | --include \ - | --includ | --inclu | --incl | --inc) - ac_prev=includedir ;; - -includedir=* | --includedir=* | --includedi=* | --included=* | --include=* \ - | --includ=* | --inclu=* | --incl=* | --inc=*) - includedir=$ac_optarg ;; - - -infodir | --infodir | --infodi | --infod | --info | --inf) - ac_prev=infodir ;; - -infodir=* | --infodir=* | --infodi=* | --infod=* | --info=* | --inf=*) - infodir=$ac_optarg ;; - - -libdir | --libdir | --libdi | --libd) - ac_prev=libdir ;; - -libdir=* | --libdir=* | --libdi=* | --libd=*) - libdir=$ac_optarg ;; - - -libexecdir | --libexecdir | --libexecdi | --libexecd | --libexec \ - | --libexe | --libex | --libe) - ac_prev=libexecdir ;; - -libexecdir=* | --libexecdir=* | --libexecdi=* | --libexecd=* | --libexec=* \ - | --libexe=* | --libex=* | --libe=*) - libexecdir=$ac_optarg ;; - - -localedir | --localedir | --localedi | --localed | --locale) - ac_prev=localedir ;; - -localedir=* | --localedir=* | --localedi=* | --localed=* | --locale=*) - localedir=$ac_optarg ;; - - -localstatedir | --localstatedir | --localstatedi | --localstated \ - | --localstate | --localstat | --localsta | --localst | --locals) - ac_prev=localstatedir ;; - -localstatedir=* | --localstatedir=* | --localstatedi=* | --localstated=* \ - | --localstate=* | --localstat=* | --localsta=* | --localst=* | --locals=*) - localstatedir=$ac_optarg ;; - - -mandir | --mandir | --mandi | --mand | --man | --ma | --m) - ac_prev=mandir ;; - -mandir=* | --mandir=* | --mandi=* | --mand=* | --man=* | --ma=* | --m=*) - mandir=$ac_optarg ;; - - -nfp | --nfp | --nf) - # Obsolete; use --without-fp. - with_fp=no ;; - - -no-create | --no-create | --no-creat | --no-crea | --no-cre \ - | --no-cr | --no-c | -n) - no_create=yes ;; - - -no-recursion | --no-recursion | --no-recursio | --no-recursi \ - | --no-recurs | --no-recur | --no-recu | --no-rec | --no-re | --no-r) - no_recursion=yes ;; - - -oldincludedir | --oldincludedir | --oldincludedi | --oldincluded \ - | --oldinclude | --oldinclud | --oldinclu | --oldincl | --oldinc \ - | --oldin | --oldi | --old | --ol | --o) - ac_prev=oldincludedir ;; - -oldincludedir=* | --oldincludedir=* | --oldincludedi=* | --oldincluded=* \ - | --oldinclude=* | --oldinclud=* | --oldinclu=* | --oldincl=* | --oldinc=* \ - | --oldin=* | --oldi=* | --old=* | --ol=* | --o=*) - oldincludedir=$ac_optarg ;; - - -prefix | --prefix | --prefi | --pref | --pre | --pr | --p) - ac_prev=prefix ;; - -prefix=* | --prefix=* | --prefi=* | --pref=* | --pre=* | --pr=* | --p=*) - prefix=$ac_optarg ;; - - -program-prefix | --program-prefix | --program-prefi | --program-pref \ - | --program-pre | --program-pr | --program-p) - ac_prev=program_prefix ;; - -program-prefix=* | --program-prefix=* | --program-prefi=* \ - | --program-pref=* | --program-pre=* | --program-pr=* | --program-p=*) - program_prefix=$ac_optarg ;; - - -program-suffix | --program-suffix | --program-suffi | --program-suff \ - | --program-suf | --program-su | --program-s) - ac_prev=program_suffix ;; - -program-suffix=* | --program-suffix=* | --program-suffi=* \ - | --program-suff=* | --program-suf=* | --program-su=* | --program-s=*) - program_suffix=$ac_optarg ;; - - -program-transform-name | --program-transform-name \ - | --program-transform-nam | --program-transform-na \ - | --program-transform-n | --program-transform- \ - | --program-transform | --program-transfor \ - | --program-transfo | --program-transf \ - | --program-trans | --program-tran \ - | --progr-tra | --program-tr | --program-t) - ac_prev=program_transform_name ;; - -program-transform-name=* | --program-transform-name=* \ - | --program-transform-nam=* | --program-transform-na=* \ - | --program-transform-n=* | --program-transform-=* \ - | --program-transform=* | --program-transfor=* \ - | --program-transfo=* | --program-transf=* \ - | --program-trans=* | --program-tran=* \ - | --progr-tra=* | --program-tr=* | --program-t=*) - program_transform_name=$ac_optarg ;; - - -pdfdir | --pdfdir | --pdfdi | --pdfd | --pdf | --pd) - ac_prev=pdfdir ;; - -pdfdir=* | --pdfdir=* | --pdfdi=* | --pdfd=* | --pdf=* | --pd=*) - pdfdir=$ac_optarg ;; - - -psdir | --psdir | --psdi | --psd | --ps) - ac_prev=psdir ;; - -psdir=* | --psdir=* | --psdi=* | --psd=* | --ps=*) - psdir=$ac_optarg ;; - - -q | -quiet | --quiet | --quie | --qui | --qu | --q \ - | -silent | --silent | --silen | --sile | --sil) - silent=yes ;; - - -sbindir | --sbindir | --sbindi | --sbind | --sbin | --sbi | --sb) - ac_prev=sbindir ;; - -sbindir=* | --sbindir=* | --sbindi=* | --sbind=* | --sbin=* \ - | --sbi=* | --sb=*) - sbindir=$ac_optarg ;; - - -sharedstatedir | --sharedstatedir | --sharedstatedi \ - | --sharedstated | --sharedstate | --sharedstat | --sharedsta \ - | --sharedst | --shareds | --shared | --share | --shar \ - | --sha | --sh) - ac_prev=sharedstatedir ;; - -sharedstatedir=* | --sharedstatedir=* | --sharedstatedi=* \ - | --sharedstated=* | --sharedstate=* | --sharedstat=* | --sharedsta=* \ - | --sharedst=* | --shareds=* | --shared=* | --share=* | --shar=* \ - | --sha=* | --sh=*) - sharedstatedir=$ac_optarg ;; - - -site | --site | --sit) - ac_prev=site ;; - -site=* | --site=* | --sit=*) - site=$ac_optarg ;; - - -srcdir | --srcdir | --srcdi | --srcd | --src | --sr) - ac_prev=srcdir ;; - -srcdir=* | --srcdir=* | --srcdi=* | --srcd=* | --src=* | --sr=*) - srcdir=$ac_optarg ;; - - -sysconfdir | --sysconfdir | --sysconfdi | --sysconfd | --sysconf \ - | --syscon | --sysco | --sysc | --sys | --sy) - ac_prev=sysconfdir ;; - -sysconfdir=* | --sysconfdir=* | --sysconfdi=* | --sysconfd=* | --sysconf=* \ - | --syscon=* | --sysco=* | --sysc=* | --sys=* | --sy=*) - sysconfdir=$ac_optarg ;; - - -target | --target | --targe | --targ | --tar | --ta | --t) - ac_prev=target_alias ;; - -target=* | --target=* | --targe=* | --targ=* | --tar=* | --ta=* | --t=*) - target_alias=$ac_optarg ;; - - -v | -verbose | --verbose | --verbos | --verbo | --verb) - verbose=yes ;; - - -version | --version | --versio | --versi | --vers | -V) - ac_init_version=: ;; - - -with-* | --with-*) - ac_useropt=`expr "x$ac_option" : 'x-*with-\([^=]*\)'` - # Reject names that are not valid shell variable names. - expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null && - as_fn_error $? "invalid package name: $ac_useropt" - ac_useropt_orig=$ac_useropt - ac_useropt=`$as_echo "$ac_useropt" | sed 's/[-+.]/_/g'` - case $ac_user_opts in - *" -"with_$ac_useropt" -"*) ;; - *) ac_unrecognized_opts="$ac_unrecognized_opts$ac_unrecognized_sep--with-$ac_useropt_orig" - ac_unrecognized_sep=', ';; - esac - eval with_$ac_useropt=\$ac_optarg ;; - - -without-* | --without-*) - ac_useropt=`expr "x$ac_option" : 'x-*without-\(.*\)'` - # Reject names that are not valid shell variable names. - expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null && - as_fn_error $? "invalid package name: $ac_useropt" - ac_useropt_orig=$ac_useropt - ac_useropt=`$as_echo "$ac_useropt" | sed 's/[-+.]/_/g'` - case $ac_user_opts in - *" -"with_$ac_useropt" -"*) ;; - *) ac_unrecognized_opts="$ac_unrecognized_opts$ac_unrecognized_sep--without-$ac_useropt_orig" - ac_unrecognized_sep=', ';; - esac - eval with_$ac_useropt=no ;; - - --x) - # Obsolete; use --with-x. - with_x=yes ;; - - -x-includes | --x-includes | --x-include | --x-includ | --x-inclu \ - | --x-incl | --x-inc | --x-in | --x-i) - ac_prev=x_includes ;; - -x-includes=* | --x-includes=* | --x-include=* | --x-includ=* | --x-inclu=* \ - | --x-incl=* | --x-inc=* | --x-in=* | --x-i=*) - x_includes=$ac_optarg ;; - - -x-libraries | --x-libraries | --x-librarie | --x-librari \ - | --x-librar | --x-libra | --x-libr | --x-lib | --x-li | --x-l) - ac_prev=x_libraries ;; - -x-libraries=* | --x-libraries=* | --x-librarie=* | --x-librari=* \ - | --x-librar=* | --x-libra=* | --x-libr=* | --x-lib=* | --x-li=* | --x-l=*) - x_libraries=$ac_optarg ;; - - -*) as_fn_error $? "unrecognized option: \`$ac_option' -Try \`$0 --help' for more information" - ;; - - *=*) - ac_envvar=`expr "x$ac_option" : 'x\([^=]*\)='` - # Reject names that are not valid shell variable names. - case $ac_envvar in #( - '' | [0-9]* | *[!_$as_cr_alnum]* ) - as_fn_error $? "invalid variable name: \`$ac_envvar'" ;; - esac - eval $ac_envvar=\$ac_optarg - export $ac_envvar ;; - - *) - # FIXME: should be removed in autoconf 3.0. - $as_echo "$as_me: WARNING: you should use --build, --host, --target" >&2 - expr "x$ac_option" : ".*[^-._$as_cr_alnum]" >/dev/null && - $as_echo "$as_me: WARNING: invalid host type: $ac_option" >&2 - : "${build_alias=$ac_option} ${host_alias=$ac_option} ${target_alias=$ac_option}" - ;; - - esac -done - -if test -n "$ac_prev"; then - ac_option=--`echo $ac_prev | sed 's/_/-/g'` - as_fn_error $? "missing argument to $ac_option" -fi - -if test -n "$ac_unrecognized_opts"; then - case $enable_option_checking in - no) ;; - fatal) as_fn_error $? "unrecognized options: $ac_unrecognized_opts" ;; - *) $as_echo "$as_me: WARNING: unrecognized options: $ac_unrecognized_opts" >&2 ;; - esac -fi - -# Check all directory arguments for consistency. -for ac_var in exec_prefix prefix bindir sbindir libexecdir datarootdir \ - datadir sysconfdir sharedstatedir localstatedir includedir \ - oldincludedir docdir infodir htmldir dvidir pdfdir psdir \ - libdir localedir mandir -do - eval ac_val=\$$ac_var - # Remove trailing slashes. - case $ac_val in - */ ) - ac_val=`expr "X$ac_val" : 'X\(.*[^/]\)' \| "X$ac_val" : 'X\(.*\)'` - eval $ac_var=\$ac_val;; - esac - # Be sure to have absolute directory names. - case $ac_val in - [\\/$]* | ?:[\\/]* ) continue;; - NONE | '' ) case $ac_var in *prefix ) continue;; esac;; - esac - as_fn_error $? "expected an absolute directory name for --$ac_var: $ac_val" -done - -# There might be people who depend on the old broken behavior: `$host' -# used to hold the argument of --host etc. -# FIXME: To remove some day. -build=$build_alias -host=$host_alias -target=$target_alias - -# FIXME: To remove some day. -if test "x$host_alias" != x; then - if test "x$build_alias" = x; then - cross_compiling=maybe - elif test "x$build_alias" != "x$host_alias"; then - cross_compiling=yes - fi -fi - -ac_tool_prefix= -test -n "$host_alias" && ac_tool_prefix=$host_alias- - -test "$silent" = yes && exec 6>/dev/null - - -ac_pwd=`pwd` && test -n "$ac_pwd" && -ac_ls_di=`ls -di .` && -ac_pwd_ls_di=`cd "$ac_pwd" && ls -di .` || - as_fn_error $? "working directory cannot be determined" -test "X$ac_ls_di" = "X$ac_pwd_ls_di" || - as_fn_error $? "pwd does not report name of working directory" - - -# Find the source files, if location was not specified. -if test -z "$srcdir"; then - ac_srcdir_defaulted=yes - # Try the directory containing this script, then the parent directory. - ac_confdir=`$as_dirname -- "$as_myself" || -$as_expr X"$as_myself" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ - X"$as_myself" : 'X\(//\)[^/]' \| \ - X"$as_myself" : 'X\(//\)$' \| \ - X"$as_myself" : 'X\(/\)' \| . 2>/dev/null || -$as_echo X"$as_myself" | - sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ - s//\1/ - q - } - /^X\(\/\/\)[^/].*/{ - s//\1/ - q - } - /^X\(\/\/\)$/{ - s//\1/ - q - } - /^X\(\/\).*/{ - s//\1/ - q - } - s/.*/./; q'` - srcdir=$ac_confdir - if test ! -r "$srcdir/$ac_unique_file"; then - srcdir=.. - fi -else - ac_srcdir_defaulted=no -fi -if test ! -r "$srcdir/$ac_unique_file"; then - test "$ac_srcdir_defaulted" = yes && srcdir="$ac_confdir or .." - as_fn_error $? "cannot find sources ($ac_unique_file) in $srcdir" -fi -ac_msg="sources are in $srcdir, but \`cd $srcdir' does not work" -ac_abs_confdir=`( - cd "$srcdir" && test -r "./$ac_unique_file" || as_fn_error $? "$ac_msg" - pwd)` -# When building in place, set srcdir=. -if test "$ac_abs_confdir" = "$ac_pwd"; then - srcdir=. -fi -# Remove unnecessary trailing slashes from srcdir. -# Double slashes in file names in object file debugging info -# mess up M-x gdb in Emacs. -case $srcdir in -*/) srcdir=`expr "X$srcdir" : 'X\(.*[^/]\)' \| "X$srcdir" : 'X\(.*\)'`;; -esac -for ac_var in $ac_precious_vars; do - eval ac_env_${ac_var}_set=\${${ac_var}+set} - eval ac_env_${ac_var}_value=\$${ac_var} - eval ac_cv_env_${ac_var}_set=\${${ac_var}+set} - eval ac_cv_env_${ac_var}_value=\$${ac_var} -done - -# -# Report the --help message. -# -if test "$ac_init_help" = "long"; then - # Omit some internal or obsolete options to make the list less imposing. - # This message is too long to be a string in the A/UX 3.1 sh. - cat <<_ACEOF -\`configure' configures MCT 2.8 to adapt to many kinds of systems. - -Usage: $0 [OPTION]... [VAR=VALUE]... - -To assign environment variables (e.g., CC, CFLAGS...), specify them as -VAR=VALUE. See below for descriptions of some of the useful variables. - -Defaults for the options are specified in brackets. - -Configuration: - -h, --help display this help and exit - --help=short display options specific to this package - --help=recursive display the short help of all the included packages - -V, --version display version information and exit - -q, --quiet, --silent do not print \`checking ...' messages - --cache-file=FILE cache test results in FILE [disabled] - -C, --config-cache alias for \`--cache-file=config.cache' - -n, --no-create do not create output files - --srcdir=DIR find the sources in DIR [configure dir or \`..'] - -Installation directories: - --prefix=PREFIX install architecture-independent files in PREFIX - [$ac_default_prefix] - --exec-prefix=EPREFIX install architecture-dependent files in EPREFIX - [PREFIX] - -By default, \`make install' will install all the files in -\`$ac_default_prefix/bin', \`$ac_default_prefix/lib' etc. You can specify -an installation prefix other than \`$ac_default_prefix' using \`--prefix', -for instance \`--prefix=\$HOME'. - -For better control, use the options below. - -Fine tuning of the installation directories: - --bindir=DIR user executables [EPREFIX/bin] - --sbindir=DIR system admin executables [EPREFIX/sbin] - --libexecdir=DIR program executables [EPREFIX/libexec] - --sysconfdir=DIR read-only single-machine data [PREFIX/etc] - --sharedstatedir=DIR modifiable architecture-independent data [PREFIX/com] - --localstatedir=DIR modifiable single-machine data [PREFIX/var] - --libdir=DIR object code libraries [EPREFIX/lib] - --includedir=DIR C header files [PREFIX/include] - --oldincludedir=DIR C header files for non-gcc [/usr/include] - --datarootdir=DIR read-only arch.-independent data root [PREFIX/share] - --datadir=DIR read-only architecture-independent data [DATAROOTDIR] - --infodir=DIR info documentation [DATAROOTDIR/info] - --localedir=DIR locale-dependent data [DATAROOTDIR/locale] - --mandir=DIR man documentation [DATAROOTDIR/man] - --docdir=DIR documentation root [DATAROOTDIR/doc/mct] - --htmldir=DIR html documentation [DOCDIR] - --dvidir=DIR dvi documentation [DOCDIR] - --pdfdir=DIR pdf documentation [DOCDIR] - --psdir=DIR ps documentation [DOCDIR] -_ACEOF - - cat <<\_ACEOF -_ACEOF -fi - -if test -n "$ac_init_help"; then - case $ac_init_help in - short | recursive ) echo "Configuration of MCT 2.8:";; - esac - cat <<\_ACEOF - -Optional Features: - --disable-option-checking ignore unrecognized --enable/--with options - --disable-FEATURE do not include FEATURE (same as --enable-FEATURE=no) - --enable-FEATURE[=ARG] include FEATURE [ARG=yes] - --enable-mpiserial Use the included MPI replacement library for single - processor - --enable-debugging Use the debugging flag and disable the optimization - flag - --enable-selectedrealkind - define single precision and double precision numbers - using the selected_real_kind function. Default uses - the kind inquiry function. - --enable-sequence Modify MCT types to make them contiguous in memory. - --enable-babel Supply this option if you plan on building the Babel - bindings to MCT - -Some influential environment variables: - MPILIBS MPI library command line invocation - MPIHEADER MPI header include path with INCLUDEFLAG - FPP C-preprocessor for Fortran source code - FPPFLAGS C-preprocessing flags for Fortran source code - FC The Fortran compiler - FCFLAGS User-defined Fortran compiler flags - PROGFCFLAGS User-defined Fortran compiler flags for example programs - CFLAGS Customized C source compilation flags - DEBUG Fortran compiler flag for generating symbolic debugging - information - OPT Fortran compiler flag for optimization level - REAL8 Fortran compiler flag for setting the default REAL size to - REAL(KIND=8) - BIT64 Fortran compiler flag for generating 64-bit objects - ENDIAN Fortran compiler flag for converting big-endian to little-endian - INCLUDEFLAG Fortran compiler flag for specifying module search path - INCLUDEPATH Additional library and module paths with INCLUDEFLAG - AR Archive command - RANLIB Archive index update command - BABELROOT Root directory of your Babel installation. i.e.: - $BABELROOT/bin/babel $BABELROOT/lib/libsidl.so - COMPILER_ROOT - Root directory of your FORTRAN compiler - FORT_SIZE Number of bits in Fortran real and double kind - CC C compiler command - LDFLAGS linker flags, e.g. -L if you have libraries in a - nonstandard directory - LIBS libraries to pass to the linker, e.g. -l - CPPFLAGS (Objective) C/C++ preprocessor flags, e.g. -I if - you have headers in a nonstandard directory - CPP C preprocessor - MPIFC MPI Fortran compiler command - -Use these variables to override the choices made by `configure' or to help -it to find libraries and programs with nonstandard names/locations. - -Report bugs to the package provider. -_ACEOF -ac_status=$? -fi - -if test "$ac_init_help" = "recursive"; then - # If there are subdirs, report their specific --help. - for ac_dir in : $ac_subdirs_all; do test "x$ac_dir" = x: && continue - test -d "$ac_dir" || - { cd "$srcdir" && ac_pwd=`pwd` && srcdir=. && test -d "$ac_dir"; } || - continue - ac_builddir=. - -case "$ac_dir" in -.) ac_dir_suffix= ac_top_builddir_sub=. ac_top_build_prefix= ;; -*) - ac_dir_suffix=/`$as_echo "$ac_dir" | sed 's|^\.[\\/]||'` - # A ".." for each directory in $ac_dir_suffix. - ac_top_builddir_sub=`$as_echo "$ac_dir_suffix" | sed 's|/[^\\/]*|/..|g;s|/||'` - case $ac_top_builddir_sub in - "") ac_top_builddir_sub=. ac_top_build_prefix= ;; - *) ac_top_build_prefix=$ac_top_builddir_sub/ ;; - esac ;; -esac -ac_abs_top_builddir=$ac_pwd -ac_abs_builddir=$ac_pwd$ac_dir_suffix -# for backward compatibility: -ac_top_builddir=$ac_top_build_prefix - -case $srcdir in - .) # We are building in place. - ac_srcdir=. - ac_top_srcdir=$ac_top_builddir_sub - ac_abs_top_srcdir=$ac_pwd ;; - [\\/]* | ?:[\\/]* ) # Absolute name. - ac_srcdir=$srcdir$ac_dir_suffix; - ac_top_srcdir=$srcdir - ac_abs_top_srcdir=$srcdir ;; - *) # Relative name. - ac_srcdir=$ac_top_build_prefix$srcdir$ac_dir_suffix - ac_top_srcdir=$ac_top_build_prefix$srcdir - ac_abs_top_srcdir=$ac_pwd/$srcdir ;; -esac -ac_abs_srcdir=$ac_abs_top_srcdir$ac_dir_suffix - - cd "$ac_dir" || { ac_status=$?; continue; } - # Check for guested configure. - if test -f "$ac_srcdir/configure.gnu"; then - echo && - $SHELL "$ac_srcdir/configure.gnu" --help=recursive - elif test -f "$ac_srcdir/configure"; then - echo && - $SHELL "$ac_srcdir/configure" --help=recursive - else - $as_echo "$as_me: WARNING: no configuration information is in $ac_dir" >&2 - fi || ac_status=$? - cd "$ac_pwd" || { ac_status=$?; break; } - done -fi - -test -n "$ac_init_help" && exit $ac_status -if $ac_init_version; then - cat <<\_ACEOF -MCT configure 2.8 -generated by GNU Autoconf 2.69 - -Copyright (C) 2012 Free Software Foundation, Inc. -This configure script is free software; the Free Software Foundation -gives unlimited permission to copy, distribute and modify it. -_ACEOF - exit -fi - -## ------------------------ ## -## Autoconf initialization. ## -## ------------------------ ## - -# ac_fn_c_try_compile LINENO -# -------------------------- -# Try to compile conftest.$ac_ext, and return whether this succeeded. -ac_fn_c_try_compile () -{ - as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack - rm -f conftest.$ac_objext - if { { ac_try="$ac_compile" -case "(($ac_try" in - *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; - *) ac_try_echo=$ac_try;; -esac -eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" -$as_echo "$ac_try_echo"; } >&5 - (eval "$ac_compile") 2>conftest.err - ac_status=$? - if test -s conftest.err; then - grep -v '^ *+' conftest.err >conftest.er1 - cat conftest.er1 >&5 - mv -f conftest.er1 conftest.err - fi - $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 - test $ac_status = 0; } && { - test -z "$ac_c_werror_flag" || - test ! -s conftest.err - } && test -s conftest.$ac_objext; then : - ac_retval=0 -else - $as_echo "$as_me: failed program was:" >&5 -sed 's/^/| /' conftest.$ac_ext >&5 - - ac_retval=1 -fi - eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno - as_fn_set_status $ac_retval - -} # ac_fn_c_try_compile - -# ac_fn_c_try_run LINENO -# ---------------------- -# Try to link conftest.$ac_ext, and return whether this succeeded. Assumes -# that executables *can* be run. -ac_fn_c_try_run () -{ - as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack - if { { ac_try="$ac_link" -case "(($ac_try" in - *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; - *) ac_try_echo=$ac_try;; -esac -eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" -$as_echo "$ac_try_echo"; } >&5 - (eval "$ac_link") 2>&5 - ac_status=$? - $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 - test $ac_status = 0; } && { ac_try='./conftest$ac_exeext' - { { case "(($ac_try" in - *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; - *) ac_try_echo=$ac_try;; -esac -eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" -$as_echo "$ac_try_echo"; } >&5 - (eval "$ac_try") 2>&5 - ac_status=$? - $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 - test $ac_status = 0; }; }; then : - ac_retval=0 -else - $as_echo "$as_me: program exited with status $ac_status" >&5 - $as_echo "$as_me: failed program was:" >&5 -sed 's/^/| /' conftest.$ac_ext >&5 - - ac_retval=$ac_status -fi - rm -rf conftest.dSYM conftest_ipa8_conftest.oo - eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno - as_fn_set_status $ac_retval - -} # ac_fn_c_try_run - -# ac_fn_c_try_cpp LINENO -# ---------------------- -# Try to preprocess conftest.$ac_ext, and return whether this succeeded. -ac_fn_c_try_cpp () -{ - as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack - if { { ac_try="$ac_cpp conftest.$ac_ext" -case "(($ac_try" in - *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; - *) ac_try_echo=$ac_try;; -esac -eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" -$as_echo "$ac_try_echo"; } >&5 - (eval "$ac_cpp conftest.$ac_ext") 2>conftest.err - ac_status=$? - if test -s conftest.err; then - grep -v '^ *+' conftest.err >conftest.er1 - cat conftest.er1 >&5 - mv -f conftest.er1 conftest.err - fi - $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 - test $ac_status = 0; } > conftest.i && { - test -z "$ac_c_preproc_warn_flag$ac_c_werror_flag" || - test ! -s conftest.err - }; then : - ac_retval=0 -else - $as_echo "$as_me: failed program was:" >&5 -sed 's/^/| /' conftest.$ac_ext >&5 - - ac_retval=1 -fi - eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno - as_fn_set_status $ac_retval - -} # ac_fn_c_try_cpp - -# ac_fn_c_check_header_compile LINENO HEADER VAR INCLUDES -# ------------------------------------------------------- -# Tests whether HEADER exists and can be compiled using the include files in -# INCLUDES, setting the cache variable VAR accordingly. -ac_fn_c_check_header_compile () -{ - as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack - { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $2" >&5 -$as_echo_n "checking for $2... " >&6; } -if eval \${$3+:} false; then : - $as_echo_n "(cached) " >&6 -else - cat confdefs.h - <<_ACEOF >conftest.$ac_ext -/* end confdefs.h. */ -$4 -#include <$2> -_ACEOF -if ac_fn_c_try_compile "$LINENO"; then : - eval "$3=yes" -else - eval "$3=no" -fi -rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext -fi -eval ac_res=\$$3 - { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_res" >&5 -$as_echo "$ac_res" >&6; } - eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno - -} # ac_fn_c_check_header_compile - -# ac_fn_fc_try_compile LINENO -# --------------------------- -# Try to compile conftest.$ac_ext, and return whether this succeeded. -ac_fn_fc_try_compile () -{ - as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack - rm -f conftest.$ac_objext - if { { ac_try="$ac_compile" -case "(($ac_try" in - *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; - *) ac_try_echo=$ac_try;; -esac -eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" -$as_echo "$ac_try_echo"; } >&5 - (eval "$ac_compile") 2>conftest.err - ac_status=$? - if test -s conftest.err; then - grep -v '^ *+' conftest.err >conftest.er1 - cat conftest.er1 >&5 - mv -f conftest.er1 conftest.err - fi - $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 - test $ac_status = 0; } && { - test -z "$ac_fc_werror_flag" || - test ! -s conftest.err - } && test -s conftest.$ac_objext; then : - ac_retval=0 -else - $as_echo "$as_me: failed program was:" >&5 -sed 's/^/| /' conftest.$ac_ext >&5 - - ac_retval=1 -fi - eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno - as_fn_set_status $ac_retval - -} # ac_fn_fc_try_compile - -# ac_fn_fc_try_link LINENO -# ------------------------ -# Try to link conftest.$ac_ext, and return whether this succeeded. -ac_fn_fc_try_link () -{ - as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack - rm -f conftest.$ac_objext conftest$ac_exeext - if { { ac_try="$ac_link" -case "(($ac_try" in - *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; - *) ac_try_echo=$ac_try;; -esac -eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" -$as_echo "$ac_try_echo"; } >&5 - (eval "$ac_link") 2>conftest.err - ac_status=$? - if test -s conftest.err; then - grep -v '^ *+' conftest.err >conftest.er1 - cat conftest.er1 >&5 - mv -f conftest.er1 conftest.err - fi - $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 - test $ac_status = 0; } && { - test -z "$ac_fc_werror_flag" || - test ! -s conftest.err - } && test -s conftest$ac_exeext && { - test "$cross_compiling" = yes || - test -x conftest$ac_exeext - }; then : - ac_retval=0 -else - $as_echo "$as_me: failed program was:" >&5 -sed 's/^/| /' conftest.$ac_ext >&5 - - ac_retval=1 -fi - # Delete the IPA/IPO (Inter Procedural Analysis/Optimization) information - # created by the PGI compiler (conftest_ipa8_conftest.oo), as it would - # interfere with the next link command; also delete a directory that is - # left behind by Apple's compiler. We do this before executing the actions. - rm -rf conftest.dSYM conftest_ipa8_conftest.oo - eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno - as_fn_set_status $ac_retval - -} # ac_fn_fc_try_link - -# ac_fn_c_try_link LINENO -# ----------------------- -# Try to link conftest.$ac_ext, and return whether this succeeded. -ac_fn_c_try_link () -{ - as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack - rm -f conftest.$ac_objext conftest$ac_exeext - if { { ac_try="$ac_link" -case "(($ac_try" in - *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; - *) ac_try_echo=$ac_try;; -esac -eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" -$as_echo "$ac_try_echo"; } >&5 - (eval "$ac_link") 2>conftest.err - ac_status=$? - if test -s conftest.err; then - grep -v '^ *+' conftest.err >conftest.er1 - cat conftest.er1 >&5 - mv -f conftest.er1 conftest.err - fi - $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 - test $ac_status = 0; } && { - test -z "$ac_c_werror_flag" || - test ! -s conftest.err - } && test -s conftest$ac_exeext && { - test "$cross_compiling" = yes || - test -x conftest$ac_exeext - }; then : - ac_retval=0 -else - $as_echo "$as_me: failed program was:" >&5 -sed 's/^/| /' conftest.$ac_ext >&5 - - ac_retval=1 -fi - # Delete the IPA/IPO (Inter Procedural Analysis/Optimization) information - # created by the PGI compiler (conftest_ipa8_conftest.oo), as it would - # interfere with the next link command; also delete a directory that is - # left behind by Apple's compiler. We do this before executing the actions. - rm -rf conftest.dSYM conftest_ipa8_conftest.oo - eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno - as_fn_set_status $ac_retval - -} # ac_fn_c_try_link -cat >config.log <<_ACEOF -This file contains any messages produced by compilers while -running configure, to aid debugging if configure makes a mistake. - -It was created by MCT $as_me 2.8, which was -generated by GNU Autoconf 2.69. Invocation command line was - - $ $0 $@ - -_ACEOF -exec 5>>config.log -{ -cat <<_ASUNAME -## --------- ## -## Platform. ## -## --------- ## - -hostname = `(hostname || uname -n) 2>/dev/null | sed 1q` -uname -m = `(uname -m) 2>/dev/null || echo unknown` -uname -r = `(uname -r) 2>/dev/null || echo unknown` -uname -s = `(uname -s) 2>/dev/null || echo unknown` -uname -v = `(uname -v) 2>/dev/null || echo unknown` - -/usr/bin/uname -p = `(/usr/bin/uname -p) 2>/dev/null || echo unknown` -/bin/uname -X = `(/bin/uname -X) 2>/dev/null || echo unknown` - -/bin/arch = `(/bin/arch) 2>/dev/null || echo unknown` -/usr/bin/arch -k = `(/usr/bin/arch -k) 2>/dev/null || echo unknown` -/usr/convex/getsysinfo = `(/usr/convex/getsysinfo) 2>/dev/null || echo unknown` -/usr/bin/hostinfo = `(/usr/bin/hostinfo) 2>/dev/null || echo unknown` -/bin/machine = `(/bin/machine) 2>/dev/null || echo unknown` -/usr/bin/oslevel = `(/usr/bin/oslevel) 2>/dev/null || echo unknown` -/bin/universe = `(/bin/universe) 2>/dev/null || echo unknown` - -_ASUNAME - -as_save_IFS=$IFS; IFS=$PATH_SEPARATOR -for as_dir in $PATH -do - IFS=$as_save_IFS - test -z "$as_dir" && as_dir=. - $as_echo "PATH: $as_dir" - done -IFS=$as_save_IFS - -} >&5 - -cat >&5 <<_ACEOF - - -## ----------- ## -## Core tests. ## -## ----------- ## - -_ACEOF - - -# Keep a trace of the command line. -# Strip out --no-create and --no-recursion so they do not pile up. -# Strip out --silent because we don't want to record it for future runs. -# Also quote any args containing shell meta-characters. -# Make two passes to allow for proper duplicate-argument suppression. -ac_configure_args= -ac_configure_args0= -ac_configure_args1= -ac_must_keep_next=false -for ac_pass in 1 2 -do - for ac_arg - do - case $ac_arg in - -no-create | --no-c* | -n | -no-recursion | --no-r*) continue ;; - -q | -quiet | --quiet | --quie | --qui | --qu | --q \ - | -silent | --silent | --silen | --sile | --sil) - continue ;; - *\'*) - ac_arg=`$as_echo "$ac_arg" | sed "s/'/'\\\\\\\\''/g"` ;; - esac - case $ac_pass in - 1) as_fn_append ac_configure_args0 " '$ac_arg'" ;; - 2) - as_fn_append ac_configure_args1 " '$ac_arg'" - if test $ac_must_keep_next = true; then - ac_must_keep_next=false # Got value, back to normal. - else - case $ac_arg in - *=* | --config-cache | -C | -disable-* | --disable-* \ - | -enable-* | --enable-* | -gas | --g* | -nfp | --nf* \ - | -q | -quiet | --q* | -silent | --sil* | -v | -verb* \ - | -with-* | --with-* | -without-* | --without-* | --x) - case "$ac_configure_args0 " in - "$ac_configure_args1"*" '$ac_arg' "* ) continue ;; - esac - ;; - -* ) ac_must_keep_next=true ;; - esac - fi - as_fn_append ac_configure_args " '$ac_arg'" - ;; - esac - done -done -{ ac_configure_args0=; unset ac_configure_args0;} -{ ac_configure_args1=; unset ac_configure_args1;} - -# When interrupted or exit'd, cleanup temporary files, and complete -# config.log. We remove comments because anyway the quotes in there -# would cause problems or look ugly. -# WARNING: Use '\'' to represent an apostrophe within the trap. -# WARNING: Do not start the trap code with a newline, due to a FreeBSD 4.0 bug. -trap 'exit_status=$? - # Save into config.log some information that might help in debugging. - { - echo - - $as_echo "## ---------------- ## -## Cache variables. ## -## ---------------- ##" - echo - # The following way of writing the cache mishandles newlines in values, -( - for ac_var in `(set) 2>&1 | sed -n '\''s/^\([a-zA-Z_][a-zA-Z0-9_]*\)=.*/\1/p'\''`; do - eval ac_val=\$$ac_var - case $ac_val in #( - *${as_nl}*) - case $ac_var in #( - *_cv_*) { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: cache variable $ac_var contains a newline" >&5 -$as_echo "$as_me: WARNING: cache variable $ac_var contains a newline" >&2;} ;; - esac - case $ac_var in #( - _ | IFS | as_nl) ;; #( - BASH_ARGV | BASH_SOURCE) eval $ac_var= ;; #( - *) { eval $ac_var=; unset $ac_var;} ;; - esac ;; - esac - done - (set) 2>&1 | - case $as_nl`(ac_space='\'' '\''; set) 2>&1` in #( - *${as_nl}ac_space=\ *) - sed -n \ - "s/'\''/'\''\\\\'\'''\''/g; - s/^\\([_$as_cr_alnum]*_cv_[_$as_cr_alnum]*\\)=\\(.*\\)/\\1='\''\\2'\''/p" - ;; #( - *) - sed -n "/^[_$as_cr_alnum]*_cv_[_$as_cr_alnum]*=/p" - ;; - esac | - sort -) - echo - - $as_echo "## ----------------- ## -## Output variables. ## -## ----------------- ##" - echo - for ac_var in $ac_subst_vars - do - eval ac_val=\$$ac_var - case $ac_val in - *\'\''*) ac_val=`$as_echo "$ac_val" | sed "s/'\''/'\''\\\\\\\\'\'''\''/g"`;; - esac - $as_echo "$ac_var='\''$ac_val'\''" - done | sort - echo - - if test -n "$ac_subst_files"; then - $as_echo "## ------------------- ## -## File substitutions. ## -## ------------------- ##" - echo - for ac_var in $ac_subst_files - do - eval ac_val=\$$ac_var - case $ac_val in - *\'\''*) ac_val=`$as_echo "$ac_val" | sed "s/'\''/'\''\\\\\\\\'\'''\''/g"`;; - esac - $as_echo "$ac_var='\''$ac_val'\''" - done | sort - echo - fi - - if test -s confdefs.h; then - $as_echo "## ----------- ## -## confdefs.h. ## -## ----------- ##" - echo - cat confdefs.h - echo - fi - test "$ac_signal" != 0 && - $as_echo "$as_me: caught signal $ac_signal" - $as_echo "$as_me: exit $exit_status" - } >&5 - rm -f core *.core core.conftest.* && - rm -f -r conftest* confdefs* conf$$* $ac_clean_files && - exit $exit_status -' 0 -for ac_signal in 1 2 13 15; do - trap 'ac_signal='$ac_signal'; as_fn_exit 1' $ac_signal -done -ac_signal=0 - -# confdefs.h avoids OS command line length limits that DEFS can exceed. -rm -f -r conftest* confdefs.h - -$as_echo "/* confdefs.h */" > confdefs.h - -# Predefined preprocessor variables. - -cat >>confdefs.h <<_ACEOF -#define PACKAGE_NAME "$PACKAGE_NAME" -_ACEOF - -cat >>confdefs.h <<_ACEOF -#define PACKAGE_TARNAME "$PACKAGE_TARNAME" -_ACEOF - -cat >>confdefs.h <<_ACEOF -#define PACKAGE_VERSION "$PACKAGE_VERSION" -_ACEOF - -cat >>confdefs.h <<_ACEOF -#define PACKAGE_STRING "$PACKAGE_STRING" -_ACEOF - -cat >>confdefs.h <<_ACEOF -#define PACKAGE_BUGREPORT "$PACKAGE_BUGREPORT" -_ACEOF - -cat >>confdefs.h <<_ACEOF -#define PACKAGE_URL "$PACKAGE_URL" -_ACEOF - - -# Let the site file select an alternate cache file if it wants to. -# Prefer an explicitly selected file to automatically selected ones. -ac_site_file1=NONE -ac_site_file2=NONE -if test -n "$CONFIG_SITE"; then - # We do not want a PATH search for config.site. - case $CONFIG_SITE in #(( - -*) ac_site_file1=./$CONFIG_SITE;; - */*) ac_site_file1=$CONFIG_SITE;; - *) ac_site_file1=./$CONFIG_SITE;; - esac -elif test "x$prefix" != xNONE; then - ac_site_file1=$prefix/share/config.site - ac_site_file2=$prefix/etc/config.site -else - ac_site_file1=$ac_default_prefix/share/config.site - ac_site_file2=$ac_default_prefix/etc/config.site -fi -for ac_site_file in "$ac_site_file1" "$ac_site_file2" -do - test "x$ac_site_file" = xNONE && continue - if test /dev/null != "$ac_site_file" && test -r "$ac_site_file"; then - { $as_echo "$as_me:${as_lineno-$LINENO}: loading site script $ac_site_file" >&5 -$as_echo "$as_me: loading site script $ac_site_file" >&6;} - sed 's/^/| /' "$ac_site_file" >&5 - . "$ac_site_file" \ - || { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 -$as_echo "$as_me: error: in \`$ac_pwd':" >&2;} -as_fn_error $? "failed to load site script $ac_site_file -See \`config.log' for more details" "$LINENO" 5; } - fi -done - -if test -r "$cache_file"; then - # Some versions of bash will fail to source /dev/null (special files - # actually), so we avoid doing that. DJGPP emulates it as a regular file. - if test /dev/null != "$cache_file" && test -f "$cache_file"; then - { $as_echo "$as_me:${as_lineno-$LINENO}: loading cache $cache_file" >&5 -$as_echo "$as_me: loading cache $cache_file" >&6;} - case $cache_file in - [\\/]* | ?:[\\/]* ) . "$cache_file";; - *) . "./$cache_file";; - esac - fi -else - { $as_echo "$as_me:${as_lineno-$LINENO}: creating cache $cache_file" >&5 -$as_echo "$as_me: creating cache $cache_file" >&6;} - >$cache_file -fi - -# Check that the precious variables saved in the cache have kept the same -# value. -ac_cache_corrupted=false -for ac_var in $ac_precious_vars; do - eval ac_old_set=\$ac_cv_env_${ac_var}_set - eval ac_new_set=\$ac_env_${ac_var}_set - eval ac_old_val=\$ac_cv_env_${ac_var}_value - eval ac_new_val=\$ac_env_${ac_var}_value - case $ac_old_set,$ac_new_set in - set,) - { $as_echo "$as_me:${as_lineno-$LINENO}: error: \`$ac_var' was set to \`$ac_old_val' in the previous run" >&5 -$as_echo "$as_me: error: \`$ac_var' was set to \`$ac_old_val' in the previous run" >&2;} - ac_cache_corrupted=: ;; - ,set) - { $as_echo "$as_me:${as_lineno-$LINENO}: error: \`$ac_var' was not set in the previous run" >&5 -$as_echo "$as_me: error: \`$ac_var' was not set in the previous run" >&2;} - ac_cache_corrupted=: ;; - ,);; - *) - if test "x$ac_old_val" != "x$ac_new_val"; then - # differences in whitespace do not lead to failure. - ac_old_val_w=`echo x $ac_old_val` - ac_new_val_w=`echo x $ac_new_val` - if test "$ac_old_val_w" != "$ac_new_val_w"; then - { $as_echo "$as_me:${as_lineno-$LINENO}: error: \`$ac_var' has changed since the previous run:" >&5 -$as_echo "$as_me: error: \`$ac_var' has changed since the previous run:" >&2;} - ac_cache_corrupted=: - else - { $as_echo "$as_me:${as_lineno-$LINENO}: warning: ignoring whitespace changes in \`$ac_var' since the previous run:" >&5 -$as_echo "$as_me: warning: ignoring whitespace changes in \`$ac_var' since the previous run:" >&2;} - eval $ac_var=\$ac_old_val - fi - { $as_echo "$as_me:${as_lineno-$LINENO}: former value: \`$ac_old_val'" >&5 -$as_echo "$as_me: former value: \`$ac_old_val'" >&2;} - { $as_echo "$as_me:${as_lineno-$LINENO}: current value: \`$ac_new_val'" >&5 -$as_echo "$as_me: current value: \`$ac_new_val'" >&2;} - fi;; - esac - # Pass precious variables to config.status. - if test "$ac_new_set" = set; then - case $ac_new_val in - *\'*) ac_arg=$ac_var=`$as_echo "$ac_new_val" | sed "s/'/'\\\\\\\\''/g"` ;; - *) ac_arg=$ac_var=$ac_new_val ;; - esac - case " $ac_configure_args " in - *" '$ac_arg' "*) ;; # Avoid dups. Use of quotes ensures accuracy. - *) as_fn_append ac_configure_args " '$ac_arg'" ;; - esac - fi -done -if $ac_cache_corrupted; then - { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 -$as_echo "$as_me: error: in \`$ac_pwd':" >&2;} - { $as_echo "$as_me:${as_lineno-$LINENO}: error: changes in the environment can compromise the build" >&5 -$as_echo "$as_me: error: changes in the environment can compromise the build" >&2;} - as_fn_error $? "run \`make distclean' and/or \`rm $cache_file' and start over" "$LINENO" 5 -fi -## -------------------- ## -## Main body of script. ## -## -------------------- ## - -ac_ext=c -ac_cpp='$CPP $CPPFLAGS' -ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' -ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' -ac_compiler_gnu=$ac_cv_c_compiler_gnu - - - -# PROCESS THE FOLLOWING MAKEFILES - -ac_config_files="$ac_config_files Makefile.conf" - -ac_config_headers="$ac_config_headers config.h" - - -# DECLARE PACKAGE OPTIONS - -# Check whether --enable-mpiserial was given. -if test "${enable_mpiserial+set}" = set; then : - enableval=$enable_mpiserial; DONOTCHECKMPI="DONOTCHECKMPI" - -fi - - -# Check whether --enable-debugging was given. -if test "${enable_debugging+set}" = set; then : - enableval=$enable_debugging; DEBUGGING="ENABLED" - -fi - - -# Check whether --enable-selectedrealkind was given. -if test "${enable_selectedrealkind+set}" = set; then : - enableval=$enable_selectedrealkind; SRKDEF="SELECTEDREALKIND" - -fi - - -# Check whether --enable-sequence was given. -if test "${enable_sequence+set}" = set; then : - enableval=$enable_sequence; SRKDEF="SEQUENCE" -fi - - -# Check whether --enable-babel was given. -if test "${enable_babel+set}" = set; then : - enableval=$enable_babel; SRKDEF="SEQUENCE" -fi - - - - -# DECLARE THE FOLLOWING PRECIOUS VARIABLES - - - - - - - - - - - - - - - - - - - - - - -# INCLUDE BABELROOT and COMPILER_ROOT in Makefile.conf(autoconf output) - - - - - -# SET TEMPORARY VARIABLES - -# OS AND PLATFORM NAME -test "$osname"=NONE && osname=`uname -s` -test "$machinename"=NONE && machinename=`uname -m` -fullhostname=`hostname -f` - - -# HARDCODE SPECIFIC MACHINES FOR EXTRAORDINARY CIRCUMSTANCES - -# CHECK IF WE ARE ON THE EARTH SIMULATOR -ES="NO" -if echo $osname | grep -i esos >/dev/null 2>&1; then - ES="YES" -fi -if echo $osname | grep -i hp-ux >/dev/null 2>&1; then - if test "$ac_hostname" = "moon"; then - ES="YES" - # TELLS CONFIGURE NOT TO RUN ANY TESTS THAT REQUIRE EXECUTION - cross_compiling="yes" - fi -fi -if test "$ES" = "YES"; then - echo "Using preset configuration values for the Earth Simulator" - if test -z "$CC"; then - CC="escc" - fi - if test -z "$FC"; then - FC="esf90" - fi - if test -z "$MPIFC"; then - MPIFC="esmpif90" - fi - if test -z "$AR"; then - AR="esar cqs" - fi - if test -z "FPP"; then - FPPFLAGS=" " - fi - if test -z "$FCFLAGS"; then - FCFLAGS="-EP -Wf'-pvctl fullmsg -L fmtlist transform map'" - fi - if test -z "$OPT"; then - OPT="-C vopt" - fi - if test -z "$CPPDEFS"; then - CPPDEFS="-DESVEC" - fi -fi - -# Check if we are on the ANL BG/P - -if echo $fullhostname | egrep -q '.\.(challenger|intrepid)\.alcf\.anl\.gov' - then if test -z "$FC"; then - FC=bgxlf90_r - fi - if test -z "$MPIFC"; then - MPIFC=mpixlf90_r - fi - if test -z "$CC"; then - CC=mpixlc_r - fi -fi - - - -# START TESTS - -# CHECK FOR THE C COMPILER -ac_ext=c -ac_cpp='$CPP $CPPFLAGS' -ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' -ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' -ac_compiler_gnu=$ac_cv_c_compiler_gnu -if test -n "$ac_tool_prefix"; then - for ac_prog in cc - do - # Extract the first word of "$ac_tool_prefix$ac_prog", so it can be a program name with args. -set dummy $ac_tool_prefix$ac_prog; ac_word=$2 -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 -$as_echo_n "checking for $ac_word... " >&6; } -if ${ac_cv_prog_CC+:} false; then : - $as_echo_n "(cached) " >&6 -else - if test -n "$CC"; then - ac_cv_prog_CC="$CC" # Let the user override the test. -else -as_save_IFS=$IFS; IFS=$PATH_SEPARATOR -for as_dir in $PATH -do - IFS=$as_save_IFS - test -z "$as_dir" && as_dir=. - for ac_exec_ext in '' $ac_executable_extensions; do - if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then - ac_cv_prog_CC="$ac_tool_prefix$ac_prog" - $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 - break 2 - fi -done - done -IFS=$as_save_IFS - -fi -fi -CC=$ac_cv_prog_CC -if test -n "$CC"; then - { $as_echo "$as_me:${as_lineno-$LINENO}: result: $CC" >&5 -$as_echo "$CC" >&6; } -else - { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 -$as_echo "no" >&6; } -fi - - - test -n "$CC" && break - done -fi -if test -z "$CC"; then - ac_ct_CC=$CC - for ac_prog in cc -do - # Extract the first word of "$ac_prog", so it can be a program name with args. -set dummy $ac_prog; ac_word=$2 -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 -$as_echo_n "checking for $ac_word... " >&6; } -if ${ac_cv_prog_ac_ct_CC+:} false; then : - $as_echo_n "(cached) " >&6 -else - if test -n "$ac_ct_CC"; then - ac_cv_prog_ac_ct_CC="$ac_ct_CC" # Let the user override the test. -else -as_save_IFS=$IFS; IFS=$PATH_SEPARATOR -for as_dir in $PATH -do - IFS=$as_save_IFS - test -z "$as_dir" && as_dir=. - for ac_exec_ext in '' $ac_executable_extensions; do - if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then - ac_cv_prog_ac_ct_CC="$ac_prog" - $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 - break 2 - fi -done - done -IFS=$as_save_IFS - -fi -fi -ac_ct_CC=$ac_cv_prog_ac_ct_CC -if test -n "$ac_ct_CC"; then - { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_ct_CC" >&5 -$as_echo "$ac_ct_CC" >&6; } -else - { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 -$as_echo "no" >&6; } -fi - - - test -n "$ac_ct_CC" && break -done - - if test "x$ac_ct_CC" = x; then - CC="" - else - case $cross_compiling:$ac_tool_warned in -yes:) -{ $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5 -$as_echo "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;} -ac_tool_warned=yes ;; -esac - CC=$ac_ct_CC - fi -fi - - -test -z "$CC" && { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 -$as_echo "$as_me: error: in \`$ac_pwd':" >&2;} -as_fn_error $? "no acceptable C compiler found in \$PATH -See \`config.log' for more details" "$LINENO" 5; } - -# Provide some information about the compiler. -$as_echo "$as_me:${as_lineno-$LINENO}: checking for C compiler version" >&5 -set X $ac_compile -ac_compiler=$2 -for ac_option in --version -v -V -qversion; do - { { ac_try="$ac_compiler $ac_option >&5" -case "(($ac_try" in - *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; - *) ac_try_echo=$ac_try;; -esac -eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" -$as_echo "$ac_try_echo"; } >&5 - (eval "$ac_compiler $ac_option >&5") 2>conftest.err - ac_status=$? - if test -s conftest.err; then - sed '10a\ -... rest of stderr output deleted ... - 10q' conftest.err >conftest.er1 - cat conftest.er1 >&5 - fi - rm -f conftest.er1 conftest.err - $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 - test $ac_status = 0; } -done - -cat confdefs.h - <<_ACEOF >conftest.$ac_ext -/* end confdefs.h. */ - -int -main () -{ - - ; - return 0; -} -_ACEOF -ac_clean_files_save=$ac_clean_files -ac_clean_files="$ac_clean_files a.out a.out.dSYM a.exe b.out" -# Try to create an executable without -o first, disregard a.out. -# It will help us diagnose broken compilers, and finding out an intuition -# of exeext. -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking whether the C compiler works" >&5 -$as_echo_n "checking whether the C compiler works... " >&6; } -ac_link_default=`$as_echo "$ac_link" | sed 's/ -o *conftest[^ ]*//'` - -# The possible output files: -ac_files="a.out conftest.exe conftest a.exe a_out.exe b.out conftest.*" - -ac_rmfiles= -for ac_file in $ac_files -do - case $ac_file in - *.$ac_ext | *.xcoff | *.tds | *.d | *.pdb | *.xSYM | *.bb | *.bbg | *.map | *.inf | *.dSYM | *.o | *.obj ) ;; - * ) ac_rmfiles="$ac_rmfiles $ac_file";; - esac -done -rm -f $ac_rmfiles - -if { { ac_try="$ac_link_default" -case "(($ac_try" in - *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; - *) ac_try_echo=$ac_try;; -esac -eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" -$as_echo "$ac_try_echo"; } >&5 - (eval "$ac_link_default") 2>&5 - ac_status=$? - $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 - test $ac_status = 0; }; then : - # Autoconf-2.13 could set the ac_cv_exeext variable to `no'. -# So ignore a value of `no', otherwise this would lead to `EXEEXT = no' -# in a Makefile. We should not override ac_cv_exeext if it was cached, -# so that the user can short-circuit this test for compilers unknown to -# Autoconf. -for ac_file in $ac_files '' -do - test -f "$ac_file" || continue - case $ac_file in - *.$ac_ext | *.xcoff | *.tds | *.d | *.pdb | *.xSYM | *.bb | *.bbg | *.map | *.inf | *.dSYM | *.o | *.obj ) - ;; - [ab].out ) - # We found the default executable, but exeext='' is most - # certainly right. - break;; - *.* ) - if test "${ac_cv_exeext+set}" = set && test "$ac_cv_exeext" != no; - then :; else - ac_cv_exeext=`expr "$ac_file" : '[^.]*\(\..*\)'` - fi - # We set ac_cv_exeext here because the later test for it is not - # safe: cross compilers may not add the suffix if given an `-o' - # argument, so we may need to know it at that point already. - # Even if this section looks crufty: it has the advantage of - # actually working. - break;; - * ) - break;; - esac -done -test "$ac_cv_exeext" = no && ac_cv_exeext= - -else - ac_file='' -fi -if test -z "$ac_file"; then : - { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 -$as_echo "no" >&6; } -$as_echo "$as_me: failed program was:" >&5 -sed 's/^/| /' conftest.$ac_ext >&5 - -{ { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 -$as_echo "$as_me: error: in \`$ac_pwd':" >&2;} -as_fn_error 77 "C compiler cannot create executables -See \`config.log' for more details" "$LINENO" 5; } -else - { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5 -$as_echo "yes" >&6; } -fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for C compiler default output file name" >&5 -$as_echo_n "checking for C compiler default output file name... " >&6; } -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_file" >&5 -$as_echo "$ac_file" >&6; } -ac_exeext=$ac_cv_exeext - -rm -f -r a.out a.out.dSYM a.exe conftest$ac_cv_exeext b.out -ac_clean_files=$ac_clean_files_save -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for suffix of executables" >&5 -$as_echo_n "checking for suffix of executables... " >&6; } -if { { ac_try="$ac_link" -case "(($ac_try" in - *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; - *) ac_try_echo=$ac_try;; -esac -eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" -$as_echo "$ac_try_echo"; } >&5 - (eval "$ac_link") 2>&5 - ac_status=$? - $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 - test $ac_status = 0; }; then : - # If both `conftest.exe' and `conftest' are `present' (well, observable) -# catch `conftest.exe'. For instance with Cygwin, `ls conftest' will -# work properly (i.e., refer to `conftest.exe'), while it won't with -# `rm'. -for ac_file in conftest.exe conftest conftest.*; do - test -f "$ac_file" || continue - case $ac_file in - *.$ac_ext | *.xcoff | *.tds | *.d | *.pdb | *.xSYM | *.bb | *.bbg | *.map | *.inf | *.dSYM | *.o | *.obj ) ;; - *.* ) ac_cv_exeext=`expr "$ac_file" : '[^.]*\(\..*\)'` - break;; - * ) break;; - esac -done -else - { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 -$as_echo "$as_me: error: in \`$ac_pwd':" >&2;} -as_fn_error $? "cannot compute suffix of executables: cannot compile and link -See \`config.log' for more details" "$LINENO" 5; } -fi -rm -f conftest conftest$ac_cv_exeext -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_exeext" >&5 -$as_echo "$ac_cv_exeext" >&6; } - -rm -f conftest.$ac_ext -EXEEXT=$ac_cv_exeext -ac_exeext=$EXEEXT -cat confdefs.h - <<_ACEOF >conftest.$ac_ext -/* end confdefs.h. */ -#include -int -main () -{ -FILE *f = fopen ("conftest.out", "w"); - return ferror (f) || fclose (f) != 0; - - ; - return 0; -} -_ACEOF -ac_clean_files="$ac_clean_files conftest.out" -# Check that the compiler produces executables we can run. If not, either -# the compiler is broken, or we cross compile. -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking whether we are cross compiling" >&5 -$as_echo_n "checking whether we are cross compiling... " >&6; } -if test "$cross_compiling" != yes; then - { { ac_try="$ac_link" -case "(($ac_try" in - *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; - *) ac_try_echo=$ac_try;; -esac -eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" -$as_echo "$ac_try_echo"; } >&5 - (eval "$ac_link") 2>&5 - ac_status=$? - $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 - test $ac_status = 0; } - if { ac_try='./conftest$ac_cv_exeext' - { { case "(($ac_try" in - *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; - *) ac_try_echo=$ac_try;; -esac -eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" -$as_echo "$ac_try_echo"; } >&5 - (eval "$ac_try") 2>&5 - ac_status=$? - $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 - test $ac_status = 0; }; }; then - cross_compiling=no - else - if test "$cross_compiling" = maybe; then - cross_compiling=yes - else - { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 -$as_echo "$as_me: error: in \`$ac_pwd':" >&2;} -as_fn_error $? "cannot run C compiled programs. -If you meant to cross compile, use \`--host'. -See \`config.log' for more details" "$LINENO" 5; } - fi - fi -fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $cross_compiling" >&5 -$as_echo "$cross_compiling" >&6; } - -rm -f conftest.$ac_ext conftest$ac_cv_exeext conftest.out -ac_clean_files=$ac_clean_files_save -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for suffix of object files" >&5 -$as_echo_n "checking for suffix of object files... " >&6; } -if ${ac_cv_objext+:} false; then : - $as_echo_n "(cached) " >&6 -else - cat confdefs.h - <<_ACEOF >conftest.$ac_ext -/* end confdefs.h. */ - -int -main () -{ - - ; - return 0; -} -_ACEOF -rm -f conftest.o conftest.obj -if { { ac_try="$ac_compile" -case "(($ac_try" in - *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; - *) ac_try_echo=$ac_try;; -esac -eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" -$as_echo "$ac_try_echo"; } >&5 - (eval "$ac_compile") 2>&5 - ac_status=$? - $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 - test $ac_status = 0; }; then : - for ac_file in conftest.o conftest.obj conftest.*; do - test -f "$ac_file" || continue; - case $ac_file in - *.$ac_ext | *.xcoff | *.tds | *.d | *.pdb | *.xSYM | *.bb | *.bbg | *.map | *.inf | *.dSYM ) ;; - *) ac_cv_objext=`expr "$ac_file" : '.*\.\(.*\)'` - break;; - esac -done -else - $as_echo "$as_me: failed program was:" >&5 -sed 's/^/| /' conftest.$ac_ext >&5 - -{ { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 -$as_echo "$as_me: error: in \`$ac_pwd':" >&2;} -as_fn_error $? "cannot compute suffix of object files: cannot compile -See \`config.log' for more details" "$LINENO" 5; } -fi -rm -f conftest.$ac_cv_objext conftest.$ac_ext -fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_objext" >&5 -$as_echo "$ac_cv_objext" >&6; } -OBJEXT=$ac_cv_objext -ac_objext=$OBJEXT -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking whether we are using the GNU C compiler" >&5 -$as_echo_n "checking whether we are using the GNU C compiler... " >&6; } -if ${ac_cv_c_compiler_gnu+:} false; then : - $as_echo_n "(cached) " >&6 -else - cat confdefs.h - <<_ACEOF >conftest.$ac_ext -/* end confdefs.h. */ - -int -main () -{ -#ifndef __GNUC__ - choke me -#endif - - ; - return 0; -} -_ACEOF -if ac_fn_c_try_compile "$LINENO"; then : - ac_compiler_gnu=yes -else - ac_compiler_gnu=no -fi -rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext -ac_cv_c_compiler_gnu=$ac_compiler_gnu - -fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_c_compiler_gnu" >&5 -$as_echo "$ac_cv_c_compiler_gnu" >&6; } -if test $ac_compiler_gnu = yes; then - GCC=yes -else - GCC= -fi -ac_test_CFLAGS=${CFLAGS+set} -ac_save_CFLAGS=$CFLAGS -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking whether $CC accepts -g" >&5 -$as_echo_n "checking whether $CC accepts -g... " >&6; } -if ${ac_cv_prog_cc_g+:} false; then : - $as_echo_n "(cached) " >&6 -else - ac_save_c_werror_flag=$ac_c_werror_flag - ac_c_werror_flag=yes - ac_cv_prog_cc_g=no - CFLAGS="-g" - cat confdefs.h - <<_ACEOF >conftest.$ac_ext -/* end confdefs.h. */ - -int -main () -{ - - ; - return 0; -} -_ACEOF -if ac_fn_c_try_compile "$LINENO"; then : - ac_cv_prog_cc_g=yes -else - CFLAGS="" - cat confdefs.h - <<_ACEOF >conftest.$ac_ext -/* end confdefs.h. */ - -int -main () -{ - - ; - return 0; -} -_ACEOF -if ac_fn_c_try_compile "$LINENO"; then : - -else - ac_c_werror_flag=$ac_save_c_werror_flag - CFLAGS="-g" - cat confdefs.h - <<_ACEOF >conftest.$ac_ext -/* end confdefs.h. */ - -int -main () -{ - - ; - return 0; -} -_ACEOF -if ac_fn_c_try_compile "$LINENO"; then : - ac_cv_prog_cc_g=yes -fi -rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext -fi -rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext -fi -rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext - ac_c_werror_flag=$ac_save_c_werror_flag -fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_prog_cc_g" >&5 -$as_echo "$ac_cv_prog_cc_g" >&6; } -if test "$ac_test_CFLAGS" = set; then - CFLAGS=$ac_save_CFLAGS -elif test $ac_cv_prog_cc_g = yes; then - if test "$GCC" = yes; then - CFLAGS="-g -O2" - else - CFLAGS="-g" - fi -else - if test "$GCC" = yes; then - CFLAGS="-O2" - else - CFLAGS= - fi -fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $CC option to accept ISO C89" >&5 -$as_echo_n "checking for $CC option to accept ISO C89... " >&6; } -if ${ac_cv_prog_cc_c89+:} false; then : - $as_echo_n "(cached) " >&6 -else - ac_cv_prog_cc_c89=no -ac_save_CC=$CC -cat confdefs.h - <<_ACEOF >conftest.$ac_ext -/* end confdefs.h. */ -#include -#include -struct stat; -/* Most of the following tests are stolen from RCS 5.7's src/conf.sh. */ -struct buf { int x; }; -FILE * (*rcsopen) (struct buf *, struct stat *, int); -static char *e (p, i) - char **p; - int i; -{ - return p[i]; -} -static char *f (char * (*g) (char **, int), char **p, ...) -{ - char *s; - va_list v; - va_start (v,p); - s = g (p, va_arg (v,int)); - va_end (v); - return s; -} - -/* OSF 4.0 Compaq cc is some sort of almost-ANSI by default. It has - function prototypes and stuff, but not '\xHH' hex character constants. - These don't provoke an error unfortunately, instead are silently treated - as 'x'. The following induces an error, until -std is added to get - proper ANSI mode. Curiously '\x00'!='x' always comes out true, for an - array size at least. It's necessary to write '\x00'==0 to get something - that's true only with -std. */ -int osf4_cc_array ['\x00' == 0 ? 1 : -1]; - -/* IBM C 6 for AIX is almost-ANSI by default, but it replaces macro parameters - inside strings and character constants. */ -#define FOO(x) 'x' -int xlc6_cc_array[FOO(a) == 'x' ? 1 : -1]; - -int test (int i, double x); -struct s1 {int (*f) (int a);}; -struct s2 {int (*f) (double a);}; -int pairnames (int, char **, FILE *(*)(struct buf *, struct stat *, int), int, int); -int argc; -char **argv; -int -main () -{ -return f (e, argv, 0) != argv[0] || f (e, argv, 1) != argv[1]; - ; - return 0; -} -_ACEOF -for ac_arg in '' -qlanglvl=extc89 -qlanglvl=ansi -std \ - -Ae "-Aa -D_HPUX_SOURCE" "-Xc -D__EXTENSIONS__" -do - CC="$ac_save_CC $ac_arg" - if ac_fn_c_try_compile "$LINENO"; then : - ac_cv_prog_cc_c89=$ac_arg -fi -rm -f core conftest.err conftest.$ac_objext - test "x$ac_cv_prog_cc_c89" != "xno" && break -done -rm -f conftest.$ac_ext -CC=$ac_save_CC - -fi -# AC_CACHE_VAL -case "x$ac_cv_prog_cc_c89" in - x) - { $as_echo "$as_me:${as_lineno-$LINENO}: result: none needed" >&5 -$as_echo "none needed" >&6; } ;; - xno) - { $as_echo "$as_me:${as_lineno-$LINENO}: result: unsupported" >&5 -$as_echo "unsupported" >&6; } ;; - *) - CC="$CC $ac_cv_prog_cc_c89" - { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_prog_cc_c89" >&5 -$as_echo "$ac_cv_prog_cc_c89" >&6; } ;; -esac -if test "x$ac_cv_prog_cc_c89" != xno; then : - -fi - -ac_ext=c -ac_cpp='$CPP $CPPFLAGS' -ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' -ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' -ac_compiler_gnu=$ac_cv_c_compiler_gnu - - -# CHECK FOR BYTE ORDERING - -ac_ext=c -ac_cpp='$CPP $CPPFLAGS' -ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' -ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' -ac_compiler_gnu=$ac_cv_c_compiler_gnu -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking how to run the C preprocessor" >&5 -$as_echo_n "checking how to run the C preprocessor... " >&6; } -# On Suns, sometimes $CPP names a directory. -if test -n "$CPP" && test -d "$CPP"; then - CPP= -fi -if test -z "$CPP"; then - if ${ac_cv_prog_CPP+:} false; then : - $as_echo_n "(cached) " >&6 -else - # Double quotes because CPP needs to be expanded - for CPP in "$CC -E" "$CC -E -traditional-cpp" "/lib/cpp" - do - ac_preproc_ok=false -for ac_c_preproc_warn_flag in '' yes -do - # Use a header file that comes with gcc, so configuring glibc - # with a fresh cross-compiler works. - # Prefer to if __STDC__ is defined, since - # exists even on freestanding compilers. - # On the NeXT, cc -E runs the code through the compiler's parser, - # not just through cpp. "Syntax error" is here to catch this case. - cat confdefs.h - <<_ACEOF >conftest.$ac_ext -/* end confdefs.h. */ -#ifdef __STDC__ -# include -#else -# include -#endif - Syntax error -_ACEOF -if ac_fn_c_try_cpp "$LINENO"; then : - -else - # Broken: fails on valid input. -continue -fi -rm -f conftest.err conftest.i conftest.$ac_ext - - # OK, works on sane cases. Now check whether nonexistent headers - # can be detected and how. - cat confdefs.h - <<_ACEOF >conftest.$ac_ext -/* end confdefs.h. */ -#include -_ACEOF -if ac_fn_c_try_cpp "$LINENO"; then : - # Broken: success on invalid input. -continue -else - # Passes both tests. -ac_preproc_ok=: -break -fi -rm -f conftest.err conftest.i conftest.$ac_ext - -done -# Because of `break', _AC_PREPROC_IFELSE's cleaning code was skipped. -rm -f conftest.i conftest.err conftest.$ac_ext -if $ac_preproc_ok; then : - break -fi - - done - ac_cv_prog_CPP=$CPP - -fi - CPP=$ac_cv_prog_CPP -else - ac_cv_prog_CPP=$CPP -fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $CPP" >&5 -$as_echo "$CPP" >&6; } -ac_preproc_ok=false -for ac_c_preproc_warn_flag in '' yes -do - # Use a header file that comes with gcc, so configuring glibc - # with a fresh cross-compiler works. - # Prefer to if __STDC__ is defined, since - # exists even on freestanding compilers. - # On the NeXT, cc -E runs the code through the compiler's parser, - # not just through cpp. "Syntax error" is here to catch this case. - cat confdefs.h - <<_ACEOF >conftest.$ac_ext -/* end confdefs.h. */ -#ifdef __STDC__ -# include -#else -# include -#endif - Syntax error -_ACEOF -if ac_fn_c_try_cpp "$LINENO"; then : - -else - # Broken: fails on valid input. -continue -fi -rm -f conftest.err conftest.i conftest.$ac_ext - - # OK, works on sane cases. Now check whether nonexistent headers - # can be detected and how. - cat confdefs.h - <<_ACEOF >conftest.$ac_ext -/* end confdefs.h. */ -#include -_ACEOF -if ac_fn_c_try_cpp "$LINENO"; then : - # Broken: success on invalid input. -continue -else - # Passes both tests. -ac_preproc_ok=: -break -fi -rm -f conftest.err conftest.i conftest.$ac_ext - -done -# Because of `break', _AC_PREPROC_IFELSE's cleaning code was skipped. -rm -f conftest.i conftest.err conftest.$ac_ext -if $ac_preproc_ok; then : - -else - { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 -$as_echo "$as_me: error: in \`$ac_pwd':" >&2;} -as_fn_error $? "C preprocessor \"$CPP\" fails sanity check -See \`config.log' for more details" "$LINENO" 5; } -fi - -ac_ext=c -ac_cpp='$CPP $CPPFLAGS' -ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' -ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' -ac_compiler_gnu=$ac_cv_c_compiler_gnu - - -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for grep that handles long lines and -e" >&5 -$as_echo_n "checking for grep that handles long lines and -e... " >&6; } -if ${ac_cv_path_GREP+:} false; then : - $as_echo_n "(cached) " >&6 -else - if test -z "$GREP"; then - ac_path_GREP_found=false - # Loop through the user's path and test for each of PROGNAME-LIST - as_save_IFS=$IFS; IFS=$PATH_SEPARATOR -for as_dir in $PATH$PATH_SEPARATOR/usr/xpg4/bin -do - IFS=$as_save_IFS - test -z "$as_dir" && as_dir=. - for ac_prog in grep ggrep; do - for ac_exec_ext in '' $ac_executable_extensions; do - ac_path_GREP="$as_dir/$ac_prog$ac_exec_ext" - as_fn_executable_p "$ac_path_GREP" || continue -# Check for GNU ac_path_GREP and select it if it is found. - # Check for GNU $ac_path_GREP -case `"$ac_path_GREP" --version 2>&1` in -*GNU*) - ac_cv_path_GREP="$ac_path_GREP" ac_path_GREP_found=:;; -*) - ac_count=0 - $as_echo_n 0123456789 >"conftest.in" - while : - do - cat "conftest.in" "conftest.in" >"conftest.tmp" - mv "conftest.tmp" "conftest.in" - cp "conftest.in" "conftest.nl" - $as_echo 'GREP' >> "conftest.nl" - "$ac_path_GREP" -e 'GREP$' -e '-(cannot match)-' < "conftest.nl" >"conftest.out" 2>/dev/null || break - diff "conftest.out" "conftest.nl" >/dev/null 2>&1 || break - as_fn_arith $ac_count + 1 && ac_count=$as_val - if test $ac_count -gt ${ac_path_GREP_max-0}; then - # Best one so far, save it but keep looking for a better one - ac_cv_path_GREP="$ac_path_GREP" - ac_path_GREP_max=$ac_count - fi - # 10*(2^10) chars as input seems more than enough - test $ac_count -gt 10 && break - done - rm -f conftest.in conftest.tmp conftest.nl conftest.out;; -esac - - $ac_path_GREP_found && break 3 - done - done - done -IFS=$as_save_IFS - if test -z "$ac_cv_path_GREP"; then - as_fn_error $? "no acceptable grep could be found in $PATH$PATH_SEPARATOR/usr/xpg4/bin" "$LINENO" 5 - fi -else - ac_cv_path_GREP=$GREP -fi - -fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_path_GREP" >&5 -$as_echo "$ac_cv_path_GREP" >&6; } - GREP="$ac_cv_path_GREP" - - -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for egrep" >&5 -$as_echo_n "checking for egrep... " >&6; } -if ${ac_cv_path_EGREP+:} false; then : - $as_echo_n "(cached) " >&6 -else - if echo a | $GREP -E '(a|b)' >/dev/null 2>&1 - then ac_cv_path_EGREP="$GREP -E" - else - if test -z "$EGREP"; then - ac_path_EGREP_found=false - # Loop through the user's path and test for each of PROGNAME-LIST - as_save_IFS=$IFS; IFS=$PATH_SEPARATOR -for as_dir in $PATH$PATH_SEPARATOR/usr/xpg4/bin -do - IFS=$as_save_IFS - test -z "$as_dir" && as_dir=. - for ac_prog in egrep; do - for ac_exec_ext in '' $ac_executable_extensions; do - ac_path_EGREP="$as_dir/$ac_prog$ac_exec_ext" - as_fn_executable_p "$ac_path_EGREP" || continue -# Check for GNU ac_path_EGREP and select it if it is found. - # Check for GNU $ac_path_EGREP -case `"$ac_path_EGREP" --version 2>&1` in -*GNU*) - ac_cv_path_EGREP="$ac_path_EGREP" ac_path_EGREP_found=:;; -*) - ac_count=0 - $as_echo_n 0123456789 >"conftest.in" - while : - do - cat "conftest.in" "conftest.in" >"conftest.tmp" - mv "conftest.tmp" "conftest.in" - cp "conftest.in" "conftest.nl" - $as_echo 'EGREP' >> "conftest.nl" - "$ac_path_EGREP" 'EGREP$' < "conftest.nl" >"conftest.out" 2>/dev/null || break - diff "conftest.out" "conftest.nl" >/dev/null 2>&1 || break - as_fn_arith $ac_count + 1 && ac_count=$as_val - if test $ac_count -gt ${ac_path_EGREP_max-0}; then - # Best one so far, save it but keep looking for a better one - ac_cv_path_EGREP="$ac_path_EGREP" - ac_path_EGREP_max=$ac_count - fi - # 10*(2^10) chars as input seems more than enough - test $ac_count -gt 10 && break - done - rm -f conftest.in conftest.tmp conftest.nl conftest.out;; -esac - - $ac_path_EGREP_found && break 3 - done - done - done -IFS=$as_save_IFS - if test -z "$ac_cv_path_EGREP"; then - as_fn_error $? "no acceptable egrep could be found in $PATH$PATH_SEPARATOR/usr/xpg4/bin" "$LINENO" 5 - fi -else - ac_cv_path_EGREP=$EGREP -fi - - fi -fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_path_EGREP" >&5 -$as_echo "$ac_cv_path_EGREP" >&6; } - EGREP="$ac_cv_path_EGREP" - - -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for ANSI C header files" >&5 -$as_echo_n "checking for ANSI C header files... " >&6; } -if ${ac_cv_header_stdc+:} false; then : - $as_echo_n "(cached) " >&6 -else - cat confdefs.h - <<_ACEOF >conftest.$ac_ext -/* end confdefs.h. */ -#include -#include -#include -#include - -int -main () -{ - - ; - return 0; -} -_ACEOF -if ac_fn_c_try_compile "$LINENO"; then : - ac_cv_header_stdc=yes -else - ac_cv_header_stdc=no -fi -rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext - -if test $ac_cv_header_stdc = yes; then - # SunOS 4.x string.h does not declare mem*, contrary to ANSI. - cat confdefs.h - <<_ACEOF >conftest.$ac_ext -/* end confdefs.h. */ -#include - -_ACEOF -if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | - $EGREP "memchr" >/dev/null 2>&1; then : - -else - ac_cv_header_stdc=no -fi -rm -f conftest* - -fi - -if test $ac_cv_header_stdc = yes; then - # ISC 2.0.2 stdlib.h does not declare free, contrary to ANSI. - cat confdefs.h - <<_ACEOF >conftest.$ac_ext -/* end confdefs.h. */ -#include - -_ACEOF -if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | - $EGREP "free" >/dev/null 2>&1; then : - -else - ac_cv_header_stdc=no -fi -rm -f conftest* - -fi - -if test $ac_cv_header_stdc = yes; then - # /bin/cc in Irix-4.0.5 gets non-ANSI ctype macros unless using -ansi. - if test "$cross_compiling" = yes; then : - : -else - cat confdefs.h - <<_ACEOF >conftest.$ac_ext -/* end confdefs.h. */ -#include -#include -#if ((' ' & 0x0FF) == 0x020) -# define ISLOWER(c) ('a' <= (c) && (c) <= 'z') -# define TOUPPER(c) (ISLOWER(c) ? 'A' + ((c) - 'a') : (c)) -#else -# define ISLOWER(c) \ - (('a' <= (c) && (c) <= 'i') \ - || ('j' <= (c) && (c) <= 'r') \ - || ('s' <= (c) && (c) <= 'z')) -# define TOUPPER(c) (ISLOWER(c) ? ((c) | 0x40) : (c)) -#endif - -#define XOR(e, f) (((e) && !(f)) || (!(e) && (f))) -int -main () -{ - int i; - for (i = 0; i < 256; i++) - if (XOR (islower (i), ISLOWER (i)) - || toupper (i) != TOUPPER (i)) - return 2; - return 0; -} -_ACEOF -if ac_fn_c_try_run "$LINENO"; then : - -else - ac_cv_header_stdc=no -fi -rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ - conftest.$ac_objext conftest.beam conftest.$ac_ext -fi - -fi -fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_header_stdc" >&5 -$as_echo "$ac_cv_header_stdc" >&6; } -if test $ac_cv_header_stdc = yes; then - -$as_echo "#define STDC_HEADERS 1" >>confdefs.h - -fi - -# On IRIX 5.3, sys/types and inttypes.h are conflicting. -for ac_header in sys/types.h sys/stat.h stdlib.h string.h memory.h strings.h \ - inttypes.h stdint.h unistd.h -do : - as_ac_Header=`$as_echo "ac_cv_header_$ac_header" | $as_tr_sh` -ac_fn_c_check_header_compile "$LINENO" "$ac_header" "$as_ac_Header" "$ac_includes_default -" -if eval test \"x\$"$as_ac_Header"\" = x"yes"; then : - cat >>confdefs.h <<_ACEOF -#define `$as_echo "HAVE_$ac_header" | $as_tr_cpp` 1 -_ACEOF - -fi - -done - - - { $as_echo "$as_me:${as_lineno-$LINENO}: checking whether byte ordering is bigendian" >&5 -$as_echo_n "checking whether byte ordering is bigendian... " >&6; } -if ${ac_cv_c_bigendian+:} false; then : - $as_echo_n "(cached) " >&6 -else - ac_cv_c_bigendian=unknown - # See if we're dealing with a universal compiler. - cat confdefs.h - <<_ACEOF >conftest.$ac_ext -/* end confdefs.h. */ -#ifndef __APPLE_CC__ - not a universal capable compiler - #endif - typedef int dummy; - -_ACEOF -if ac_fn_c_try_compile "$LINENO"; then : - - # Check for potential -arch flags. It is not universal unless - # there are at least two -arch flags with different values. - ac_arch= - ac_prev= - for ac_word in $CC $CFLAGS $CPPFLAGS $LDFLAGS; do - if test -n "$ac_prev"; then - case $ac_word in - i?86 | x86_64 | ppc | ppc64) - if test -z "$ac_arch" || test "$ac_arch" = "$ac_word"; then - ac_arch=$ac_word - else - ac_cv_c_bigendian=universal - break - fi - ;; - esac - ac_prev= - elif test "x$ac_word" = "x-arch"; then - ac_prev=arch - fi - done -fi -rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext - if test $ac_cv_c_bigendian = unknown; then - # See if sys/param.h defines the BYTE_ORDER macro. - cat confdefs.h - <<_ACEOF >conftest.$ac_ext -/* end confdefs.h. */ -#include - #include - -int -main () -{ -#if ! (defined BYTE_ORDER && defined BIG_ENDIAN \ - && defined LITTLE_ENDIAN && BYTE_ORDER && BIG_ENDIAN \ - && LITTLE_ENDIAN) - bogus endian macros - #endif - - ; - return 0; -} -_ACEOF -if ac_fn_c_try_compile "$LINENO"; then : - # It does; now see whether it defined to BIG_ENDIAN or not. - cat confdefs.h - <<_ACEOF >conftest.$ac_ext -/* end confdefs.h. */ -#include - #include - -int -main () -{ -#if BYTE_ORDER != BIG_ENDIAN - not big endian - #endif - - ; - return 0; -} -_ACEOF -if ac_fn_c_try_compile "$LINENO"; then : - ac_cv_c_bigendian=yes -else - ac_cv_c_bigendian=no -fi -rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext -fi -rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext - fi - if test $ac_cv_c_bigendian = unknown; then - # See if defines _LITTLE_ENDIAN or _BIG_ENDIAN (e.g., Solaris). - cat confdefs.h - <<_ACEOF >conftest.$ac_ext -/* end confdefs.h. */ -#include - -int -main () -{ -#if ! (defined _LITTLE_ENDIAN || defined _BIG_ENDIAN) - bogus endian macros - #endif - - ; - return 0; -} -_ACEOF -if ac_fn_c_try_compile "$LINENO"; then : - # It does; now see whether it defined to _BIG_ENDIAN or not. - cat confdefs.h - <<_ACEOF >conftest.$ac_ext -/* end confdefs.h. */ -#include - -int -main () -{ -#ifndef _BIG_ENDIAN - not big endian - #endif - - ; - return 0; -} -_ACEOF -if ac_fn_c_try_compile "$LINENO"; then : - ac_cv_c_bigendian=yes -else - ac_cv_c_bigendian=no -fi -rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext -fi -rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext - fi - if test $ac_cv_c_bigendian = unknown; then - # Compile a test program. - if test "$cross_compiling" = yes; then : - # Try to guess by grepping values from an object file. - cat confdefs.h - <<_ACEOF >conftest.$ac_ext -/* end confdefs.h. */ -short int ascii_mm[] = - { 0x4249, 0x4765, 0x6E44, 0x6961, 0x6E53, 0x7953, 0 }; - short int ascii_ii[] = - { 0x694C, 0x5454, 0x656C, 0x6E45, 0x6944, 0x6E61, 0 }; - int use_ascii (int i) { - return ascii_mm[i] + ascii_ii[i]; - } - short int ebcdic_ii[] = - { 0x89D3, 0xE3E3, 0x8593, 0x95C5, 0x89C4, 0x9581, 0 }; - short int ebcdic_mm[] = - { 0xC2C9, 0xC785, 0x95C4, 0x8981, 0x95E2, 0xA8E2, 0 }; - int use_ebcdic (int i) { - return ebcdic_mm[i] + ebcdic_ii[i]; - } - extern int foo; - -int -main () -{ -return use_ascii (foo) == use_ebcdic (foo); - ; - return 0; -} -_ACEOF -if ac_fn_c_try_compile "$LINENO"; then : - if grep BIGenDianSyS conftest.$ac_objext >/dev/null; then - ac_cv_c_bigendian=yes - fi - if grep LiTTleEnDian conftest.$ac_objext >/dev/null ; then - if test "$ac_cv_c_bigendian" = unknown; then - ac_cv_c_bigendian=no - else - # finding both strings is unlikely to happen, but who knows? - ac_cv_c_bigendian=unknown - fi - fi -fi -rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext -else - cat confdefs.h - <<_ACEOF >conftest.$ac_ext -/* end confdefs.h. */ -$ac_includes_default -int -main () -{ - - /* Are we little or big endian? From Harbison&Steele. */ - union - { - long int l; - char c[sizeof (long int)]; - } u; - u.l = 1; - return u.c[sizeof (long int) - 1] == 1; - - ; - return 0; -} -_ACEOF -if ac_fn_c_try_run "$LINENO"; then : - ac_cv_c_bigendian=no -else - ac_cv_c_bigendian=yes -fi -rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ - conftest.$ac_objext conftest.beam conftest.$ac_ext -fi - - fi -fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_c_bigendian" >&5 -$as_echo "$ac_cv_c_bigendian" >&6; } - case $ac_cv_c_bigendian in #( - yes) - $as_echo "#define WORDS_BIGENDIAN 1" >>confdefs.h -;; #( - no) - ;; #( - universal) - -$as_echo "#define AC_APPLE_UNIVERSAL_BUILD 1" >>confdefs.h - - ;; #( - *) - as_fn_error $? "unknown endianness - presetting ac_cv_c_bigendian=no (or yes) will help" "$LINENO" 5 ;; - esac - - -# CHECK FOR THE FORTRAN COMPILER -# RLJ- specify the order, include PathScale and do not search for F77 -ac_ext=${ac_fc_srcext-f} -ac_compile='$FC -c $FCFLAGS $ac_fcflags_srcext conftest.$ac_ext >&5' -ac_link='$FC -o conftest$ac_exeext $FCFLAGS $LDFLAGS $ac_fcflags_srcext conftest.$ac_ext $LIBS >&5' -ac_compiler_gnu=$ac_cv_fc_compiler_gnu -if test -n "$ac_tool_prefix"; then - for ac_prog in nagfor xlf95 pgf95 ifort gfortran pathf95 ftn lf95 f95 fort ifc efc g95 xlf90 pgf90 pathf90 epcf90 pghpf - do - # Extract the first word of "$ac_tool_prefix$ac_prog", so it can be a program name with args. -set dummy $ac_tool_prefix$ac_prog; ac_word=$2 -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 -$as_echo_n "checking for $ac_word... " >&6; } -if ${ac_cv_prog_FC+:} false; then : - $as_echo_n "(cached) " >&6 -else - if test -n "$FC"; then - ac_cv_prog_FC="$FC" # Let the user override the test. -else -as_save_IFS=$IFS; IFS=$PATH_SEPARATOR -for as_dir in $PATH -do - IFS=$as_save_IFS - test -z "$as_dir" && as_dir=. - for ac_exec_ext in '' $ac_executable_extensions; do - if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then - ac_cv_prog_FC="$ac_tool_prefix$ac_prog" - $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 - break 2 - fi -done - done -IFS=$as_save_IFS - -fi -fi -FC=$ac_cv_prog_FC -if test -n "$FC"; then - { $as_echo "$as_me:${as_lineno-$LINENO}: result: $FC" >&5 -$as_echo "$FC" >&6; } -else - { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 -$as_echo "no" >&6; } -fi - - - test -n "$FC" && break - done -fi -if test -z "$FC"; then - ac_ct_FC=$FC - for ac_prog in nagfor xlf95 pgf95 ifort gfortran pathf95 ftn lf95 f95 fort ifc efc g95 xlf90 pgf90 pathf90 epcf90 pghpf -do - # Extract the first word of "$ac_prog", so it can be a program name with args. -set dummy $ac_prog; ac_word=$2 -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 -$as_echo_n "checking for $ac_word... " >&6; } -if ${ac_cv_prog_ac_ct_FC+:} false; then : - $as_echo_n "(cached) " >&6 -else - if test -n "$ac_ct_FC"; then - ac_cv_prog_ac_ct_FC="$ac_ct_FC" # Let the user override the test. -else -as_save_IFS=$IFS; IFS=$PATH_SEPARATOR -for as_dir in $PATH -do - IFS=$as_save_IFS - test -z "$as_dir" && as_dir=. - for ac_exec_ext in '' $ac_executable_extensions; do - if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then - ac_cv_prog_ac_ct_FC="$ac_prog" - $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 - break 2 - fi -done - done -IFS=$as_save_IFS - -fi -fi -ac_ct_FC=$ac_cv_prog_ac_ct_FC -if test -n "$ac_ct_FC"; then - { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_ct_FC" >&5 -$as_echo "$ac_ct_FC" >&6; } -else - { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 -$as_echo "no" >&6; } -fi - - - test -n "$ac_ct_FC" && break -done - - if test "x$ac_ct_FC" = x; then - FC="" - else - case $cross_compiling:$ac_tool_warned in -yes:) -{ $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5 -$as_echo "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;} -ac_tool_warned=yes ;; -esac - FC=$ac_ct_FC - fi -fi - - -# Provide some information about the compiler. -$as_echo "$as_me:${as_lineno-$LINENO}: checking for Fortran compiler version" >&5 -set X $ac_compile -ac_compiler=$2 -for ac_option in --version -v -V -qversion; do - { { ac_try="$ac_compiler $ac_option >&5" -case "(($ac_try" in - *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; - *) ac_try_echo=$ac_try;; -esac -eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" -$as_echo "$ac_try_echo"; } >&5 - (eval "$ac_compiler $ac_option >&5") 2>conftest.err - ac_status=$? - if test -s conftest.err; then - sed '10a\ -... rest of stderr output deleted ... - 10q' conftest.err >conftest.er1 - cat conftest.er1 >&5 - fi - rm -f conftest.er1 conftest.err - $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 - test $ac_status = 0; } -done -rm -f a.out - -# If we don't use `.F' as extension, the preprocessor is not run on the -# input file. (Note that this only needs to work for GNU compilers.) -ac_save_ext=$ac_ext -ac_ext=F -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking whether we are using the GNU Fortran compiler" >&5 -$as_echo_n "checking whether we are using the GNU Fortran compiler... " >&6; } -if ${ac_cv_fc_compiler_gnu+:} false; then : - $as_echo_n "(cached) " >&6 -else - cat > conftest.$ac_ext <<_ACEOF - program main -#ifndef __GNUC__ - choke me -#endif - - end -_ACEOF -if ac_fn_fc_try_compile "$LINENO"; then : - ac_compiler_gnu=yes -else - ac_compiler_gnu=no -fi -rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext -ac_cv_fc_compiler_gnu=$ac_compiler_gnu - -fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_fc_compiler_gnu" >&5 -$as_echo "$ac_cv_fc_compiler_gnu" >&6; } -ac_ext=$ac_save_ext -ac_test_FCFLAGS=${FCFLAGS+set} -ac_save_FCFLAGS=$FCFLAGS -FCFLAGS= -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking whether $FC accepts -g" >&5 -$as_echo_n "checking whether $FC accepts -g... " >&6; } -if ${ac_cv_prog_fc_g+:} false; then : - $as_echo_n "(cached) " >&6 -else - FCFLAGS=-g -cat > conftest.$ac_ext <<_ACEOF - program main - - end -_ACEOF -if ac_fn_fc_try_compile "$LINENO"; then : - ac_cv_prog_fc_g=yes -else - ac_cv_prog_fc_g=no -fi -rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext - -fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_prog_fc_g" >&5 -$as_echo "$ac_cv_prog_fc_g" >&6; } -if test "$ac_test_FCFLAGS" = set; then - FCFLAGS=$ac_save_FCFLAGS -elif test $ac_cv_prog_fc_g = yes; then - if test "x$ac_cv_fc_compiler_gnu" = xyes; then - FCFLAGS="-g -O2" - else - FCFLAGS="-g" - fi -else - if test "x$ac_cv_fc_compiler_gnu" = xyes; then - FCFLAGS="-O2" - else - FCFLAGS= - fi -fi - -if test $ac_compiler_gnu = yes; then - GFC=yes -else - GFC= -fi -ac_ext=c -ac_cpp='$CPP $CPPFLAGS' -ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' -ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' -ac_compiler_gnu=$ac_cv_c_compiler_gnu - - -# CHECK FOR MPI LIBRARIES -ac_ext=${ac_fc_srcext-f} -ac_compile='$FC -c $FCFLAGS $ac_fcflags_srcext conftest.$ac_ext >&5' -ac_link='$FC -o conftest$ac_exeext $FCFLAGS $LDFLAGS $ac_fcflags_srcext conftest.$ac_ext $LIBS >&5' -ac_compiler_gnu=$ac_cv_fc_compiler_gnu - - - -ac_ext=${ac_fc_srcext-f} -ac_compile='$FC -c $FCFLAGS $ac_fcflags_srcext conftest.$ac_ext >&5' -ac_link='$FC -o conftest$ac_exeext $FCFLAGS $LDFLAGS $ac_fcflags_srcext conftest.$ac_ext $LIBS >&5' -ac_compiler_gnu=$ac_cv_fc_compiler_gnu -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for Fortran flag to compile .F90 files" >&5 -$as_echo_n "checking for Fortran flag to compile .F90 files... " >&6; } -if ${ac_cv_fc_srcext_F90+:} false; then : - $as_echo_n "(cached) " >&6 -else - ac_ext=F90 -ac_fcflags_srcext_save=$ac_fcflags_srcext -ac_fcflags_srcext= -ac_cv_fc_srcext_F90=unknown -case $ac_ext in #( - [fF]77) ac_try=f77;; #( - *) ac_try=f95;; -esac -for ac_flag in none -qsuffix=f=F90 -Tf "-x $ac_try"; do - test "x$ac_flag" != xnone && ac_fcflags_srcext="$ac_flag" - cat > conftest.$ac_ext <<_ACEOF - program main - - end -_ACEOF -if ac_fn_fc_try_compile "$LINENO"; then : - ac_cv_fc_srcext_F90=$ac_flag; break -fi -rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext -done -rm -f conftest.$ac_objext conftest.F90 -ac_fcflags_srcext=$ac_fcflags_srcext_save - -fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_fc_srcext_F90" >&5 -$as_echo "$ac_cv_fc_srcext_F90" >&6; } -if test "x$ac_cv_fc_srcext_F90" = xunknown; then - as_fn_error $? "Fortran could not compile .F90 files" "$LINENO" 5 -else - ac_fc_srcext=F90 - if test "x$ac_cv_fc_srcext_F90" = xnone; then - ac_fcflags_srcext="" - FCFLAGS_F90="" - else - ac_fcflags_srcext=$ac_cv_fc_srcext_F90 - FCFLAGS_F90=$ac_cv_fc_srcext_F90 - fi - - -fi -ac_ext=${ac_fc_srcext-f} -ac_compile='$FC -c $FCFLAGS $ac_fcflags_srcext conftest.$ac_ext >&5' -ac_link='$FC -o conftest$ac_exeext $FCFLAGS $LDFLAGS $ac_fcflags_srcext conftest.$ac_ext $LIBS >&5' -ac_compiler_gnu=$ac_cv_fc_compiler_gnu - - -OLDFCFLAGS="$FCFLAGS" - -if test -n "$MPIHEADER"; then - FCFLAGS="$FCFLAGS $MPIHEADER" -fi - -# CHECK MPI BY DEFAULT -if test -z "$DONOTCHECKMPI"; then - - - - - - for ac_prog in mpif90 hf90 mpxlf90 mpxlf95 mpf90 cmpifc cmpif90c -do - # Extract the first word of "$ac_prog", so it can be a program name with args. -set dummy $ac_prog; ac_word=$2 -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 -$as_echo_n "checking for $ac_word... " >&6; } -if ${ac_cv_prog_MPIFC+:} false; then : - $as_echo_n "(cached) " >&6 -else - if test -n "$MPIFC"; then - ac_cv_prog_MPIFC="$MPIFC" # Let the user override the test. -else -as_save_IFS=$IFS; IFS=$PATH_SEPARATOR -for as_dir in $PATH -do - IFS=$as_save_IFS - test -z "$as_dir" && as_dir=. - for ac_exec_ext in '' $ac_executable_extensions; do - if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then - ac_cv_prog_MPIFC="$ac_prog" - $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 - break 2 - fi -done - done -IFS=$as_save_IFS - -fi -fi -MPIFC=$ac_cv_prog_MPIFC -if test -n "$MPIFC"; then - { $as_echo "$as_me:${as_lineno-$LINENO}: result: $MPIFC" >&5 -$as_echo "$MPIFC" >&6; } -else - { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 -$as_echo "no" >&6; } -fi - - - test -n "$MPIFC" && break -done -test -n "$MPIFC" || MPIFC="$FC" - - acx_mpi_save_FC="$FC" - FC="$MPIFC" - - - -if test x = x"$MPILIBS"; then - { $as_echo "$as_me:${as_lineno-$LINENO}: checking for MPI_Init" >&5 -$as_echo_n "checking for MPI_Init... " >&6; } - cat > conftest.$ac_ext <<_ACEOF - program main - call MPI_Init - end -_ACEOF -if ac_fn_fc_try_link "$LINENO"; then : - MPILIBS=" " - { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5 -$as_echo "yes" >&6; } -else - { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 -$as_echo "no" >&6; } -fi -rm -f core conftest.err conftest.$ac_objext \ - conftest$ac_exeext conftest.$ac_ext -fi - - if test x = x"$MPILIBS"; then - { $as_echo "$as_me:${as_lineno-$LINENO}: checking for MPI_Init in -lfmpi" >&5 -$as_echo_n "checking for MPI_Init in -lfmpi... " >&6; } -if ${ac_cv_lib_fmpi_MPI_Init+:} false; then : - $as_echo_n "(cached) " >&6 -else - ac_check_lib_save_LIBS=$LIBS -LIBS="-lfmpi $LIBS" -cat > conftest.$ac_ext <<_ACEOF - program main - call MPI_Init - end -_ACEOF -if ac_fn_fc_try_link "$LINENO"; then : - ac_cv_lib_fmpi_MPI_Init=yes -else - ac_cv_lib_fmpi_MPI_Init=no -fi -rm -f core conftest.err conftest.$ac_objext \ - conftest$ac_exeext conftest.$ac_ext -LIBS=$ac_check_lib_save_LIBS -fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_fmpi_MPI_Init" >&5 -$as_echo "$ac_cv_lib_fmpi_MPI_Init" >&6; } -if test "x$ac_cv_lib_fmpi_MPI_Init" = xyes; then : - MPILIBS="-lfmpi" -fi - - fi - if test x = x"$MPILIBS"; then - { $as_echo "$as_me:${as_lineno-$LINENO}: checking for MPI_Init in -lmpichf90" >&5 -$as_echo_n "checking for MPI_Init in -lmpichf90... " >&6; } -if ${ac_cv_lib_mpichf90_MPI_Init+:} false; then : - $as_echo_n "(cached) " >&6 -else - ac_check_lib_save_LIBS=$LIBS -LIBS="-lmpichf90 $LIBS" -cat > conftest.$ac_ext <<_ACEOF - program main - call MPI_Init - end -_ACEOF -if ac_fn_fc_try_link "$LINENO"; then : - ac_cv_lib_mpichf90_MPI_Init=yes -else - ac_cv_lib_mpichf90_MPI_Init=no -fi -rm -f core conftest.err conftest.$ac_objext \ - conftest$ac_exeext conftest.$ac_ext -LIBS=$ac_check_lib_save_LIBS -fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_mpichf90_MPI_Init" >&5 -$as_echo "$ac_cv_lib_mpichf90_MPI_Init" >&6; } -if test "x$ac_cv_lib_mpichf90_MPI_Init" = xyes; then : - MPILIBS="-lmpichf90" -fi - - fi - -if test x = x"$MPILIBS"; then - { $as_echo "$as_me:${as_lineno-$LINENO}: checking for MPI_Init in -lmpi" >&5 -$as_echo_n "checking for MPI_Init in -lmpi... " >&6; } -if ${ac_cv_lib_mpi_MPI_Init+:} false; then : - $as_echo_n "(cached) " >&6 -else - ac_check_lib_save_LIBS=$LIBS -LIBS="-lmpi $LIBS" -cat > conftest.$ac_ext <<_ACEOF - program main - call MPI_Init - end -_ACEOF -if ac_fn_fc_try_link "$LINENO"; then : - ac_cv_lib_mpi_MPI_Init=yes -else - ac_cv_lib_mpi_MPI_Init=no -fi -rm -f core conftest.err conftest.$ac_objext \ - conftest$ac_exeext conftest.$ac_ext -LIBS=$ac_check_lib_save_LIBS -fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_mpi_MPI_Init" >&5 -$as_echo "$ac_cv_lib_mpi_MPI_Init" >&6; } -if test "x$ac_cv_lib_mpi_MPI_Init" = xyes; then : - MPILIBS="-lmpi" -fi - -fi -if test x = x"$MPILIBS"; then - { $as_echo "$as_me:${as_lineno-$LINENO}: checking for MPI_Init in -lmpich" >&5 -$as_echo_n "checking for MPI_Init in -lmpich... " >&6; } -if ${ac_cv_lib_mpich_MPI_Init+:} false; then : - $as_echo_n "(cached) " >&6 -else - ac_check_lib_save_LIBS=$LIBS -LIBS="-lmpich $LIBS" -cat > conftest.$ac_ext <<_ACEOF - program main - call MPI_Init - end -_ACEOF -if ac_fn_fc_try_link "$LINENO"; then : - ac_cv_lib_mpich_MPI_Init=yes -else - ac_cv_lib_mpich_MPI_Init=no -fi -rm -f core conftest.err conftest.$ac_objext \ - conftest$ac_exeext conftest.$ac_ext -LIBS=$ac_check_lib_save_LIBS -fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_mpich_MPI_Init" >&5 -$as_echo "$ac_cv_lib_mpich_MPI_Init" >&6; } -if test "x$ac_cv_lib_mpich_MPI_Init" = xyes; then : - MPILIBS="-lmpich" -fi - -fi - -if test x != x"$MPILIBS"; then - { $as_echo "$as_me:${as_lineno-$LINENO}: checking for mpif.h" >&5 -$as_echo_n "checking for mpif.h... " >&6; } - cat > conftest.$ac_ext <<_ACEOF - program main - include 'mpif.h' - end -_ACEOF -if ac_fn_fc_try_compile "$LINENO"; then : - { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5 -$as_echo "yes" >&6; } -else - MPILIBS="" - { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 -$as_echo "no" >&6; } -fi -rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext -fi - -FC="$acx_mpi_save_FC" - - - -# Finally, execute ACTION-IF-FOUND/ACTION-IF-NOT-FOUND: -if test x = x"$MPILIBS"; then - - : -else - -$as_echo "#define HAVE_MPI 1" >>confdefs.h - - : -fi - -fi - -# DONT CHECK MPI IF SERIALMPI OPTION IS ENABLED -if test -n "$DONOTCHECKMPI"; then - echo "MPISERIAL ENABLED: BYPASSING MPI CHECK" - if test -z "$MPIFC"; then - MPIFC=$FC - fi - if test -z "$FORT_SIZE"; then - FORT_SIZE="real4double8" - echo "FORT_SIZE IS PRESET TO $FORT_SIZE" - fi - abs_top_builddir=`pwd` - MPISERPATH=$abs_top_builddir/mpi-serial - - MPIHEADER=-I$MPISERPATH - MPILIBS="-L$MPISERPATH -lmpi-serial" -fi - -FCFLAGS="$OLDFCFLAGS" - -# A HACK TO FIX ACX_MPI TO GET MPILIBS TO BE AN EMPTY STRING -if test "$MPILIBS" = " "; then - MPILIBS="" -fi - -# SET FC TO MPIFC. IF MPILIBS IS PRESENT, SET FC TO FC. -if test -z "$FC"; then - FC=$MPIFC - if test "$FC" != "$MPIFC"; then - if test -n "$MPILIBS"; then - FC=$FC - fi - fi -fi - -# FOR SANITY, CHECK THAT FILENAME EXTENSION FOR FC IS CONSISTENT WITH FC -OLDFC="$FC" -FC="$FC" - -cat > conftest.$ac_ext <<_ACEOF - subroutine oof() - return - end -_ACEOF -if ac_fn_fc_try_compile "$LINENO"; then : - -else - { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $FC FAILED TO COMPILE FILENAME EXTENSION $ac_ext" >&5 -$as_echo "$as_me: WARNING: $FC FAILED TO COMPILE FILENAME EXTENSION $ac_ext" >&2;} - -fi -rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext - - - -FC="$OLDFC" - -# CHECK HOW TO GET THE COMPILER VERSION. -echo "Checking Compiler Version" -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking how to get the version output from $FC" >&5 -$as_echo_n "checking how to get the version output from $FC... " >&6; } -if ${ac_cv_prog_fc_version+:} false; then : - $as_echo_n "(cached) " >&6 -else - -cat > conftest.$ac_ext <<_ACEOF - program main - - end -_ACEOF -if ac_fn_fc_try_compile "$LINENO"; then : - ac_cv_prog_fc_version= -# Try some options frequently used verbose output -for ac_version in -V -version --version +version -qversion; do - ac_ext=${ac_fc_srcext-f} -ac_compile='$FC -c $FCFLAGS $ac_fcflags_srcext conftest.$ac_ext >&5' -ac_link='$FC -o conftest$ac_exeext $FCFLAGS $LDFLAGS $ac_fcflags_srcext conftest.$ac_ext $LIBS >&5' -ac_compiler_gnu=$ac_cv_fc_compiler_gnu - -cat > conftest.$ac_ext <<_ACEOF - program main - - end -_ACEOF - -# Compile and link our simple test program by passing a flag (argument -# 1 to this macro) to the Fortran 90 compiler in order to get "version" output -ac_save_FCFLAGS=$FCFLAGS -FCFLAGS="$FCFLAGS $ac_version" -(eval echo $as_me:4068: \"$ac_link\") >&5 -ac_fc_version_output=`eval $ac_link 5>&1 2>&1 | grep -v 'Driving:'` -echo "$ac_fc_version_output" >&5 -FCFLAGS=$ac_save_FCFLAGS - -rm -f conftest.* -ac_ext=${ac_fc_srcext-f} -ac_compile='$FC -c $FCFLAGS $ac_fcflags_srcext conftest.$ac_ext >&5' -ac_link='$FC -o conftest$ac_exeext $FCFLAGS $LDFLAGS $ac_fcflags_srcext conftest.$ac_ext $LIBS >&5' -ac_compiler_gnu=$ac_cv_fc_compiler_gnu - - - # look for "copyright" constructs in the output - for ac_arg in $ac_fc_version_output; do - case $ac_arg in - COPYRIGHT | copyright | Copyright | '(c)' | '(C)' | Compiler | Compilers | Version | Version:) - ac_cv_prog_fc_version=$ac_version - break 2 ;; - esac - done -done -if test -z "$ac_cv_prog_fc_version"; then - { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: cannot determine how to obtain version information from $FC" >&5 -$as_echo "$as_me: WARNING: cannot determine how to obtain version information from $FC" >&2;} -fi -else - { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: compilation failed" >&5 -$as_echo "$as_me: WARNING: compilation failed" >&2;} -fi -rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext - -fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_prog_fc_version" >&5 -$as_echo "$ac_cv_prog_fc_version" >&6; } - -ac_ext=c -ac_cpp='$CPP $CPPFLAGS' -ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' -ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' -ac_compiler_gnu=$ac_cv_c_compiler_gnu - - -# Check how to use the cpp with fortran - -ac_ext=${ac_fc_srcext-f} -ac_compile='$FC -c $FCFLAGS $ac_fcflags_srcext conftest.$ac_ext >&5' -ac_link='$FC -o conftest$ac_exeext $FCFLAGS $LDFLAGS $ac_fcflags_srcext conftest.$ac_ext $LIBS >&5' -ac_compiler_gnu=$ac_cv_fc_compiler_gnu -ac_fc_pp_define_srcext_save=$ac_fc_srcext -ac_ext=${ac_fc_srcext-f} -ac_compile='$FC -c $FCFLAGS $ac_fcflags_srcext conftest.$ac_ext >&5' -ac_link='$FC -o conftest$ac_exeext $FCFLAGS $LDFLAGS $ac_fcflags_srcext conftest.$ac_ext $LIBS >&5' -ac_compiler_gnu=$ac_cv_fc_compiler_gnu -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for Fortran flag to compile preprocessed .F files" >&5 -$as_echo_n "checking for Fortran flag to compile preprocessed .F files... " >&6; } -if ${ac_cv_fc_pp_srcext_F+:} false; then : - $as_echo_n "(cached) " >&6 -else - ac_ext=F -ac_fcflags_pp_srcext_save=$ac_fcflags_srcext -ac_fcflags_srcext= -ac_cv_fc_pp_srcext_F=unknown -case $ac_ext in #( - [fF]77) ac_try=f77-cpp-input;; #( - *) ac_try=f95-cpp-input;; -esac -for ac_flag in none -ftpp -fpp -Tf "-fpp -Tf" -xpp=fpp -Mpreprocess "-e Z" \ - -cpp -xpp=cpp -qsuffix=cpp=F "-x $ac_try" +cpp -Cpp; do - test "x$ac_flag" != xnone && ac_fcflags_srcext="$ac_flag" - cat > conftest.$ac_ext <<_ACEOF - program main - -#if 0 -#include - choke me -#endif - end -_ACEOF -if ac_fn_fc_try_compile "$LINENO"; then : - cat > conftest.$ac_ext <<_ACEOF - program main - -#if 1 -#include - choke me -#endif - end -_ACEOF -if ac_fn_fc_try_compile "$LINENO"; then : - -else - ac_cv_fc_pp_srcext_F=$ac_flag; break -fi -rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext -fi -rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext -done -rm -f conftest.$ac_objext conftest.F -ac_fcflags_srcext=$ac_fcflags_pp_srcext_save - -fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_fc_pp_srcext_F" >&5 -$as_echo "$ac_cv_fc_pp_srcext_F" >&6; } -if test "x$ac_cv_fc_pp_srcext_F" = xunknown; then - as_fn_error $? "Fortran could not compile preprocessed .F files" "$LINENO" 5 -else - ac_fc_srcext=F - if test "x$ac_cv_fc_pp_srcext_F" = xnone; then - ac_fcflags_srcext="" - FCFLAGS_F="" - else - ac_fcflags_srcext=$ac_cv_fc_pp_srcext_F - FCFLAGS_F=$ac_cv_fc_pp_srcext_F - fi - - -fi -ac_ext=${ac_fc_srcext-f} -ac_compile='$FC -c $FCFLAGS $ac_fcflags_srcext conftest.$ac_ext >&5' -ac_link='$FC -o conftest$ac_exeext $FCFLAGS $LDFLAGS $ac_fcflags_srcext conftest.$ac_ext $LIBS >&5' -ac_compiler_gnu=$ac_cv_fc_compiler_gnu - -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking how to define symbols for preprocessed Fortran" >&5 -$as_echo_n "checking how to define symbols for preprocessed Fortran... " >&6; } -if ${ac_cv_fc_pp_define+:} false; then : - $as_echo_n "(cached) " >&6 -else - ac_fc_pp_define_srcext_save=$ac_fc_srcext -ac_cv_fc_pp_define=unknown -ac_fc_pp_define_FCFLAGS_save=$FCFLAGS -for ac_flag in -D -WF,-D -Wp,-D -Wc,-D -do - FCFLAGS="$ac_fc_pp_define_FCFLAGS_save ${ac_flag}FOOBAR ${ac_flag}ZORK=42" - cat > conftest.$ac_ext <<_ACEOF - program main - -#ifndef FOOBAR - choke me -#endif -#if ZORK != 42 - choke me -#endif - end -_ACEOF -if ac_fn_fc_try_compile "$LINENO"; then : - ac_cv_fc_pp_define=$ac_flag -fi -rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext - test x"$ac_cv_fc_pp_define" != xunknown && break -done -FCFLAGS=$ac_fc_pp_define_FCFLAGS_save - -fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_fc_pp_define" >&5 -$as_echo "$ac_cv_fc_pp_define" >&6; } -ac_fc_srcext=$ac_fc_pp_define_srcext_save -if test "x$ac_cv_fc_pp_define" = xunknown; then - FC_DEFINE= - as_fn_error 77 "Fortran does not allow to define preprocessor symbols" "$LINENO" 5 -else - FC_DEFINE=$ac_cv_fc_pp_define - -fi -ac_ext=c -ac_cpp='$CPP $CPPFLAGS' -ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' -ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' -ac_compiler_gnu=$ac_cv_c_compiler_gnu - - - -# CHECK HOW TO NAME MANGLE C FUNCTIONS SO THAT IT CAN BE CALLED FROM FORTRAN -OLDFC="$FC" - -ac_ext=${ac_fc_srcext-f} -ac_compile='$FC -c $FCFLAGS $ac_fcflags_srcext conftest.$ac_ext >&5' -ac_link='$FC -o conftest$ac_exeext $FCFLAGS $LDFLAGS $ac_fcflags_srcext conftest.$ac_ext $LIBS >&5' -ac_compiler_gnu=$ac_cv_fc_compiler_gnu -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking how to get verbose linking output from $FC" >&5 -$as_echo_n "checking how to get verbose linking output from $FC... " >&6; } -if ${ac_cv_prog_fc_v+:} false; then : - $as_echo_n "(cached) " >&6 -else - cat > conftest.$ac_ext <<_ACEOF - program main - - end -_ACEOF -if ac_fn_fc_try_compile "$LINENO"; then : - ac_cv_prog_fc_v= -# Try some options frequently used verbose output -for ac_verb in -v -verbose --verbose -V -\#\#\#; do - cat > conftest.$ac_ext <<_ACEOF - program main - - end -_ACEOF - -# Compile and link our simple test program by passing a flag (argument -# 1 to this macro) to the Fortran compiler in order to get -# "verbose" output that we can then parse for the Fortran linker -# flags. -ac_save_FCFLAGS=$FCFLAGS -FCFLAGS="$FCFLAGS $ac_verb" -eval "set x $ac_link" -shift -$as_echo "$as_me:${as_lineno-$LINENO}: $*" >&5 -# gfortran 4.3 outputs lines setting COLLECT_GCC_OPTIONS, COMPILER_PATH, -# LIBRARY_PATH; skip all such settings. -ac_fc_v_output=`eval $ac_link 5>&1 2>&1 | - sed '/^Driving:/d; /^Configured with:/d; - '"/^[_$as_cr_Letters][_$as_cr_alnum]*=/d"` -$as_echo "$ac_fc_v_output" >&5 -FCFLAGS=$ac_save_FCFLAGS - -rm -rf conftest* - -# On HP/UX there is a line like: "LPATH is: /foo:/bar:/baz" where -# /foo, /bar, and /baz are search directories for the Fortran linker. -# Here, we change these into -L/foo -L/bar -L/baz (and put it first): -ac_fc_v_output="`echo $ac_fc_v_output | - grep 'LPATH is:' | - sed 's|.*LPATH is\(: *[^ ]*\).*|\1|;s|: */| -L/|g'` $ac_fc_v_output" - -# FIXME: we keep getting bitten by quoted arguments; a more general fix -# that detects unbalanced quotes in FLIBS should be implemented -# and (ugh) tested at some point. -case $ac_fc_v_output in - # With xlf replace commas with spaces, - # and remove "-link" and closing parenthesis. - *xlfentry*) - ac_fc_v_output=`echo $ac_fc_v_output | - sed ' - s/,/ /g - s/ -link / /g - s/) *$// - ' - ` ;; - - # With Intel ifc, ignore the quoted -mGLOB_options_string stuff (quoted - # $LIBS confuse us, and the libraries appear later in the output anyway). - *mGLOB_options_string*) - ac_fc_v_output=`echo $ac_fc_v_output | sed 's/"-mGLOB[^"]*"/ /g'` ;; - - # Portland Group compiler has singly- or doubly-quoted -cmdline argument - # Singly-quoted arguments were reported for versions 5.2-4 and 6.0-4. - # Doubly-quoted arguments were reported for "PGF90/x86 Linux/x86 5.0-2". - *-cmdline\ * | *-ignore\ * | *-def\ *) - ac_fc_v_output=`echo $ac_fc_v_output | sed "\ - s/-cmdline *'[^']*'/ /g; s/-cmdline *\"[^\"]*\"/ /g - s/-ignore *'[^']*'/ /g; s/-ignore *\"[^\"]*\"/ /g - s/-def *'[^']*'/ /g; s/-def *\"[^\"]*\"/ /g"` ;; - - # If we are using fort77 (the f2c wrapper) then filter output and delete quotes. - *fort77*f2c*gcc*) - ac_fc_v_output=`echo "$ac_fc_v_output" | sed -n ' - /:[ ]\+Running[ ]\{1,\}"gcc"/{ - /"-c"/d - /[.]c"*/d - s/^.*"gcc"/"gcc"/ - s/"//gp - }'` ;; - - # If we are using Cray Fortran then delete quotes. - *cft90*) - ac_fc_v_output=`echo $ac_fc_v_output | sed 's/"//g'` ;; -esac - - - # look for -l* and *.a constructs in the output - for ac_arg in $ac_fc_v_output; do - case $ac_arg in - [\\/]*.a | ?:[\\/]*.a | -[lLRu]*) - ac_cv_prog_fc_v=$ac_verb - break 2 ;; - esac - done -done -if test -z "$ac_cv_prog_fc_v"; then - { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: cannot determine how to obtain linking information from $FC" >&5 -$as_echo "$as_me: WARNING: cannot determine how to obtain linking information from $FC" >&2;} -fi -else - { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: compilation failed" >&5 -$as_echo "$as_me: WARNING: compilation failed" >&2;} -fi -rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext - -fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_prog_fc_v" >&5 -$as_echo "$ac_cv_prog_fc_v" >&6; } -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for Fortran libraries of $FC" >&5 -$as_echo_n "checking for Fortran libraries of $FC... " >&6; } -if ${ac_cv_fc_libs+:} false; then : - $as_echo_n "(cached) " >&6 -else - if test "x$FCLIBS" != "x"; then - ac_cv_fc_libs="$FCLIBS" # Let the user override the test. -else - -cat > conftest.$ac_ext <<_ACEOF - program main - - end -_ACEOF - -# Compile and link our simple test program by passing a flag (argument -# 1 to this macro) to the Fortran compiler in order to get -# "verbose" output that we can then parse for the Fortran linker -# flags. -ac_save_FCFLAGS=$FCFLAGS -FCFLAGS="$FCFLAGS $ac_cv_prog_fc_v" -eval "set x $ac_link" -shift -$as_echo "$as_me:${as_lineno-$LINENO}: $*" >&5 -# gfortran 4.3 outputs lines setting COLLECT_GCC_OPTIONS, COMPILER_PATH, -# LIBRARY_PATH; skip all such settings. -ac_fc_v_output=`eval $ac_link 5>&1 2>&1 | - sed '/^Driving:/d; /^Configured with:/d; - '"/^[_$as_cr_Letters][_$as_cr_alnum]*=/d"` -$as_echo "$ac_fc_v_output" >&5 -FCFLAGS=$ac_save_FCFLAGS - -rm -rf conftest* - -# On HP/UX there is a line like: "LPATH is: /foo:/bar:/baz" where -# /foo, /bar, and /baz are search directories for the Fortran linker. -# Here, we change these into -L/foo -L/bar -L/baz (and put it first): -ac_fc_v_output="`echo $ac_fc_v_output | - grep 'LPATH is:' | - sed 's|.*LPATH is\(: *[^ ]*\).*|\1|;s|: */| -L/|g'` $ac_fc_v_output" - -# FIXME: we keep getting bitten by quoted arguments; a more general fix -# that detects unbalanced quotes in FLIBS should be implemented -# and (ugh) tested at some point. -case $ac_fc_v_output in - # With xlf replace commas with spaces, - # and remove "-link" and closing parenthesis. - *xlfentry*) - ac_fc_v_output=`echo $ac_fc_v_output | - sed ' - s/,/ /g - s/ -link / /g - s/) *$// - ' - ` ;; - - # With Intel ifc, ignore the quoted -mGLOB_options_string stuff (quoted - # $LIBS confuse us, and the libraries appear later in the output anyway). - *mGLOB_options_string*) - ac_fc_v_output=`echo $ac_fc_v_output | sed 's/"-mGLOB[^"]*"/ /g'` ;; - - # Portland Group compiler has singly- or doubly-quoted -cmdline argument - # Singly-quoted arguments were reported for versions 5.2-4 and 6.0-4. - # Doubly-quoted arguments were reported for "PGF90/x86 Linux/x86 5.0-2". - *-cmdline\ * | *-ignore\ * | *-def\ *) - ac_fc_v_output=`echo $ac_fc_v_output | sed "\ - s/-cmdline *'[^']*'/ /g; s/-cmdline *\"[^\"]*\"/ /g - s/-ignore *'[^']*'/ /g; s/-ignore *\"[^\"]*\"/ /g - s/-def *'[^']*'/ /g; s/-def *\"[^\"]*\"/ /g"` ;; - - # If we are using fort77 (the f2c wrapper) then filter output and delete quotes. - *fort77*f2c*gcc*) - ac_fc_v_output=`echo "$ac_fc_v_output" | sed -n ' - /:[ ]\+Running[ ]\{1,\}"gcc"/{ - /"-c"/d - /[.]c"*/d - s/^.*"gcc"/"gcc"/ - s/"//gp - }'` ;; - - # If we are using Cray Fortran then delete quotes. - *cft90*) - ac_fc_v_output=`echo $ac_fc_v_output | sed 's/"//g'` ;; -esac - - - -ac_cv_fc_libs= - -# Save positional arguments (if any) -ac_save_positional="$@" - -set X $ac_fc_v_output -while test $# != 1; do - shift - ac_arg=$1 - case $ac_arg in - [\\/]*.a | ?:[\\/]*.a) - ac_exists=false - for ac_i in $ac_cv_fc_libs; do - if test x"$ac_arg" = x"$ac_i"; then - ac_exists=true - break - fi - done - - if test x"$ac_exists" = xtrue; then : - -else - ac_cv_fc_libs="$ac_cv_fc_libs $ac_arg" -fi - ;; - -bI:*) - ac_exists=false - for ac_i in $ac_cv_fc_libs; do - if test x"$ac_arg" = x"$ac_i"; then - ac_exists=true - break - fi - done - - if test x"$ac_exists" = xtrue; then : - -else - if test "$ac_compiler_gnu" = yes; then - for ac_link_opt in $ac_arg; do - ac_cv_fc_libs="$ac_cv_fc_libs -Xlinker $ac_link_opt" - done -else - ac_cv_fc_libs="$ac_cv_fc_libs $ac_arg" -fi -fi - ;; - # Ignore these flags. - -lang* | -lcrt*.o | -lc | -lgcc* | -lSystem | -libmil | -little \ - |-LANG:=* | -LIST:* | -LNO:* | -link | -list | -lnuma ) - ;; - -lkernel32) - test x"$CYGWIN" != xyes && ac_cv_fc_libs="$ac_cv_fc_libs $ac_arg" - ;; - -[LRuYz]) - # These flags, when seen by themselves, take an argument. - # We remove the space between option and argument and re-iterate - # unless we find an empty arg or a new option (starting with -) - case $2 in - "" | -*);; - *) - ac_arg="$ac_arg$2" - shift; shift - set X $ac_arg "$@" - ;; - esac - ;; - -YP,*) - for ac_j in `$as_echo "$ac_arg" | sed -e 's/-YP,/-L/;s/:/ -L/g'`; do - ac_exists=false - for ac_i in $ac_cv_fc_libs; do - if test x"$ac_j" = x"$ac_i"; then - ac_exists=true - break - fi - done - - if test x"$ac_exists" = xtrue; then : - -else - ac_arg="$ac_arg $ac_j" - ac_cv_fc_libs="$ac_cv_fc_libs $ac_j" -fi - done - ;; - -[lLR]*) - ac_exists=false - for ac_i in $ac_cv_fc_libs; do - if test x"$ac_arg" = x"$ac_i"; then - ac_exists=true - break - fi - done - - if test x"$ac_exists" = xtrue; then : - -else - ac_cv_fc_libs="$ac_cv_fc_libs $ac_arg" -fi - ;; - -zallextract*| -zdefaultextract) - ac_cv_fc_libs="$ac_cv_fc_libs $ac_arg" - ;; - # Ignore everything else. - esac -done -# restore positional arguments -set X $ac_save_positional; shift - -# We only consider "LD_RUN_PATH" on Solaris systems. If this is seen, -# then we insist that the "run path" must be an absolute path (i.e. it -# must begin with a "/"). -case `(uname -sr) 2>/dev/null` in - "SunOS 5"*) - ac_ld_run_path=`$as_echo "$ac_fc_v_output" | - sed -n 's,^.*LD_RUN_PATH *= *\(/[^ ]*\).*$,-R\1,p'` - test "x$ac_ld_run_path" != x && - if test "$ac_compiler_gnu" = yes; then - for ac_link_opt in $ac_ld_run_path; do - ac_cv_fc_libs="$ac_cv_fc_libs -Xlinker $ac_link_opt" - done -else - ac_cv_fc_libs="$ac_cv_fc_libs $ac_ld_run_path" -fi - ;; -esac -fi # test "x$[]_AC_LANG_PREFIX[]LIBS" = "x" - -fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_fc_libs" >&5 -$as_echo "$ac_cv_fc_libs" >&6; } -FCLIBS="$ac_cv_fc_libs" - - -ac_ext=c -ac_cpp='$CPP $CPPFLAGS' -ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' -ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' -ac_compiler_gnu=$ac_cv_c_compiler_gnu - -ac_ext=${ac_fc_srcext-f} -ac_compile='$FC -c $FCFLAGS $ac_fcflags_srcext conftest.$ac_ext >&5' -ac_link='$FC -o conftest$ac_exeext $FCFLAGS $LDFLAGS $ac_fcflags_srcext conftest.$ac_ext $LIBS >&5' -ac_compiler_gnu=$ac_cv_fc_compiler_gnu - -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for dummy main to link with Fortran libraries" >&5 -$as_echo_n "checking for dummy main to link with Fortran libraries... " >&6; } -if ${ac_cv_fc_dummy_main+:} false; then : - $as_echo_n "(cached) " >&6 -else - ac_fc_dm_save_LIBS=$LIBS - LIBS="$LIBS $FCLIBS" - ac_fortran_dm_var=FC_DUMMY_MAIN - ac_ext=c -ac_cpp='$CPP $CPPFLAGS' -ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' -ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' -ac_compiler_gnu=$ac_cv_c_compiler_gnu - - # First, try linking without a dummy main: - cat confdefs.h - <<_ACEOF >conftest.$ac_ext -/* end confdefs.h. */ - -#ifdef FC_DUMMY_MAIN -#ifndef FC_DUMMY_MAIN_EQ_F77 -# ifdef __cplusplus - extern "C" -# endif - int FC_DUMMY_MAIN() { return 1; } -#endif -#endif -int -main () -{ - - ; - return 0; -} -_ACEOF -if ac_fn_c_try_link "$LINENO"; then : - ac_cv_fortran_dummy_main=none -else - ac_cv_fortran_dummy_main=unknown -fi -rm -f core conftest.err conftest.$ac_objext \ - conftest$ac_exeext conftest.$ac_ext - - if test $ac_cv_fortran_dummy_main = unknown; then - for ac_func in MAIN__ MAIN_ __main MAIN _MAIN __MAIN main_ main__ _main; do - cat confdefs.h - <<_ACEOF >conftest.$ac_ext -/* end confdefs.h. */ -#define $ac_fortran_dm_var $ac_func -#ifdef FC_DUMMY_MAIN -#ifndef FC_DUMMY_MAIN_EQ_F77 -# ifdef __cplusplus - extern "C" -# endif - int FC_DUMMY_MAIN() { return 1; } -#endif -#endif -int -main () -{ - - ; - return 0; -} -_ACEOF -if ac_fn_c_try_link "$LINENO"; then : - ac_cv_fortran_dummy_main=$ac_func; break -fi -rm -f core conftest.err conftest.$ac_objext \ - conftest$ac_exeext conftest.$ac_ext - done - fi - ac_ext=${ac_fc_srcext-f} -ac_compile='$FC -c $FCFLAGS $ac_fcflags_srcext conftest.$ac_ext >&5' -ac_link='$FC -o conftest$ac_exeext $FCFLAGS $LDFLAGS $ac_fcflags_srcext conftest.$ac_ext $LIBS >&5' -ac_compiler_gnu=$ac_cv_fc_compiler_gnu - ac_cv_fc_dummy_main=$ac_cv_fortran_dummy_main - rm -rf conftest* - LIBS=$ac_fc_dm_save_LIBS - -fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_fc_dummy_main" >&5 -$as_echo "$ac_cv_fc_dummy_main" >&6; } -FC_DUMMY_MAIN=$ac_cv_fc_dummy_main -if test "$FC_DUMMY_MAIN" != unknown; then : - if test $FC_DUMMY_MAIN != none; then - -cat >>confdefs.h <<_ACEOF -#define FC_DUMMY_MAIN $FC_DUMMY_MAIN -_ACEOF - - if test "x$ac_cv_fc_dummy_main" = "x$ac_cv_f77_dummy_main"; then - -$as_echo "#define FC_DUMMY_MAIN_EQ_F77 1" >>confdefs.h - - fi -fi -else - { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 -$as_echo "$as_me: error: in \`$ac_pwd':" >&2;} -as_fn_error $? "linking to Fortran libraries from C fails -See \`config.log' for more details" "$LINENO" 5; } -fi - -ac_ext=c -ac_cpp='$CPP $CPPFLAGS' -ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' -ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' -ac_compiler_gnu=$ac_cv_c_compiler_gnu - -ac_ext=${ac_fc_srcext-f} -ac_compile='$FC -c $FCFLAGS $ac_fcflags_srcext conftest.$ac_ext >&5' -ac_link='$FC -o conftest$ac_exeext $FCFLAGS $LDFLAGS $ac_fcflags_srcext conftest.$ac_ext $LIBS >&5' -ac_compiler_gnu=$ac_cv_fc_compiler_gnu -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for Fortran name-mangling scheme" >&5 -$as_echo_n "checking for Fortran name-mangling scheme... " >&6; } -if ${ac_cv_fc_mangling+:} false; then : - $as_echo_n "(cached) " >&6 -else - cat > conftest.$ac_ext <<_ACEOF - subroutine foobar() - return - end - subroutine foo_bar() - return - end -_ACEOF -if ac_fn_fc_try_compile "$LINENO"; then : - mv conftest.$ac_objext cfortran_test.$ac_objext - - ac_save_LIBS=$LIBS - LIBS="cfortran_test.$ac_objext $LIBS $FCLIBS" - - ac_ext=c -ac_cpp='$CPP $CPPFLAGS' -ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' -ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' -ac_compiler_gnu=$ac_cv_c_compiler_gnu - ac_success=no - for ac_foobar in foobar FOOBAR; do - for ac_underscore in "" "_"; do - ac_func="$ac_foobar$ac_underscore" - cat confdefs.h - <<_ACEOF >conftest.$ac_ext -/* end confdefs.h. */ - -/* Override any GCC internal prototype to avoid an error. - Use char because int might match the return type of a GCC - builtin and then its argument prototype would still apply. */ -#ifdef __cplusplus -extern "C" -#endif -char $ac_func (); -#ifdef FC_DUMMY_MAIN -#ifndef FC_DUMMY_MAIN_EQ_F77 -# ifdef __cplusplus - extern "C" -# endif - int FC_DUMMY_MAIN() { return 1; } -#endif -#endif -int -main () -{ -return $ac_func (); - ; - return 0; -} -_ACEOF -if ac_fn_c_try_link "$LINENO"; then : - ac_success=yes; break 2 -fi -rm -f core conftest.err conftest.$ac_objext \ - conftest$ac_exeext conftest.$ac_ext - done - done - ac_ext=${ac_fc_srcext-f} -ac_compile='$FC -c $FCFLAGS $ac_fcflags_srcext conftest.$ac_ext >&5' -ac_link='$FC -o conftest$ac_exeext $FCFLAGS $LDFLAGS $ac_fcflags_srcext conftest.$ac_ext $LIBS >&5' -ac_compiler_gnu=$ac_cv_fc_compiler_gnu - - if test "$ac_success" = "yes"; then - case $ac_foobar in - foobar) - ac_case=lower - ac_foo_bar=foo_bar - ;; - FOOBAR) - ac_case=upper - ac_foo_bar=FOO_BAR - ;; - esac - - ac_ext=c -ac_cpp='$CPP $CPPFLAGS' -ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' -ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' -ac_compiler_gnu=$ac_cv_c_compiler_gnu - ac_success_extra=no - for ac_extra in "" "_"; do - ac_func="$ac_foo_bar$ac_underscore$ac_extra" - cat confdefs.h - <<_ACEOF >conftest.$ac_ext -/* end confdefs.h. */ - -/* Override any GCC internal prototype to avoid an error. - Use char because int might match the return type of a GCC - builtin and then its argument prototype would still apply. */ -#ifdef __cplusplus -extern "C" -#endif -char $ac_func (); -#ifdef FC_DUMMY_MAIN -#ifndef FC_DUMMY_MAIN_EQ_F77 -# ifdef __cplusplus - extern "C" -# endif - int FC_DUMMY_MAIN() { return 1; } -#endif -#endif -int -main () -{ -return $ac_func (); - ; - return 0; -} -_ACEOF -if ac_fn_c_try_link "$LINENO"; then : - ac_success_extra=yes; break -fi -rm -f core conftest.err conftest.$ac_objext \ - conftest$ac_exeext conftest.$ac_ext - done - ac_ext=${ac_fc_srcext-f} -ac_compile='$FC -c $FCFLAGS $ac_fcflags_srcext conftest.$ac_ext >&5' -ac_link='$FC -o conftest$ac_exeext $FCFLAGS $LDFLAGS $ac_fcflags_srcext conftest.$ac_ext $LIBS >&5' -ac_compiler_gnu=$ac_cv_fc_compiler_gnu - - if test "$ac_success_extra" = "yes"; then - ac_cv_fc_mangling="$ac_case case" - if test -z "$ac_underscore"; then - ac_cv_fc_mangling="$ac_cv_fc_mangling, no underscore" - else - ac_cv_fc_mangling="$ac_cv_fc_mangling, underscore" - fi - if test -z "$ac_extra"; then - ac_cv_fc_mangling="$ac_cv_fc_mangling, no extra underscore" - else - ac_cv_fc_mangling="$ac_cv_fc_mangling, extra underscore" - fi - else - ac_cv_fc_mangling="unknown" - fi - else - ac_cv_fc_mangling="unknown" - fi - - LIBS=$ac_save_LIBS - rm -rf conftest* - rm -f cfortran_test* -else - { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 -$as_echo "$as_me: error: in \`$ac_pwd':" >&2;} -as_fn_error $? "cannot compile a simple Fortran program -See \`config.log' for more details" "$LINENO" 5; } -fi -rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext - -fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_fc_mangling" >&5 -$as_echo "$ac_cv_fc_mangling" >&6; } - -ac_ext=c -ac_cpp='$CPP $CPPFLAGS' -ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' -ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' -ac_compiler_gnu=$ac_cv_c_compiler_gnu - -ac_ext=${ac_fc_srcext-f} -ac_compile='$FC -c $FCFLAGS $ac_fcflags_srcext conftest.$ac_ext >&5' -ac_link='$FC -o conftest$ac_exeext $FCFLAGS $LDFLAGS $ac_fcflags_srcext conftest.$ac_ext $LIBS >&5' -ac_compiler_gnu=$ac_cv_fc_compiler_gnu -case $ac_cv_fc_mangling in - "lower case, no underscore, no extra underscore") - $as_echo "#define FC_FUNC(name,NAME) name" >>confdefs.h - - $as_echo "#define FC_FUNC_(name,NAME) name" >>confdefs.h - ;; - "lower case, no underscore, extra underscore") - $as_echo "#define FC_FUNC(name,NAME) name" >>confdefs.h - - $as_echo "#define FC_FUNC_(name,NAME) name ## _" >>confdefs.h - ;; - "lower case, underscore, no extra underscore") - $as_echo "#define FC_FUNC(name,NAME) name ## _" >>confdefs.h - - $as_echo "#define FC_FUNC_(name,NAME) name ## _" >>confdefs.h - ;; - "lower case, underscore, extra underscore") - $as_echo "#define FC_FUNC(name,NAME) name ## _" >>confdefs.h - - $as_echo "#define FC_FUNC_(name,NAME) name ## __" >>confdefs.h - ;; - "upper case, no underscore, no extra underscore") - $as_echo "#define FC_FUNC(name,NAME) NAME" >>confdefs.h - - $as_echo "#define FC_FUNC_(name,NAME) NAME" >>confdefs.h - ;; - "upper case, no underscore, extra underscore") - $as_echo "#define FC_FUNC(name,NAME) NAME" >>confdefs.h - - $as_echo "#define FC_FUNC_(name,NAME) NAME ## _" >>confdefs.h - ;; - "upper case, underscore, no extra underscore") - $as_echo "#define FC_FUNC(name,NAME) NAME ## _" >>confdefs.h - - $as_echo "#define FC_FUNC_(name,NAME) NAME ## _" >>confdefs.h - ;; - "upper case, underscore, extra underscore") - $as_echo "#define FC_FUNC(name,NAME) NAME ## _" >>confdefs.h - - $as_echo "#define FC_FUNC_(name,NAME) NAME ## __" >>confdefs.h - ;; - *) - { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: unknown Fortran name-mangling scheme" >&5 -$as_echo "$as_me: WARNING: unknown Fortran name-mangling scheme" >&2;} - ;; -esac - -ac_ext=c -ac_cpp='$CPP $CPPFLAGS' -ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' -ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' -ac_compiler_gnu=$ac_cv_c_compiler_gnu - - -FC="$OLDFC" - -# CHECK THAT THE FORTRAN COMPILER CAN CORRECTLY PROCESS THESE DIRECTIVES -# IF NOT, USE THE EXTERNAL C PREPROCESSOR -OLDFC="$FC" - -defineflag="-Daardvark" -if test "$OLDFC" = "xlf90"; then - defineflag="-WF,-Daardvark" -fi -if test "$OLDFC" = "frt"; then - defineflag="-Wp,-Daardvark" -fi - -FC="$OLDFC" - -# DEFINE VARIABLES ACCORDING TO OS AND COMPILER - -echo "Hostname=$ac_hostname" -echo "Machine=$machinename" -echo "OS=$osname" - -# CHECK OS NAME -if echo $osname | grep -i aix >/dev/null 2>&1; then - SYSDEF="AIX" -fi -if echo $osname | grep -i darwin >/dev/null 2>&1; then - SYSDEF="DARWIN" -fi -if echo $osname | grep -i unix_system_v >/dev/null 2>&1; then - SYSDEF="UNIXSYSTEMV" -fi -if echo $osname | grep -i irix >/dev/null 2>&1; then - SYSDEF="IRIX" -fi -if echo $osname | grep -i irix64 >/dev/null 2>&1; then - SYSDEF="IRIX64" -fi -if echo $osname | grep -i linux >/dev/null 2>&1; then - SYSDEF="LINUX" -fi -if echo $osname | grep -i osf1 >/dev/null 2>&1; then - SYSDEF="OSF1" -fi -if echo $osname | grep -i super >/dev/null 2>&1; then - SYSDEF="SUPERUX" -fi -if echo $osname | grep -i sun >/dev/null 2>&1; then - SYSDEF="SUNOS" -fi -if echo $osname | grep -i t3e >/dev/null 2>&1; then - SYSDEF="T3E" -fi -if echo $osname | grep -i unicos >/dev/null 2>&1; then - SYSDEF="UNICOS" -fi -if test -z "$SYSDEF"; then - { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: OPERATING SYSTEM UNKNOWN" >&5 -$as_echo "$as_me: WARNING: OPERATING SYSTEM UNKNOWN" >&2;} - SYSDEF="UNKNOWNOS" -fi - -# Set the default FCFLAGS for non-gfortran compilers. -# NOTE: This may change with a new version of autoconf. -DEFFCFLAGS="-g" - -##################################################### -# CHECK COMPILER NAME and add specific flags -if echo $FC | grep xlf >/dev/null 2>&1; then - echo "Fortran Compiler is XLF" - CPRDEF="XLF" - if test -z "$REAL8"; then - REAL8="-qrealsize=8" - fi - if test -z "$OPT"; then - OPT="-O2 -qarch=auto" - fi - if test -z "$DEBUG"; then - DEBUG="-qdbg" - fi - if test "$FCFLAGS" = "$DEFFCFLAGS"; then - FCFLAGS="" - fi -elif echo $FC | grep pgf >/dev/null 2>&1; then - echo "Fortran Compiler is Portland Group" - CPRDEF="PGI" - if test -z "$REAL8"; then - REAL8="-r8" - fi - if test -z "$BIT64"; then - BIT64="-pc 64" - fi - if test "$FCFLAGS" = "$DEFFCFLAGS"; then - FCFLAGS="" - fi - if test -z "$ENDIAN"; then - ENDIAN="-byteswapio" - fi - if test -z "$OPT"; then - OPT="-O2" - fi - if test -z "$DEBUG"; then - DEBUG="-g" - fi -elif echo $FC | grep ftn >/dev/null 2>&1; then - if echo $ac_fc_version_output | grep -i Portland >/dev/null 2>&1; then - echo "Fortran Compiler is Portland Group, Cray" - CPRDEF="PGI" - SYSDEF="CNLINUX" - if test -z "$REAL8"; then - REAL8="-r8" - fi - if test -z "$BIT64"; then - BIT64="-pc 64" - fi - if test "$FCFLAGS" = "$DEFFCFLAGS"; then - FCFLAGS="" - fi - if test -z "$ENDIAN"; then - ENDIAN="-byteswapio" - fi - if test -z "$OPT"; then - OPT="-O2" - fi - if test -z "$DEBUG"; then - DEBUG="-g" - fi - fi -elif echo $FC | grep ifort >/dev/null 2>&1; then - echo "Fortran Compiler is Intel ifort" - CPRDEF="INTEL" - if test -z "$REAL8"; then - REAL8="-r8" - fi - if test "$FCFLAGS" = "$DEFFCFLAGS"; then - FCFLAGS="-w -ftz" - fi - if test -z "$PROGFCFLAGS"; then - PROGFCFLAGS="-assume byterecl" - fi - if test -z "$ENDIAN"; then - ENDIAN="-convert big_endian" - fi - if test -z "$OPT"; then - OPT="-O2" - fi - if test -z "$DEBUG"; then - DEBUG="-g" - fi -elif echo $FC | grep g95 >/dev/null 2>&1; then - echo "Fortran Compiler is GNU" - CPRDEF="GNU" -elif echo $FC | grep gfortran >/dev/null 2>&1; then - echo "Fortran Compiler is GNU" - CPRDEF="GNU" -# For gfortran, default flags are different - if test "$FCFLAGS" = "-g -O2"; then - FCFLAGS="" - fi - if test -z "$DEBUG"; then - DEBUG="-g" - fi - if test -z "$OPT"; then - OPT="-O2" - fi -elif echo $ac_fc_version_output | grep -i nag >/dev/null 2>&1; then - echo "Fortran Compiler is NAG" - CPRDEF="NAG" - if test -z "$REAL8"; then - REAL8="-r8" - fi - if test "$FCFLAGS" = "$DEFFCFLAGS"; then - FCFLAGS="-wmismatch=mpi_send,mpi_recv,mpi_bcast,mpi_allreduce,mpi_reduce,mpi_gatherv,mpi_gather,mpi_rsend,mpi_irecv,mpi_isend,mpi_scatterv,mpi_alltoallv -dusty" - fi - if test -z "$ENDIAN"; then - ENDIAN="-convert=BIG_IEEE" - fi - if test -z "$OPT"; then - OPT="-O2" - fi - if test -z "$DEBUG"; then - DEBUG="-g" - fi -########################################################### -# the compiler flags below have not been verified recently -########################################################### -elif echo $FC | grep frt >/dev/null 2>&1; then - echo "Fortran Compiler is UXP/V" - echo "Suggested additional vectorization flags: -Wv,-s5,-t3,-noalias,-ilfunc,-md" - CPRDEF="FUJITSU" - if test -z "$F90FLAGS"; then - F90FLAGS="-Am -X9" - fi - if test -z "$BIT64"; then - BIT64="-KA64" - fi - if test -z "$REAL8"; then - REAL8="-Ad" - fi -elif echo $ac_fc_version_output | grep Lahey >/dev/null 2>&1; then - echo "Fortran Compiler is Lahey" - CPRDEF="LAHEY" -elif echo $FC | grep ifc >/dev/null 2>&1; then - echo "Fortran Compiler is Intel 7.x or earlier" - echo "Intel ifc compiler must set the environment variable F_UFMTENDIAN=big to do endian conversion" - CPRDEF="INTEL" - if test -z "$REAL8"; then - REAL8="-r8" - fi - if test -z "$F90FLAGS"; then - F90FLAGS="-w" - fi - if test -z "$OPT"; then - OPT="-O2" - fi -elif echo $FC | grep efc >/dev/null 2>&1; then - echo "Fortran Compiler is Intel 7.x or earlier for IA-64" - echo "Intel efc compiler must set the environment variable F_UFMTENDIAN=big to do endian conversion" - CPRDEF="INTEL" - if test -z "$REAL8"; then - REAL8="-r8" - fi - if test -z "$F90FLAGS"; then - F90FLAGS="-w -ftz" - fi - if test -z "$OPT"; then - OPT="-O2" - fi -elif echo $FC | grep pathf90 >/dev/null 2>&1; then - echo "Fortran Compiler is PathScale" - CPRDEF="PATHSC" - if test -z "$REAL8"; then - REAL8="-r8" - fi - if test -z "$BIT64"; then - BIT64="-m64" - fi - if test -z "$OPT"; then - OPT="-O2" - fi -elif echo $ac_fc_version_output | grep -i absoft >/dev/null 2>&1; then - echo "Fortran Compiler is Absoft" - CPRDEF="ABSOFT" - if test -z "$REAL8"; then - REAL8="-N113" - fi - if test -z "$INCLUDEFLAG"; then - INCLUDEFLAG="-p" - fi - if test -z "$OPT"; then - OPT="-O2" - fi -elif echo $ac_fc_version_output | grep -i workshop >/dev/null 2>&1; then - echo "Fortran Compiler is Workshop" - CPRDEF="WORKSHOP" - if test -z "$INCLUDEFLAG"; then - INCLUDEFLAG="-M" - fi -elif echo $ac_fc_version_output | grep -i mipspro >/dev/null 2>&1; then - echo "Fortran Compiler is MIPSPro" - CPRDEF="MIPSPRO" - EXTRACFLAGS="-64" - if test -z "$OPT"; then - OPT="-O3" - fi - if test -z "$REAL8"; then - REAL8="-r8" - fi - if test -z "$BIT64"; then - BIT64="-64" - fi -elif echo $ac_fc_version_output | grep -i compaq >/dev/null 2>&1; then - echo "Fortran Compiler is Compaq" - CPRDEF="COMPAQ" - MPILIBS="$MPILIBS -lelan" - if test -z "$OPT"; then - OPT="-fast" - fi - if test -z "$REAL8"; then - REAL8="-real_size 64" - fi - if test -z "$ENDIAN"; then - ENDIAN="-convert big_endian" - fi - -# Compaq Fortran changed its name to HP Fortran. -# Lets support both versions for now. -elif echo $ac_fc_version_output | grep HP >/dev/null 2>&1; then - echo "Fortran Compiler is HP" - CPRDEF="COMPAQ" - MPILIBS="$MPILIBS -lelan" - if test -z "$OPT"; then - OPT="-fast" - fi - if test -z "$REAL8"; then - REAL8="-real_size 64" - fi - if test -z "$ENDIAN"; then - ENDIAN="-convert big_endian" - fi - -elif echo $ac_fc_version_output | grep -i sx >/dev/null 2>&1; then - echo "Fortran Compiler is SX" - CPRDEF="SX" - if test -z "$F90FLAGS"; then - F90FLAGS="-EP -Wf'-pvctl noassoc'" - fi - if test -z "$OPT"; then - OPT="-Chopt" - fi -fi - -########################################################### -# END of compiler-specific flag setting -########################################################### - -CPPDEFS="$CPPDEFS -DSYS$SYSDEF -DCPR$CPRDEF" -if test -n "$SRKDEF"; then - CPPDEFS="$CPPDEFS -D$SRKDEF" -fi - -# IF DEBUGGING ENABLED, DISABLE OPTIMIZATION FLAG -if test "$DEBUGGING" = "ENABLED"; then - OPT="" -else - DEBUG="" -fi - -# SET HARDCODED VARIABLES AS A LAST RESORT - -# ALWAYS ENABLE CRULE IN MAKEFILE -CRULE=.c.o - - - - -# INCLUDE FLAG IF NOT ALREADY SET IS MOST LIKELY -I -if test -z "$INCLUDEFLAG"; then - INCLUDEFLAG="-I" -fi - -# ARCHIVE COMMAND SIMILAR ACROSS ALL PLATFORMS -if test -z "$AR"; then - AR="ar cq" -fi - -# RANLIB -if test -z "$RANLIB"; then - # Necessary on Darwin to deal with common symbols (particularly when - # using ifort). - if test "$SYSDEF"x = DARWINx; then - RANLIB="ranlib -c" - else - if test -n "$ac_tool_prefix"; then - # Extract the first word of "${ac_tool_prefix}ranlib", so it can be a program name with args. -set dummy ${ac_tool_prefix}ranlib; ac_word=$2 -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 -$as_echo_n "checking for $ac_word... " >&6; } -if ${ac_cv_prog_RANLIB+:} false; then : - $as_echo_n "(cached) " >&6 -else - if test -n "$RANLIB"; then - ac_cv_prog_RANLIB="$RANLIB" # Let the user override the test. -else -as_save_IFS=$IFS; IFS=$PATH_SEPARATOR -for as_dir in $PATH -do - IFS=$as_save_IFS - test -z "$as_dir" && as_dir=. - for ac_exec_ext in '' $ac_executable_extensions; do - if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then - ac_cv_prog_RANLIB="${ac_tool_prefix}ranlib" - $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 - break 2 - fi -done - done -IFS=$as_save_IFS - -fi -fi -RANLIB=$ac_cv_prog_RANLIB -if test -n "$RANLIB"; then - { $as_echo "$as_me:${as_lineno-$LINENO}: result: $RANLIB" >&5 -$as_echo "$RANLIB" >&6; } -else - { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 -$as_echo "no" >&6; } -fi - - -fi -if test -z "$ac_cv_prog_RANLIB"; then - ac_ct_RANLIB=$RANLIB - # Extract the first word of "ranlib", so it can be a program name with args. -set dummy ranlib; ac_word=$2 -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 -$as_echo_n "checking for $ac_word... " >&6; } -if ${ac_cv_prog_ac_ct_RANLIB+:} false; then : - $as_echo_n "(cached) " >&6 -else - if test -n "$ac_ct_RANLIB"; then - ac_cv_prog_ac_ct_RANLIB="$ac_ct_RANLIB" # Let the user override the test. -else -as_save_IFS=$IFS; IFS=$PATH_SEPARATOR -for as_dir in $PATH -do - IFS=$as_save_IFS - test -z "$as_dir" && as_dir=. - for ac_exec_ext in '' $ac_executable_extensions; do - if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then - ac_cv_prog_ac_ct_RANLIB="ranlib" - $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 - break 2 - fi -done - done -IFS=$as_save_IFS - -fi -fi -ac_ct_RANLIB=$ac_cv_prog_ac_ct_RANLIB -if test -n "$ac_ct_RANLIB"; then - { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_ct_RANLIB" >&5 -$as_echo "$ac_ct_RANLIB" >&6; } -else - { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 -$as_echo "no" >&6; } -fi - - if test "x$ac_ct_RANLIB" = x; then - RANLIB=":" - else - case $cross_compiling:$ac_tool_warned in -yes:) -{ $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5 -$as_echo "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;} -ac_tool_warned=yes ;; -esac - RANLIB=$ac_ct_RANLIB - fi -else - RANLIB="$ac_cv_prog_RANLIB" -fi - - fi -fi - -echo -echo Output Variables: {CC=$CC} {CFLAGS=$CFLAGS} \ -{FC=$FC} {FCFLAGS=$FCFLAGS} {PROGFCFLAGS=$PROGFCFLAGS}\ -{CPPDEFS=$CPPDEFS} {OPT=$OPT} {DEBUG=$DEBUG} {REAL8=$REAL8} \ -{BIT64=$BIT64} {ENDIAN=$ENDIAN} {MPIFC=$MPIFC} \ -{MPILIBS=$MPILIBS} {MPIHEADER=$MPIHEADER} \ -{INCLUDEFLAG=$INCLUDEFLAG} {INCLUDEPATH=$INCLUDEPATH} \ -{AR=$AR} {RANLIB=$RANLIB} {BABELROOT=$BABELROOT} {COMPILER_ROOT=$COMPILER_ROOT} \ -{PYTHON=$PYTHON} {PYTHONOPTS=$PYTHONOPTS} {FORT_SIZE=$FORT_SIZE} {prefix=$prefix} \ -{SRCDIR=$SRCDIR} {FC_DEFINE=$FC_DEFINE} -echo - -cat >confcache <<\_ACEOF -# This file is a shell script that caches the results of configure -# tests run on this system so they can be shared between configure -# scripts and configure runs, see configure's option --config-cache. -# It is not useful on other systems. If it contains results you don't -# want to keep, you may remove or edit it. -# -# config.status only pays attention to the cache file if you give it -# the --recheck option to rerun configure. -# -# `ac_cv_env_foo' variables (set or unset) will be overridden when -# loading this file, other *unset* `ac_cv_foo' will be assigned the -# following values. - -_ACEOF - -# The following way of writing the cache mishandles newlines in values, -# but we know of no workaround that is simple, portable, and efficient. -# So, we kill variables containing newlines. -# Ultrix sh set writes to stderr and can't be redirected directly, -# and sets the high bit in the cache file unless we assign to the vars. -( - for ac_var in `(set) 2>&1 | sed -n 's/^\([a-zA-Z_][a-zA-Z0-9_]*\)=.*/\1/p'`; do - eval ac_val=\$$ac_var - case $ac_val in #( - *${as_nl}*) - case $ac_var in #( - *_cv_*) { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: cache variable $ac_var contains a newline" >&5 -$as_echo "$as_me: WARNING: cache variable $ac_var contains a newline" >&2;} ;; - esac - case $ac_var in #( - _ | IFS | as_nl) ;; #( - BASH_ARGV | BASH_SOURCE) eval $ac_var= ;; #( - *) { eval $ac_var=; unset $ac_var;} ;; - esac ;; - esac - done - - (set) 2>&1 | - case $as_nl`(ac_space=' '; set) 2>&1` in #( - *${as_nl}ac_space=\ *) - # `set' does not quote correctly, so add quotes: double-quote - # substitution turns \\\\ into \\, and sed turns \\ into \. - sed -n \ - "s/'/'\\\\''/g; - s/^\\([_$as_cr_alnum]*_cv_[_$as_cr_alnum]*\\)=\\(.*\\)/\\1='\\2'/p" - ;; #( - *) - # `set' quotes correctly as required by POSIX, so do not add quotes. - sed -n "/^[_$as_cr_alnum]*_cv_[_$as_cr_alnum]*=/p" - ;; - esac | - sort -) | - sed ' - /^ac_cv_env_/b end - t clear - :clear - s/^\([^=]*\)=\(.*[{}].*\)$/test "${\1+set}" = set || &/ - t end - s/^\([^=]*\)=\(.*\)$/\1=${\1=\2}/ - :end' >>confcache -if diff "$cache_file" confcache >/dev/null 2>&1; then :; else - if test -w "$cache_file"; then - if test "x$cache_file" != "x/dev/null"; then - { $as_echo "$as_me:${as_lineno-$LINENO}: updating cache $cache_file" >&5 -$as_echo "$as_me: updating cache $cache_file" >&6;} - if test ! -f "$cache_file" || test -h "$cache_file"; then - cat confcache >"$cache_file" - else - case $cache_file in #( - */* | ?:*) - mv -f confcache "$cache_file"$$ && - mv -f "$cache_file"$$ "$cache_file" ;; #( - *) - mv -f confcache "$cache_file" ;; - esac - fi - fi - else - { $as_echo "$as_me:${as_lineno-$LINENO}: not updating unwritable cache $cache_file" >&5 -$as_echo "$as_me: not updating unwritable cache $cache_file" >&6;} - fi -fi -rm -f confcache - -test "x$prefix" = xNONE && prefix=$ac_default_prefix -# Let make expand exec_prefix. -test "x$exec_prefix" = xNONE && exec_prefix='${prefix}' - -DEFS=-DHAVE_CONFIG_H - -ac_libobjs= -ac_ltlibobjs= -U= -for ac_i in : $LIBOBJS; do test "x$ac_i" = x: && continue - # 1. Remove the extension, and $U if already installed. - ac_script='s/\$U\././;s/\.o$//;s/\.obj$//' - ac_i=`$as_echo "$ac_i" | sed "$ac_script"` - # 2. Prepend LIBOBJDIR. When used with automake>=1.10 LIBOBJDIR - # will be set to the directory where LIBOBJS objects are built. - as_fn_append ac_libobjs " \${LIBOBJDIR}$ac_i\$U.$ac_objext" - as_fn_append ac_ltlibobjs " \${LIBOBJDIR}$ac_i"'$U.lo' -done -LIBOBJS=$ac_libobjs - -LTLIBOBJS=$ac_ltlibobjs - - - - -: "${CONFIG_STATUS=./config.status}" -ac_write_fail=0 -ac_clean_files_save=$ac_clean_files -ac_clean_files="$ac_clean_files $CONFIG_STATUS" -{ $as_echo "$as_me:${as_lineno-$LINENO}: creating $CONFIG_STATUS" >&5 -$as_echo "$as_me: creating $CONFIG_STATUS" >&6;} -as_write_fail=0 -cat >$CONFIG_STATUS <<_ASEOF || as_write_fail=1 -#! $SHELL -# Generated by $as_me. -# Run this file to recreate the current configuration. -# Compiler output produced by configure, useful for debugging -# configure, is in config.log if it exists. - -debug=false -ac_cs_recheck=false -ac_cs_silent=false - -SHELL=\${CONFIG_SHELL-$SHELL} -export SHELL -_ASEOF -cat >>$CONFIG_STATUS <<\_ASEOF || as_write_fail=1 -## -------------------- ## -## M4sh Initialization. ## -## -------------------- ## - -# Be more Bourne compatible -DUALCASE=1; export DUALCASE # for MKS sh -if test -n "${ZSH_VERSION+set}" && (emulate sh) >/dev/null 2>&1; then : - emulate sh - NULLCMD=: - # Pre-4.2 versions of Zsh do word splitting on ${1+"$@"}, which - # is contrary to our usage. Disable this feature. - alias -g '${1+"$@"}'='"$@"' - setopt NO_GLOB_SUBST -else - case `(set -o) 2>/dev/null` in #( - *posix*) : - set -o posix ;; #( - *) : - ;; -esac -fi - - -as_nl=' -' -export as_nl -# Printing a long string crashes Solaris 7 /usr/bin/printf. -as_echo='\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\' -as_echo=$as_echo$as_echo$as_echo$as_echo$as_echo -as_echo=$as_echo$as_echo$as_echo$as_echo$as_echo$as_echo -# Prefer a ksh shell builtin over an external printf program on Solaris, -# but without wasting forks for bash or zsh. -if test -z "$BASH_VERSION$ZSH_VERSION" \ - && (test "X`print -r -- $as_echo`" = "X$as_echo") 2>/dev/null; then - as_echo='print -r --' - as_echo_n='print -rn --' -elif (test "X`printf %s $as_echo`" = "X$as_echo") 2>/dev/null; then - as_echo='printf %s\n' - as_echo_n='printf %s' -else - if test "X`(/usr/ucb/echo -n -n $as_echo) 2>/dev/null`" = "X-n $as_echo"; then - as_echo_body='eval /usr/ucb/echo -n "$1$as_nl"' - as_echo_n='/usr/ucb/echo -n' - else - as_echo_body='eval expr "X$1" : "X\\(.*\\)"' - as_echo_n_body='eval - arg=$1; - case $arg in #( - *"$as_nl"*) - expr "X$arg" : "X\\(.*\\)$as_nl"; - arg=`expr "X$arg" : ".*$as_nl\\(.*\\)"`;; - esac; - expr "X$arg" : "X\\(.*\\)" | tr -d "$as_nl" - ' - export as_echo_n_body - as_echo_n='sh -c $as_echo_n_body as_echo' - fi - export as_echo_body - as_echo='sh -c $as_echo_body as_echo' -fi - -# The user is always right. -if test "${PATH_SEPARATOR+set}" != set; then - PATH_SEPARATOR=: - (PATH='/bin;/bin'; FPATH=$PATH; sh -c :) >/dev/null 2>&1 && { - (PATH='/bin:/bin'; FPATH=$PATH; sh -c :) >/dev/null 2>&1 || - PATH_SEPARATOR=';' - } -fi - - -# IFS -# We need space, tab and new line, in precisely that order. Quoting is -# there to prevent editors from complaining about space-tab. -# (If _AS_PATH_WALK were called with IFS unset, it would disable word -# splitting by setting IFS to empty value.) -IFS=" "" $as_nl" - -# Find who we are. Look in the path if we contain no directory separator. -as_myself= -case $0 in #(( - *[\\/]* ) as_myself=$0 ;; - *) as_save_IFS=$IFS; IFS=$PATH_SEPARATOR -for as_dir in $PATH -do - IFS=$as_save_IFS - test -z "$as_dir" && as_dir=. - test -r "$as_dir/$0" && as_myself=$as_dir/$0 && break - done -IFS=$as_save_IFS - - ;; -esac -# We did not find ourselves, most probably we were run as `sh COMMAND' -# in which case we are not to be found in the path. -if test "x$as_myself" = x; then - as_myself=$0 -fi -if test ! -f "$as_myself"; then - $as_echo "$as_myself: error: cannot find myself; rerun with an absolute file name" >&2 - exit 1 -fi - -# Unset variables that we do not need and which cause bugs (e.g. in -# pre-3.0 UWIN ksh). But do not cause bugs in bash 2.01; the "|| exit 1" -# suppresses any "Segmentation fault" message there. '((' could -# trigger a bug in pdksh 5.2.14. -for as_var in BASH_ENV ENV MAIL MAILPATH -do eval test x\${$as_var+set} = xset \ - && ( (unset $as_var) || exit 1) >/dev/null 2>&1 && unset $as_var || : -done -PS1='$ ' -PS2='> ' -PS4='+ ' - -# NLS nuisances. -LC_ALL=C -export LC_ALL -LANGUAGE=C -export LANGUAGE - -# CDPATH. -(unset CDPATH) >/dev/null 2>&1 && unset CDPATH - - -# as_fn_error STATUS ERROR [LINENO LOG_FD] -# ---------------------------------------- -# Output "`basename $0`: error: ERROR" to stderr. If LINENO and LOG_FD are -# provided, also output the error to LOG_FD, referencing LINENO. Then exit the -# script with STATUS, using 1 if that was 0. -as_fn_error () -{ - as_status=$1; test $as_status -eq 0 && as_status=1 - if test "$4"; then - as_lineno=${as_lineno-"$3"} as_lineno_stack=as_lineno_stack=$as_lineno_stack - $as_echo "$as_me:${as_lineno-$LINENO}: error: $2" >&$4 - fi - $as_echo "$as_me: error: $2" >&2 - as_fn_exit $as_status -} # as_fn_error - - -# as_fn_set_status STATUS -# ----------------------- -# Set $? to STATUS, without forking. -as_fn_set_status () -{ - return $1 -} # as_fn_set_status - -# as_fn_exit STATUS -# ----------------- -# Exit the shell with STATUS, even in a "trap 0" or "set -e" context. -as_fn_exit () -{ - set +e - as_fn_set_status $1 - exit $1 -} # as_fn_exit - -# as_fn_unset VAR -# --------------- -# Portably unset VAR. -as_fn_unset () -{ - { eval $1=; unset $1;} -} -as_unset=as_fn_unset -# as_fn_append VAR VALUE -# ---------------------- -# Append the text in VALUE to the end of the definition contained in VAR. Take -# advantage of any shell optimizations that allow amortized linear growth over -# repeated appends, instead of the typical quadratic growth present in naive -# implementations. -if (eval "as_var=1; as_var+=2; test x\$as_var = x12") 2>/dev/null; then : - eval 'as_fn_append () - { - eval $1+=\$2 - }' -else - as_fn_append () - { - eval $1=\$$1\$2 - } -fi # as_fn_append - -# as_fn_arith ARG... -# ------------------ -# Perform arithmetic evaluation on the ARGs, and store the result in the -# global $as_val. Take advantage of shells that can avoid forks. The arguments -# must be portable across $(()) and expr. -if (eval "test \$(( 1 + 1 )) = 2") 2>/dev/null; then : - eval 'as_fn_arith () - { - as_val=$(( $* )) - }' -else - as_fn_arith () - { - as_val=`expr "$@" || test $? -eq 1` - } -fi # as_fn_arith - - -if expr a : '\(a\)' >/dev/null 2>&1 && - test "X`expr 00001 : '.*\(...\)'`" = X001; then - as_expr=expr -else - as_expr=false -fi - -if (basename -- /) >/dev/null 2>&1 && test "X`basename -- / 2>&1`" = "X/"; then - as_basename=basename -else - as_basename=false -fi - -if (as_dir=`dirname -- /` && test "X$as_dir" = X/) >/dev/null 2>&1; then - as_dirname=dirname -else - as_dirname=false -fi - -as_me=`$as_basename -- "$0" || -$as_expr X/"$0" : '.*/\([^/][^/]*\)/*$' \| \ - X"$0" : 'X\(//\)$' \| \ - X"$0" : 'X\(/\)' \| . 2>/dev/null || -$as_echo X/"$0" | - sed '/^.*\/\([^/][^/]*\)\/*$/{ - s//\1/ - q - } - /^X\/\(\/\/\)$/{ - s//\1/ - q - } - /^X\/\(\/\).*/{ - s//\1/ - q - } - s/.*/./; q'` - -# Avoid depending upon Character Ranges. -as_cr_letters='abcdefghijklmnopqrstuvwxyz' -as_cr_LETTERS='ABCDEFGHIJKLMNOPQRSTUVWXYZ' -as_cr_Letters=$as_cr_letters$as_cr_LETTERS -as_cr_digits='0123456789' -as_cr_alnum=$as_cr_Letters$as_cr_digits - -ECHO_C= ECHO_N= ECHO_T= -case `echo -n x` in #((((( --n*) - case `echo 'xy\c'` in - *c*) ECHO_T=' ';; # ECHO_T is single tab character. - xy) ECHO_C='\c';; - *) echo `echo ksh88 bug on AIX 6.1` > /dev/null - ECHO_T=' ';; - esac;; -*) - ECHO_N='-n';; -esac - -rm -f conf$$ conf$$.exe conf$$.file -if test -d conf$$.dir; then - rm -f conf$$.dir/conf$$.file -else - rm -f conf$$.dir - mkdir conf$$.dir 2>/dev/null -fi -if (echo >conf$$.file) 2>/dev/null; then - if ln -s conf$$.file conf$$ 2>/dev/null; then - as_ln_s='ln -s' - # ... but there are two gotchas: - # 1) On MSYS, both `ln -s file dir' and `ln file dir' fail. - # 2) DJGPP < 2.04 has no symlinks; `ln -s' creates a wrapper executable. - # In both cases, we have to default to `cp -pR'. - ln -s conf$$.file conf$$.dir 2>/dev/null && test ! -f conf$$.exe || - as_ln_s='cp -pR' - elif ln conf$$.file conf$$ 2>/dev/null; then - as_ln_s=ln - else - as_ln_s='cp -pR' - fi -else - as_ln_s='cp -pR' -fi -rm -f conf$$ conf$$.exe conf$$.dir/conf$$.file conf$$.file -rmdir conf$$.dir 2>/dev/null - - -# as_fn_mkdir_p -# ------------- -# Create "$as_dir" as a directory, including parents if necessary. -as_fn_mkdir_p () -{ - - case $as_dir in #( - -*) as_dir=./$as_dir;; - esac - test -d "$as_dir" || eval $as_mkdir_p || { - as_dirs= - while :; do - case $as_dir in #( - *\'*) as_qdir=`$as_echo "$as_dir" | sed "s/'/'\\\\\\\\''/g"`;; #'( - *) as_qdir=$as_dir;; - esac - as_dirs="'$as_qdir' $as_dirs" - as_dir=`$as_dirname -- "$as_dir" || -$as_expr X"$as_dir" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ - X"$as_dir" : 'X\(//\)[^/]' \| \ - X"$as_dir" : 'X\(//\)$' \| \ - X"$as_dir" : 'X\(/\)' \| . 2>/dev/null || -$as_echo X"$as_dir" | - sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ - s//\1/ - q - } - /^X\(\/\/\)[^/].*/{ - s//\1/ - q - } - /^X\(\/\/\)$/{ - s//\1/ - q - } - /^X\(\/\).*/{ - s//\1/ - q - } - s/.*/./; q'` - test -d "$as_dir" && break - done - test -z "$as_dirs" || eval "mkdir $as_dirs" - } || test -d "$as_dir" || as_fn_error $? "cannot create directory $as_dir" - - -} # as_fn_mkdir_p -if mkdir -p . 2>/dev/null; then - as_mkdir_p='mkdir -p "$as_dir"' -else - test -d ./-p && rmdir ./-p - as_mkdir_p=false -fi - - -# as_fn_executable_p FILE -# ----------------------- -# Test if FILE is an executable regular file. -as_fn_executable_p () -{ - test -f "$1" && test -x "$1" -} # as_fn_executable_p -as_test_x='test -x' -as_executable_p=as_fn_executable_p - -# Sed expression to map a string onto a valid CPP name. -as_tr_cpp="eval sed 'y%*$as_cr_letters%P$as_cr_LETTERS%;s%[^_$as_cr_alnum]%_%g'" - -# Sed expression to map a string onto a valid variable name. -as_tr_sh="eval sed 'y%*+%pp%;s%[^_$as_cr_alnum]%_%g'" - - -exec 6>&1 -## ----------------------------------- ## -## Main body of $CONFIG_STATUS script. ## -## ----------------------------------- ## -_ASEOF -test $as_write_fail = 0 && chmod +x $CONFIG_STATUS || ac_write_fail=1 - -cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 -# Save the log message, to keep $0 and so on meaningful, and to -# report actual input values of CONFIG_FILES etc. instead of their -# values after options handling. -ac_log=" -This file was extended by MCT $as_me 2.8, which was -generated by GNU Autoconf 2.69. Invocation command line was - - CONFIG_FILES = $CONFIG_FILES - CONFIG_HEADERS = $CONFIG_HEADERS - CONFIG_LINKS = $CONFIG_LINKS - CONFIG_COMMANDS = $CONFIG_COMMANDS - $ $0 $@ - -on `(hostname || uname -n) 2>/dev/null | sed 1q` -" - -_ACEOF - -case $ac_config_files in *" -"*) set x $ac_config_files; shift; ac_config_files=$*;; -esac - -case $ac_config_headers in *" -"*) set x $ac_config_headers; shift; ac_config_headers=$*;; -esac - - -cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 -# Files that config.status was made for. -config_files="$ac_config_files" -config_headers="$ac_config_headers" - -_ACEOF - -cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 -ac_cs_usage="\ -\`$as_me' instantiates files and other configuration actions -from templates according to the current configuration. Unless the files -and actions are specified as TAGs, all are instantiated by default. - -Usage: $0 [OPTION]... [TAG]... - - -h, --help print this help, then exit - -V, --version print version number and configuration settings, then exit - --config print configuration, then exit - -q, --quiet, --silent - do not print progress messages - -d, --debug don't remove temporary files - --recheck update $as_me by reconfiguring in the same conditions - --file=FILE[:TEMPLATE] - instantiate the configuration file FILE - --header=FILE[:TEMPLATE] - instantiate the configuration header FILE - -Configuration files: -$config_files - -Configuration headers: -$config_headers - -Report bugs to the package provider." - -_ACEOF -cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 -ac_cs_config="`$as_echo "$ac_configure_args" | sed 's/^ //; s/[\\""\`\$]/\\\\&/g'`" -ac_cs_version="\\ -MCT config.status 2.8 -configured by $0, generated by GNU Autoconf 2.69, - with options \\"\$ac_cs_config\\" - -Copyright (C) 2012 Free Software Foundation, Inc. -This config.status script is free software; the Free Software Foundation -gives unlimited permission to copy, distribute and modify it." - -ac_pwd='$ac_pwd' -srcdir='$srcdir' -test -n "\$AWK" || AWK=awk -_ACEOF - -cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 -# The default lists apply if the user does not specify any file. -ac_need_defaults=: -while test $# != 0 -do - case $1 in - --*=?*) - ac_option=`expr "X$1" : 'X\([^=]*\)='` - ac_optarg=`expr "X$1" : 'X[^=]*=\(.*\)'` - ac_shift=: - ;; - --*=) - ac_option=`expr "X$1" : 'X\([^=]*\)='` - ac_optarg= - ac_shift=: - ;; - *) - ac_option=$1 - ac_optarg=$2 - ac_shift=shift - ;; - esac - - case $ac_option in - # Handling of the options. - -recheck | --recheck | --rechec | --reche | --rech | --rec | --re | --r) - ac_cs_recheck=: ;; - --version | --versio | --versi | --vers | --ver | --ve | --v | -V ) - $as_echo "$ac_cs_version"; exit ;; - --config | --confi | --conf | --con | --co | --c ) - $as_echo "$ac_cs_config"; exit ;; - --debug | --debu | --deb | --de | --d | -d ) - debug=: ;; - --file | --fil | --fi | --f ) - $ac_shift - case $ac_optarg in - *\'*) ac_optarg=`$as_echo "$ac_optarg" | sed "s/'/'\\\\\\\\''/g"` ;; - '') as_fn_error $? "missing file argument" ;; - esac - as_fn_append CONFIG_FILES " '$ac_optarg'" - ac_need_defaults=false;; - --header | --heade | --head | --hea ) - $ac_shift - case $ac_optarg in - *\'*) ac_optarg=`$as_echo "$ac_optarg" | sed "s/'/'\\\\\\\\''/g"` ;; - esac - as_fn_append CONFIG_HEADERS " '$ac_optarg'" - ac_need_defaults=false;; - --he | --h) - # Conflict between --help and --header - as_fn_error $? "ambiguous option: \`$1' -Try \`$0 --help' for more information.";; - --help | --hel | -h ) - $as_echo "$ac_cs_usage"; exit ;; - -q | -quiet | --quiet | --quie | --qui | --qu | --q \ - | -silent | --silent | --silen | --sile | --sil | --si | --s) - ac_cs_silent=: ;; - - # This is an error. - -*) as_fn_error $? "unrecognized option: \`$1' -Try \`$0 --help' for more information." ;; - - *) as_fn_append ac_config_targets " $1" - ac_need_defaults=false ;; - - esac - shift -done - -ac_configure_extra_args= - -if $ac_cs_silent; then - exec 6>/dev/null - ac_configure_extra_args="$ac_configure_extra_args --silent" -fi - -_ACEOF -cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 -if \$ac_cs_recheck; then - set X $SHELL '$0' $ac_configure_args \$ac_configure_extra_args --no-create --no-recursion - shift - \$as_echo "running CONFIG_SHELL=$SHELL \$*" >&6 - CONFIG_SHELL='$SHELL' - export CONFIG_SHELL - exec "\$@" -fi - -_ACEOF -cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 -exec 5>>config.log -{ - echo - sed 'h;s/./-/g;s/^.../## /;s/...$/ ##/;p;x;p;x' <<_ASBOX -## Running $as_me. ## -_ASBOX - $as_echo "$ac_log" -} >&5 - -_ACEOF -cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 -_ACEOF - -cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 - -# Handling of arguments. -for ac_config_target in $ac_config_targets -do - case $ac_config_target in - "Makefile.conf") CONFIG_FILES="$CONFIG_FILES Makefile.conf" ;; - "config.h") CONFIG_HEADERS="$CONFIG_HEADERS config.h" ;; - - *) as_fn_error $? "invalid argument: \`$ac_config_target'" "$LINENO" 5;; - esac -done - - -# If the user did not use the arguments to specify the items to instantiate, -# then the envvar interface is used. Set only those that are not. -# We use the long form for the default assignment because of an extremely -# bizarre bug on SunOS 4.1.3. -if $ac_need_defaults; then - test "${CONFIG_FILES+set}" = set || CONFIG_FILES=$config_files - test "${CONFIG_HEADERS+set}" = set || CONFIG_HEADERS=$config_headers -fi - -# Have a temporary directory for convenience. Make it in the build tree -# simply because there is no reason against having it here, and in addition, -# creating and moving files from /tmp can sometimes cause problems. -# Hook for its removal unless debugging. -# Note that there is a small window in which the directory will not be cleaned: -# after its creation but before its name has been assigned to `$tmp'. -$debug || -{ - tmp= ac_tmp= - trap 'exit_status=$? - : "${ac_tmp:=$tmp}" - { test ! -d "$ac_tmp" || rm -fr "$ac_tmp"; } && exit $exit_status -' 0 - trap 'as_fn_exit 1' 1 2 13 15 -} -# Create a (secure) tmp directory for tmp files. - -{ - tmp=`(umask 077 && mktemp -d "./confXXXXXX") 2>/dev/null` && - test -d "$tmp" -} || -{ - tmp=./conf$$-$RANDOM - (umask 077 && mkdir "$tmp") -} || as_fn_error $? "cannot create a temporary directory in ." "$LINENO" 5 -ac_tmp=$tmp - -# Set up the scripts for CONFIG_FILES section. -# No need to generate them if there are no CONFIG_FILES. -# This happens for instance with `./config.status config.h'. -if test -n "$CONFIG_FILES"; then - - -ac_cr=`echo X | tr X '\015'` -# On cygwin, bash can eat \r inside `` if the user requested igncr. -# But we know of no other shell where ac_cr would be empty at this -# point, so we can use a bashism as a fallback. -if test "x$ac_cr" = x; then - eval ac_cr=\$\'\\r\' -fi -ac_cs_awk_cr=`$AWK 'BEGIN { print "a\rb" }' /dev/null` -if test "$ac_cs_awk_cr" = "a${ac_cr}b"; then - ac_cs_awk_cr='\\r' -else - ac_cs_awk_cr=$ac_cr -fi - -echo 'BEGIN {' >"$ac_tmp/subs1.awk" && -_ACEOF - - -{ - echo "cat >conf$$subs.awk <<_ACEOF" && - echo "$ac_subst_vars" | sed 's/.*/&!$&$ac_delim/' && - echo "_ACEOF" -} >conf$$subs.sh || - as_fn_error $? "could not make $CONFIG_STATUS" "$LINENO" 5 -ac_delim_num=`echo "$ac_subst_vars" | grep -c '^'` -ac_delim='%!_!# ' -for ac_last_try in false false false false false :; do - . ./conf$$subs.sh || - as_fn_error $? "could not make $CONFIG_STATUS" "$LINENO" 5 - - ac_delim_n=`sed -n "s/.*$ac_delim\$/X/p" conf$$subs.awk | grep -c X` - if test $ac_delim_n = $ac_delim_num; then - break - elif $ac_last_try; then - as_fn_error $? "could not make $CONFIG_STATUS" "$LINENO" 5 - else - ac_delim="$ac_delim!$ac_delim _$ac_delim!! " - fi -done -rm -f conf$$subs.sh - -cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 -cat >>"\$ac_tmp/subs1.awk" <<\\_ACAWK && -_ACEOF -sed -n ' -h -s/^/S["/; s/!.*/"]=/ -p -g -s/^[^!]*!// -:repl -t repl -s/'"$ac_delim"'$// -t delim -:nl -h -s/\(.\{148\}\)..*/\1/ -t more1 -s/["\\]/\\&/g; s/^/"/; s/$/\\n"\\/ -p -n -b repl -:more1 -s/["\\]/\\&/g; s/^/"/; s/$/"\\/ -p -g -s/.\{148\}// -t nl -:delim -h -s/\(.\{148\}\)..*/\1/ -t more2 -s/["\\]/\\&/g; s/^/"/; s/$/"/ -p -b -:more2 -s/["\\]/\\&/g; s/^/"/; s/$/"\\/ -p -g -s/.\{148\}// -t delim -' >$CONFIG_STATUS || ac_write_fail=1 -rm -f conf$$subs.awk -cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 -_ACAWK -cat >>"\$ac_tmp/subs1.awk" <<_ACAWK && - for (key in S) S_is_set[key] = 1 - FS = "" - -} -{ - line = $ 0 - nfields = split(line, field, "@") - substed = 0 - len = length(field[1]) - for (i = 2; i < nfields; i++) { - key = field[i] - keylen = length(key) - if (S_is_set[key]) { - value = S[key] - line = substr(line, 1, len) "" value "" substr(line, len + keylen + 3) - len += length(value) + length(field[++i]) - substed = 1 - } else - len += 1 + keylen - } - - print line -} - -_ACAWK -_ACEOF -cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 -if sed "s/$ac_cr//" < /dev/null > /dev/null 2>&1; then - sed "s/$ac_cr\$//; s/$ac_cr/$ac_cs_awk_cr/g" -else - cat -fi < "$ac_tmp/subs1.awk" > "$ac_tmp/subs.awk" \ - || as_fn_error $? "could not setup config files machinery" "$LINENO" 5 -_ACEOF - -# VPATH may cause trouble with some makes, so we remove sole $(srcdir), -# ${srcdir} and @srcdir@ entries from VPATH if srcdir is ".", strip leading and -# trailing colons and then remove the whole line if VPATH becomes empty -# (actually we leave an empty line to preserve line numbers). -if test "x$srcdir" = x.; then - ac_vpsub='/^[ ]*VPATH[ ]*=[ ]*/{ -h -s/// -s/^/:/ -s/[ ]*$/:/ -s/:\$(srcdir):/:/g -s/:\${srcdir}:/:/g -s/:@srcdir@:/:/g -s/^:*// -s/:*$// -x -s/\(=[ ]*\).*/\1/ -G -s/\n// -s/^[^=]*=[ ]*$// -}' -fi - -cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 -fi # test -n "$CONFIG_FILES" - -# Set up the scripts for CONFIG_HEADERS section. -# No need to generate them if there are no CONFIG_HEADERS. -# This happens for instance with `./config.status Makefile'. -if test -n "$CONFIG_HEADERS"; then -cat >"$ac_tmp/defines.awk" <<\_ACAWK || -BEGIN { -_ACEOF - -# Transform confdefs.h into an awk script `defines.awk', embedded as -# here-document in config.status, that substitutes the proper values into -# config.h.in to produce config.h. - -# Create a delimiter string that does not exist in confdefs.h, to ease -# handling of long lines. -ac_delim='%!_!# ' -for ac_last_try in false false :; do - ac_tt=`sed -n "/$ac_delim/p" confdefs.h` - if test -z "$ac_tt"; then - break - elif $ac_last_try; then - as_fn_error $? "could not make $CONFIG_HEADERS" "$LINENO" 5 - else - ac_delim="$ac_delim!$ac_delim _$ac_delim!! " - fi -done - -# For the awk script, D is an array of macro values keyed by name, -# likewise P contains macro parameters if any. Preserve backslash -# newline sequences. - -ac_word_re=[_$as_cr_Letters][_$as_cr_alnum]* -sed -n ' -s/.\{148\}/&'"$ac_delim"'/g -t rset -:rset -s/^[ ]*#[ ]*define[ ][ ]*/ / -t def -d -:def -s/\\$// -t bsnl -s/["\\]/\\&/g -s/^ \('"$ac_word_re"'\)\(([^()]*)\)[ ]*\(.*\)/P["\1"]="\2"\ -D["\1"]=" \3"/p -s/^ \('"$ac_word_re"'\)[ ]*\(.*\)/D["\1"]=" \2"/p -d -:bsnl -s/["\\]/\\&/g -s/^ \('"$ac_word_re"'\)\(([^()]*)\)[ ]*\(.*\)/P["\1"]="\2"\ -D["\1"]=" \3\\\\\\n"\\/p -t cont -s/^ \('"$ac_word_re"'\)[ ]*\(.*\)/D["\1"]=" \2\\\\\\n"\\/p -t cont -d -:cont -n -s/.\{148\}/&'"$ac_delim"'/g -t clear -:clear -s/\\$// -t bsnlc -s/["\\]/\\&/g; s/^/"/; s/$/"/p -d -:bsnlc -s/["\\]/\\&/g; s/^/"/; s/$/\\\\\\n"\\/p -b cont -' >$CONFIG_STATUS || ac_write_fail=1 - -cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 - for (key in D) D_is_set[key] = 1 - FS = "" -} -/^[\t ]*#[\t ]*(define|undef)[\t ]+$ac_word_re([\t (]|\$)/ { - line = \$ 0 - split(line, arg, " ") - if (arg[1] == "#") { - defundef = arg[2] - mac1 = arg[3] - } else { - defundef = substr(arg[1], 2) - mac1 = arg[2] - } - split(mac1, mac2, "(") #) - macro = mac2[1] - prefix = substr(line, 1, index(line, defundef) - 1) - if (D_is_set[macro]) { - # Preserve the white space surrounding the "#". - print prefix "define", macro P[macro] D[macro] - next - } else { - # Replace #undef with comments. This is necessary, for example, - # in the case of _POSIX_SOURCE, which is predefined and required - # on some systems where configure will not decide to define it. - if (defundef == "undef") { - print "/*", prefix defundef, macro, "*/" - next - } - } -} -{ print } -_ACAWK -_ACEOF -cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 - as_fn_error $? "could not setup config headers machinery" "$LINENO" 5 -fi # test -n "$CONFIG_HEADERS" - - -eval set X " :F $CONFIG_FILES :H $CONFIG_HEADERS " -shift -for ac_tag -do - case $ac_tag in - :[FHLC]) ac_mode=$ac_tag; continue;; - esac - case $ac_mode$ac_tag in - :[FHL]*:*);; - :L* | :C*:*) as_fn_error $? "invalid tag \`$ac_tag'" "$LINENO" 5;; - :[FH]-) ac_tag=-:-;; - :[FH]*) ac_tag=$ac_tag:$ac_tag.in;; - esac - ac_save_IFS=$IFS - IFS=: - set x $ac_tag - IFS=$ac_save_IFS - shift - ac_file=$1 - shift - - case $ac_mode in - :L) ac_source=$1;; - :[FH]) - ac_file_inputs= - for ac_f - do - case $ac_f in - -) ac_f="$ac_tmp/stdin";; - *) # Look for the file first in the build tree, then in the source tree - # (if the path is not absolute). The absolute path cannot be DOS-style, - # because $ac_f cannot contain `:'. - test -f "$ac_f" || - case $ac_f in - [\\/$]*) false;; - *) test -f "$srcdir/$ac_f" && ac_f="$srcdir/$ac_f";; - esac || - as_fn_error 1 "cannot find input file: \`$ac_f'" "$LINENO" 5;; - esac - case $ac_f in *\'*) ac_f=`$as_echo "$ac_f" | sed "s/'/'\\\\\\\\''/g"`;; esac - as_fn_append ac_file_inputs " '$ac_f'" - done - - # Let's still pretend it is `configure' which instantiates (i.e., don't - # use $as_me), people would be surprised to read: - # /* config.h. Generated by config.status. */ - configure_input='Generated from '` - $as_echo "$*" | sed 's|^[^:]*/||;s|:[^:]*/|, |g' - `' by configure.' - if test x"$ac_file" != x-; then - configure_input="$ac_file. $configure_input" - { $as_echo "$as_me:${as_lineno-$LINENO}: creating $ac_file" >&5 -$as_echo "$as_me: creating $ac_file" >&6;} - fi - # Neutralize special characters interpreted by sed in replacement strings. - case $configure_input in #( - *\&* | *\|* | *\\* ) - ac_sed_conf_input=`$as_echo "$configure_input" | - sed 's/[\\\\&|]/\\\\&/g'`;; #( - *) ac_sed_conf_input=$configure_input;; - esac - - case $ac_tag in - *:-:* | *:-) cat >"$ac_tmp/stdin" \ - || as_fn_error $? "could not create $ac_file" "$LINENO" 5 ;; - esac - ;; - esac - - ac_dir=`$as_dirname -- "$ac_file" || -$as_expr X"$ac_file" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ - X"$ac_file" : 'X\(//\)[^/]' \| \ - X"$ac_file" : 'X\(//\)$' \| \ - X"$ac_file" : 'X\(/\)' \| . 2>/dev/null || -$as_echo X"$ac_file" | - sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ - s//\1/ - q - } - /^X\(\/\/\)[^/].*/{ - s//\1/ - q - } - /^X\(\/\/\)$/{ - s//\1/ - q - } - /^X\(\/\).*/{ - s//\1/ - q - } - s/.*/./; q'` - as_dir="$ac_dir"; as_fn_mkdir_p - ac_builddir=. - -case "$ac_dir" in -.) ac_dir_suffix= ac_top_builddir_sub=. ac_top_build_prefix= ;; -*) - ac_dir_suffix=/`$as_echo "$ac_dir" | sed 's|^\.[\\/]||'` - # A ".." for each directory in $ac_dir_suffix. - ac_top_builddir_sub=`$as_echo "$ac_dir_suffix" | sed 's|/[^\\/]*|/..|g;s|/||'` - case $ac_top_builddir_sub in - "") ac_top_builddir_sub=. ac_top_build_prefix= ;; - *) ac_top_build_prefix=$ac_top_builddir_sub/ ;; - esac ;; -esac -ac_abs_top_builddir=$ac_pwd -ac_abs_builddir=$ac_pwd$ac_dir_suffix -# for backward compatibility: -ac_top_builddir=$ac_top_build_prefix - -case $srcdir in - .) # We are building in place. - ac_srcdir=. - ac_top_srcdir=$ac_top_builddir_sub - ac_abs_top_srcdir=$ac_pwd ;; - [\\/]* | ?:[\\/]* ) # Absolute name. - ac_srcdir=$srcdir$ac_dir_suffix; - ac_top_srcdir=$srcdir - ac_abs_top_srcdir=$srcdir ;; - *) # Relative name. - ac_srcdir=$ac_top_build_prefix$srcdir$ac_dir_suffix - ac_top_srcdir=$ac_top_build_prefix$srcdir - ac_abs_top_srcdir=$ac_pwd/$srcdir ;; -esac -ac_abs_srcdir=$ac_abs_top_srcdir$ac_dir_suffix - - - case $ac_mode in - :F) - # - # CONFIG_FILE - # - -_ACEOF - -cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 -# If the template does not know about datarootdir, expand it. -# FIXME: This hack should be removed a few years after 2.60. -ac_datarootdir_hack=; ac_datarootdir_seen= -ac_sed_dataroot=' -/datarootdir/ { - p - q -} -/@datadir@/p -/@docdir@/p -/@infodir@/p -/@localedir@/p -/@mandir@/p' -case `eval "sed -n \"\$ac_sed_dataroot\" $ac_file_inputs"` in -*datarootdir*) ac_datarootdir_seen=yes;; -*@datadir@*|*@docdir@*|*@infodir@*|*@localedir@*|*@mandir@*) - { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $ac_file_inputs seems to ignore the --datarootdir setting" >&5 -$as_echo "$as_me: WARNING: $ac_file_inputs seems to ignore the --datarootdir setting" >&2;} -_ACEOF -cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 - ac_datarootdir_hack=' - s&@datadir@&$datadir&g - s&@docdir@&$docdir&g - s&@infodir@&$infodir&g - s&@localedir@&$localedir&g - s&@mandir@&$mandir&g - s&\\\${datarootdir}&$datarootdir&g' ;; -esac -_ACEOF - -# Neutralize VPATH when `$srcdir' = `.'. -# Shell code in configure.ac might set extrasub. -# FIXME: do we really want to maintain this feature? -cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 -ac_sed_extra="$ac_vpsub -$extrasub -_ACEOF -cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 -:t -/@[a-zA-Z_][a-zA-Z_0-9]*@/!b -s|@configure_input@|$ac_sed_conf_input|;t t -s&@top_builddir@&$ac_top_builddir_sub&;t t -s&@top_build_prefix@&$ac_top_build_prefix&;t t -s&@srcdir@&$ac_srcdir&;t t -s&@abs_srcdir@&$ac_abs_srcdir&;t t -s&@top_srcdir@&$ac_top_srcdir&;t t -s&@abs_top_srcdir@&$ac_abs_top_srcdir&;t t -s&@builddir@&$ac_builddir&;t t -s&@abs_builddir@&$ac_abs_builddir&;t t -s&@abs_top_builddir@&$ac_abs_top_builddir&;t t -$ac_datarootdir_hack -" -eval sed \"\$ac_sed_extra\" "$ac_file_inputs" | $AWK -f "$ac_tmp/subs.awk" \ - >$ac_tmp/out || as_fn_error $? "could not create $ac_file" "$LINENO" 5 - -test -z "$ac_datarootdir_hack$ac_datarootdir_seen" && - { ac_out=`sed -n '/\${datarootdir}/p' "$ac_tmp/out"`; test -n "$ac_out"; } && - { ac_out=`sed -n '/^[ ]*datarootdir[ ]*:*=/p' \ - "$ac_tmp/out"`; test -z "$ac_out"; } && - { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $ac_file contains a reference to the variable \`datarootdir' -which seems to be undefined. Please make sure it is defined" >&5 -$as_echo "$as_me: WARNING: $ac_file contains a reference to the variable \`datarootdir' -which seems to be undefined. Please make sure it is defined" >&2;} - - rm -f "$ac_tmp/stdin" - case $ac_file in - -) cat "$ac_tmp/out" && rm -f "$ac_tmp/out";; - *) rm -f "$ac_file" && mv "$ac_tmp/out" "$ac_file";; - esac \ - || as_fn_error $? "could not create $ac_file" "$LINENO" 5 - ;; - :H) - # - # CONFIG_HEADER - # - if test x"$ac_file" != x-; then - { - $as_echo "/* $configure_input */" \ - && eval '$AWK -f "$ac_tmp/defines.awk"' "$ac_file_inputs" - } >"$ac_tmp/config.h" \ - || as_fn_error $? "could not create $ac_file" "$LINENO" 5 - if diff "$ac_file" "$ac_tmp/config.h" >/dev/null 2>&1; then - { $as_echo "$as_me:${as_lineno-$LINENO}: $ac_file is unchanged" >&5 -$as_echo "$as_me: $ac_file is unchanged" >&6;} - else - rm -f "$ac_file" - mv "$ac_tmp/config.h" "$ac_file" \ - || as_fn_error $? "could not create $ac_file" "$LINENO" 5 - fi - else - $as_echo "/* $configure_input */" \ - && eval '$AWK -f "$ac_tmp/defines.awk"' "$ac_file_inputs" \ - || as_fn_error $? "could not create -" "$LINENO" 5 - fi - ;; - - - esac - -done # for ac_tag - - -as_fn_exit 0 -_ACEOF -ac_clean_files=$ac_clean_files_save - -test $ac_write_fail = 0 || - as_fn_error $? "write failure creating $CONFIG_STATUS" "$LINENO" 5 - - -# configure is writing to config.log, and then calls config.status. -# config.status does its own redirection, appending to config.log. -# Unfortunately, on DOS this fails, as config.log is still kept open -# by configure, so config.status won't be able to write to it; its -# output is simply discarded. So we exec the FD to /dev/null, -# effectively closing config.log, so it can be properly (re)opened and -# appended to by config.status. When coming back to configure, we -# need to make the FD available again. -if test "$no_create" != yes; then - ac_cs_success=: - ac_config_status_args= - test "$silent" = yes && - ac_config_status_args="$ac_config_status_args --quiet" - exec 5>/dev/null - $SHELL $CONFIG_STATUS $ac_config_status_args || ac_cs_success=false - exec 5>>config.log - # Use ||, not &&, to avoid exiting from the if with $? = 1, which - # would make configure fail if this is the last instruction. - $ac_cs_success || as_fn_exit 1 -fi -if test -n "$ac_unrecognized_opts" && test "$enable_option_checking" != no; then - { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: unrecognized options: $ac_unrecognized_opts" >&5 -$as_echo "$as_me: WARNING: unrecognized options: $ac_unrecognized_opts" >&2;} -fi - - -echo Please check the Makefile.conf -echo Have a nice day! - -# test -z is true for empty strings -# test -n is true for non-empty strings - - - - diff --git a/cesm/models/utils/mct/configure.ac b/cesm/models/utils/mct/configure.ac deleted file mode 100644 index 8e36319..0000000 --- a/cesm/models/utils/mct/configure.ac +++ /dev/null @@ -1,606 +0,0 @@ -# -*- Autoconf -*- -# Process this file with autoconf to produce a configure script. - -AC_INIT(MCT, 2.8) - -# PROCESS THE FOLLOWING MAKEFILES -AC_CONFIG_MACRO_DIR([m4]) -AC_CONFIG_FILES(Makefile.conf) -AC_CONFIG_HEADER(config.h) - -# DECLARE PACKAGE OPTIONS - -AC_ARG_ENABLE(mpiserial, -AC_HELP_STRING([--enable-mpiserial], -[Use the included MPI replacement library for single processor]), -[DONOTCHECKMPI="DONOTCHECKMPI"] -) - -AC_ARG_ENABLE(debugging, -AC_HELP_STRING([--enable-debugging], -[Use the debugging flag and disable the optimization flag]), -[DEBUGGING="ENABLED"] -) - -AC_ARG_ENABLE(selectedrealkind, -AC_HELP_STRING([--enable-selectedrealkind], -[define single precision and double precision numbers using the selected_real_kind function. Default uses the kind inquiry function.]), -[SRKDEF="SELECTEDREALKIND"] -) - -AC_ARG_ENABLE(sequence, -AC_HELP_STRING([--enable-sequence],[Modify MCT types to make them contiguous in memory.]), -[SRKDEF="SEQUENCE"],) - -AC_ARG_ENABLE(babel, -AC_HELP_STRING([--enable-babel],[Supply this option if you plan on building the Babel bindings to MCT]), -[SRKDEF="SEQUENCE"],) - - - -# DECLARE THE FOLLOWING PRECIOUS VARIABLES - -AC_ARG_VAR(MPILIBS,[MPI library command line invocation]) -AC_ARG_VAR(MPIHEADER,[MPI header include path with INCLUDEFLAG]) -AC_ARG_VAR(FPP,C-preprocessor for Fortran source code) -AC_ARG_VAR(FPPFLAGS,C-preprocessing flags for Fortran source code) -AC_ARG_VAR(FC,The Fortran compiler) -AC_ARG_VAR(FCFLAGS,User-defined Fortran compiler flags) -AC_ARG_VAR(PROGFCFLAGS,User-defined Fortran compiler flags for example programs) -AC_ARG_VAR(CFLAGS,Customized C source compilation flags) -AC_ARG_VAR(DEBUG,Fortran compiler flag for generating symbolic debugging information) -AC_ARG_VAR(OPT,Fortran compiler flag for optimization level) -AC_ARG_VAR(REAL8,[Fortran compiler flag for setting the default REAL size to REAL(KIND=8)]) -AC_ARG_VAR(BIT64,Fortran compiler flag for generating 64-bit objects) -AC_ARG_VAR(ENDIAN,Fortran compiler flag for converting big-endian to little-endian) -AC_ARG_VAR(INCLUDEFLAG,Fortran compiler flag for specifying module search path) -AC_ARG_VAR(INCLUDEPATH,Additional library and module paths with INCLUDEFLAG) -AC_ARG_VAR(AR,Archive command) -AC_ARG_VAR(RANLIB,Archive index update command) -AC_ARG_VAR(BABELROOT,Root directory of your Babel installation. i.e.: $BABELROOT/bin/babel $BABELROOT/lib/libsidl.so) -AC_ARG_VAR(COMPILER_ROOT,Root directory of your FORTRAN compiler) -AC_ARG_VAR(FORT_SIZE, Number of bits in Fortran real and double kind) - -# INCLUDE BABELROOT and COMPILER_ROOT in Makefile.conf(autoconf output) -AC_SUBST(BABELROOT) -AC_SUBST(COMPILER_ROOT) -AC_SUBST(PYTHON) -AC_SUBST(PYTHONOPTS) - -# SET TEMPORARY VARIABLES - -# OS AND PLATFORM NAME -test "$osname"=NONE && osname=`uname -s` -test "$machinename"=NONE && machinename=`uname -m` -fullhostname=`hostname -f` - - -# HARDCODE SPECIFIC MACHINES FOR EXTRAORDINARY CIRCUMSTANCES - -# CHECK IF WE ARE ON THE EARTH SIMULATOR -ES="NO" -if echo $osname | grep -i esos >/dev/null 2>&1; then - ES="YES" -fi -if echo $osname | grep -i hp-ux >/dev/null 2>&1; then - if test "$ac_hostname" = "moon"; then - ES="YES" - # TELLS CONFIGURE NOT TO RUN ANY TESTS THAT REQUIRE EXECUTION - cross_compiling="yes" - fi -fi -if test "$ES" = "YES"; then - echo "Using preset configuration values for the Earth Simulator" - if test -z "$CC"; then - CC="escc" - fi - if test -z "$FC"; then - FC="esf90" - fi - if test -z "$MPIFC"; then - MPIFC="esmpif90" - fi - if test -z "$AR"; then - AR="esar cqs" - fi - if test -z "FPP"; then - FPPFLAGS=" " - fi - if test -z "$FCFLAGS"; then - FCFLAGS="-EP -Wf'-pvctl fullmsg -L fmtlist transform map'" - fi - if test -z "$OPT"; then - OPT="-C vopt" - fi - if test -z "$CPPDEFS"; then - CPPDEFS="-DESVEC" - fi -fi - -# Check if we are on the ANL BG/P - -if echo $fullhostname | egrep -q '.\.(challenger|intrepid)\.alcf\.anl\.gov' - then if test -z "$FC"; then - FC=bgxlf90_r - fi - if test -z "$MPIFC"; then - MPIFC=mpixlf90_r - fi - if test -z "$CC"; then - CC=mpixlc_r - fi -fi - - - -# START TESTS - -# CHECK FOR THE C COMPILER -AC_PROG_CC([cc]) - -# CHECK FOR BYTE ORDERING -AC_C_BIGENDIAN - -# CHECK FOR THE FORTRAN COMPILER -# RLJ- specify the order, include PathScale and do not search for F77 -AC_PROG_FC([nagfor xlf95 pgf95 ifort gfortran pathf95 ftn lf95 f95 fort ifc efc g95 xlf90 pgf90 pathf90 epcf90 pghpf]) - -# CHECK FOR MPI LIBRARIES -AC_LANG_PUSH(Fortran) - -AC_FC_SRCEXT(F90) - -OLDFCFLAGS="$FCFLAGS" - -if test -n "$MPIHEADER"; then - FCFLAGS="$FCFLAGS $MPIHEADER" -fi - -# CHECK MPI BY DEFAULT -if test -z "$DONOTCHECKMPI"; then - ACX_MPI -fi - -# DONT CHECK MPI IF SERIALMPI OPTION IS ENABLED -if test -n "$DONOTCHECKMPI"; then - echo "MPISERIAL ENABLED: BYPASSING MPI CHECK" - if test -z "$MPIFC"; then - MPIFC=$FC - fi - if test -z "$FORT_SIZE"; then - FORT_SIZE="real4double8" - echo "FORT_SIZE IS PRESET TO $FORT_SIZE" - fi - abs_top_builddir=`pwd` - MPISERPATH=$abs_top_builddir/mpi-serial - AC_SUBST(MPISERPATH) - MPIHEADER=-I$MPISERPATH - MPILIBS="-L$MPISERPATH -lmpi-serial" -fi - -FCFLAGS="$OLDFCFLAGS" - -# A HACK TO FIX ACX_MPI TO GET MPILIBS TO BE AN EMPTY STRING -if test "$MPILIBS" = " "; then - MPILIBS="" -fi - -# SET FC TO MPIFC. IF MPILIBS IS PRESENT, SET FC TO FC. -if test -z "$FC"; then - FC=$MPIFC - if test "$FC" != "$MPIFC"; then - if test -n "$MPILIBS"; then - FC=$FC - fi - fi -fi - -# FOR SANITY, CHECK THAT FILENAME EXTENSION FOR FC IS CONSISTENT WITH FC -OLDFC="$FC" -FC="$FC" - -AC_COMPILE_IFELSE( - [ subroutine oof() - return - end], [], - [AC_MSG_WARN([$FC FAILED TO COMPILE FILENAME EXTENSION $ac_ext]) - ]) - - - -FC="$OLDFC" - -# CHECK HOW TO GET THE COMPILER VERSION. -echo "Checking Compiler Version" -AX_FC_VERSION() - -AC_LANG_POP(Fortran) - -# Check how to use the cpp with fortran - -AC_FC_PP_DEFINE() - - -# CHECK HOW TO NAME MANGLE C FUNCTIONS SO THAT IT CAN BE CALLED FROM FORTRAN -OLDFC="$FC" - -AC_FC_WRAPPERS() - -FC="$OLDFC" - -# CHECK THAT THE FORTRAN COMPILER CAN CORRECTLY PROCESS THESE DIRECTIVES -# IF NOT, USE THE EXTERNAL C PREPROCESSOR -OLDFC="$FC" - -defineflag="-Daardvark" -if test "$OLDFC" = "xlf90"; then - defineflag="-WF,-Daardvark" -fi -if test "$OLDFC" = "frt"; then - defineflag="-Wp,-Daardvark" -fi - -FC="$OLDFC" - -# DEFINE VARIABLES ACCORDING TO OS AND COMPILER - -echo "Hostname=$ac_hostname" -echo "Machine=$machinename" -echo "OS=$osname" - -# CHECK OS NAME -if echo $osname | grep -i aix >/dev/null 2>&1; then - SYSDEF="AIX" -fi -if echo $osname | grep -i darwin >/dev/null 2>&1; then - SYSDEF="DARWIN" -fi -if echo $osname | grep -i unix_system_v >/dev/null 2>&1; then - SYSDEF="UNIXSYSTEMV" -fi -if echo $osname | grep -i irix >/dev/null 2>&1; then - SYSDEF="IRIX" -fi -if echo $osname | grep -i irix64 >/dev/null 2>&1; then - SYSDEF="IRIX64" -fi -if echo $osname | grep -i linux >/dev/null 2>&1; then - SYSDEF="LINUX" -fi -if echo $osname | grep -i osf1 >/dev/null 2>&1; then - SYSDEF="OSF1" -fi -if echo $osname | grep -i super >/dev/null 2>&1; then - SYSDEF="SUPERUX" -fi -if echo $osname | grep -i sun >/dev/null 2>&1; then - SYSDEF="SUNOS" -fi -if echo $osname | grep -i t3e >/dev/null 2>&1; then - SYSDEF="T3E" -fi -if echo $osname | grep -i unicos >/dev/null 2>&1; then - SYSDEF="UNICOS" -fi -if test -z "$SYSDEF"; then - AC_MSG_WARN([OPERATING SYSTEM UNKNOWN]) - SYSDEF="UNKNOWNOS" -fi - -# Set the default FCFLAGS for non-gfortran compilers. -# NOTE: This may change with a new version of autoconf. -DEFFCFLAGS="-g" - -##################################################### -# CHECK COMPILER NAME and add specific flags -if echo $FC | grep xlf >/dev/null 2>&1; then - echo "Fortran Compiler is XLF" - CPRDEF="XLF" - if test -z "$REAL8"; then - REAL8="-qrealsize=8" - fi - if test -z "$OPT"; then - OPT="-O2 -qarch=auto" - fi - if test -z "$DEBUG"; then - DEBUG="-qdbg" - fi - if test "$FCFLAGS" = "$DEFFCFLAGS"; then - FCFLAGS="" - fi -elif echo $FC | grep pgf >/dev/null 2>&1; then - echo "Fortran Compiler is Portland Group" - CPRDEF="PGI" - if test -z "$REAL8"; then - REAL8="-r8" - fi - if test -z "$BIT64"; then - BIT64="-pc 64" - fi - if test "$FCFLAGS" = "$DEFFCFLAGS"; then - FCFLAGS="" - fi - if test -z "$ENDIAN"; then - ENDIAN="-byteswapio" - fi - if test -z "$OPT"; then - OPT="-O2" - fi - if test -z "$DEBUG"; then - DEBUG="-g" - fi -elif echo $FC | grep ftn >/dev/null 2>&1; then - if echo $ac_fc_version_output | grep -i Portland >/dev/null 2>&1; then - echo "Fortran Compiler is Portland Group, Cray" - CPRDEF="PGI" - SYSDEF="CNLINUX" - if test -z "$REAL8"; then - REAL8="-r8" - fi - if test -z "$BIT64"; then - BIT64="-pc 64" - fi - if test "$FCFLAGS" = "$DEFFCFLAGS"; then - FCFLAGS="" - fi - if test -z "$ENDIAN"; then - ENDIAN="-byteswapio" - fi - if test -z "$OPT"; then - OPT="-O2" - fi - if test -z "$DEBUG"; then - DEBUG="-g" - fi - fi -elif echo $FC | grep ifort >/dev/null 2>&1; then - echo "Fortran Compiler is Intel ifort" - CPRDEF="INTEL" - if test -z "$REAL8"; then - REAL8="-r8" - fi - if test "$FCFLAGS" = "$DEFFCFLAGS"; then - FCFLAGS="-w -ftz" - fi - if test -z "$PROGFCFLAGS"; then - PROGFCFLAGS="-assume byterecl" - fi - if test -z "$ENDIAN"; then - ENDIAN="-convert big_endian" - fi - if test -z "$OPT"; then - OPT="-O2" - fi - if test -z "$DEBUG"; then - DEBUG="-g" - fi -elif echo $FC | grep g95 >/dev/null 2>&1; then - echo "Fortran Compiler is GNU" - CPRDEF="GNU" -elif echo $FC | grep gfortran >/dev/null 2>&1; then - echo "Fortran Compiler is GNU" - CPRDEF="GNU" -# For gfortran, default flags are different - if test "$FCFLAGS" = "-g -O2"; then - FCFLAGS="" - fi - if test -z "$DEBUG"; then - DEBUG="-g" - fi - if test -z "$OPT"; then - OPT="-O2" - fi -elif echo $ac_fc_version_output | grep -i nag >/dev/null 2>&1; then - echo "Fortran Compiler is NAG" - CPRDEF="NAG" - if test -z "$REAL8"; then - REAL8="-r8" - fi - if test "$FCFLAGS" = "$DEFFCFLAGS"; then - FCFLAGS="-wmismatch=mpi_send,mpi_recv,mpi_bcast,mpi_allreduce,mpi_reduce,mpi_gatherv,mpi_gather,mpi_rsend,mpi_irecv,mpi_isend,mpi_scatterv,mpi_alltoallv -dusty" - fi - if test -z "$ENDIAN"; then - ENDIAN="-convert=BIG_IEEE" - fi - if test -z "$OPT"; then - OPT="-O2" - fi - if test -z "$DEBUG"; then - DEBUG="-g" - fi -########################################################### -# the compiler flags below have not been verified recently -########################################################### -elif echo $FC | grep frt >/dev/null 2>&1; then - echo "Fortran Compiler is UXP/V" - echo "Suggested additional vectorization flags: -Wv,-s5,-t3,-noalias,-ilfunc,-md" - CPRDEF="FUJITSU" - if test -z "$F90FLAGS"; then - F90FLAGS="-Am -X9" - fi - if test -z "$BIT64"; then - BIT64="-KA64" - fi - if test -z "$REAL8"; then - REAL8="-Ad" - fi -elif echo $ac_fc_version_output | grep Lahey >/dev/null 2>&1; then - echo "Fortran Compiler is Lahey" - CPRDEF="LAHEY" -elif echo $FC | grep ifc >/dev/null 2>&1; then - echo "Fortran Compiler is Intel 7.x or earlier" - echo "Intel ifc compiler must set the environment variable F_UFMTENDIAN=big to do endian conversion" - CPRDEF="INTEL" - if test -z "$REAL8"; then - REAL8="-r8" - fi - if test -z "$F90FLAGS"; then - F90FLAGS="-w" - fi - if test -z "$OPT"; then - OPT="-O2" - fi -elif echo $FC | grep efc >/dev/null 2>&1; then - echo "Fortran Compiler is Intel 7.x or earlier for IA-64" - echo "Intel efc compiler must set the environment variable F_UFMTENDIAN=big to do endian conversion" - CPRDEF="INTEL" - if test -z "$REAL8"; then - REAL8="-r8" - fi - if test -z "$F90FLAGS"; then - F90FLAGS="-w -ftz" - fi - if test -z "$OPT"; then - OPT="-O2" - fi -elif echo $FC | grep pathf90 >/dev/null 2>&1; then - echo "Fortran Compiler is PathScale" - CPRDEF="PATHSC" - if test -z "$REAL8"; then - REAL8="-r8" - fi - if test -z "$BIT64"; then - BIT64="-m64" - fi - if test -z "$OPT"; then - OPT="-O2" - fi -elif echo $ac_fc_version_output | grep -i absoft >/dev/null 2>&1; then - echo "Fortran Compiler is Absoft" - CPRDEF="ABSOFT" - if test -z "$REAL8"; then - REAL8="-N113" - fi - if test -z "$INCLUDEFLAG"; then - INCLUDEFLAG="-p" - fi - if test -z "$OPT"; then - OPT="-O2" - fi -elif echo $ac_fc_version_output | grep -i workshop >/dev/null 2>&1; then - echo "Fortran Compiler is Workshop" - CPRDEF="WORKSHOP" - if test -z "$INCLUDEFLAG"; then - INCLUDEFLAG="-M" - fi -elif echo $ac_fc_version_output | grep -i mipspro >/dev/null 2>&1; then - echo "Fortran Compiler is MIPSPro" - CPRDEF="MIPSPRO" - EXTRACFLAGS="-64" - if test -z "$OPT"; then - OPT="-O3" - fi - if test -z "$REAL8"; then - REAL8="-r8" - fi - if test -z "$BIT64"; then - BIT64="-64" - fi -elif echo $ac_fc_version_output | grep -i compaq >/dev/null 2>&1; then - echo "Fortran Compiler is Compaq" - CPRDEF="COMPAQ" - MPILIBS="$MPILIBS -lelan" - if test -z "$OPT"; then - OPT="-fast" - fi - if test -z "$REAL8"; then - REAL8="-real_size 64" - fi - if test -z "$ENDIAN"; then - ENDIAN="-convert big_endian" - fi - -# Compaq Fortran changed its name to HP Fortran. -# Lets support both versions for now. -elif echo $ac_fc_version_output | grep HP >/dev/null 2>&1; then - echo "Fortran Compiler is HP" - CPRDEF="COMPAQ" - MPILIBS="$MPILIBS -lelan" - if test -z "$OPT"; then - OPT="-fast" - fi - if test -z "$REAL8"; then - REAL8="-real_size 64" - fi - if test -z "$ENDIAN"; then - ENDIAN="-convert big_endian" - fi - -elif echo $ac_fc_version_output | grep -i sx >/dev/null 2>&1; then - echo "Fortran Compiler is SX" - CPRDEF="SX" - if test -z "$F90FLAGS"; then - F90FLAGS="-EP -Wf'-pvctl noassoc'" - fi - if test -z "$OPT"; then - OPT="-Chopt" - fi -fi - -########################################################### -# END of compiler-specific flag setting -########################################################### - -CPPDEFS="$CPPDEFS -DSYS$SYSDEF -DCPR$CPRDEF" -if test -n "$SRKDEF"; then - CPPDEFS="$CPPDEFS -D$SRKDEF" -fi - -# IF DEBUGGING ENABLED, DISABLE OPTIMIZATION FLAG -if test "$DEBUGGING" = "ENABLED"; then - OPT="" -else - DEBUG="" -fi - -# SET HARDCODED VARIABLES AS A LAST RESORT - -# ALWAYS ENABLE CRULE IN MAKEFILE -AC_SUBST(CRULE,[.c.o]) - -AC_SUBST(CPPDEFS) - -# INCLUDE FLAG IF NOT ALREADY SET IS MOST LIKELY -I -if test -z "$INCLUDEFLAG"; then - INCLUDEFLAG="-I" -fi - -# ARCHIVE COMMAND SIMILAR ACROSS ALL PLATFORMS -if test -z "$AR"; then - AR="ar cq" -fi - -# RANLIB -if test -z "$RANLIB"; then - # Necessary on Darwin to deal with common symbols (particularly when - # using ifort). - if test "$SYSDEF"x = DARWINx; then - RANLIB="ranlib -c" - else - AC_PROG_RANLIB - fi -fi - -echo -echo Output Variables: {CC=$CC} {CFLAGS=$CFLAGS} \ -{FC=$FC} {FCFLAGS=$FCFLAGS} {PROGFCFLAGS=$PROGFCFLAGS}\ -{CPPDEFS=$CPPDEFS} {OPT=$OPT} {DEBUG=$DEBUG} {REAL8=$REAL8} \ -{BIT64=$BIT64} {ENDIAN=$ENDIAN} {MPIFC=$MPIFC} \ -{MPILIBS=$MPILIBS} {MPIHEADER=$MPIHEADER} \ -{INCLUDEFLAG=$INCLUDEFLAG} {INCLUDEPATH=$INCLUDEPATH} \ -{AR=$AR} {RANLIB=$RANLIB} {BABELROOT=$BABELROOT} {COMPILER_ROOT=$COMPILER_ROOT} \ -{PYTHON=$PYTHON} {PYTHONOPTS=$PYTHONOPTS} {FORT_SIZE=$FORT_SIZE} {prefix=$prefix} \ -{SRCDIR=$SRCDIR} {FC_DEFINE=$FC_DEFINE} -echo - -AC_OUTPUT - -echo Please check the Makefile.conf -echo Have a nice day! - -# test -z is true for empty strings -# test -n is true for non-empty strings - - - - diff --git a/cesm/models/utils/mct/doc/.gitignore b/cesm/models/utils/mct/doc/.gitignore deleted file mode 100644 index aadc44c..0000000 --- a/cesm/models/utils/mct/doc/.gitignore +++ /dev/null @@ -1,7 +0,0 @@ -*.toc -*.log -*.dvi -*.aux -*.blg -*.bbl -*.pdf diff --git a/cesm/models/utils/mct/doc/Makefile b/cesm/models/utils/mct/doc/Makefile deleted file mode 100644 index 2d6e5ef..0000000 --- a/cesm/models/utils/mct/doc/Makefile +++ /dev/null @@ -1,27 +0,0 @@ -#!/bin/make -#----------------------------------------------------------------------- -# Documentation -all: - cd texsrc; make - make apis - -html: - latex2html -white -toc_depth 5 -split 4 -show_section_numbers \ - -address "jacob@mcs.anl.gov" \ - mct_APIs.tex -apis: - cd texsrc; make - make apisdvi - -apisdvi: mct_APIs.dvi - -clean: - cd texsrc; make clean - rm -f *.dvi *.log *.bbl *.blg *.aux *.toc - -.SUFFIXES: .dvi .tex - -.tex.dvi: - latex $*.tex - -#. diff --git a/cesm/models/utils/mct/doc/README b/cesm/models/utils/mct/doc/README deleted file mode 100644 index 9ccfdfe..0000000 --- a/cesm/models/utils/mct/doc/README +++ /dev/null @@ -1,20 +0,0 @@ - -To build the .dvi files for the documentation. type "make". - -This will build the API's document. - -To build the APIs, type "make apis" - -NOTE: this build system isn't working perfectly yet. It will -build a .dvi file but you will need to run "bibtex" manually to -build the bibliography. - -To build "by hand" using the design doc as an example: -cd to texsrc, type "make" -cd back to doc directory then do: - -latex mct_APIs -bibtex mct_APIs -latex mct_APIs -latex mct_APIs - diff --git a/cesm/models/utils/mct/doc/coupler.bib b/cesm/models/utils/mct/doc/coupler.bib deleted file mode 100644 index 3dd67ac..0000000 --- a/cesm/models/utils/mct/doc/coupler.bib +++ /dev/null @@ -1,254 +0,0 @@ -@article{gaspari-1999a, - author = "G.~Gaspari and S.~E.~Cohn", - title = {{Construction of Correlation Functions in Two and Three Dimensions}}, - journal ={Quart.~J.~Roy.~Met.~Soc.}, - year = "1999", - volume = "125", - pages = "723--757", -} -@article{jones-1999, - author = "P.~W.~Jones", - title = {{First- and Second-order Conservative Remapping Schemes for Grids in Spherical Coordinates}}, - journal ={Monthly Weather Reveiw}, - year = "1999", - volume = "127", - pages = "2204-2210", -} -@Techreport{gaspari-1998, - author = "G.~Gaspari and S.~E.~Cohn and D.~P.~Dee and J.~Guo and A.~M.~da~Silva", - title = {{Construction of the PSAS Multi-level Forecast Error Covariance Models}}, - year = "1998", - institution = "NASA/Goddard Space Flight Center", - number = "DAO Office Note 98-06 {\bf http://dao.gsfc.nasa.gov/subpages/office-notes.html}", - address = "Greenbelt, Maryland." -} -@techreport{dasilva-1998a, - author = "A.~da Silva and M.~Tippett and J.~Guo", - title = {{The PSAS Users' Manual}}, - year = "1999", - institution = "NASA/Goddard Space Flight Center", - number = "To be published as DAO Office Note 99-XX", - address = "Greenbelt, Maryland" -} -@Techreport{guo+al-1998a, - author = "J.~Guo and J.~W.~Larson and G.~Gaspari and A.~da~Silva and P.~M.~Lyster", - title = {{Documentation of the Physical-space Statistical Analysis System (PSAS) Part II: The Factored-Operator Formulation of Error Covariances}}, - year = "1998", - institution = "NASA/Goddard Space Flight Center", - number = "DAO Office Note 98-04 {\bf http://dao.gsfc.nasa.gov/subpages/office-notes.html}", - address = "Greenbelt, Maryland." -} -@techreport{ODS-95, - author = "A.~M.~da Silva and C.~Redder", - title = {{Documentation of the GEOS/DAS Observation Data Stream (ODS), Version 1.01}}, - year = "1995", - institution = "NASA/Goddard Space Flight Center", - number = "DAO Office Note 95-01", - address = "Greenbelt, Maryland" -} -@techreport{farrell-1996a, - author = "W.~E.~Farrell and A.~J.~Busalacchi and A.~Davis - and W.~P.~Dannevik and G-R.~Hoffmann and M.~Kafatos and R.~W.~Moore - and J.~Sloan and T.~Sterling", - title = {{Report of the Data Assimilation Office Computer Advisory - Panel to the Laboratory for Atmospheres}}, - year = "1996", - institution = "NASA/Goddard Space Flight Center", - address = "Greenbelt, Maryland" -} -@techreport{lam+daS-1996a, - author = "D.~Lamich and A.~da~Silva", - title = {{Architectural Design for the GEOS-2.1 Data Assimilation System Document Version 1}}, - year = "1996", - institution = "NASA/Goddard Space Flight Center", - number = "DAO Office Note 96-XX", - address = "Greenbelt, Maryland" -} -@techreport{atbd-1996a, - author = "D.~A.~O.~Staff", - title = {{Algorithm Theoretical Basis Document, Version 1.01}}, - year = "1996", - institution = "NASA/Goddard Space Flight Center", - address = "Greenbelt, Maryland {\bf http://dao.gsfc.nasa.gov/subpages/atbd.html}" -} -@techreport{suarez-1995a, - author = "M.~J.~Suarez and L.~L.~Takacs", - title = {{Documentation of the Aries-GEOS Dynamical Core: Version 2}}, - year = "1995", - institution = "NASA/Goddard Space Flight Center", - number = "NASA Techinical Memorandum 104606, Vol. 5", - address = "Greenbelt, Maryland" -} -@techreport{takacs-1994a, - author = "L.~L.~Takacs and A.~Molod and T.~Wang", - title = {{Documentation of the Goddard Earth Observing - System (GEOS) General Circulation Model--Version 1}}, - year = "1994", - institution = "NASA/Goddard Space Flight Center", - number = "NASA Techinical Memorandum 104606, Vol. 1", - address = "Greenbelt, Maryland" -} - -@techreport{pfaendtner-1995a, - author = "J.~W.~Pfaendtner and J.~S.~Bloom and D.~Lamich and - and M.~Seablom and M.~Sienkiewicz and J.~Stobie and A.~da~Silva", - title = {{Documentation of the Goddard Earth Observing System - (GEOS) Data Assimilation System -- Version 1}}, - year = "1995", - institution = "NASA/Goddard Space Flight Center", - number = "Tech. Memo No. 104606, Vol. 4", - address = "Greenbelt, Maryland." -} -@techreport{pfaendtner-1996a, - author = "J.~W.~Pfaendtner", - title = {{Notes on the Icosahedral Domain Decompostion in PSAS}}, - year = "1996", - institution = "NASA/Goddard Space Flight Center", - number = "DAO Office Note 96-04 {\bf http://dao.gsfc.nasa.gov/subpages/office-notes.html}", - address = "Greenbelt, Maryland." -} -@Conference{seablom-1991a, - author = "M.~Seablom and J.~Pfaendtner and P.~E.~Piraino", - title = {{Quality Control techniques for the interactive GLA - retrieval/assimilation system}}, - year = "1991", - pages="28-29", - booktitle={{AMS Ninth Conference on Numerical Weather Prediction, - Denver, Colorado, October 14-18, 1991}}, -} -@Conference{daSilva-1995a, - author = "A.~da Silva and J.~Pfaendtner and J.~Guo and - M.~Sienkiewicz and S.~Cohn", - title = {{Assessing the Effects of Data Selection with - DAO's Physical-space Statistical Analysis System}}, - year = "1995", - booktitle="Proceedings of the Second International Symposium on the - Assimilation of Observations in Meteorology and Oceanography, Tokyo Japan" -} -@techreport{zero-1996a, - author = "J.~Zero and R.~Lucchesi and R.~Rood", - title = {{Data Assimilation Office (DAO) Strategy Statement: - Evolution Towards the 1998 Computing Environment}}, - year = "1996", - institution = "NASA/Goddard Space Flight Center", - number = "Tech. Memo No. 104606, Vol. 4", - address = "Greenbelt, Maryland" -} -@techreport{daSilva-1996a, - author = "A.~da Silva and J.~Guo", - title = {{Documentation of the Physical-space Statistical Analysis - System (PSAS) Part I: The Conjugate Gradient Solver, Version - PSAS-1.00}}, - year = "1996", - institution = "NASA/Goddard Space Flight Center", - number = "DAO Office Note No.~96-02 {\bf http://dao.gsfc.nasa.gov/subpages/office-notes.html}", - address = "Greenbelt, Maryland" -} -@techreport{stobie-1996a, - author = "J.~Stobie", - title = {{GEOS 3.0 System Requirements}}, - institution = "NASA/Goddard Space Flight Center", - address = "Greenbelt, Maryland" -} -@Conference{ding-1995a, - author = "C.~Ding and R.~D.~Ferraro", - title = {{An 18 GFLOPS Parallel Data Assimilation PSAS Package}}, - year = "1995", - pages="70", - booktitle={{Proceedings of the Intel Supercomputer Users Group - Conference}} -} -@Conference{ding-1995b, - author = "C.~Ding and R.~D.~Ferraro", - title = {{A General Purpose Parallel Sparse-Matrix Solver Package}}, - year = "1995", - pages="70", - booktitle={{Proceedings of the 9th International Parallel Processing Symposium}} -} -@Conference{ding-1996a, - author = "C.~Ding and R.~D.~Ferraro", - title = {{Climate Data Assimilation on a Massively Parallel Computer}}, - year = "1996", - booktitle={{Proceedings of Supercomputing, 96}} -} -@techreport{hennecke-1996a, - author = "M.~Hennecke", - title = {{A Fortran 90 Interface to MPI Version 1.1}}, - institution = "RZ Universitat Karlsruhe", - year = "1996", - number = "Internal Report 63/96", - address = "Karlsruhe, Germany" -} -@techreport{daSilva-1996b, - author = "A.~da Silva and C.~Redder", - title = {{Documentation of the GEOS/DAS Observation Data - Stream (ODS) Version 1.01}}, - institution = "NASA/Goddard Space Flight Center", - number = "DAO Office Note No. 96-01", - address = "Greenbelt, Maryland" -} -@book{gol+vloan-1989, - author = "G.~H.~Golub and C.~F.~van Loan", - title = {Matrix Computations}, - edition = "second", - publisher = "The John Hopkins University Press", - year = "1989", - pages = "642", - address = "Baltimore" -} -@book{NumRec-1992, - author = " W.~H.~Press and S.~A.~Teukolsky and W.~T.~Vetterling", - title = {{Numerical Recipes in Fortran: The Art of Scientific - Computing}}, - edition = "second", - publisher = "Cambridge University Press", - year = "1992", - pages = "963", - address = "Cambridge" -} -@book{daley-1991, - author = "R.~Daley", - title = {{Atmospheric Data Analysis}}, - publisher = "Cambridge Press", - year = "1991", - pages = "457", - address = "Cambridge" -} -@phdthesis{vonlasz-1996a, - author = "G.~ von Laszewski", - title = {{The Parallel Data Assimilation System and its Implications on a Metacomputing Environment}}, - school = "Syracuse University", - year = "1996", - address = "Syracuse, New York" -} -@proposal{lyster-1995a, - author = "P.~M.~Lyster", - title = {{Four Dimensional Data Assimilation of the Atmosphere}}, - program = "NASA Cooperative Agreement for High Performance Computing - and Communications (HPCC) initiative", - agency = "National Aeronautics and Space Administration", - address = "Washington, D.~C.~" -} -@book{arfken, - author = "G.~Arfken", - title = {{Mathematical Methods for Physicists}}, - publisher = "Academic Press", - year = "1970", - pages = "815", - address = "New York" -} -@article{cohn-1998, - author="S.~E.~Cohn and A.~da~Silva and J.~Guo and M.~Sienkiewicz and D.~Lamich", - title={{Assessing the effects of data selection with the DAO Physical-space Statistical Analysis System}}, - journal={Mon.~Wea.~Rev.}, - volume="126", - pages="2913--2926", - year="1998" -} -@article{lyster-1998, - author="P.~M.~Lyster", - title={{The Computational Complexity of Atmospheric Data Assimilation}}, - journal="Submitted to {Int.~J.~Appl.~Sci.~Comp.}", - note="Available on-line from {\bf http://dao.gsfc.nasa.gov/DAO\_people/lys/complexity}", - year="1998" -} diff --git a/cesm/models/utils/mct/doc/mct_APIs.tex b/cesm/models/utils/mct/doc/mct_APIs.tex deleted file mode 100755 index da90957..0000000 --- a/cesm/models/utils/mct/doc/mct_APIs.tex +++ /dev/null @@ -1,336 +0,0 @@ -%mct API Specification -% J.W. Larson / MCS, Argonne National Laboratory -% R.L. Jacob -% First Version Begun 8/28/00 -% -% -\documentclass{article} -\usepackage{epsfig} -\usepackage{graphicx} -%\usepackage{fancyheadings} - -% Keep these dimensions - -\textheight 9in \topmargin 0pt \headsep 22pt -\headheight 0pt - -\textwidth 6in \oddsidemargin 0in \evensidemargin 0in - -\marginparpush 0pt \pagestyle{plain} - -\setlength{\hoffset}{0.25in} - -% Headings -% -------- -\pagestyle{plain} % AFTER redefining \textheight etc. - -% \lhead[]{{\em NGC Design Document}} % left part of header -% \chead[]{} % center part of header -% \rhead[]{\em {\today}} % right part of header - - % \cfoot{\roman{page}} - %\lfoot[]{} % left part of footer - % \rfoot[]{} % right part of footer - % \headrulewidth 0pt % if you don't want a rule under the header - % \footrulewidth 0pt % if you don't want a rule above the footer - -%...................................................................... -%.............begin document............. - -\begin{document} - -\begin{sloppypar} -{\huge\bf -%%% -%%% Enter your title below (after deleting mine) -%%% -The Model Coupling Toolkit API Reference Manual: MCT v. 2.8 -\\ } %%% IMPORTANT: Keep this \\ before the } -\end{sloppypar} - -%%% -%%% Author names and affiliations go below, follow example -%%% -\vspace{.3in} -\noindent J.~W.~Larson\\ -R.~L.~Jacob\\ -E.~Ong\\ -R.~Loy\\ -\vspace{.2in} {\em Mathematics and Computer Science Division, -Argonne National Laboratory\\} - -\vfill - -%%% -%%% These lines are standard - keep them! -%%% Edit the ``has not been published'' as appropriated. -{\em This paper has not been published and should be regarded as -an Internal Report from MCS. Permission to quote from this -Technical Note should be obtained from the MCS Division of -Argonne National Laboratory.} - -\vspace{0.4in} - - -\thispagestyle{empty} -\newpage - -%.......................... END FIRST PAGE ...................... - -\pagenumbering{roman} - -%......................... REVISION HISTORY .......................... - -\newpage -\setcounter{page}{2} %%%% Revision History starts at page ii - -\addcontentsline{toc}{part}{Revision History} - -\vspace*{\fill} - -\centerline{\huge\bf Revision History} - -\bigskip -\noindent{This Technical Note was produced for the Scientific -Discovery through Advanced Computing (SciDAC) project.} - -\begin{center} -\begin{tabular}{|l|l|l|l|}\hline -{\bf Version} & {\bf Version} & {\bf Pages Affected/} & {\bf Aproval}\\ -{\bf Number} & {\bf Date} & {\bf Extent of Changes} & {\bf Authority}\\ -\hline -\hline -Version 1$\beta$ & December 13, 2000 & First draft (before review) & -\\\hline -Version 1$\beta2$ & February 16, 2001 & Add more routines & -\\\hline -Version 1$\beta3$ & June 6, 2001 & Convert to pure API's doc & -\\\hline -Version 1$\beta4$ & Apr 24, 2002 & Update with latest source & -\\\hline -Version 1.0 & Nov 14, 2002 & 1.0 Version & -\\\hline -Version 2.0.0 & Apr 23, 2004 & 2.0.0 Version & -\\\hline -Version 2.0.1 & May 18, 2004 & 2.0.1 Version & -\\\hline -Version 2.1.0 & Feb 11, 2005 & 2.1.0 Version & -\\\hline -Version 2.2.0 & Dec 01, 2005 & 2.2.0 Version & -\\\hline -Version 2.2.1 & Apr 22, 2006 & 2.2.1 Version & -\\\hline -Version 2.2.2 & Sep 08, 2006 & 2.2.2 Version & -\\\hline -Version 2.2.3 & Oct 16, 2006 & 2.2.3 Version & -\\\hline -Version 2.3.0 & Jan 10, 2007 & 2.3.0 Version & -\\\hline -Version 2.4.0 & Aug 17, 2007 & 2.4.0 Version & -\\\hline -Version 2.4.1 & Nov 21, 2007 & 2.4.1 Version & -\\\hline -Version 2.5.0 & Jan 28, 2008 & 2.5.0 Version & -\\\hline -Version 2.5.1 & May 20, 2008 & 2.5.1 Version & -\\\hline -Version 2.6.0 & Mar 05, 2009 & 2.6.0 Version & -\\\hline -Version 2.7.0 & Jan 05, 2010 & 2.7.0 Version & -\\\hline -Version 2.7.1 & Feb 28, 2010 & 2.7.1 Version & -\\\hline -Version 2.7.2 & Nov 30, 2010 & 2.7.2 Version & -\\\hline -Version 2.7.3 & Jan 25, 2011 & 2.7.3 Version & -\\\hline -Version 2.7.4 & Mar 07, 2012 & 2.7.4 Version & -\\\hline -Version 2.8.0 & Apr 30, 2012 & 2.8.0 Version & -\\\hline -Version 2.8.1 & Jul 05, 2012 & 2.8.1 Version & -\\\hline -Version 2.8.2 & Sep 12, 2012 & 2.8.2 Version & -\\\hline -Version 2.8.3 & Dec 17, 2012 & 2.8.3 Version & -\\\hline -\end{tabular} -\end{center} - -\vspace*{\fill} - - -%.......................... ABSTRACT .................................. -\newpage -\setcounter{page}{3} %%%% abstract starts at page iii -\addcontentsline{toc}{part}{Preface} - -\vspace*{\fill} - -This document describes the Application Program Interfaces (APIs) -for the Model Coupling Toolkit (MCT). - -For functions that take a Fortran90 {\tt real} argument, either a scalar or -a vector, MCT provides both double and single precision versions. Only -the single precision version are described here denoted by SP. The double precision versions -are otherwise identical. - -\vspace*{\fill} -\newpage - -\tableofcontents -\newpage - -% Switch page numbering to arabic numerals - -\pagenumbering{arabic} - -\part{Basic API's and associated communication routines} -% -\section{MCTWorld} -\input{texsrc/m_MCTWorld} -\vspace*{\fill} -\newpage -% -% -\section{The Attribute Vector} -\input{texsrc/m_AttrVect} -\vspace*{\fill} -\newpage -% -\input{texsrc/m_AttrVectComms} -\vspace*{\fill} -\newpage -% -\input{texsrc/m_AttrVectReduce} -\vspace*{\fill} -\newpage -% -% -\section{Global Segment Map} -\input{texsrc/m_GlobalSegMap} -\vspace*{\fill} -\newpage -% -\input{texsrc/m_GlobalSegMapComms} -\vspace*{\fill} -\newpage -% -% -\section{The Router} -\input{texsrc/m_Router} -\vspace*{\fill} -\newpage -% -% -\section{The General Grid} -\input{texsrc/m_GeneralGrid} -\vspace*{\fill} -\newpage -% -\input{texsrc/m_GeneralGridComms} -\vspace*{\fill} -\newpage -% -% -\section{The Navigator} -\input{texsrc/m_Navigator} -\vspace*{\fill} -\newpage -% -% -\section{The Global Map} -\input{texsrc/m_GlobalMap} -\vspace*{\fill} -\newpage -% -% -\part{High Level API's} -% -\section{Sending and Receiving Attribute Vectors} -\input{texsrc/m_Transfer} -\vspace*{\fill} -\newpage -% -\section{Rearranging Attribute Vectors} -\input{texsrc/m_Rearranger} -\vspace*{\fill} -\newpage -% -\section{Sprase Matrix Support} -\input{texsrc/m_SparseMatrix} -\vspace*{\fill} -\newpage -% -\input{texsrc/m_SparseMatrixComms} -\vspace*{\fill} -\newpage -% -\input{texsrc/m_SparseMatrixDecomp} -\vspace*{\fill} -\newpage -% -\input{texsrc/m_SparseMatrixToMaps} -\vspace*{\fill} -\newpage -% -\input{texsrc/m_SparseMatrixPlus} -\vspace*{\fill} -\newpage -% -% -\section{Matrix Vector Multiplication} -\input{texsrc/m_MatAttrVectMul} -\vspace*{\fill} -\newpage -% -\section{Spatial Integration and Averaging} -\input{texsrc/m_SpatialIntegral} -\vspace*{\fill} -\newpage -\input{texsrc/m_SpatialIntegralV} -\vspace*{\fill} -\newpage -% -\section{Merging of Flux and State Data from Multiple Sources} -\input{texsrc/m_Merge} -\vspace*{\fill} -\newpage -% -\section{Time Averaging} -\input{texsrc/m_Accumulator} -\vspace*{\fill} -\newpage -% -\input{texsrc/m_AccumulatorComms} -\vspace*{\fill} -\newpage -% -\section{Global To Local Index Translation} -\input{texsrc/m_GlobalToLocal} -\vspace*{\fill} -\newpage -% -\section{Convert From Global Map To Global Segment Map} -\input{texsrc/m_ConvertMaps} -\vspace*{\fill} -\newpage - -\part{Documentation of MPEU Datatypes Used to Define MCT Datatypes} -% -\section{The String Datatype} -\input{texsrc/m_String} -\vspace*{\fill} -\newpage -% -\section{The List Datatype} -\input{texsrc/m_List} -\vspace*{\fill} -\newpage - -%\addcontentsline{toc}{part}{References} - -%\bibliographystyle{apalike} % for BibTeX - uses [Name, year] method?? - -%\bibliography{coupler} -\end{document} diff --git a/cesm/models/utils/mct/doc/texsrc/.gitignore b/cesm/models/utils/mct/doc/texsrc/.gitignore deleted file mode 100644 index 89a588f..0000000 --- a/cesm/models/utils/mct/doc/texsrc/.gitignore +++ /dev/null @@ -1,2 +0,0 @@ -*.tex -*.F90 diff --git a/cesm/models/utils/mct/doc/texsrc/Makefile b/cesm/models/utils/mct/doc/texsrc/Makefile deleted file mode 100644 index 7d40496..0000000 --- a/cesm/models/utils/mct/doc/texsrc/Makefile +++ /dev/null @@ -1,29 +0,0 @@ -#!/bin/make - -TEXFILES = -include SRCS_tex.mk - -PROTEXLOC = ../../protex/protex - -PROTEX = perl $(PROTEXLOC) -b # bare mode--no TOC - -#----------------------------------------------------------------------- -# Documentation -all: - cp ../../mct/*.F90 . - cp ../../mpeu/m_String.F90 . - cp ../../mpeu/m_List.F90 . - make doc - -doc: $(TEXFILES) - -clean: - rm -f *.F90 - rm -f *.tex - -.SUFFIXES: .F90 .tex - -.F90.tex: - $(PROTEX) $*.F90 > $*.tex - -#. diff --git a/cesm/models/utils/mct/doc/texsrc/SRCS_tex.mk b/cesm/models/utils/mct/doc/texsrc/SRCS_tex.mk deleted file mode 100644 index 556c721..0000000 --- a/cesm/models/utils/mct/doc/texsrc/SRCS_tex.mk +++ /dev/null @@ -1,31 +0,0 @@ -TEXFILES= \ -m_Accumulator.tex \ -m_AccumulatorComms.tex \ -m_AttrVect.tex \ -m_AttrVectComms.tex \ -m_AttrVectReduce.tex \ -m_ConvertMaps.tex \ -m_ExchangeMaps.tex \ -m_GeneralGrid.tex \ -m_GeneralGridComms.tex \ -m_GlobalMap.tex \ -m_GlobalSegMap.tex \ -m_GlobalSegMapComms.tex \ -m_GlobalToLocal.tex \ -m_MCTWorld.tex \ -m_MatAttrVectMul.tex \ -m_Merge.tex \ -m_Navigator.tex \ -m_Rearranger.tex \ -m_Router.tex \ -m_SparseMatrix.tex \ -m_SparseMatrixComms.tex \ -m_SparseMatrixDecomp.tex \ -m_SparseMatrixToMaps.tex \ -m_SparseMatrixPlus.tex \ -m_SpatialIntegral.tex \ -m_SpatialIntegralV.tex \ -m_String.tex \ -m_Transfer.tex \ -m_List.tex - diff --git a/cesm/models/utils/mct/examples/Makefile b/cesm/models/utils/mct/examples/Makefile deleted file mode 100644 index dfd7972..0000000 --- a/cesm/models/utils/mct/examples/Makefile +++ /dev/null @@ -1,20 +0,0 @@ - -SHELL = /bin/sh - -SUBDIRS = simple climate_concur1 climate_sequen1 - -# TARGETS -subdirs: - @for dir in $(SUBDIRS); do \ - cd $$dir; \ - $(MAKE); \ - cd ..; \ - done - -clean: - @for dir in $(SUBDIRS); do \ - cd $$dir; \ - $(MAKE) clean; \ - cd ..; \ - done - diff --git a/cesm/models/utils/mct/examples/README b/cesm/models/utils/mct/examples/README deleted file mode 100644 index 4a66905..0000000 --- a/cesm/models/utils/mct/examples/README +++ /dev/null @@ -1,22 +0,0 @@ - -Directories containing example programs showing -the use of MCT. - -simple/ - Multiple single-source file examples showing how to set - up MCTWorld, GSMaps and send/recv data in various two-component - coupled configurations (sequential and concurrent). Require - no input data. - -climate_concur1/ - A small program demonstrating MCT features - in a configuration which mimics part of a concurrently executing - climate model. Uses real climate model numerical grids. Requires - the MCT/data directory. - - -climate_sequen1/ - A small program demonstrating MCT features - in a configuration which mimics part of a sequentially executing - climate model. Uses real climate model numerical grids. Requires - the MCT/data directory - - -More examples will be available in future releases. diff --git a/cesm/models/utils/mct/examples/climate_concur1/.gitignore b/cesm/models/utils/mct/examples/climate_concur1/.gitignore deleted file mode 100644 index 8821ba5..0000000 --- a/cesm/models/utils/mct/examples/climate_concur1/.gitignore +++ /dev/null @@ -1,3 +0,0 @@ -climate -*.mod -poe.* diff --git a/cesm/models/utils/mct/examples/climate_concur1/Makefile b/cesm/models/utils/mct/examples/climate_concur1/Makefile deleted file mode 100644 index bd32d2c..0000000 --- a/cesm/models/utils/mct/examples/climate_concur1/Makefile +++ /dev/null @@ -1,52 +0,0 @@ - -SHELL = /bin/sh - -# SOURCE FILES - -SRCS_F90 = master.F90 coupler.F90 model.F90 - -OBJS_ALL = $(SRCS_F90:.F90=.o) - -# MACHINE AND COMPILER FLAGS - -include ../../Makefile.conf - -# ADDITIONAL FLAGS SPECIFIC FOR UTMCT COMPILATION - -MCTLIBS = -L$(MPEUPATH) -L$(MCTPATH) -lmct -lmpeu -UTLDFLAGS = $(REAL8) -UTCMPFLAGS = $(REAL8) $(INCFLAG)$(MPEUPATH) $(INCFLAG)$(MCTPATH) - -# TARGETS - -all: climate - -climate: $(OBJS_ALL) - $(FC) -o $@ $(OBJS_ALL) $(FCFLAGS) $(UTLDFLAGS) $(MCTLIBS) $(MPILIBS) - -# RULES - -.SUFFIXES: -.SUFFIXES: .F90 .o - -.F90.o: - $(FC) -c $(INCPATH) $(FPPDEFS) $(FCFLAGS) $(MCTFLAGS) $(UTCMPFLAGS) $< - - -clean: - ${RM} *.o *.mod climate - -# DEPENDENCIES: - -$(OBJS_ALL): $(MCTPATH)/libmct.a - - - - - - - - - - - diff --git a/cesm/models/utils/mct/examples/climate_concur1/README b/cesm/models/utils/mct/examples/climate_concur1/README deleted file mode 100644 index 65602ac..0000000 --- a/cesm/models/utils/mct/examples/climate_concur1/README +++ /dev/null @@ -1,38 +0,0 @@ - -This program demonstrates the use of MCT in a simple -coupled system consisting of a "model" and a "coupler". - -The grids used are taken from a real climate model. -"model" uses an atmosphere grid and "coupler" interpolates -data on it to an ocean grid. - -The model and coupler run on separate pools of processors. - -master.F90 - the top level program -model.F90 - the first component, an atmosphere model. - sends data to the coupler. -coupler.F90 - the second component, a coupler which takes - the received atmosphere data and maps it to - the ocean grid. - ------------------------------------------------------ -To compile: -First make sure you have compiled MCT. See instructions in -MCT/README - -Type "make" here or "make examples" in the top-level directory. - -The executable is called "climate" - ------------------------------------------------------ -To run: -"climate" requires a data file of interpolation weights in -the directory MCT/data. If this directory was not present when -you untarred MCT, you can get it from the MCT website. - -climate requires at least 2 MPI processes to run but can run on -any even number of processors. Consult your -local documentation for how to run parallel programs. -Typical command: mpirun -np 8 climate - -This program will not work with mpi-serial. diff --git a/cesm/models/utils/mct/examples/climate_concur1/coupler.F90 b/cesm/models/utils/mct/examples/climate_concur1/coupler.F90 deleted file mode 100644 index 083438c..0000000 --- a/cesm/models/utils/mct/examples/climate_concur1/coupler.F90 +++ /dev/null @@ -1,315 +0,0 @@ -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!----------------------------------------------------------------------- -! CVS $Id: coupler.F90,v 1.8 2004-04-23 20:57:10 jacob Exp $ -! CVS $Name: $ -!BOP ------------------------------------------------------------------- -! -! !ROUTINE: coupler -- coupler for unit tester -! -! !DESCRIPTION: -! A coupler subroutine to test functionality of MCT. -! -! !INTERFACE: -! - subroutine coupler (comm,ncomps,compid) -! -! !USES: -! -! Get the things needed from MCT by "Use,only" with renaming: -! -! ---------- first group is identical to what model.F90 uses ---- -! -!---Component Model Registry - use m_MCTWorld,only: MCTWorld_init => init - use m_MCTWorld,only: MCTWorld_clean => clean -!---Domain Decomposition Descriptor DataType and associated methods - use m_GlobalSegMap,only: GlobalSegMap - use m_GlobalSegMap,only: GlobalSegMap_init => init - use m_GlobalSegMap,only: GlobalSegMap_lsize => lsize - use m_GlobalSegMap,only: GlobalSegMap_clean => clean - use m_GlobalSegMap,only: GlobalSegMap_Ordpnts => OrderedPoints -!---Field Storage DataType and associated methods - use m_AttrVect,only : AttrVect - use m_AttrVect,only : AttrVect_init => init - use m_AttrVect,only : AttrVect_clean => clean - use m_AttrVect,only : AttrVect_importRAttr => importRAttr -!---Intercomponent communications scheduler - use m_Router,only: Router - use m_Router,only: Router_init => init - use m_Router,only: Router_clean => clean -!---Intercomponent transfer - use m_Transfer,only : MCT_Send => send - use m_Transfer,only : MCT_Recv => recv - -! ---------- because coupler will do the interpolation --------- -! it needs more methods -! -!---Sparse Matrix DataType and associated methods - use m_SparseMatrix, only : SparseMatrix - use m_SparseMatrix, only : SparseMatrix_init => init - use m_SparseMatrix, only : SparseMatrix_importGRowInd => & - importGlobalRowIndices - use m_SparseMatrix, only : SparseMatrix_importGColInd => & - importGlobalColumnIndices - use m_SparseMatrix, only : SparseMatrix_importMatrixElts => & - importMatrixElements - use m_SparseMatrixPlus, only : SparseMatrixPlus - use m_SparseMatrixPlus, only : SparseMatrixPlus_init => init - use m_SparseMatrixPlus, only : SparseMatrixPlus_clean => clean - use m_SparseMatrixPlus, only : Xonly ! Decompose matrix by row -!---Matrix-Vector multiply methods - use m_MatAttrVectMul, only: MCT_MatVecMul => sMatAvMult - -!---MPEU I/O utilities - use m_stdio - use m_ioutil - - implicit none - - include "mpif.h" - -! !INPUT PARAMETERS: - - integer,intent(in) :: comm - integer,intent(in) :: ncomps - integer,intent(in) :: compid -! -!EOP ___________________________________________________________________ - -! Local variables - - character(len=*), parameter :: cplname='coupler.F90' - - integer :: nxa ! number of points in x-direction, atmos - integer :: nya ! number of points in y-direction, atmos - integer :: nxo ! number of points in x-direction, ocean - integer :: nyo ! number of points in y-direction, ocean - - character(len=100),parameter :: & - RemapMatrixFile='../../data/t42_to_popx1_c_mat.asc' - -! Loop indicies - integer :: i,j,k,n - - logical :: match - -! MPI variables - integer :: rank, nprocs, root, ierr -! MCTWorld variables - integer :: AtmID -! Grid variables - integer :: localsize -! GlobalSegMap variables - type(GlobalSegMap) :: AtmGSMap, OcnGSMap - integer,dimension(1) :: start,length - integer, dimension(:), pointer :: points - integer :: latsize, lonsize - integer :: rowindex, colindex, boxvertex -! AttVect variables - type(AttrVect) :: AtmAV, OcnAV - integer :: aavsize,oavsize -! Router variables - type(Router) :: Rout -! SparseMatrix variables - integer :: mdev - integer :: num_elements, nRows, nColumns - integer, dimension(2) :: src_dims, dst_dims - integer, dimension(:), pointer :: rows, columns - real, dimension(:), pointer :: weights -! A2O SparseMatrix elements on root - type(SparseMatrix) :: sMat -! A2O distributed SparseMatrixPlus variables - type(SparseMatrixPlus) :: A2OMatPlus -! _____________________________________________________________________ - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! INITIALIZATION PHASE -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - - ! LOCAL RANK AND SIZE - call MPI_COMM_RANK(comm,rank,ierr) - call MPI_COMM_SIZE(comm,nprocs,ierr) - root = 0 - - if(rank==0) write(6,*) cplname,' MyID ', compid - if(rank==0) write(6,*) cplname,' Num procs ', nprocs - - ! Initialize MCTworld - call MCTWorld_init(ncomps,MPI_COMM_WORLD,comm,compid) - - ! Set the atm component id. Must be known to this - ! component. (MCT doesn't handle that). - AtmID=1 - - ! Set grid dimensions for atmosphere and ocean grids. - ! MCT could be used for this (by defining a GeneralGrid in - ! each and sending them to the coupler) but for this simple - ! example, we'll assume they're known to the coupler - nxa = 128 - nya = 64 - - nxo = 320 - nyo = 384 - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! Read matrix weights for interpolation from a file. - if (rank == root) then - mdev = luavail() - open(mdev, file=trim(RemapMatrixFile), status="old") - read(mdev,*) num_elements - read(mdev,*) src_dims(1), src_dims(2) - read(mdev,*) dst_dims(1), dst_dims(2) - - allocate(rows(num_elements), columns(num_elements), & - weights(num_elements), stat=ierr) - - do n=1, num_elements - read(mdev,*) rows(n), columns(n), weights(n) - end do - - close(mdev) - - ! Initialize a Sparsematrix - nRows = dst_dims(1) * dst_dims(2) - nColumns = src_dims(1) * src_dims(2) - call SparseMatrix_init(sMat,nRows,nColumns,num_elements) - call SparseMatrix_importGRowInd(sMat, rows, size(rows)) - call SparseMatrix_importGColInd(sMat, columns, size(columns)) - call SparseMatrix_importMatrixElts(sMat, weights, size(weights)) - - deallocate(rows, columns, weights, stat=ierr) - - endif - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! Initialize a Global Segment Map for the Ocean - - ! Set up a 1-d decomposition. - ! There is just 1 segment per processor - localsize = nxo*nyo / nprocs - - ! we'll use the distributed init of GSMap so - ! initialize start and length arrays for this processor - start(1) = (rank*localsize) + 1 - length(1) = localsize - - ! initialize the GSMap - call GlobalSegMap_init(OcnGSMap,start,length,root,comm,compid) - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! Initialize a Global Segment Map for the Atmosphere - - ! Set up a 1-d decomposition. - ! There is just 1 segment per processor - localsize = nxa*nya / nprocs - - ! we'll use the distributed init of GSMap so - ! initialize start and length arrays for this processor - start(1) = (rank*localsize) + 1 - length(1) = localsize - - ! initialize the GSMap - call GlobalSegMap_init(AtmGSMap,start,length,root,comm,compid) - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - ! Use a GSMap function: - ! return the points local to this processor - ! in their assumed order. - call GlobalSegMap_Ordpnts(AtmGSMap,rank,points) - - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! Build a SparseMatrixPlus for doing the interpolation - ! Specify matrix decomposition to be by row. - ! following the atmosphere's decomposition. - call SparseMatrixPlus_init(A2OMatPlus, sMat, AtmGSMap, OcnGSMap, & - Xonly, root, comm, compid) - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! Initialize and Attribute vector the atmosphere grid - aavsize = GlobalSegMap_lsize(AtmGSMap,comm) - if(rank==0) write(6,*) cplname, ' localsize: Atm ', aavsize - call AttrVect_init(AtmAV,rList="field1:field2",lsize=aavsize) - - - ! Initialize and Attribute vector the ocean grid - oavsize = GlobalSegMap_lsize(OcnGSMap,comm) - if(rank==0) write(6,*) cplname, ' localsize: Ocn ', oavsize - call AttrVect_init(OcnAV,rList="field1:field2",lsize=oavsize) - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! Initialize a Router - call Router_init(AtmID,AtmGSMap,comm,Rout) - -!!! END OF INIT !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! RUN PHASE -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - do j=1,10 ! "timestep" loop - - - ! coupler calculations here - - match=.TRUE. - - ! Receive the data - call MCT_Recv(AtmAV,Rout) - - ! The 2nd attribute has the values of each gridpoint in - ! the index numbering scheme. Check the received values - ! against the points on the this processor. They should - ! match exactly. - do i=1,aavsize - if( int(AtmAV%rAttr(2,i)) .ne. points(i)) then - write(6,*) cplname,rank, " Data doesn't match ",i - match=.FALSE. - endif - enddo - if(match .and. j==10) & - write(6,*) cplname," Last step, All points match on ",rank - - if(rank==0) write(6,*) cplname, " Received data step ",j - - ! Interpolate by doing a parallel sparsematrix-attrvect multiply - ! Note: it doesn't make much sense to interpolate "field2" which - ! is the grid point indicies but MatVecMul will interpolate all - ! real attributes. - call MCT_MatVecMul(AtmAV, A2OMatPlus, OcnAV) - if(rank==0) write(6,*) cplname," Data transformed step ",j - - - ! pass interpolated data on to ocean model and/or - ! do more calculations - - enddo - - -!!! END OF RUN !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! FINALIZE PHASE -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - ! deallocate memory - call Router_clean(Rout) - call AttrVect_clean(AtmAV) - call AttrVect_clean(OcnAV) - call GlobalSegMap_clean(AtmGSMap) - call GlobalSegMap_clean(OcnGSMap) - call MCTWorld_clean() - if(rank==0) write(6,*) cplname, " done" - - end subroutine coupler - diff --git a/cesm/models/utils/mct/examples/climate_concur1/master.F90 b/cesm/models/utils/mct/examples/climate_concur1/master.F90 deleted file mode 100644 index 4a0b5db..0000000 --- a/cesm/models/utils/mct/examples/climate_concur1/master.F90 +++ /dev/null @@ -1,89 +0,0 @@ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!----------------------------------------------------------------------- -! CVS $Id: master.F90,v 1.7 2004-04-23 05:43:11 jacob Exp $ -! CVS $Name: $ -!BOP ------------------------------------------------------------------- -! -! !ROUTINE: master -- driver for simple concurrent coupled model -! -! !DESCRIPTION: Provide a simple example of using MCT to connect to -! components executing concurrently in a single executable. -! -! !INTERFACE: -! - program master -! -! !USES: -! - - implicit none - - include "mpif.h" - -! -!EOP ___________________________________________________________________ - -! local variables - - character(len=*), parameter :: mastername='master.F90' - - integer, parameter :: ncomps = 2 ! Must know total number of - ! components in coupled system - - integer, parameter :: AtmID = 1 ! pick an id for the atmosphere - integer, parameter :: CplID = 2 ! pick an id for the coupler - - - - -! MPI variables - integer :: splitcomm, rank, nprocs,compid, myID, ierr,color - integer :: anprocs,cnprocs - -!----------------------------------------------------------------------- -! The Main program. -! We are implementing a single-executable, concurrent-execution system. -! -! This small main program carves up MPI_COMM_WORLD and then starts -! each component on its own processor set. - - ! Initialize MPI - call MPI_INIT(ierr) - - ! Get basic MPI information - call MPI_COMM_SIZE(MPI_COMM_WORLD,nprocs,ierr) - call MPI_COMM_RANK(MPI_COMM_WORLD,rank,ierr) - - ! Create MPI communicators for each component - ! - ! each component will run on half the processors - ! - ! set color - if (rank .lt. nprocs/2) then - color = 0 - else - color = 1 - endif - - - ! Split MPI_COMM_WORLD into communicators for each component. - call MPI_COMM_SPLIT(MPI_COMM_WORLD,color,0,splitcomm,ierr) - - - ! Start the components - select case (color) - case(0) - call model(splitcomm,ncomps,AtmID) - case(1) - call coupler(splitcomm,ncomps,CplID) - case default - print *, "color error, color = ", color - end select - - ! Components are done - call MPI_FINALIZE(ierr) - - - end program master diff --git a/cesm/models/utils/mct/examples/climate_concur1/model.F90 b/cesm/models/utils/mct/examples/climate_concur1/model.F90 deleted file mode 100644 index 32729d0..0000000 --- a/cesm/models/utils/mct/examples/climate_concur1/model.F90 +++ /dev/null @@ -1,198 +0,0 @@ -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!----------------------------------------------------------------------- -! CVS $Id: model.F90,v 1.8 2004-04-23 20:56:23 jacob Exp $ -! CVS $Name: $ -!BOP ------------------------------------------------------------------- -! -! !ROUTINE: model -- generic model for unit tester -! -! !DESCRIPTION: -! A generic model subroutine to test functionality of MCT. -! -! !INTERFACE: -! - subroutine model (comm,ncomps,compid) -! -! !USES: -! -! Get the things needed from MCT by "Use,only" with renaming: -! -!---Component Model Registry - use m_MCTWorld,only: MCTWorld_init => init - use m_MCTWorld,only: MCTWorld_clean => clean -!---Domain Decomposition Descriptor DataType and associated methods - use m_GlobalSegMap,only: GlobalSegMap - use m_GlobalSegMap,only: GlobalSegMap_init => init - use m_GlobalSegMap,only: GlobalSegMap_lsize => lsize - use m_GlobalSegMap,only: GlobalSegMap_clean => clean - use m_GlobalSegMap,only: GlobalSegMap_Ordpnts => OrderedPoints -!---Field Storage DataType and associated methods - use m_AttrVect,only : AttrVect - use m_AttrVect,only : AttrVect_init => init - use m_AttrVect,only : AttrVect_clean => clean - use m_AttrVect,only : AttrVect_indxR => indexRA - use m_AttrVect,only : AttrVect_importRAttr => importRAttr -!---Intercomponent communications scheduler - use m_Router,only: Router - use m_Router,only: Router_init => init - use m_Router,only: Router_clean => clean -!---Intercomponent transfer - use m_Transfer,only : MCT_Send => send - use m_Transfer,only : MCT_Recv => recv -!---Stored Grid data - - implicit none - - include "mpif.h" - -! !INPUT PARAMETERS: - - integer,intent(in) :: comm ! MPI communicator for this component - integer,intent(in) :: ncomps ! total number of models in coupled system - integer,intent(in) :: compid ! the integer id of this model -! -!EOP ___________________________________________________________________ - -! local variables - -! parameters for this model - character(len=*), parameter :: modelname='model.F90' - integer,parameter :: nxa = 128 ! number of points in x-direction - integer,parameter :: nya = 64 ! number of points in y-direction - - integer :: i,j,k - -! note decleration of instances of MCT defined types. -! MPI variables - integer :: rank, nprocs, root, CplID, ierr -! Grid variables - integer :: localsize -! GlobalSegMap variables - type(GlobalSegMap) :: GSMap ! MCT defined type - integer,dimension(1) :: start,length - integer, dimension(:), pointer :: points -! AttrVect variables - type(AttrVect) :: AV ! MCT defined type - real, dimension(:), pointer :: avdata - integer :: avsize -! Router variables - type(Router) :: Rout ! MCT defined type -! _____________________________________________________________________ - - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! INITIALIZATION PHASE -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - ! Get local rank and size - call MPI_COMM_RANK (comm,rank, ierr) - call MPI_COMM_SIZE(comm,nprocs,ierr) - root = 0 - - if(rank==0) write(6,*) modelname,' MyID ', compid - if(rank==0) write(6,*) modelname,' Num procs ', nprocs - - ! Initialize MCTworld - call MCTWorld_init(ncomps,MPI_COMM_WORLD,comm,compid) - - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! Initialize a Global Segment Map - - ! set up a 1-d decomposition. - ! there is just 1 segment per processor - localsize = nxa*nya / nprocs - - ! we'll use the distributed init of GSMap so - ! initialize start and length arrays for this processor - start(1) = (rank*localsize) + 1 - length(1) = localsize - - ! initialize the GSMap - call GlobalSegMap_init(GSMap,start,length,root,comm,compid) - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - - ! Use a GSMap function: - ! return the points local to this processor - ! in their assumed order. - call GlobalSegMap_Ordpnts(GSMap,rank,points) - - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! Initialize an Attribute vector - - ! size is the number of grid point on this processor - avsize = GlobalSegMap_lsize(GSMap,comm) - if(rank==0) write(6,*) modelname, ' localsize ', avsize - - ! initialize Av with two real attributes. - call AttrVect_init(AV,rList="field1:field2",lsize=avsize) - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! Initialize a router to the coupler component. - ! - ! Need to know the integer ID of the coupler. - CplID = 2 - call Router_init(CplID,GSMap,comm,Rout) - - ! create an array used in RUN - allocate(avdata(avsize),stat=ierr) -!!! END OF INIT !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! RUN PHASE -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - - do j=1,10 ! "timestep" loop - - - ! model calculations - - - ! load data into aV - ! load the first field using "import" method. - ! First field will be a constant real number. - avdata=30.0 - call AttrVect_importRAttr(AV,"field1",avdata) - - ! Load the second field using direct access - ! Second field will be the indicies of each grid point - ! in the grid point numbering scheme. - do i=1,avsize - AV%rAttr(AttrVect_indxR(AV,"field2"),i) = points(i) - enddo - - ! Send the data - ! this is a synchronization point between the coupler and - ! this model. - if(rank==0) write(6,*) modelname,' sending data step ',j - call MCT_Send(AV,Rout) - - - ! more model calculations - - - enddo - -!!! END OF RUN !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! FINALIZE PHASE -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! clean up - call Router_clean(Rout) - call AttrVect_clean(AV) - call GlobalSegMap_clean(GSMap) - call MCTWorld_clean() - if(rank==0) write(6,*) modelname,' done' -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - end subroutine model - diff --git a/cesm/models/utils/mct/examples/climate_sequen1/.gitignore b/cesm/models/utils/mct/examples/climate_sequen1/.gitignore deleted file mode 100644 index d7d8bc5..0000000 --- a/cesm/models/utils/mct/examples/climate_sequen1/.gitignore +++ /dev/null @@ -1,4 +0,0 @@ -MCT* -*.mod -climate -TS1out.dat diff --git a/cesm/models/utils/mct/examples/climate_sequen1/Makefile b/cesm/models/utils/mct/examples/climate_sequen1/Makefile deleted file mode 100644 index ebd7582..0000000 --- a/cesm/models/utils/mct/examples/climate_sequen1/Makefile +++ /dev/null @@ -1,51 +0,0 @@ - -SHELL = /bin/sh - -# SOURCE FILES - -SRCS_F90 = mutils.F90 srcmodel.F90 dstmodel.F90 coupler.F90 master.F90 - -OBJS_ALL = $(SRCS_F90:.F90=.o) - -# MACHINE AND COMPILER FLAGS - -include ../../Makefile.conf - -# ADDITIONAL FLAGS SPECIFIC FOR UTMCT COMPILATION - -MCTLIBS = -L$(MPEUPATH) -L$(MCTPATH) -lmct -lmpeu -UTLDFLAGS = $(REAL8) -UTCMPFLAGS = $(REAL8) $(INCFLAG)$(MPEUPATH) $(INCFLAG)$(MCTPATH) - -# TARGETS - -all: climate - -climate: $(OBJS_ALL) - $(FC) -o $@ $(OBJS_ALL) $(FCFLAGS) $(UTLDFLAGS) $(MCTLIBS) $(MPILIBS) - -# RULES - -.SUFFIXES: -.SUFFIXES: .F90 .o - -.F90.o: - $(FC) -c $(INCPATH) $(FPPDEFS) $(FCFLAGS) $(MCTFLAGS) $(UTCMPFLAGS) $< - -clean: - ${RM} *.o *.mod climate - -# DEPENDENCIES: - -$(OBJS_ALL): $(MCTPATH)/libmct.a - - - - - - - - - - - diff --git a/cesm/models/utils/mct/examples/climate_sequen1/README b/cesm/models/utils/mct/examples/climate_sequen1/README deleted file mode 100644 index 890c56a..0000000 --- a/cesm/models/utils/mct/examples/climate_sequen1/README +++ /dev/null @@ -1,42 +0,0 @@ - -This program demonstrates the use of MCT in a simple -coupled system consisting of two models and a coupler. - -The grids used are taken from a real climate model. -"srcmodel" uses an atmosphere grid and "coupler" interpolates -data on it to an ocean grid in "dstmodel" - -The srcmodel reads in a temperature field TS1.dat on the the atmosphere grid. -dstmodel outputs the interpolated temperature field to TS1out.dat - -srcmodel,dstmodel and coupler are broken into init, run and finalize phases. - -The model and coupler run sequentially on a pool of processors - -master.F90 - the top level program -srcmodel.F90 - the first component, an atmosphere model. -dstmodel.F90 - the second component, an ocean model. -coupler.F90 - the third component, a coupler which takes - the atmosphere data and maps it to - the ocean grid. - ------------------------------------------------------ -To compile: -First make sure you have compiled MCT. See instructions in -MCT/README - -Type "make" here or "make examples" in the top-level directory. - -The executable is called "climate" - ------------------------------------------------------ -To run: -"climate" requires a data file of interpolation weights in -the directory MCT/data. If this directory was not present when -you untarred MCT, you can get it from the MCT website. - -climate requires at least 1 MPI processes to run but can run on -any even number of processors. Consult your -local documentation for how to run parallel programs. - -Typical command: mpirun -np 8 climate diff --git a/cesm/models/utils/mct/examples/climate_sequen1/TS1.dat b/cesm/models/utils/mct/examples/climate_sequen1/TS1.dat deleted file mode 100644 index 6e9ce15..0000000 --- a/cesm/models/utils/mct/examples/climate_sequen1/TS1.dat +++ /dev/null @@ -1,8193 +0,0 @@ -128 64 -210.598221 -210.370956 -210.200317 -209.999313 -209.773987 -209.545242 -209.338638 -209.079834 -208.818771 -208.530273 -208.189346 -207.917847 -207.668228 -207.482681 -207.322525 -207.134918 -206.982986 -206.822006 -206.676392 -206.721191 -206.731567 -206.764267 -206.714890 -206.735657 -206.747650 -206.827255 -206.850861 -206.983688 -207.129868 -207.300278 -207.427399 -207.649628 -207.937622 -208.207809 -208.546432 -208.819489 -209.170090 -209.519623 -209.858063 -210.218704 -210.569855 -210.952911 -211.282089 -211.552551 -211.894699 -212.337753 -212.782440 -213.256454 -213.748413 -214.255295 -214.766602 -215.275497 -215.744263 -216.132645 -216.580765 -217.098587 -217.593170 -218.020859 -218.403473 -218.774872 -219.153122 -219.486679 -219.813370 -220.131027 -220.357315 -220.542770 -220.604584 -220.937531 -221.070450 -221.289825 -221.557281 -221.853806 -222.160858 -222.459793 -222.693054 -222.786880 -222.874527 -222.896362 -222.825470 -222.752060 -222.734604 -222.658218 -222.471939 -222.252823 -222.029297 -221.792542 -221.557983 -221.311111 -220.990540 -220.650986 -220.355820 -219.980530 -219.635452 -219.326462 -218.962769 -218.577789 -218.222351 -217.879379 -217.496918 -217.081879 -216.670471 -216.243790 -215.800110 -215.363174 -214.910431 -214.569214 -214.127563 -213.685287 -213.289276 -212.880142 -213.003998 -213.130981 -213.308594 -213.289597 -212.976425 -212.866028 -212.840363 -212.713272 -212.476395 -212.316055 -212.394791 -212.154297 -211.890137 -211.663696 -211.405029 -211.171967 -211.026276 -210.856613 -213.167435 -212.562256 -212.014374 -211.504456 -211.025330 -210.481094 -209.938019 -209.340591 -208.417923 -207.137955 -205.945206 -204.466553 -202.577072 -200.389435 -198.414307 -196.707825 -195.323639 -194.249283 -192.984116 -191.853104 -190.434647 -190.028534 -189.964020 -189.970642 -190.117691 -190.522552 -191.164093 -191.902359 -192.807236 -193.725388 -194.719238 -195.973923 -197.250046 -199.003326 -200.910721 -202.147079 -203.195541 -203.966690 -205.127243 -206.276566 -206.781235 -207.342941 -207.898224 -208.407654 -209.211517 -210.186508 -211.245926 -212.426620 -213.630768 -214.591736 -215.851624 -217.332382 -218.879410 -220.246094 -221.651947 -223.145447 -224.005936 -224.752151 -225.357178 -226.345139 -227.101364 -228.065659 -228.966431 -229.100510 -230.123230 -230.977768 -231.241364 -231.654526 -231.855270 -235.246109 -235.445724 -235.503387 -235.447708 -235.248032 -233.090515 -232.651276 -232.059616 -231.876999 -231.778717 -231.750641 -231.459259 -230.894257 -230.159058 -229.533539 -229.958359 -229.331268 -228.658630 -227.984222 -227.349060 -226.695679 -225.077408 -223.466232 -221.725479 -221.504913 -221.443954 -221.182358 -220.250595 -220.077789 -220.920624 -222.083618 -222.760086 -222.779373 -222.677231 -222.581085 -222.494858 -222.415268 -222.327332 -222.277954 -222.224213 -222.164093 -222.143753 -222.175461 -222.210510 -222.056595 -221.827530 -221.473419 -221.094986 -220.646164 -220.121704 -219.539032 -218.877380 -218.169312 -217.399780 -216.614441 -215.835999 -215.063995 -214.336258 -213.638046 -215.556839 -214.143646 -212.680069 -211.400772 -210.178741 -208.861877 -207.274490 -205.058029 -202.457718 -199.698135 -197.382919 -195.492950 -194.106613 -192.725250 -191.600372 -190.947159 -190.290909 -189.465027 -186.893555 -185.100830 -184.374512 -184.130112 -183.782822 -183.367874 -183.250015 -183.133804 -183.022476 -183.095383 -183.638931 -184.575165 -185.803024 -187.062988 -188.894089 -190.552078 -192.286118 -193.417603 -195.194046 -197.707962 -200.826935 -203.688507 -205.255905 -205.875717 -206.337860 -206.663528 -207.365692 -207.999008 -208.404755 -209.958054 -211.473389 -213.113861 -214.949188 -217.032959 -219.286453 -221.279465 -223.460953 -225.035309 -226.788651 -227.175400 -228.037872 -235.137680 -236.596985 -237.839508 -238.908478 -239.669586 -240.169785 -240.624069 -240.848145 -240.866089 -240.343811 -240.016068 -239.366928 -238.294479 -237.757645 -237.197769 -226.152878 -225.532440 -224.927856 -225.174408 -225.600693 -226.000214 -226.331573 -226.283493 -226.036835 -225.600281 -224.700211 -223.377274 -222.089157 -220.716812 -220.822800 -219.998932 -218.664337 -217.075836 -216.318375 -216.012772 -216.365967 -216.833740 -217.248184 -218.718140 -220.790848 -224.842697 -227.980240 -228.560654 -228.919907 -229.107925 -229.643784 -230.317825 -230.689423 -231.045853 -231.218002 -231.631363 -232.147446 -232.725494 -233.351242 -233.979721 -234.391464 -233.847321 -233.173294 -232.267868 -231.373795 -229.994705 -228.617630 -226.905823 -225.032150 -223.399902 -221.907013 -220.051224 -218.387192 -216.907990 -216.803253 -214.330490 -212.666077 -211.305756 -209.714539 -208.160431 -206.624924 -204.745132 -202.388794 -200.705963 -199.604858 -198.958603 -198.529282 -198.494705 -198.366898 -198.511841 -198.526398 -198.483109 -198.481888 -196.241806 -194.316101 -195.219955 -196.749954 -198.072418 -198.284668 -197.068298 -194.908432 -191.956192 -189.250092 -186.491058 -184.236938 -183.249725 -183.637604 -184.810577 -186.584885 -189.267258 -191.118713 -192.881485 -194.483322 -196.234467 -197.321030 -198.656067 -199.488083 -200.601730 -201.736862 -202.883148 -204.424118 -205.990936 -207.530136 -209.261200 -211.170059 -213.168182 -215.410522 -217.802292 -221.807510 -225.082321 -227.731567 -230.305405 -234.507309 -236.748611 -238.697388 -240.269302 -241.385284 -241.801010 -242.278534 -242.475616 -241.820312 -240.339005 -238.250641 -235.985336 -235.027740 -235.721375 -235.590530 -236.166336 -227.330338 -227.829422 -225.608932 -225.338638 -226.067764 -226.972641 -228.235962 -229.247818 -229.865173 -229.445694 -228.165390 -226.516830 -224.984421 -223.781662 -222.570251 -220.534103 -219.150116 -218.304306 -217.669205 -217.182922 -217.995422 -219.271072 -220.411377 -222.585175 -224.228394 -225.086761 -228.922073 -232.388336 -232.858475 -233.568344 -234.537537 -235.637100 -236.969269 -238.463333 -239.950439 -233.884460 -234.261917 -235.947968 -237.480743 -246.237122 -246.724487 -246.729843 -242.308350 -241.468597 -238.629440 -233.350159 -232.267059 -230.252396 -227.592026 -224.840179 -222.396255 -223.133240 -220.707642 -219.132935 -217.075272 -212.818604 -209.693283 -207.163101 -205.337723 -203.381042 -202.002075 -200.424271 -199.532822 -200.810440 -202.920486 -204.497971 -205.334732 -205.805710 -206.097427 -206.785324 -207.351974 -207.284286 -207.248703 -206.631348 -204.505142 -204.932251 -205.157883 -205.533630 -205.957703 -205.994156 -206.462448 -206.938202 -206.845764 -205.541077 -203.267120 -199.568680 -196.129684 -193.607971 -194.003128 -195.612839 -197.663803 -198.066711 -198.175110 -198.009781 -197.872818 -197.890167 -197.997025 -197.955460 -198.879669 -200.427582 -201.480591 -202.802475 -204.993851 -207.465668 -209.653366 -212.042679 -214.537018 -217.207047 -220.008331 -222.901230 -225.834305 -228.763412 -231.508957 -235.266205 -237.701294 -239.822601 -241.556580 -242.849701 -243.441254 -243.835724 -244.082169 -243.937134 -243.518021 -242.543228 -239.571030 -237.307816 -235.659332 -235.331055 -237.555786 -237.983734 -227.302689 -226.626282 -226.627762 -226.923370 -227.548691 -228.518768 -233.553268 -233.180557 -231.671539 -229.297409 -226.110962 -224.788040 -224.307465 -224.276642 -224.250275 -224.226349 -224.249619 -224.540970 -224.784851 -224.899216 -224.615601 -224.265488 -224.227798 -225.339493 -227.531403 -228.531525 -229.157959 -230.206482 -231.741028 -236.652466 -238.289352 -240.121048 -242.116043 -244.084290 -246.014084 -247.713684 -248.578842 -248.167892 -248.566437 -248.895050 -249.638535 -249.198868 -240.670593 -238.254501 -234.596741 -231.307693 -229.274506 -228.187164 -225.986938 -227.384964 -224.577286 -221.570511 -233.674194 -231.766693 -230.290558 -228.810776 -226.972916 -224.844421 -221.683044 -219.777649 -218.624634 -218.878876 -219.472687 -220.139496 -220.303497 -219.374481 -217.834381 -216.290939 -214.593552 -212.577652 -211.100952 -211.091675 -210.422791 -208.266266 -207.504425 -209.187073 -211.201569 -209.356781 -209.906860 -212.042496 -214.548691 -220.531525 -220.352341 -215.327454 -207.993683 -205.045975 -205.060623 -205.866959 -205.786850 -205.538513 -204.943970 -204.880371 -204.659744 -204.709122 -203.280991 -202.153885 -203.263855 -204.885345 -205.702637 -206.837646 -208.926666 -211.051392 -213.485641 -215.877701 -218.358414 -220.931931 -223.410675 -225.733551 -228.032791 -230.226654 -232.499664 -234.857681 -237.059677 -240.249039 -242.322754 -243.976822 -245.226059 -246.032501 -246.406494 -246.443176 -246.180862 -245.751923 -245.185150 -243.538345 -240.405624 -239.348785 -238.994873 -239.435455 -240.171463 -240.269211 -240.193787 -239.949814 -239.742096 -239.719116 -240.075119 -240.776276 -241.193054 -234.442001 -240.280457 -239.104736 -238.409805 -237.937637 -237.865448 -237.386124 -236.494034 -232.030960 -233.395798 -233.877304 -234.296600 -234.369064 -234.960968 -235.306015 -235.436157 -235.978806 -236.175079 -236.420105 -237.009018 -237.998825 -239.358215 -242.386658 -244.207108 -246.046600 -247.820633 -249.402542 -251.017044 -252.288940 -252.520233 -252.438110 -251.875015 -250.971695 -248.615524 -246.374710 -243.145737 -240.921326 -231.697464 -230.287155 -229.651566 -231.731689 -236.549210 -235.273453 -241.647888 -241.563858 -241.577255 -241.488342 -241.050125 -240.381561 -238.435043 -236.724564 -236.911743 -237.364456 -238.172852 -238.720047 -239.087982 -239.064896 -237.673416 -235.307007 -231.666153 -226.408035 -221.938004 -219.849472 -219.547806 -217.750092 -217.415985 -219.228638 -222.837601 -226.718109 -231.130997 -236.459869 -239.557327 -239.733368 -237.241928 -232.325134 -226.267807 -221.730621 -220.718689 -222.741821 -221.684662 -220.566879 -219.095505 -217.708908 -216.635040 -216.239120 -216.149796 -216.250519 -216.348984 -216.308731 -216.181351 -216.253021 -216.634979 -217.657379 -219.376923 -221.368530 -223.879532 -226.487610 -229.064529 -231.016373 -232.477173 -233.763885 -234.739105 -235.854614 -237.255753 -240.270844 -242.283463 -244.228958 -245.873520 -246.957321 -247.533920 -247.733551 -247.620361 -247.240509 -246.763062 -246.293381 -245.924805 -245.536118 -244.966049 -244.618484 -244.249115 -244.080643 -243.951401 -243.963531 -244.089920 -244.293488 -244.600174 -244.911285 -245.035950 -244.990753 -244.516235 -243.776459 -243.028473 -242.634949 -241.989227 -241.559769 -240.780396 -240.651596 -240.678833 -240.986801 -241.551239 -242.032562 -242.347351 -242.470444 -242.354141 -242.065781 -241.810623 -240.813141 -240.803055 -241.600952 -242.604828 -244.836624 -246.318222 -247.883957 -249.172119 -250.429871 -251.156616 -251.757172 -253.076294 -253.409271 -252.756409 -250.574570 -249.624023 -247.305374 -246.143738 -244.985901 -244.100540 -242.950470 -242.065292 -238.393127 -240.074860 -242.011047 -248.560425 -248.369232 -248.228989 -248.124649 -247.922943 -247.543182 -246.991180 -246.257065 -245.402115 -244.688126 -244.208969 -244.054367 -244.114288 -243.681351 -243.043854 -239.749405 -239.431793 -237.868866 -235.753128 -233.133560 -230.818161 -229.447495 -229.773438 -232.099960 -235.966873 -242.815628 -248.433365 -251.144333 -251.804398 -248.780624 -246.646194 -244.207458 -239.708435 -238.320419 -237.095413 -236.195862 -235.080215 -234.204468 -233.162674 -232.286148 -231.844482 -231.671051 -231.545959 -231.209808 -230.402130 -229.014374 -227.202591 -225.376328 -224.090317 -223.763229 -224.561493 -226.258163 -228.323685 -232.464325 -227.765762 -235.967834 -236.834442 -237.007812 -237.224182 -237.560440 -236.882858 -238.725052 -240.611023 -242.861053 -245.012619 -246.806793 -248.132980 -248.892868 -249.370560 -249.504425 -249.000244 -248.332611 -247.642822 -246.833740 -246.374100 -246.109879 -246.124512 -246.426910 -246.857285 -247.159607 -247.252274 -247.155426 -246.818588 -246.232391 -245.663559 -245.243240 -245.042068 -244.669373 -244.152802 -243.503418 -242.897263 -242.431366 -242.032593 -241.791153 -241.841644 -242.249863 -242.987534 -243.963226 -245.015060 -246.023743 -246.797180 -247.412277 -247.853516 -248.207443 -248.381622 -247.375809 -248.929626 -249.250320 -249.813873 -250.607330 -251.437881 -251.941452 -252.757812 -253.399261 -253.757568 -253.844879 -253.831039 -252.951538 -251.238876 -249.642685 -249.233582 -248.723206 -248.573288 -248.478531 -248.782654 -248.899124 -248.792480 -248.734940 -258.557220 -258.505646 -257.810181 -256.639191 -255.411148 -254.010483 -252.732178 -251.542892 -250.241898 -248.964355 -247.691467 -246.481705 -245.583878 -245.857437 -245.969803 -246.261154 -246.706787 -246.671906 -245.939911 -244.849060 -243.761597 -243.161652 -243.664917 -245.415344 -248.177887 -252.080460 -256.314117 -258.248413 -258.366577 -257.311859 -255.547623 -252.558380 -250.714615 -250.067398 -249.588455 -249.108063 -248.532639 -247.699600 -246.767624 -245.961929 -245.740891 -246.115860 -246.831268 -247.425919 -247.374924 -246.367233 -244.456070 -242.050140 -239.797256 -238.327301 -237.909103 -238.621552 -239.992477 -241.275772 -241.817230 -241.753815 -241.639816 -241.436356 -241.920883 -242.477615 -243.142319 -244.339874 -245.988068 -247.566025 -249.295059 -251.188568 -253.076019 -254.260925 -255.326767 -256.095917 -256.057953 -255.536560 -254.447784 -252.639938 -251.036072 -250.247498 -250.327698 -250.976669 -252.456467 -253.944321 -254.573898 -254.902069 -254.253860 -253.066162 -252.260345 -251.261536 -250.158615 -249.016098 -247.917328 -247.096786 -246.412323 -245.697128 -244.972504 -244.631882 -244.938675 -245.872604 -247.344315 -249.211578 -251.333481 -253.471939 -254.680649 -255.519562 -256.252106 -257.019043 -257.411438 -256.582733 -254.931778 -254.267059 -253.746490 -253.566498 -253.864548 -254.528732 -255.179321 -255.838425 -256.246979 -256.338745 -256.289581 -255.836777 -254.964218 -253.893906 -252.838593 -252.136093 -252.008408 -252.580963 -253.771606 -255.261963 -256.737152 -257.906799 -268.072296 -268.586670 -268.314728 -267.356903 -265.898376 -263.972809 -261.564636 -259.257660 -256.889832 -254.743210 -253.002686 -251.409027 -249.706772 -248.684296 -247.991470 -248.406128 -248.770508 -249.065582 -250.180084 -250.634506 -250.590302 -250.362122 -250.363251 -250.912277 -252.114761 -253.839066 -256.294708 -258.334869 -259.414337 -259.174652 -259.972626 -259.292542 -258.190369 -257.421173 -256.768372 -256.124115 -255.614548 -255.188187 -254.860031 -255.158752 -256.130188 -257.863007 -260.090881 -262.369293 -271.407104 -271.512756 -271.641418 -271.765808 -271.796997 -271.808960 -271.768951 -271.646973 -271.497284 -271.481445 -271.474243 -271.506073 -271.515991 -271.434570 -255.415192 -271.654144 -271.763824 -272.168732 -272.224487 -272.197266 -272.163483 -272.145477 -272.128143 -272.110657 -272.098419 -272.067688 -271.997772 -271.876465 -271.465485 -271.413879 -271.349854 -258.953918 -258.900208 -260.095337 -271.470551 -271.554962 -271.883484 -272.018219 -272.294312 -272.577179 -272.774384 -272.880585 -272.948944 -273.015839 -273.076111 -273.137329 -273.200195 -273.261505 -273.305878 -273.322662 -273.321625 -273.310822 -273.270386 -273.179657 -272.995392 -272.698151 -272.339844 -272.260284 -272.112274 -271.890900 -272.402832 -271.172791 -268.963959 -265.997772 -263.500885 -261.785156 -260.678436 -259.832703 -259.157074 -258.772949 -258.687775 -258.697235 -258.765533 -258.751404 -258.503113 -258.026428 -257.532501 -257.265747 -257.572113 -258.619415 -260.379700 -262.604553 -264.846283 -266.785828 -270.714447 -271.029266 -270.822845 -270.120819 -269.055450 -267.379028 -265.740967 -264.233521 -262.387878 -260.484711 -259.021179 -257.235382 -255.900681 -254.511719 -251.002579 -248.309540 -248.258606 -248.981857 -249.812683 -250.839996 -251.797379 -252.427017 -252.498260 -252.765457 -253.601242 -254.423065 -255.435699 -256.653656 -258.129517 -259.548370 -260.590057 -260.701477 -260.686798 -260.622101 -260.905792 -260.850006 -261.009827 -261.527191 -262.515961 -271.518890 -271.827606 -271.955597 -272.035309 -272.287994 -272.507965 -272.627350 -272.728058 -272.865021 -272.964447 -273.001373 -272.985474 -272.926086 -272.876160 -272.850677 -272.896454 -273.191833 -273.441223 -273.699860 -273.726074 -274.204285 -274.557953 -274.742188 -274.693085 -274.565399 -274.483582 -274.443176 -274.376892 -274.278168 -274.163635 -274.032410 -273.866669 -273.647919 -273.345520 -273.040497 -272.714417 -272.538574 -272.443848 -272.477875 -272.736816 -273.032104 -273.386261 -273.679108 -273.928436 -274.113708 -274.205719 -274.248596 -274.285492 -274.354309 -274.451874 -274.552246 -274.667023 -274.760010 -274.823334 -274.849518 -274.844025 -274.863708 -274.905609 -274.935944 -274.947937 -274.921448 -274.870575 -274.776398 -274.600922 -274.326385 -273.843353 -273.264709 -271.743927 -270.968689 -269.189331 -267.882751 -266.812286 -265.737976 -264.570312 -263.305206 -262.012085 -261.010956 -260.522156 -260.523224 -260.655334 -260.951477 -261.415100 -262.028168 -262.957001 -264.139435 -265.624054 -267.299805 -268.891418 -270.065155 -271.449585 -271.680939 -271.506927 -270.984467 -270.481415 -269.705719 -268.961823 -268.373444 -271.658875 -271.964172 -272.144928 -272.241730 -272.277893 -272.254395 -272.170410 -272.075409 -272.026581 -272.048004 -272.151215 -272.212280 -272.266785 -272.283783 -272.304749 -272.269958 -272.207794 -272.053253 -271.560242 -260.486389 -261.257874 -262.219055 -263.694794 -272.160645 -272.418304 -272.498627 -272.471100 -272.407471 -272.371246 -272.388123 -272.469757 -272.517059 -272.778229 -273.005920 -273.233826 -273.555145 -273.840118 -273.998077 -274.133453 -274.339233 -274.468933 -274.486938 -274.449738 -274.410980 -274.528900 -274.778778 -275.048370 -275.376251 -275.677216 -275.976410 -276.429626 -276.972961 -277.367889 -277.409882 -277.118195 -276.829285 -276.718750 -276.700836 -276.632233 -276.487823 -276.326996 -276.174164 -275.991699 -275.811554 -275.597260 -275.307495 -275.006012 -274.751526 -274.639252 -274.760834 -274.984955 -275.135895 -275.243683 -275.402191 -275.629425 -275.811523 -275.843781 -275.792206 -275.762970 -275.804810 -275.903320 -276.010223 -276.100647 -276.153351 -276.207031 -276.251465 -276.271423 -276.304596 -276.368958 -276.456451 -276.561340 -276.664917 -276.786102 -276.910797 -276.964294 -276.956848 -276.847473 -276.503845 -275.660797 -274.836426 -274.098358 -273.389648 -272.348511 -272.424744 -271.422394 -270.162079 -268.572601 -266.545807 -264.845734 -263.863159 -263.600647 -263.784760 -264.395325 -264.868195 -265.653107 -266.823608 -268.033905 -269.270874 -270.186707 -270.969818 -272.166168 -272.242493 -272.227539 -272.192017 -272.151001 -272.252350 -272.284912 -272.246368 -272.520691 -272.757721 -273.000366 -273.174927 -273.242950 -273.183472 -273.045593 -272.918823 -272.881653 -272.952576 -273.082336 -273.184662 -273.246033 -273.310883 -273.341461 -273.308075 -273.276367 -273.169861 -272.976562 -272.798462 -272.685699 -272.786224 -273.143738 -273.594330 -273.915833 -273.919281 -273.744476 -273.607849 -273.523407 -273.498199 -273.530365 -273.601501 -273.855042 -274.201080 -274.587036 -275.033600 -275.421204 -275.703125 -275.909119 -276.153534 -276.294647 -276.265503 -276.209015 -276.265442 -276.608948 -277.140717 -277.556519 -277.862396 -278.105194 -278.421051 -278.930450 -279.433960 -279.715393 -279.647919 -279.166534 -278.745972 -278.639954 -278.716064 -278.764557 -278.676544 -278.530701 -278.422729 -278.318420 -278.244507 -278.149109 -277.983917 -277.782471 -277.602814 -277.491699 -277.519318 -277.581909 -277.527679 -277.423218 -277.408600 -277.496552 -277.549744 -277.449097 -277.267151 -277.136169 -277.151581 -277.253143 -277.327820 -277.337585 -277.309113 -277.310974 -277.332184 -277.350342 -277.371002 -277.413727 -277.501526 -277.658966 -277.901001 -278.253052 -278.599304 -278.686584 -277.688416 -277.686249 -278.073700 -277.575256 -276.995178 -276.327271 -275.642975 -275.024689 -274.384247 -273.866302 -273.626190 -273.574432 -273.555695 -273.355865 -272.845093 -272.391205 -272.477448 -272.726593 -272.828857 -272.806305 -272.693298 -272.512878 -272.317657 -272.172119 -272.102264 -274.039978 -274.109344 -274.111389 -274.056213 -273.944183 -273.887817 -273.796143 -273.622620 -273.679413 -273.936462 -274.249146 -274.508026 -274.529724 -274.380249 -274.193817 -274.073517 -274.053619 -274.114014 -274.240631 -274.344360 -274.415375 -274.496948 -274.501923 -274.427734 -274.398834 -274.333649 -274.177124 -274.047943 -274.056030 -274.325531 -274.890472 -275.531738 -275.915375 -275.773041 -275.390472 -275.153473 -275.054382 -275.012207 -275.022308 -275.101379 -275.407990 -275.867371 -276.387939 -276.937134 -277.466980 -277.906616 -278.183594 -278.396332 -278.509094 -278.499847 -278.527222 -278.689270 -279.085022 -279.602264 -279.978333 -280.203674 -280.340668 -280.567383 -280.979248 -281.248199 -281.140320 -280.822540 -280.384430 -280.063110 -280.043396 -280.266479 -280.526794 -280.571472 -280.474274 -280.417969 -280.415924 -280.448364 -280.427124 -280.329132 -280.188385 -280.039093 -279.883362 -279.736237 -279.584503 -279.419220 -279.246338 -279.086853 -278.965057 -278.836212 -278.627747 -278.368530 -278.192078 -278.218414 -278.334534 -278.380432 -278.333374 -278.239258 -278.176666 -278.153046 -278.155975 -278.183807 -278.239319 -278.356659 -278.590668 -278.973755 -279.478882 -279.805115 -278.479431 -277.843658 -279.070831 -278.827118 -278.490631 -278.067444 -277.599335 -277.165955 -276.806213 -276.346832 -275.821106 -275.448792 -275.257996 -275.093811 -274.849152 -274.545837 -274.388458 -274.431793 -274.513580 -274.496002 -274.353912 -274.117035 -273.809387 -273.603760 -273.609772 -273.778046 -276.265076 -276.390015 -276.394897 -276.369202 -276.338013 -276.287415 -276.111877 -275.803436 -275.684357 -275.814728 -276.169342 -276.441803 -276.343262 -276.037811 -275.793610 -275.691620 -275.601898 -275.468140 -275.452911 -275.606903 -275.932922 -276.254150 -276.253448 -275.992493 -275.867523 -275.944336 -276.055389 -276.143005 -276.261475 -276.608185 -277.272430 -277.931610 -278.196381 -277.948120 -277.481659 -277.219269 -277.194031 -277.273651 -277.438171 -277.666046 -278.060730 -278.497986 -278.895172 -279.328247 -279.825562 -280.230865 -280.459839 -280.616455 -280.729919 -280.807068 -280.913605 -281.068207 -281.339203 -281.665802 -281.874146 -281.948914 -281.988312 -282.153839 -282.484375 -282.571930 -282.120422 -281.533478 -281.167969 -281.029419 -281.135803 -281.504791 -281.954193 -282.128662 -282.075073 -281.980225 -281.925049 -281.906921 -281.833038 -281.668030 -281.452148 -281.239441 -281.033752 -280.820190 -280.605743 -280.435272 -280.250885 -280.021912 -279.828949 -279.673615 -279.487793 -279.306488 -279.234375 -279.299896 -279.399384 -279.433380 -279.365601 -279.216187 -279.093140 -279.039642 -279.043793 -279.104767 -279.224915 -279.418182 -279.714722 -280.150543 -280.686951 -280.958160 -278.410828 -278.998016 -279.947113 -279.610962 -279.149048 -278.749481 -278.675598 -278.907135 -279.085663 -278.902435 -278.498505 -278.107117 -277.812958 -277.511780 -277.191071 -276.865448 -276.633911 -276.555847 -276.606812 -276.616333 -276.412292 -276.089813 -275.720367 -275.505371 -275.623413 -275.919128 -278.866974 -279.017242 -279.019623 -279.044678 -279.143311 -279.154175 -279.088928 -278.939819 -278.796814 -278.760162 -278.972565 -279.032623 -278.685944 -278.180359 -277.809174 -277.604919 -277.354065 -276.982452 -276.869690 -277.302948 -278.300598 -279.315216 -279.574463 -279.134338 -278.842468 -279.066559 -279.428284 -279.560242 -279.506317 -279.662842 -280.120941 -280.484436 -280.487427 -280.248596 -279.981537 -279.929718 -280.063934 -280.268585 -280.512451 -280.719330 -280.978363 -281.181152 -281.326935 -281.514771 -281.769867 -281.966431 -282.052399 -282.137604 -282.282410 -282.468475 -282.680908 -282.900635 -283.168793 -283.418152 -283.454926 -283.341919 -283.309174 -283.461243 -283.748993 -283.839569 -278.015259 -282.732483 -282.329407 -282.269989 -282.482544 -282.884521 -283.274078 -283.420349 -283.337830 -283.156769 -282.972931 -282.811890 -282.650024 -282.447968 -282.202881 -281.965057 -281.766663 -281.597778 -281.427338 -281.297058 -281.161102 -280.974304 -280.821350 -280.715240 -280.598206 -280.538605 -280.584778 -280.668396 -280.731720 -280.741272 -280.642426 -280.449615 -280.284363 -280.229248 -280.270844 -280.380524 -280.562897 -280.803925 -281.096985 -281.480347 -281.916046 -282.167267 -279.546204 -280.074402 -280.618073 -280.696594 -280.060455 -279.596985 -279.978790 -281.135834 -281.682709 -281.395905 -280.920441 -280.587769 -280.348846 -280.102936 -279.875092 -279.585266 -279.304810 -279.165375 -279.216187 -279.200531 -278.919556 -278.615936 -278.413879 -278.335968 -278.446503 -278.633972 -281.455231 -281.611389 -281.686890 -281.870850 -282.260803 -282.373383 -282.655365 -282.881287 -282.868195 -282.631592 -282.665161 -282.500763 -281.965149 -281.389679 -280.811615 -280.496887 -280.316925 -279.790222 -279.611816 -280.481110 -282.035278 -283.469421 -283.896393 -283.460510 -283.100647 -283.203827 -283.314514 -283.142975 -282.904205 -282.801117 -282.828888 -282.789124 -282.646484 -282.568878 -282.572754 -282.626953 -282.695557 -282.778595 -282.838776 -282.876282 -282.966858 -283.005280 -283.026398 -283.078613 -283.168762 -283.247620 -283.250824 -283.314514 -283.534515 -283.828674 -284.147156 -284.447418 -284.747314 -284.977600 -284.970734 -284.808533 -284.709930 -284.794769 -285.018555 -285.176575 -284.984955 -282.542572 -284.117340 -284.151489 -284.410156 -284.664948 -284.774261 -284.692017 -284.453735 -284.167755 -283.913269 -283.696838 -283.524017 -283.380798 -283.220581 -283.034027 -282.865021 -282.752716 -282.655823 -282.597626 -282.563232 -282.475159 -282.359131 -282.272186 -282.219757 -282.257965 -282.324951 -282.339752 -282.362946 -282.361206 -282.195068 -281.978271 -281.807068 -281.735870 -281.818024 -281.997620 -282.221344 -282.465851 -282.735199 -283.045044 -283.204285 -283.303223 -283.225067 -280.283234 -281.014496 -282.368347 -281.322571 -280.663361 -281.089142 -283.009674 -283.676483 -283.140259 -282.454712 -282.256439 -282.294830 -282.338043 -282.462341 -282.444489 -282.324524 -282.225220 -282.171783 -281.982758 -281.678711 -281.583496 -281.662659 -281.635498 -281.485291 -281.393890 -283.435089 -283.570801 -283.809479 -284.233917 -284.971436 -285.555267 -286.519226 -287.048279 -287.073059 -286.590759 -286.809753 -286.840912 -286.458893 -286.117828 -285.467133 -285.300995 -285.430511 -284.920715 -284.507874 -285.090027 -286.069519 -286.704498 -286.688721 -286.365448 -286.055939 -285.880585 -285.677185 -285.340240 -285.089935 -284.906982 -284.695831 -284.504120 -284.337189 -284.258362 -284.182404 -284.128967 -284.116211 -284.152588 -284.214661 -284.359772 -284.614960 -284.769165 -284.776184 -284.728577 -284.679749 -284.651245 -284.609100 -284.683899 -284.954468 -285.273895 -285.533417 -285.716064 -285.930389 -286.246582 -286.485138 -286.489777 -286.403900 -286.385986 -286.439423 -286.480469 -286.392609 -286.099884 -285.926147 -286.065338 -286.281830 -286.279846 -286.076111 -285.800262 -285.498627 -285.218384 -285.003967 -284.836212 -284.706604 -284.624908 -284.565857 -284.478210 -284.369751 -284.299438 -284.282806 -284.325012 -284.362122 -284.300018 -284.183258 -284.084381 -284.091492 -284.156403 -284.211823 -284.229706 -284.263000 -284.198700 -283.899689 -283.670288 -283.528564 -283.443695 -283.536133 -283.778564 -284.004120 -284.246002 -284.471008 -284.560486 -284.431793 -284.346344 -280.741974 -279.108429 -278.454071 -282.496155 -282.700256 -281.932068 -281.985168 -283.801117 -285.261475 -285.256805 -284.825073 -284.885712 -285.047943 -285.023071 -285.150726 -285.224792 -285.138763 -284.980499 -284.769775 -284.421234 -284.193817 -284.219147 -284.191376 -284.001373 -283.656586 -283.449402 -285.652130 -285.717560 -285.894409 -286.320801 -286.972321 -287.686157 -288.399963 -288.954315 -289.474701 -289.867126 -290.060974 -289.996216 -289.767700 -289.459869 -289.113953 -288.907593 -288.713287 -288.419983 -288.181946 -288.069672 -288.027527 -287.910553 -287.648651 -287.381714 -287.163055 -286.926514 -286.617920 -286.278259 -286.042053 -285.841919 -285.619965 -285.422424 -285.280792 -285.173096 -285.100220 -285.136383 -285.268768 -285.463226 -285.698853 -286.072968 -286.631378 -287.002502 -286.962830 -286.653015 -286.365021 -286.193268 -286.109619 -286.158356 -286.320343 -286.468079 -286.540497 -282.316742 -283.526581 -284.467957 -288.143921 -288.404053 -288.348816 -288.204620 -288.001617 -287.765106 -287.579590 -287.439728 -287.418152 -287.559723 -287.607208 -287.351990 -286.974823 -286.705597 -286.542297 -286.413483 -286.313965 -286.249542 -286.175293 -286.138855 -286.122894 -286.115723 -286.090912 -286.071411 -286.061493 -286.097046 -286.134216 -286.158630 -286.141541 -286.045105 -286.060120 -286.123932 -286.167908 -286.267212 -286.320801 -286.127106 -285.835632 -285.592041 -285.503448 -285.436646 -285.458862 -285.642792 -285.774323 -285.846436 -285.842590 -285.756683 -285.508331 -285.215027 -280.187653 -277.929016 -279.047333 -283.485840 -283.648376 -284.570221 -283.606201 -284.962280 -286.947540 -287.692505 -287.782928 -287.731079 -287.546814 -287.388947 -287.313232 -287.248413 -287.111481 -286.918884 -286.677002 -286.435364 -286.317474 -286.287903 -286.056366 -285.799500 -285.607025 -285.598358 -287.815826 -287.847870 -287.934784 -288.120544 -288.409973 -288.612976 -288.660553 -288.867889 -289.622681 -290.815063 -291.717316 -291.900848 -291.632843 -291.260193 -290.925537 -290.608856 -290.294159 -290.026672 -289.787689 -289.496002 -289.179779 -288.906555 -288.658630 -288.440552 -288.225067 -287.976929 -287.691223 -287.405670 -287.194153 -287.009949 -286.817047 -286.637024 -286.500671 -286.410950 -286.400818 -286.529999 -286.761139 -287.080200 -287.506775 -288.115753 -288.897797 -289.311523 -280.162598 -288.288971 -287.720184 -287.468445 -287.404572 -287.403870 -287.303802 -281.890076 -281.348999 -282.851105 -284.979309 -286.534637 -289.987061 -290.402588 -290.330566 -290.038849 -289.619446 -289.195740 -288.903351 -288.796753 -288.843964 -288.917450 -288.816925 -288.491882 -288.160919 -287.967072 -287.902222 -287.867798 -287.850769 -287.847443 -287.846161 -287.870361 -287.901428 -287.936951 -287.950378 -287.924286 -287.885254 -287.881470 -287.905212 -287.947052 -288.023682 -288.083618 -288.148895 -288.206024 -288.290680 -288.311066 -288.263062 -288.109894 -287.905579 -287.669708 -287.603577 -287.501923 -287.413025 -287.402893 -287.376801 -287.307098 -287.166809 -286.947754 -286.597137 -286.098907 -285.679199 -278.495911 -280.161224 -284.164642 -282.039001 -284.617615 -284.625336 -286.333862 -288.271088 -289.552551 -289.694061 -289.435242 -289.200104 -289.073212 -288.986206 -288.875488 -288.740723 -288.589203 -288.458862 -288.411163 -288.378082 -288.282684 -288.128906 -287.956146 -287.863770 -287.823212 -289.321259 -289.252930 -289.186798 -289.114166 -288.999023 -288.662689 -288.215851 -288.893188 -286.024628 -284.168182 -284.723175 -293.258850 -293.141388 -292.806702 -292.485748 -292.157104 -291.798309 -291.453796 -291.166321 -290.884766 -290.606628 -290.377777 -290.194061 -290.000549 -289.747528 -289.477142 -289.243683 -289.050751 -288.882385 -288.692383 -288.512329 -288.381653 -288.283020 -288.224487 -288.234985 -288.347198 -288.546967 -288.851440 -289.351776 -290.084320 -290.839905 -291.083801 -279.753662 -279.925995 -280.488678 -279.807343 -280.257935 -280.924805 -282.458740 -283.678436 -286.368774 -288.661774 -290.148834 -288.921204 -291.026550 -292.042999 -291.862762 -291.452576 -291.047455 -290.696777 -290.430725 -290.302521 -290.304535 -290.301910 -290.179779 -289.963043 -289.785858 -289.680695 -289.638702 -289.628479 -289.626831 -289.629791 -289.644226 -289.685730 -289.746185 -289.809967 -289.865387 -289.890076 -289.882355 -289.894745 -289.920715 -289.954193 -290.025330 -290.115814 -290.205902 -290.271454 -290.353394 -290.359711 -290.311401 -290.152466 -290.005524 -289.805786 -289.734192 -289.598328 -289.440460 -289.259186 -289.031799 -288.825867 -288.577515 -288.301270 -287.860565 -287.095917 -286.390045 -276.211823 -279.537811 -284.495789 -283.138763 -285.102844 -287.175873 -286.810822 -289.297913 -290.892517 -291.351257 -291.085602 -290.807678 -290.689087 -290.650909 -290.600677 -290.509003 -290.389313 -290.263123 -290.160980 -290.047852 -289.927124 -289.827698 -289.695404 -289.554382 -289.415466 -290.393250 -290.209198 -289.979034 -289.646698 -289.111176 -288.228302 -288.232849 -290.025238 -286.815094 -282.847168 -281.594666 -283.535126 -294.401062 -294.256653 -294.037964 -293.880280 -293.643768 -293.261566 -292.874237 -292.576660 -292.354065 -292.153931 -291.945374 -291.700684 -291.435028 -291.201447 -291.019043 -290.889862 -290.746704 -290.550934 -290.363708 -290.257202 -290.192017 -290.155731 -290.176788 -290.266235 -290.449738 -290.706604 -291.163910 -291.826538 -292.354309 -283.564514 -283.075470 -282.623169 -283.148193 -284.259857 -284.790894 -284.071075 -284.190826 -287.397766 -291.603790 -293.262207 -292.349915 -291.898560 -291.543488 -293.286438 -293.014160 -292.631226 -292.378632 -292.182373 -292.006775 -291.897339 -291.860626 -291.841217 -291.771423 -291.692413 -291.659698 -291.639374 -291.629150 -291.609100 -291.592377 -291.588135 -291.581482 -291.586548 -291.622040 -291.681030 -291.756287 -291.850037 -291.943634 -292.021851 -292.077087 -292.116058 -292.158783 -292.216492 -292.232056 -292.232910 -292.223846 -292.250763 -292.280914 -292.188751 -292.039703 -291.775726 -291.575409 -291.381805 -291.101135 -290.799957 -290.510406 -290.208069 -289.867920 -289.527924 -288.955017 -288.046661 -287.164307 -276.955933 -279.344818 -284.930206 -286.620300 -287.154938 -287.205536 -286.837524 -289.439606 -292.110901 -293.014008 -293.005615 -292.718903 -292.499054 -292.371490 -292.319672 -292.234955 -292.065460 -291.879791 -291.714386 -291.517273 -291.324158 -291.171783 -291.002655 -290.820129 -290.599365 -291.295776 -290.936493 -290.504791 -289.892578 -288.917999 -287.647858 -289.456970 -290.754700 -289.466278 -285.027618 -282.986938 -284.096405 -295.286530 -295.401917 -295.260162 -295.182190 -295.114563 -294.916931 -294.605560 -294.313507 -294.093018 -293.848572 -293.585175 -293.341766 -293.134033 -292.967072 -292.819885 -292.690704 -292.533539 -292.355011 -292.196930 -292.068634 -291.968445 -291.884186 -291.876373 -291.976654 -292.193909 -292.444885 -292.826813 -293.333038 -293.667084 -288.203796 -286.947418 -287.037598 -288.023499 -288.828400 -289.583740 -286.984406 -287.145660 -291.378052 -293.595764 -294.155457 -293.750946 -291.541504 -291.264038 -294.332275 -294.046661 -293.734039 -293.627655 -293.600342 -293.583954 -293.564789 -293.535431 -293.496918 -293.476807 -293.481323 -293.509857 -293.545471 -293.597809 -293.628998 -293.637299 -293.618378 -293.591583 -293.597443 -293.646759 -293.685303 -293.755554 -293.864319 -293.977020 -294.039612 -294.076111 -294.119507 -294.175598 -294.178772 -294.106964 -294.018372 -293.945190 -293.870117 -293.825256 -293.735382 -293.519592 -293.207245 -292.872223 -292.544739 -292.187225 -291.839569 -291.529938 -291.187927 -290.813538 -290.407959 -289.750397 -288.827515 -288.008728 -277.443115 -277.459137 -284.165344 -288.688568 -289.414337 -288.875153 -288.508087 -290.050995 -293.083984 -294.107025 -294.504303 -294.459778 -294.181061 -293.934937 -293.755920 -293.569214 -293.343384 -293.172791 -293.009521 -292.779663 -292.532410 -292.302673 -292.091919 -291.892090 -291.632355 -291.835663 -291.343292 -290.740814 -289.937317 -288.690979 -287.441040 -286.734833 -291.289368 -291.159454 -288.255157 -285.837921 -286.575836 -289.157745 -296.336487 -296.330048 -296.212006 -288.954163 -287.554871 -295.793304 -295.607910 -295.396332 -295.133301 -294.874054 -294.697601 -294.572296 -294.440643 -294.309509 -294.163574 -294.012543 -293.861267 -293.714813 -293.564087 -293.436493 -293.352051 -293.374756 -293.531158 -293.769684 -293.999176 -294.298920 -294.702209 -295.029388 -291.572937 -291.981598 -292.789185 -292.277161 -291.259064 -289.367737 -287.776062 -289.437592 -293.522034 -294.296783 -294.449371 -292.303711 -291.007294 -295.146912 -295.384094 -295.152130 -294.882568 -294.860779 -294.987793 -295.119537 -295.205414 -295.211578 -295.207550 -295.238892 -295.283905 -295.306641 -295.366913 -295.481232 -295.580261 -295.611572 -295.582184 -295.544250 -295.560699 -295.615997 -295.693634 -295.785400 -295.893250 -295.950745 -295.931274 -295.896637 -295.873718 -295.855957 -295.782867 -295.638916 -295.483521 -295.335724 -295.157349 -294.927460 -294.669586 -294.391724 -294.089630 -293.742981 -293.365387 -292.959320 -292.574860 -292.192810 -291.801025 -291.409851 -290.960205 -290.298126 -289.491425 -288.825806 -277.846161 -276.241669 -281.621887 -289.213684 -290.526367 -290.951111 -290.692474 -290.863739 -292.914764 -292.419373 -295.204559 -295.490082 -295.460724 -295.278259 -295.057068 -294.793335 -294.530823 -294.334167 -294.171631 -293.934082 -293.611786 -293.273407 -292.984314 -292.694275 -292.308105 -292.096649 -291.531830 -290.838440 -289.910797 -288.670166 -285.336884 -288.645294 -293.072906 -291.100250 -289.406799 -286.990387 -287.514984 -289.198486 -296.998962 -297.274353 -297.252014 -290.976166 -289.557678 -296.425232 -296.321075 -296.178009 -295.989807 -295.825500 -295.731262 -295.649384 -295.555145 -295.448395 -295.312836 -295.189178 -295.080597 -294.960205 -294.844147 -294.786652 -294.804596 -294.930908 -295.145416 -295.365417 -295.525299 -295.734375 -296.023590 -296.297974 -296.493011 -293.076416 -295.032471 -293.578857 -291.733704 -290.114471 -291.922180 -294.146393 -295.072601 -296.475769 -294.575470 -292.312744 -292.296539 -296.256775 -296.491577 -296.371796 -296.212585 -296.259979 -296.448456 -296.667450 -296.810120 -296.865540 -296.892944 -296.960693 -297.050873 -297.117706 -297.219025 -297.346741 -297.441010 -297.455261 -297.439301 -297.437958 -297.431458 -297.420441 -297.429565 -297.458008 -297.477417 -297.460022 -297.420624 -297.358276 -297.254333 -297.121643 -296.940979 -296.718292 -296.494781 -296.258209 -295.986145 -295.665222 -295.321167 -294.964600 -294.619965 -294.244812 -293.837341 -293.448730 -293.077301 -292.612946 -292.124573 -291.709137 -291.201996 -290.499634 -289.781128 -289.288727 -289.270233 -277.787079 -283.211273 -289.655121 -292.303009 -293.520508 -293.854462 -294.049835 -294.113617 -292.601654 -292.824768 -296.344177 -296.536865 -296.443329 -296.204620 -295.896820 -295.608704 -295.333099 -295.013092 -294.647247 -294.285797 -293.935181 -293.547852 -293.114014 -292.623505 -292.322144 -291.698151 -290.984619 -290.117279 -289.236847 -291.332703 -292.539429 -292.529419 -290.884430 -289.377930 -287.475433 -287.633545 -289.795105 -292.185364 -297.872620 -298.005066 -294.963654 -293.153473 -296.984619 -296.899506 -296.804504 -296.662231 -296.592896 -296.569214 -296.524902 -296.471069 -296.427612 -296.359772 -296.287048 -296.231903 -296.204956 -296.233093 -296.328796 -296.479401 -296.669922 -296.839386 -296.961029 -297.037872 -297.153717 -297.329865 -297.551544 -297.784729 -297.944305 -298.056976 -292.640900 -292.971527 -294.016876 -294.201202 -295.198029 -296.872589 -295.122498 -293.724670 -293.818604 -297.130981 -297.522064 -297.666443 -297.702118 -297.746460 -297.843506 -298.002655 -298.184479 -298.330902 -298.439575 -298.524750 -298.643646 -298.789307 -298.888641 -298.937683 -298.966766 -298.983398 -298.991760 -299.008606 -299.008301 -298.974274 -298.907715 -298.815796 -298.689270 -298.573914 -298.493805 -298.434418 -298.340240 -298.179871 -297.990479 -297.756165 -297.493164 -297.184509 -296.843262 -296.492432 -296.140900 -295.780212 -295.432739 -295.083374 -294.676971 -294.239319 -293.827698 -293.392151 -292.843781 -292.286987 -291.784790 -291.170868 -290.379425 -289.688049 -289.356934 -282.514069 -283.609100 -289.651978 -291.793945 -294.104950 -295.111603 -296.135742 -296.009399 -294.173676 -292.586243 -293.111542 -293.225098 -297.424469 -297.324768 -297.052185 -296.704468 -296.311890 -295.929047 -295.558319 -295.186310 -294.823792 -294.390381 -293.902954 -293.389801 -292.877075 -292.842072 -292.223206 -291.653351 -291.186340 -290.957428 -292.978485 -292.436554 -291.584015 -290.851379 -290.137054 -288.570923 -288.037659 -290.126312 -293.203979 -296.016479 -298.358978 -298.246216 -294.330994 -297.548248 -297.477509 -297.435425 -297.341492 -297.287079 -297.282043 -297.293854 -297.307800 -297.335480 -297.342346 -297.339966 -297.388641 -297.515656 -297.713684 -297.942383 -298.133270 -298.276550 -298.332855 -298.320862 -298.294128 -298.326111 -298.462769 -298.698395 -298.931519 -299.112732 -299.222229 -299.227112 -293.868866 -293.187256 -293.997803 -293.811768 -297.848114 -297.679840 -296.229767 -297.805847 -298.246338 -298.610748 -298.795074 -298.993256 -299.197052 -299.319885 -299.410400 -299.510345 -299.638916 -299.792816 -299.949402 -300.089508 -300.193695 -300.253510 -300.248932 -300.210236 -300.176941 -300.150055 -300.128815 -300.085510 -300.008911 -299.925781 -299.810028 -299.617035 -299.416351 -299.273254 -299.137421 -298.957794 -298.735352 -298.512299 -298.268036 -298.017822 -297.734100 -297.378387 -297.002258 -296.614990 -296.246155 -295.897644 -295.553833 -295.156189 -294.706512 -294.242737 -293.717377 -293.096924 -292.401550 -291.764648 -291.064331 -290.175049 -289.532898 -289.153351 -288.543152 -289.466705 -291.497406 -292.662476 -295.351532 -296.947144 -296.876251 -295.196106 -294.099640 -293.581512 -294.036346 -293.850464 -298.094604 -298.019592 -297.743195 -297.355652 -296.971649 -296.645142 -296.289825 -295.889893 -295.468842 -294.979370 -294.442657 -293.911285 -293.409210 -293.818024 -293.303558 -292.982178 -292.942963 -293.066376 -293.601410 -292.981567 -291.411591 -291.014893 -291.320923 -289.883698 -289.632294 -290.142731 -293.214417 -295.427155 -298.418671 -298.386078 -298.150696 -297.955322 -297.976013 -298.067474 -298.097351 -298.080566 -298.071228 -298.093079 -298.155518 -298.236481 -298.299805 -298.366486 -298.499634 -298.726715 -298.997711 -299.228119 -299.343781 -299.367828 -299.328156 -299.239929 -299.131744 -299.072968 -299.136292 -299.337952 -299.558075 -299.748383 -299.867981 -299.884064 -299.804840 -299.674347 -294.436646 -295.925934 -298.722015 -298.521118 -298.380524 -298.524750 -298.951508 -299.398102 -299.756836 -300.092804 -300.359436 -300.492096 -300.547485 -300.605133 -300.687103 -300.811859 -300.975464 -301.090240 -301.121368 -301.125488 -301.121094 -301.091858 -301.041077 -300.941406 -300.849762 -300.740448 -300.638550 -300.557312 -300.445831 -300.252197 -300.023224 -299.795044 -299.564819 -299.315613 -299.052948 -298.808075 -298.549286 -298.304016 -298.068451 -297.813324 -297.513580 -297.152588 -296.779816 -296.402832 -296.039032 -295.645386 -295.200439 -294.707031 -294.151306 -293.454132 -292.686432 -291.966217 -291.118134 -290.208588 -291.867218 -288.441132 -291.549866 -293.822388 -293.409363 -295.232666 -296.244720 -296.529022 -295.597168 -294.927734 -293.896698 -293.914825 -294.143707 -294.101379 -298.530487 -298.553223 -298.376465 -298.061737 -297.775360 -297.517792 -297.175476 -296.737152 -296.271881 -295.812347 -295.328888 -294.840424 -294.356171 -294.849976 -294.495758 -294.369019 -294.419891 -294.389282 -296.702820 -296.701843 -294.873444 -293.261902 -292.115265 -290.991699 -290.919830 -291.944305 -293.715118 -294.807800 -298.385895 -298.360077 -298.266144 -298.264862 -298.426727 -298.657837 -298.826843 -298.914795 -298.973907 -299.008301 -299.042084 -299.127594 -299.252747 -299.388611 -299.548096 -299.759521 -299.968475 -300.095337 -300.115570 -300.077087 -300.008484 -299.921997 -299.805298 -299.720032 -299.694244 -299.790039 -299.939270 -300.092468 -300.190369 -300.167938 -300.033783 -299.817902 -299.547821 -299.262909 -299.121460 -299.060883 -299.054169 -299.260773 -299.715698 -300.262878 -300.690125 -301.007721 -301.227936 -301.362366 -301.412109 -301.446198 -301.468475 -301.513672 -301.579559 -301.587280 -301.578094 -301.585266 -301.589722 -301.543732 -301.427765 -301.279572 -301.183044 -301.061951 -300.931824 -300.821411 -300.705383 -300.520142 -300.278015 -300.002563 -299.727478 -299.457153 -299.181305 -298.927155 -298.659973 -298.383179 -298.148224 -297.940491 -297.693695 -297.383484 -297.042175 -296.678162 -296.312073 -295.939240 -295.549225 -295.109314 -294.595154 -293.932190 -293.159241 -292.276398 -291.246948 -290.527222 -290.844757 -292.866821 -294.952667 -294.463715 -295.459808 -296.820953 -296.431366 -296.026550 -296.129181 -296.438690 -296.309692 -295.760498 -294.690613 -294.424835 -294.939087 -298.951904 -298.915558 -298.761353 -298.539886 -298.237610 -297.859161 -297.429321 -297.006500 -296.604462 -296.185364 -295.742310 -295.291626 -295.585022 -295.438812 -295.431396 -295.370575 -295.063904 -295.051025 -297.901093 -296.928192 -295.357056 -294.413666 -292.460754 -292.355377 -291.997864 -293.243713 -298.372223 -298.398224 -298.389252 -298.433289 -298.637238 -298.958496 -299.286743 -299.560028 -299.747833 -299.878876 -299.955231 -299.999329 -300.057068 -300.166656 -300.297455 -300.420776 -300.551239 -300.660248 -300.721649 -300.746613 -300.751587 -300.739624 -300.718964 -300.692474 -300.636200 -298.146362 -300.448029 -300.467804 -300.508972 -300.450531 -300.322906 -300.140228 -299.892792 -299.643433 -299.539795 -299.669800 -298.644928 -298.981384 -298.401611 -300.853882 -301.260071 -301.523865 -301.691528 -301.829742 -301.922119 -301.932831 -301.899170 -301.862579 -301.847168 -301.836670 -301.796204 -301.717285 -301.661865 -301.681000 -301.599548 -301.420532 -301.245941 -301.163177 -301.059204 -300.915802 -300.768433 -300.612946 -300.425232 -300.170776 -299.894012 -299.631622 -299.364594 -299.085083 -298.827881 -298.569702 -298.279755 -297.998291 -297.752045 -297.485168 -297.171143 -296.827484 -296.486389 -296.165649 -295.836121 -295.495575 -295.146515 -294.767914 -294.285492 -293.583832 -292.604645 -291.629822 -290.003235 -291.972076 -293.050751 -294.747528 -295.297913 -295.996826 -297.379303 -296.489075 -296.385681 -296.562378 -297.315918 -297.450073 -297.226807 -296.610352 -296.064087 -296.817078 -299.230499 -299.204987 -299.094727 -298.833832 -298.462585 -298.056274 -297.647278 -297.278351 -296.922943 -296.539581 -296.179016 -295.849670 -296.188385 -296.230957 -296.305847 -296.200226 -295.818115 -293.745544 -296.478424 -298.015778 -297.295624 -296.032288 -294.108246 -292.908051 -290.448212 -292.081360 -293.869385 -298.484863 -298.511108 -298.670044 -299.011932 -299.472656 -299.930847 -300.301666 -300.545959 -300.681793 -300.760529 -300.815216 -300.852631 -300.890808 -300.945923 -300.999542 -301.047516 -301.097687 -301.172241 -301.252472 -301.310516 -301.361755 -301.414307 -298.886078 -301.327698 -301.122040 -300.961761 -300.972137 -300.996948 -300.860260 -300.607086 -300.433746 -300.319733 -300.252838 -297.837189 -297.504211 -297.450104 -297.046417 -301.515320 -301.813141 -301.976807 -302.027954 -302.049408 -302.090820 -302.114410 -302.085144 -301.995117 -301.917938 -301.867828 -301.819946 -301.754913 -301.617676 -301.507629 -301.487335 -301.409485 -301.242828 -301.064301 -300.961517 -300.867676 -300.716003 -300.532288 -300.354187 -300.108795 -299.772369 -299.454041 -299.229858 -298.978668 -298.740509 -298.523071 -298.258331 -297.932709 -297.613953 -297.301971 -296.984436 -296.634460 -296.262573 -295.912628 -295.610870 -295.362579 -295.132507 -294.904999 -294.691620 -294.460175 -294.066833 -293.508911 -293.237854 -292.770294 -293.455933 -295.067780 -296.574921 -296.820312 -297.472046 -299.048889 -298.478302 -297.940918 -297.527893 -298.116028 -298.255127 -298.978210 -299.759552 -298.140076 -299.491119 -299.376862 -299.260010 -299.102356 -298.787567 -298.376678 -297.944733 -297.529449 -297.185455 -296.857819 -296.540405 -296.331665 -296.219971 -297.096100 -297.260681 -297.371490 -297.273743 -294.124146 -294.905548 -295.343781 -297.027405 -298.362915 -297.244537 -294.089355 -292.797302 -289.382599 -291.934235 -295.737335 -298.635895 -298.620300 -298.822876 -299.196655 -299.733887 -300.326233 -300.804382 -301.085083 -301.239471 -301.305420 -301.321899 -301.296265 -301.269958 -301.240692 -301.211151 -301.205780 -301.248138 -301.345734 -301.473511 -301.592468 -301.709106 -298.290070 -299.702240 -301.593018 -301.433136 -298.011414 -297.947845 -301.547791 -298.350342 -301.144104 -300.966492 -301.034668 -297.685272 -301.403503 -301.625183 -301.781311 -301.912659 -302.060730 -302.219849 -302.264252 -302.225891 -302.166870 -302.125977 -302.093994 -302.039490 -301.956177 -301.837952 -301.776398 -301.724792 -301.624329 -301.473602 -301.354553 -301.272644 -301.189209 -301.075592 -300.926025 -300.791046 -300.687805 -300.546295 -300.361298 -300.123016 -299.832947 -299.507019 -299.170135 -298.917542 -298.684113 -298.466858 -298.272705 -297.991882 -297.692749 -297.419037 -297.112396 -296.759796 -296.381317 -296.034821 -295.738892 -295.501587 -295.370972 -295.329529 -295.285034 -295.263550 -295.315277 -295.409241 -295.586029 -296.123505 -294.539124 -294.463440 -296.096466 -298.150757 -297.633392 -297.931976 -298.936829 -299.181793 -298.539917 -298.741241 -299.055450 -298.954681 -300.330414 -300.038605 -299.891022 -299.768799 -299.549622 -299.321991 -299.121460 -298.798981 -298.392334 -297.956360 -297.581573 -297.280609 -296.991760 -296.781006 -296.769409 -296.915405 -297.958008 -298.229858 -298.418762 -298.364349 -294.698730 -294.817871 -295.047760 -296.540619 -297.193054 -296.918610 -295.346863 -294.692749 -293.746643 -294.313599 -297.404724 -297.895386 -297.997803 -298.774231 -299.115723 -299.658356 -300.320587 -300.905182 -301.289093 -301.509888 -301.579376 -301.535309 -301.419678 -301.308380 -301.221710 -301.147614 -301.145325 -301.206543 -301.315613 -301.486938 -301.719574 -301.943115 -296.955872 -301.899109 -301.758362 -301.716949 -297.252502 -297.132080 -297.507355 -301.880432 -301.650360 -301.483032 -301.557312 -301.747192 -301.922791 -302.030487 -302.077942 -302.136292 -302.225861 -302.306854 -302.341888 -302.317413 -302.256439 -302.182434 -302.116669 -302.048431 -301.989655 -301.911560 -301.832977 -301.735291 -301.638184 -301.503204 -301.389008 -301.275726 -301.186340 -301.092407 -300.972198 -300.833649 -300.712616 -300.593262 -300.451477 -300.222656 -299.958191 -299.701172 -299.452179 -299.226105 -298.956177 -298.703766 -298.523407 -298.315002 -298.115997 -297.939056 -297.704651 -297.429291 -297.163818 -296.968384 -296.837677 -296.758698 -296.812164 -296.990326 -297.169525 -297.297852 -297.443085 -297.709137 -298.099762 -298.669189 -295.777008 -294.405334 -295.476257 -297.982971 -297.852753 -296.755646 -297.511261 -298.853027 -299.153625 -298.848236 -298.858795 -300.835052 -300.610046 -300.446320 -300.363098 -300.204926 -299.928375 -299.649719 -299.458649 -299.221252 -298.885864 -298.519257 -298.250305 -298.056519 -297.861603 -297.673065 -297.571045 -297.716766 -298.158813 -298.555237 -298.881836 -294.619904 -294.836426 -295.747772 -297.301727 -297.678925 -296.904419 -296.889771 -298.362396 -298.671906 -297.682648 -295.565277 -293.900085 -294.643188 -296.873535 -297.309448 -298.834442 -299.245850 -299.893921 -300.604584 -301.148010 -301.451508 -301.531158 -301.473755 -301.294128 -301.088501 -300.947693 -300.964783 -301.049866 -301.146973 -301.249146 -301.424500 -301.723328 -302.029938 -298.760773 -301.975098 -301.862762 -301.847748 -301.908936 -298.265533 -299.400574 -301.991730 -301.886993 -301.798615 -301.815735 -301.906067 -302.023804 -302.104004 -302.129761 -302.162628 -302.239197 -302.311462 -302.360107 -302.380005 -302.378113 -302.354065 -302.293152 -302.218323 -302.148682 -302.082397 -301.998260 -301.888214 -301.731445 -301.599121 -301.505127 -301.422089 -301.363617 -301.305145 -301.226501 -301.116119 -301.007477 -300.916412 -300.844299 -300.711029 -300.526978 -300.342773 -300.209686 -300.075500 -299.861359 -299.642578 -299.507996 -299.402771 -299.267975 -299.127441 -299.000916 -298.934113 -298.914062 -298.895355 -298.857574 -298.862366 -298.974548 -299.161285 -299.315521 -299.394348 -299.438477 -299.565155 -299.790253 -300.063110 -300.340698 -294.683319 -294.706940 -298.071381 -298.361664 -297.090668 -297.561737 -298.202148 -300.460358 -299.718323 -301.159485 -301.116547 -301.051514 -300.992950 -300.888519 -300.701996 -300.450531 -300.208069 -300.047577 -299.910065 -299.706726 -299.447601 -299.257141 -299.136749 -298.965515 -298.581024 -298.113800 -297.990295 -296.335297 -297.848236 -296.904510 -295.924194 -297.890717 -300.567017 -299.672394 -298.758606 -297.212311 -297.660400 -300.895203 -301.447784 -298.483917 -292.571472 -291.851959 -293.469208 -295.956665 -299.247742 -298.763031 -298.772339 -299.248383 -300.010040 -300.680542 -301.056305 -301.198334 -301.184021 -300.990021 -300.718750 -300.691803 -298.045074 -301.138367 -301.217407 -301.268280 -301.376343 -301.609406 -301.908020 -302.040894 -301.973267 -301.861389 -301.808960 -301.840576 -301.924774 -301.977783 -301.974518 -301.961761 -301.963165 -301.956757 -301.975983 -302.035706 -302.092255 -302.115234 -302.150848 -302.227173 -302.301361 -302.367706 -302.420074 -302.461823 -302.502014 -302.488037 -302.409424 -302.297394 -302.195587 -302.078461 -301.924042 -301.755096 -301.602539 -301.493073 -301.450775 -301.441589 -301.436310 -301.388397 -301.308044 -301.223572 -301.155914 -301.122314 -301.086975 -300.987915 -300.858612 -300.770966 -300.714172 -300.641968 -300.566376 -300.481262 -300.388306 -300.277069 -300.189301 -300.147308 -300.169434 -300.220123 -300.250305 -300.262299 -300.299683 -300.383331 -300.461975 -300.481781 -300.457520 -300.453156 -300.577240 -300.775696 -300.924866 -301.056152 -296.442230 -296.018890 -298.283173 -299.887909 -299.382843 -299.440094 -299.333771 -301.462677 -301.409149 -301.413177 -301.453461 -301.425568 -301.298767 -301.122833 -300.947937 -300.758911 -300.585632 -300.433044 -300.315979 -300.193939 -300.029327 -299.897705 -299.779358 -296.480194 -296.359222 -295.964600 -295.338531 -297.145325 -297.757751 -298.607147 -299.284363 -300.183014 -300.698364 -301.343536 -300.280518 -298.442169 -297.867249 -300.332153 -302.059967 -297.745148 -293.873230 -292.992645 -296.687408 -297.237000 -300.133179 -298.173553 -298.539307 -298.746063 -299.390381 -300.055908 -300.548645 -300.837769 -300.914886 -300.737610 -300.533051 -300.132355 -301.193481 -301.408173 -301.414490 -301.371338 -301.360077 -301.468903 -301.745941 -301.958130 -301.966095 -300.648376 -301.734589 -301.742157 -301.849640 -301.954376 -301.991852 -302.030487 -302.113129 -302.046600 -302.041595 -302.060760 -302.091370 -302.122192 -302.134216 -302.208038 -302.311188 -302.393433 -302.431213 -302.448090 -302.498199 -302.482086 -302.335510 -302.238098 -302.149994 -302.024628 -301.871704 -301.707947 -301.523163 -301.368622 -301.301483 -301.276306 -301.258118 -301.206116 -301.135162 -301.084351 -301.057220 -301.048676 -301.037903 -300.981293 -300.911896 -300.861694 -300.846191 -300.851807 -300.866669 -300.820007 -300.758820 -300.732819 -300.759918 -300.778961 -300.797821 -300.846802 -300.913788 -300.978363 -301.060852 -301.148621 -301.213257 -301.228180 -301.200897 -301.183777 -301.283844 -301.434235 -301.495728 -301.495605 -301.468353 -299.373444 -299.477448 -300.454193 -301.025909 -300.564484 -301.696198 -301.634003 -301.536865 -301.484222 -301.467804 -301.359985 -301.171204 -300.985474 -300.848083 -300.743073 -300.635132 -300.514984 -300.400604 -300.331543 -300.297729 -300.241089 -298.342529 -298.234650 -298.262543 -297.953857 -297.440887 -302.950104 -301.960205 -301.894623 -301.283752 -302.746124 -301.734589 -304.326141 -303.492493 -303.233337 -302.275238 -303.477081 -302.829132 -299.862762 -296.475189 -297.584595 -297.827118 -302.988068 -301.515656 -299.585388 -298.464966 -298.407410 -298.880249 -299.521362 -300.122040 -300.563416 -300.733032 -300.630615 -298.753418 -301.031494 -301.488800 -301.645325 -301.596344 -301.490417 -301.385498 -301.418121 -297.992859 -297.768768 -299.624847 -301.261780 -301.815125 -301.780640 -301.857819 -301.967255 -302.033325 -302.174561 -302.212067 -302.166595 -302.270142 -302.308228 -302.319794 -302.330353 -302.257812 -302.326233 -302.378937 -302.483704 -302.386230 -302.341888 -302.202850 -302.307983 -302.155945 -302.001678 -301.957367 -301.889771 -301.787354 -301.650574 -301.452393 -301.280975 -301.156830 -301.019775 -300.891083 -300.794678 -300.707764 -300.635742 -300.615875 -300.602325 -300.571838 -300.537506 -300.521027 -300.523376 -300.555786 -300.625702 -300.694580 -300.704071 -300.712952 -300.784058 -300.892120 -300.982758 -301.062439 -301.174438 -301.296631 -301.466248 -301.658447 -301.822784 -301.931976 -301.992004 -301.972717 -301.916382 -301.876129 -298.363373 -301.768646 -301.660309 -301.549438 -301.445129 -301.448120 -301.540558 -301.621704 -301.674805 -301.653870 -301.548645 -301.398407 -301.235779 -301.061981 -300.851135 -300.651184 -300.496338 -300.398438 -300.379730 -300.382294 -300.331085 -300.254364 -300.294647 -300.486237 -300.524536 -300.744110 -301.927887 -303.189362 -303.469482 -304.991486 -306.292419 -307.250702 -307.270142 -303.888580 -304.452728 -305.322388 -306.232147 -305.622467 -303.816803 -305.418213 -306.091248 -306.394989 -303.986298 -300.683990 -298.290253 -304.405518 -300.126129 -301.697235 -298.898529 -298.484833 -298.119751 -298.499603 -299.220123 -299.906647 -300.409576 -300.640686 -300.645325 -299.342163 -300.652435 -301.654053 -301.788513 -301.740967 -301.605499 -301.455872 -301.445831 -299.277863 -299.184021 -299.939728 -301.156616 -302.046051 -301.922821 -301.924805 -302.022858 -301.534454 -302.301147 -302.147858 -302.100922 -302.343445 -302.468689 -302.444641 -302.386444 -302.327240 -302.388641 -302.476654 -302.550323 -302.463654 -302.375763 -302.160065 -302.113159 -302.134644 -302.024933 -301.863434 -301.770905 -301.693268 -301.568207 -301.400452 -301.247375 -301.083923 -300.866516 -300.655548 -300.510071 -300.355103 -300.187103 -300.046173 -299.928070 -299.808868 -299.727173 -299.683563 -299.682770 -299.752655 -299.881470 -299.989075 -300.047241 -300.158356 -300.348114 -300.546051 -300.754181 -300.969788 -301.202576 -301.463287 -301.811096 -302.140350 -302.338104 -302.385773 -302.411072 -299.930969 -299.098663 -298.610138 -299.703888 -301.984924 -301.858398 -301.744293 -301.659882 -301.656219 -301.716339 -301.727631 -301.643127 -301.501770 -301.319214 -301.105316 -300.871155 -300.595795 -300.327515 -300.110657 -299.924622 -299.785736 -299.740417 -299.759491 -299.720428 -299.658936 -299.824097 -300.265076 -300.287964 -304.994446 -306.411713 -304.711365 -304.706909 -305.189178 -305.429932 -306.707062 -307.168304 -304.022766 -304.071625 -304.671631 -304.795380 -305.136932 -305.385864 -306.360565 -307.219391 -307.541229 -307.109131 -303.669342 -304.681427 -301.656586 -303.716614 -304.827911 -305.471313 -302.574463 -298.533691 -298.461487 -299.215485 -299.959534 -300.435822 -300.680298 -298.407349 -299.681274 -300.204529 -301.612762 -301.851196 -301.859283 -301.718475 -301.528625 -299.713715 -299.896881 -301.067444 -300.469025 -302.386993 -302.138519 -301.942841 -301.935272 -302.003845 -302.069397 -302.191589 -302.030975 -301.915894 -302.050323 -302.359009 -302.424957 -302.328308 -302.346283 -302.274292 -302.550568 -302.655701 -302.585358 -302.488281 -302.431732 -302.255249 -302.181274 -302.004639 -301.933136 -301.796265 -301.633331 -301.489166 -301.335785 -301.188263 -301.011627 -300.782471 -300.537750 -300.350555 -300.162323 -299.901581 -299.602386 -299.327454 -299.078857 -298.877045 -298.717834 -298.586731 -298.546204 -298.590271 -298.631012 -298.681763 -298.835938 -299.115112 -299.431183 -299.814697 -300.267029 -300.812225 -301.452179 -302.086639 -302.475098 -297.745239 -298.293030 -299.198151 -300.848663 -300.831238 -302.308929 -302.322662 -302.288849 -302.227081 -302.099915 -301.993073 -299.521118 -301.811493 -301.698639 -301.523468 -301.340729 -301.146545 -300.912567 -300.648224 -300.352570 -300.063904 -299.800812 -299.536438 -299.297913 -299.129242 -298.982422 -298.840759 -298.725952 -298.814728 -299.103912 -299.030212 -307.551544 -305.832031 -304.066986 -305.053955 -305.198090 -306.606659 -305.583832 -305.263794 -303.308533 -301.670532 -300.473450 -300.460724 -301.296204 -302.777374 -304.766205 -306.551849 -307.132446 -307.905090 -303.746979 -304.186920 -305.452393 -304.273834 -306.626068 -309.547180 -307.058472 -304.161865 -299.372681 -299.794983 -300.264435 -300.601837 -300.766418 -299.383820 -299.647125 -300.793854 -302.733887 -303.889862 -302.660675 -301.650482 -300.908539 -299.962219 -298.238312 -298.449005 -298.282166 -298.399414 -299.606323 -301.643585 -301.646271 -301.701202 -301.953583 -302.131195 -302.066498 -301.888245 -301.794067 -301.922272 -302.031982 -302.096619 -302.163361 -302.117279 -302.352814 -302.559052 -302.605804 -302.409027 -302.291321 -302.155762 -302.169586 -301.934204 -301.886688 -301.690948 -301.501740 -301.335632 -301.165314 -300.990417 -300.801483 -300.592255 -300.373291 -300.198608 -300.000092 -299.696869 -299.302063 -298.921387 -298.566498 -298.246185 -297.926147 -297.612335 -297.358337 -297.182861 -297.050751 -296.996887 -297.080872 -297.353638 -297.768982 -298.268219 -298.978363 -300.082367 -301.408264 -302.360596 -298.118622 -294.244843 -296.106506 -302.224121 -302.274139 -302.296661 -301.764587 -302.498749 -302.589142 -302.520844 -302.296967 -302.120667 -301.973114 -301.837463 -301.590363 -301.357880 -301.209198 -301.039917 -300.811737 -300.551208 -300.261902 -299.971466 -299.669922 -299.347351 -299.044586 -298.741852 -298.447113 -298.191132 -297.967957 -297.758209 -297.408081 -300.488251 -307.019409 -305.900665 -304.456787 -302.292206 -304.204651 -305.554138 -305.084290 -302.931793 -300.088287 -298.077545 -297.818085 -298.994171 -299.939545 -301.370789 -303.266266 -304.862366 -305.910950 -306.007721 -302.855713 -302.294617 -302.692566 -304.474396 -307.378143 -309.101074 -305.109131 -303.951965 -301.303009 -300.894928 -300.596680 -300.610229 -302.289093 -300.998169 -301.370148 -302.172791 -303.530121 -302.795898 -302.661041 -302.381165 -300.854584 -299.559937 -295.856201 -295.160126 -296.914185 -297.370667 -298.733215 -300.440430 -300.495270 -300.865448 -301.251221 -301.772980 -301.928070 -301.713470 -301.663422 -301.742584 -301.824524 -301.855896 -301.861176 -302.001709 -302.088562 -302.106781 -302.177582 -302.106750 -302.025757 -301.824158 -301.735046 -301.570129 -301.479187 -301.329773 -301.182037 -301.021759 -300.842377 -300.664154 -300.482758 -300.296204 -300.126831 -299.973083 -299.782440 -299.479645 -299.088623 -298.682190 -298.266663 -297.847046 -297.424438 -296.974701 -296.507599 -296.106567 -295.779877 -295.565979 -295.518433 -295.691528 -296.032562 -296.487213 -297.412872 -299.289673 -301.439972 -299.616730 -295.322235 -294.984894 -296.014008 -302.223236 -302.391083 -302.445831 -302.499176 -302.598053 -302.592621 -302.481476 -302.189758 -302.033539 -301.930634 -301.813293 -301.535919 -301.269684 -301.142700 -300.988953 -300.774994 -300.516724 -300.249390 -299.951752 -299.632599 -299.304840 -298.963226 -298.612610 -298.259613 -297.928040 -297.586639 -297.164337 -296.462219 -295.597900 -305.801086 -305.203827 -303.030365 -300.201935 -302.094727 -304.296631 -304.083130 -301.402374 -298.825562 -297.090698 -297.329010 -298.553925 -299.361176 -300.682343 -302.527252 -303.795166 -304.806396 -302.247467 -300.071289 -300.968719 -300.671021 -302.833374 -305.192139 -304.987854 -305.222412 -300.102448 -303.753662 -302.198090 -302.358887 -303.937042 -305.698364 -305.730103 -304.368225 -302.199890 -299.997284 -297.279663 -294.609161 -293.448578 -294.210938 -293.251495 -291.978058 -293.178925 -297.029999 -298.598907 -299.478485 -300.304443 -300.666382 -300.146362 -300.928467 -301.330566 -301.730316 -301.655640 -301.550629 -301.542847 -301.627533 -301.547485 -301.419983 -301.534973 -301.696503 -301.732452 -301.683838 -301.622406 -301.597443 -301.478760 -301.398590 -301.258453 -301.051239 -300.877502 -300.700684 -300.548950 -300.408630 -300.263519 -300.108765 -299.956360 -299.798889 -299.642944 -299.466553 -299.213593 -298.877106 -298.500977 -298.071960 -297.568787 -297.061066 -296.539642 -295.981812 -295.450256 -294.981995 -294.598358 -294.337311 -294.266632 -294.402374 -294.765717 -295.857178 -298.258820 -299.574524 -299.851685 -297.551666 -295.929596 -299.374786 -302.211975 -302.517670 -302.544922 -302.523834 -302.706726 -300.810455 -302.437469 -302.094025 -301.893555 -301.788910 -301.667603 -301.525604 -301.376099 -301.184784 -300.953583 -300.745758 -300.517639 -300.249725 -299.958344 -299.646912 -299.328400 -298.996826 -298.633453 -298.256775 -297.873810 -297.448761 -296.966095 -296.310883 -295.497681 -294.826111 -303.483643 -302.670074 -301.004486 -302.024200 -300.528046 -300.934143 -299.461792 -297.651245 -296.781342 -296.834473 -297.592316 -295.958801 -298.043488 -299.560181 -300.446259 -300.791656 -302.470917 -302.831207 -301.594849 -302.681580 -303.752014 -301.188690 -297.052612 -295.676270 -295.371277 -297.403412 -297.658722 -298.580780 -300.751312 -305.886810 -306.856689 -302.590057 -295.740997 -291.926331 -289.706146 -287.588928 -288.504944 -286.694946 -284.176422 -285.776306 -291.207489 -296.253693 -299.591248 -299.820648 -300.645782 -300.900665 -300.941986 -300.726013 -300.972839 -301.371735 -301.515747 -301.512512 -301.448303 -301.430603 -301.324860 -301.105743 -301.047913 -301.136810 -301.102142 -301.042603 -301.005859 -300.955414 -300.855164 -300.767731 -300.679901 -300.485046 -300.293335 -300.068817 -299.926544 -299.824188 -299.721252 -299.605682 -299.466248 -299.309998 -299.138275 -298.987671 -298.779083 -298.492004 -298.174805 -297.789124 -297.287048 -296.741760 -296.183563 -295.634827 -295.057831 -294.472809 -293.888153 -293.357025 -293.004425 -292.975403 -293.414429 -294.606537 -299.408722 -303.931549 -301.345581 -300.344269 -299.941528 -301.003784 -301.121887 -302.407562 -299.685211 -302.230103 -302.175323 -300.012115 -302.022736 -301.653168 -301.415039 -301.393433 -301.302979 -301.272980 -301.246918 -301.124603 -300.858521 -300.647919 -300.455963 -300.166931 -299.897644 -299.609375 -299.312317 -299.010864 -298.672241 -298.293457 -297.878113 -297.426453 -296.926544 -296.369690 -295.720886 -295.035431 -294.563568 -299.421509 -299.418671 -299.967041 -295.743347 -296.960297 -297.388367 -297.366272 -297.061401 -297.153778 -299.180267 -299.112885 -295.713867 -298.707306 -298.949524 -299.535736 -300.362823 -302.668213 -304.464172 -304.334137 -301.749329 -296.251770 -293.219177 -290.234589 -291.887909 -291.941986 -293.843719 -293.789978 -296.581726 -299.465546 -299.401306 -292.697479 -286.152710 -282.887421 -282.326080 -281.362305 -283.588501 -284.254822 -284.451477 -285.828522 -289.790619 -295.984558 -298.658539 -299.961548 -301.563660 -302.966858 -302.674316 -300.817505 -299.330994 -300.347107 -300.663452 -300.840637 -301.144684 -300.920624 -300.931885 -300.776337 -300.557678 -300.480438 -300.359344 -300.203186 -300.087677 -299.974396 -299.814240 -299.655731 -299.608490 -299.357880 -299.236420 -299.151184 -299.047577 -298.967377 -298.884277 -298.792328 -298.680176 -298.544495 -298.396149 -298.251953 -298.079956 -297.842041 -297.578918 -297.259003 -296.858124 -296.368866 -295.839569 -295.285065 -294.656311 -293.953918 -293.179535 -292.359772 -291.739960 -291.716156 -292.436371 -299.293396 -303.045380 -302.220215 -301.706573 -301.432037 -303.447418 -304.893005 -303.477478 -301.021393 -300.019287 -300.730408 -301.343048 -299.311371 -301.796967 -301.394409 -300.884247 -300.690247 -300.628418 -300.672028 -300.647308 -300.545319 -300.414368 -300.253937 -300.102478 -299.891937 -299.669891 -299.390625 -299.106354 -298.812347 -298.507538 -298.152679 -297.753204 -297.339355 -296.872894 -296.365814 -295.813263 -295.252930 -294.813446 -295.113556 -294.755402 -294.986511 -293.457764 -294.789520 -295.631317 -296.693237 -298.509827 -298.828979 -298.924225 -298.737305 -298.290527 -298.073303 -298.437286 -299.283875 -300.108398 -300.171936 -303.906677 -302.970551 -299.990601 -295.965179 -293.225952 -292.254669 -291.845520 -291.572479 -290.479004 -291.076782 -291.170135 -289.754425 -287.061584 -284.064606 -282.807343 -281.942200 -282.732330 -283.481079 -285.574219 -286.276459 -286.455200 -287.185242 -292.246735 -295.703247 -299.095001 -301.855347 -303.831299 -305.358856 -305.079865 -296.845276 -298.094452 -298.024231 -298.707458 -297.712677 -297.699677 -297.421448 -299.666870 -300.068420 -299.807373 -299.683075 -299.562866 -299.238831 -298.982880 -298.882294 -298.664062 -298.386261 -298.279449 -298.087585 -297.932007 -297.808472 -297.718628 -297.657745 -297.593414 -297.531006 -297.457092 -297.369171 -297.265411 -297.137695 -296.992615 -296.809448 -296.604431 -296.359558 -296.051819 -295.667145 -295.213531 -294.706940 -294.082794 -293.326508 -292.364288 -291.200378 -290.285461 -290.281281 -296.628448 -302.099487 -302.837402 -299.096619 -298.140900 -299.401306 -301.917572 -304.040771 -302.881744 -302.096375 -302.703064 -302.649506 -301.481323 -300.612274 -299.112152 -300.565369 -300.406586 -300.443329 -300.174561 -300.002136 -299.867218 -299.723511 -299.579529 -299.511261 -299.454163 -299.249054 -299.089081 -298.867004 -298.604797 -298.299744 -297.961823 -297.601471 -297.212280 -296.863586 -296.512878 -296.102905 -295.617584 -295.147766 -294.787354 -294.624817 -293.441010 -291.247864 -296.962402 -297.419434 -297.569366 -297.754547 -298.037659 -298.274658 -298.333374 -298.130402 -292.202515 -297.337585 -293.012238 -292.849945 -292.584045 -293.673340 -296.287567 -295.282288 -294.423798 -295.498810 -297.950409 -298.175171 -295.257050 -293.142242 -293.708221 -292.763275 -290.063263 -287.023499 -284.275604 -284.955780 -287.595520 -287.350311 -285.841980 -285.082092 -287.199707 -289.274048 -290.592010 -291.785828 -294.066223 -297.106903 -300.612457 -302.468231 -301.962524 -301.741547 -300.114594 -295.991669 -295.684601 -298.056335 -296.704651 -297.592194 -298.177246 -298.155609 -297.360809 -297.187531 -297.553680 -297.506653 -297.397400 -297.204163 -296.904327 -296.828461 -296.674347 -296.485809 -296.193726 -296.024963 -295.892487 -295.771759 -295.726440 -295.715271 -295.677216 -295.625305 -295.585480 -295.562775 -295.522522 -295.464691 -295.385010 -295.262726 -295.111084 -294.926727 -294.710815 -294.460602 -294.142456 -293.746460 -293.250977 -292.577240 -291.545502 -290.019623 -288.795898 -293.294312 -296.716797 -301.417419 -300.553680 -297.979523 -293.763580 -296.035980 -299.090302 -301.215851 -300.486481 -299.572998 -300.784698 -300.622650 -301.042603 -300.069733 -300.128326 -299.823395 -297.870361 -299.566223 -300.084076 -300.150818 -299.793762 -299.422485 -299.226257 -299.087860 -298.920258 -298.553619 -298.254639 -298.013672 -297.763245 -297.462250 -297.078156 -296.639038 -296.237274 -295.967529 -295.712311 -295.407898 -295.014526 -294.542755 -294.102631 -293.952332 -293.632782 -292.706757 -291.928467 -296.675720 -296.803223 -296.976410 -297.242493 -297.468933 -291.098633 -288.933533 -289.673676 -289.768768 -289.757263 -288.766327 -289.317688 -288.643738 -288.186707 -289.885406 -291.209106 -295.085297 -295.881714 -295.919769 -298.113831 -297.031067 -296.097412 -295.568542 -293.139465 -289.733368 -287.455688 -288.870972 -290.752258 -292.561249 -289.734314 -288.709412 -288.439880 -289.886993 -290.282013 -290.775330 -294.823029 -297.306274 -298.111908 -297.630402 -296.591217 -294.211029 -293.678894 -293.853851 -295.818726 -296.959595 -294.972137 -294.920410 -295.261688 -296.304810 -297.691895 -293.429901 -293.354797 -293.962189 -294.326874 -294.001648 -293.212128 -292.885620 -292.854248 -293.141815 -293.225098 -292.951263 -292.860260 -292.838898 -292.858704 -292.897797 -292.904694 -292.906494 -292.918793 -292.971527 -293.030823 -293.067688 -293.084381 -293.069885 -292.990021 -292.882599 -292.805023 -292.724884 -292.602661 -292.403137 -292.143555 -291.742065 -290.891327 -289.303528 -288.964691 -291.270477 -295.180328 -298.883453 -297.914490 -297.807220 -294.924835 -294.526031 -296.403503 -297.687805 -296.973236 -296.265656 -297.214569 -297.441559 -297.381683 -295.895264 -296.624512 -297.034851 -296.638397 -293.850189 -293.972321 -296.441101 -297.800964 -297.975922 -298.107758 -297.617462 -296.927521 -296.946198 -297.153534 -296.795349 -296.556213 -296.398682 -296.060455 -295.588989 -295.126923 -294.875397 -294.595490 -294.312897 -294.001038 -293.567261 -293.030029 -293.302765 -293.158264 -292.883148 -292.102203 -293.242157 -293.503326 -295.974396 -293.326263 -291.883423 -291.435364 -291.310089 -290.428009 -289.687103 -289.667664 -295.529694 -295.652832 -295.685120 -295.605255 -290.002838 -291.046387 -292.908020 -294.577454 -297.472656 -297.264191 -293.076965 -294.451324 -296.201508 -295.230469 -293.910583 -292.614014 -292.236023 -292.400574 -292.011597 -292.195038 -293.238190 -293.823303 -292.376526 -291.053253 -291.006470 -293.480103 -296.285370 -296.188934 -295.093689 -294.221558 -293.329132 -290.981873 -291.743103 -293.265076 -292.926727 -292.801697 -291.811157 -291.960236 -293.124512 -292.822876 -293.127563 -288.209167 -287.934418 -288.749634 -289.730347 -289.755615 -289.440063 -288.744751 -288.182373 -288.179321 -288.521973 -288.949493 -289.255035 -289.366516 -289.427002 -289.503326 -289.595123 -289.698456 -289.833130 -289.978058 -290.093994 -290.195343 -290.311951 -290.396301 -290.444489 -290.515350 -290.624664 -290.727020 -290.780121 -290.806305 -290.755127 -290.307953 -289.069183 -285.902466 -286.913635 -289.391418 -293.178589 -295.527100 -297.573181 -300.425720 -298.371338 -298.324066 -297.302795 -296.942139 -296.476410 -295.965149 -293.814117 -294.755920 -293.213257 -292.017029 -293.587341 -294.177582 -296.185577 -286.829041 -289.201996 -291.021576 -291.690735 -292.546082 -291.982452 -290.474884 -291.793396 -294.731659 -295.205658 -294.542969 -294.425537 -294.317902 -294.052460 -293.683105 -293.412872 -293.155914 -292.958801 -292.750732 -292.462524 -292.079651 -291.954834 -289.706390 -293.372589 -291.808685 -290.876587 -291.196594 -290.482056 -290.536346 -291.496490 -292.665405 -292.886139 -292.482697 -292.504211 -293.113892 -291.983704 -292.633911 -292.441803 -294.089539 -292.827362 -291.889038 -292.237488 -293.777954 -293.745087 -294.569031 -292.030548 -291.951721 -294.917877 -296.342987 -296.616364 -297.011383 -297.269775 -295.423676 -293.147705 -291.759827 -291.808411 -291.689606 -290.620789 -289.431396 -289.608795 -290.725494 -293.109192 -295.576630 -295.918335 -295.450195 -294.173096 -290.929932 -289.442108 -289.385986 -289.115936 -288.417755 -287.902557 -287.580505 -287.133881 -289.772247 -288.120148 -286.866577 -285.093842 -283.322815 -284.449982 -285.715637 -286.339844 -286.223907 -285.611115 -285.217316 -285.374908 -285.742371 -286.075226 -286.213837 -286.269531 -286.379242 -286.533661 -286.706573 -286.887695 -287.078796 -287.247620 -287.407074 -287.614685 -287.854218 -288.064667 -288.268311 -288.479004 -288.720581 -289.002167 -289.308258 -289.579468 -289.490662 -288.648712 -285.440186 -286.210602 -285.765472 -289.552734 -294.216858 -297.963867 -301.654938 -302.736450 -300.957672 -299.744293 -297.207581 -297.460693 -296.338501 -292.990601 -291.859253 -289.745819 -291.035614 -293.000275 -294.951294 -296.790405 -297.077240 -295.380859 -289.208862 -288.317047 -287.566101 -287.041473 -286.155792 -286.521881 -289.215027 -291.737122 -292.174164 -291.779877 -291.626587 -291.756042 -291.714539 -291.604370 -291.543854 -291.480072 -291.402557 -291.284821 -291.147491 -291.100067 -291.307037 -291.721954 -289.838562 -290.430939 -289.285065 -288.332733 -289.355560 -290.625397 -292.103699 -292.559174 -293.117950 -292.656250 -292.724670 -292.659149 -293.004486 -294.114288 -294.067169 -294.641083 -294.396454 -294.981079 -293.704773 -292.791229 -292.888428 -292.915649 -292.191193 -292.565796 -293.528992 -294.465607 -295.954285 -297.402161 -296.804413 -294.575378 -292.429749 -289.345795 -288.511688 -286.596466 -287.846985 -285.151581 -284.705109 -286.582489 -290.348114 -293.109283 -293.444733 -292.507507 -290.938202 -288.180908 -286.515656 -286.935822 -288.018402 -287.261688 -286.899017 -287.745789 -286.813141 -286.502899 -285.546448 -284.738617 -282.560730 -282.261627 -283.315399 -284.141418 -284.408081 -284.176025 -283.920563 -283.819183 -283.876709 -283.892609 -283.931702 -284.012177 -284.138092 -284.326385 -284.558014 -284.807922 -285.047607 -285.262299 -285.439178 -285.670837 -285.933685 -286.183777 -286.454132 -286.720123 -287.057709 -287.519684 -288.013580 -288.324493 -288.148651 -287.490601 -284.279968 -284.191101 -284.142975 -286.769653 -290.928741 -297.216583 -301.250732 -302.908569 -301.762329 -299.528198 -297.117523 -295.208710 -293.490814 -290.954529 -290.478851 -289.116333 -289.459076 -291.756500 -294.006683 -295.990173 -296.947662 -296.035736 -286.808167 -287.006500 -292.812042 -284.573334 -283.868988 -284.017120 -285.539642 -288.352570 -289.476990 -289.290863 -289.379822 -289.666870 -289.747986 -289.784027 -289.875519 -289.951508 -289.989594 -289.986023 -289.970032 -289.926605 -289.935089 -287.847168 -286.928772 -289.564758 -288.335663 -290.085602 -291.348877 -291.954742 -292.366638 -293.018646 -292.235413 -291.197815 -291.245850 -292.060760 -291.700409 -292.009705 -291.380524 -291.887665 -293.516388 -293.173676 -294.155914 -292.904694 -290.639648 -290.504425 -290.455566 -290.461426 -290.252167 -290.206787 -291.040039 -293.486603 -295.629730 -295.930389 -293.695007 -292.646118 -290.613495 -288.961884 -288.729004 -288.534088 -288.774078 -288.247681 -288.968079 -291.082825 -291.615112 -291.103149 -289.200867 -287.585815 -287.166290 -287.788208 -288.495178 -288.501587 -288.824524 -288.635834 -286.540710 -285.533203 -284.795258 -284.687653 -283.631073 -282.980804 -284.976685 -283.621307 -283.666412 -283.308289 -283.103607 -282.852631 -282.647339 -282.528839 -282.525848 -282.606903 -282.719391 -282.884796 -283.180450 -283.580597 -283.965912 -284.281708 -284.503571 -284.740204 -284.965302 -285.206665 -285.498322 -285.824127 -286.234131 -286.742279 -287.145599 -287.141968 -286.614471 -283.214081 -283.047882 -282.816986 -283.266510 -284.043762 -287.484528 -293.373810 -298.784271 -301.579773 -300.162720 -297.202850 -296.650024 -295.827850 -295.259552 -293.820892 -291.422089 -288.046509 -288.180115 -289.294037 -290.844086 -291.814453 -293.035034 -294.496826 -294.790894 -294.447113 -293.850159 -281.295746 -282.192688 -284.430908 -285.836334 -286.317749 -286.177460 -286.244873 -286.700104 -287.183807 -287.567505 -287.970032 -288.294098 -288.523193 -288.646484 -288.708344 -288.723755 -288.692688 -288.630310 -286.791779 -287.790100 -288.411255 -288.998077 -286.777863 -287.117340 -288.398499 -289.636230 -288.865479 -289.363098 -290.411652 -291.583496 -292.026459 -291.744202 -290.529083 -289.409058 -291.041107 -291.921326 -292.247467 -291.949066 -292.108032 -290.896057 -290.645630 -291.331329 -292.173645 -292.831329 -292.525360 -292.419525 -293.168915 -293.452667 -294.328064 -293.976562 -293.697479 -292.150116 -291.322937 -291.176147 -291.295227 -290.611359 -289.838593 -288.981079 -287.841125 -289.391449 -289.819122 -289.898071 -289.732178 -289.521088 -289.119202 -288.760681 -288.904266 -289.418274 -289.327972 -285.406982 -284.363129 -284.086609 -284.081879 -283.702972 -283.418335 -284.885223 -284.710754 -283.645630 -283.191925 -282.762268 -282.419861 -282.194916 -282.066650 -281.982117 -281.977417 -281.987762 -282.057007 -282.292694 -282.706207 -283.236359 -283.770111 -284.142334 -284.417145 -284.645447 -284.908569 -285.242157 -285.613312 -286.015808 -286.346680 -286.325317 -285.926697 -283.421753 -283.069641 -282.845612 -283.497406 -285.073029 -284.874176 -285.878998 -289.425873 -292.465942 -296.132996 -297.852722 -297.915283 -297.945526 -298.086060 -297.760193 -296.726318 -293.549469 -280.805664 -281.837280 -286.450562 -286.436371 -286.889618 -287.213776 -286.292725 -287.934814 -288.938019 -279.075684 -279.819214 -282.094330 -283.445099 -283.463684 -283.470123 -283.692047 -284.080109 -284.483307 -285.147980 -285.897736 -286.523956 -287.009399 -287.293274 -287.465179 -287.564636 -287.601807 -287.533295 -287.411926 -286.533569 -286.748779 -287.360229 -287.981323 -288.485229 -288.680054 -287.301483 -286.770569 -288.632690 -288.843536 -289.614288 -290.603882 -291.741180 -291.221466 -289.682831 -288.624481 -291.023224 -292.252838 -292.389709 -292.711853 -292.103119 -291.473999 -291.092834 -292.294281 -293.489105 -294.230316 -294.544617 -294.377411 -294.561401 -294.526703 -294.161957 -293.370728 -292.325867 -291.090179 -290.270599 -289.726105 -289.311676 -289.222290 -289.260559 -288.951935 -288.106079 -287.260925 -287.517181 -288.265259 -288.999878 -289.554413 -290.021454 -289.631927 -289.333801 -289.777740 -290.704926 -284.280273 -283.878540 -283.557190 -283.232117 -282.859985 -282.726776 -282.861023 -285.685608 -283.456360 -283.297516 -282.782104 -282.281586 -282.048004 -281.922211 -281.824982 -281.792572 -281.791718 -281.769775 -281.902496 -282.288452 -282.828125 -283.336853 -281.639160 -284.247864 -284.495605 -284.894318 -285.347626 -285.718964 -285.929932 -285.815796 -283.624207 -283.178864 -283.142975 -281.798828 -283.280579 -285.267517 -287.360168 -288.213196 -288.009125 -286.955566 -287.233124 -289.172424 -291.141876 -294.225891 -295.449249 -295.816010 -278.877014 -278.096039 -278.594238 -279.668030 -280.460205 -288.878204 -288.350677 -287.700836 -287.204651 -284.363373 -276.345154 -277.527679 -279.968323 -281.416321 -282.293335 -282.031036 -281.672028 -282.354340 -282.816620 -283.282928 -283.945251 -284.780670 -285.363037 -285.696014 -285.996796 -286.228424 -286.389771 -286.519379 -286.563721 -286.462860 -286.323181 -285.534637 -285.782654 -286.342865 -284.147095 -284.883270 -284.478424 -285.121521 -286.229340 -287.395447 -287.722839 -288.539398 -289.551147 -290.036591 -288.306091 -288.407227 -289.097839 -291.289520 -292.510864 -292.952545 -292.634705 -292.362000 -291.782257 -290.941956 -290.670624 -291.066223 -291.409515 -291.263702 -290.676147 -289.801971 -288.553223 -287.832947 -286.298157 -284.994324 -283.817200 -283.088989 -283.026062 -283.272095 -283.399109 -283.801422 -284.664459 -283.669769 -283.479950 -283.557373 -284.402618 -285.979645 -287.684662 -289.117218 -290.126190 -290.506592 -290.440002 -290.370361 -290.220520 -289.042236 -284.780396 -283.235199 -284.146484 -284.505524 -282.315430 -282.795868 -284.328796 -283.745941 -282.761475 -282.081573 -281.721130 -281.551453 -281.498016 -281.533142 -281.507477 -281.424469 -281.637543 -282.335541 -279.907928 -280.498749 -280.484711 -280.159821 -281.442810 -281.422119 -285.395844 -280.177643 -279.818237 -272.036560 -280.127686 -280.359589 -281.075134 -282.287750 -284.189545 -286.508392 -288.399323 -289.305878 -289.206024 -287.911804 -288.410309 -288.850037 -290.311157 -291.941040 -291.877655 -279.124573 -278.809998 -278.604950 -278.402069 -278.506866 -279.138214 -289.673492 -291.432953 -290.380096 -274.998230 -275.103729 -276.737030 -278.986206 -280.523376 -280.281555 -279.104950 -277.844788 -277.587006 -279.831909 -281.992126 -282.615326 -283.170654 -283.740143 -284.258728 -284.677338 -284.989044 -285.206451 -285.339264 -285.403320 -285.357758 -285.243073 -285.203094 -285.357391 -284.737183 -285.285919 -285.688416 -283.617065 -283.901947 -284.428986 -285.237610 -286.125885 -287.972473 -289.369690 -289.590210 -288.237000 -286.961670 -287.253571 -288.760559 -290.579407 -291.443695 -291.904816 -291.534363 -290.556091 -289.064209 -287.397858 -285.934174 -284.865967 -284.200073 -283.637451 -282.926056 -282.175781 -281.568634 -280.672302 -279.640808 -278.470642 -277.488708 -276.943298 -276.997833 -277.381927 -277.779297 -278.125671 -279.160187 -279.911957 -280.105927 -280.003876 -281.988861 -284.235718 -286.576782 -288.527863 -289.300140 -289.067627 -287.968231 -286.471893 -285.134308 -283.441803 -279.746674 -276.872192 -278.688019 -280.075684 -281.145660 -283.345734 -284.917236 -286.324280 -286.661346 -286.234894 -284.715942 -283.830383 -280.775818 -280.883850 -280.757507 -280.612640 -281.115784 -282.403687 -278.213654 -280.326630 -280.154785 -280.675659 -281.616028 -282.119904 -280.760406 -281.250519 -281.204132 -280.990234 -282.673920 -283.120850 -283.900482 -285.434357 -287.262726 -289.395233 -290.641571 -290.449951 -290.490448 -290.469910 -290.833679 -291.400726 -292.106812 -292.852753 -293.167145 -290.929840 -278.080811 -277.704651 -277.530426 -276.030945 -276.591675 -276.533936 -275.966034 -275.413788 -283.996796 -274.667267 -275.666809 -278.410034 -278.982239 -278.126221 -276.791718 -269.863403 -268.858337 -270.736084 -280.338135 -281.660461 -282.681824 -282.971344 -283.072601 -283.349091 -283.619751 -283.787811 -283.857147 -283.746948 -283.533691 -283.481628 -283.731842 -284.173248 -283.688751 -284.223694 -284.600250 -284.830872 -284.865570 -284.239929 -285.526337 -287.121124 -287.425446 -289.457336 -289.938599 -289.282928 -286.555817 -284.387054 -285.367584 -286.790497 -288.640839 -289.577515 -289.443268 -288.836945 -287.771118 -286.345825 -284.843628 -283.404785 -282.201416 -281.276764 -279.154907 -278.650024 -278.872162 -277.894440 -276.654266 -275.247803 -273.978760 -273.000153 -272.566315 -272.784760 -273.077820 -273.506012 -274.437775 -275.178192 -276.101471 -277.364807 -278.969025 -280.875275 -282.923523 -284.487061 -285.174866 -284.524078 -282.946838 -281.140808 -278.894440 -276.176575 -273.472687 -272.490448 -272.766052 -274.027893 -276.121704 -278.885651 -282.430176 -285.458374 -287.089539 -286.565918 -287.236328 -286.689301 -285.002014 -283.662537 -280.345215 -278.857391 -280.247498 -281.757965 -278.047791 -280.060150 -280.083344 -280.514832 -281.578949 -282.520172 -282.430603 -283.550293 -284.551666 -285.308960 -285.938721 -285.749146 -286.000732 -286.840271 -287.878021 -289.031464 -290.899750 -291.942871 -292.876862 -293.176636 -293.302856 -293.547485 -293.703918 -293.507202 -292.490662 -291.755249 -290.724884 -288.368561 -286.046661 -272.548737 -272.625305 -272.857880 -278.842316 -277.999725 -276.970184 -273.359802 -273.227386 -276.533722 -277.525269 -277.711273 -267.149841 -264.276276 -262.784698 -263.186554 -268.674347 -278.361908 -279.198059 -279.715302 -280.170288 -280.565826 -280.669525 -279.267731 -279.148804 -281.307587 -281.225037 -281.460938 -282.158142 -282.979553 -282.240204 -282.721375 -283.119110 -283.453949 -283.715332 -283.831909 -284.525696 -286.813232 -287.879639 -289.172058 -289.097900 -288.516724 -286.893677 -283.315582 -281.149231 -280.721771 -280.425934 -280.354950 -280.229706 -287.434265 -286.913544 -285.462891 -285.257843 -282.916595 -280.659576 -280.320892 -278.195740 -278.417816 -277.413818 -276.997498 -276.766296 -275.425507 -274.022858 -272.975342 -273.460876 -272.319977 -271.549835 -271.569855 -272.068146 -272.710785 -273.409729 -274.276550 -275.154449 -275.975494 -276.716187 -277.198578 -277.449707 -276.876648 -275.997406 -274.822876 -273.187408 -271.477478 -269.552277 -269.177673 -269.275146 -270.656738 -272.395416 -274.655457 -277.642212 -280.589996 -282.447815 -284.113464 -285.019714 -284.542511 -283.340485 -276.055664 -277.366119 -278.087341 -278.992615 -279.813354 -276.721008 -277.585175 -277.375214 -278.542969 -278.241699 -279.071045 -279.918213 -280.547180 -281.056030 -280.959442 -280.781433 -280.628387 -280.501373 -280.546906 -281.280029 -282.609802 -282.665527 -283.443878 -283.698059 -283.831085 -284.340698 -284.265747 -284.005219 -284.154724 -283.762207 -284.462830 -283.270111 -281.965576 -280.669922 -278.513184 -272.496887 -272.628021 -275.908325 -275.033325 -274.969788 -273.201477 -273.274658 -276.177551 -277.204651 -270.631104 -264.436646 -258.455017 -255.816544 -255.436493 -261.729645 -264.632507 -267.855469 -270.997162 -272.951508 -276.972504 -273.710266 -276.041595 -277.703430 -278.839874 -279.273773 -279.952576 -280.810333 -281.626099 -280.216949 -280.663452 -281.139954 -281.507416 -281.906616 -282.169189 -282.044983 -281.709137 -281.584198 -281.542603 -281.436371 -281.205444 -280.809723 -280.310913 -279.959564 -279.730072 -279.508820 -279.267639 -278.951691 -278.574738 -278.067719 -277.329773 -276.501862 -276.135315 -276.341187 -277.135834 -275.673950 -275.487701 -275.065247 -275.148743 -274.786499 -274.375763 -273.533051 -272.091858 -272.367432 -272.380188 -272.174683 -272.236908 -272.587036 -273.178619 -272.468231 -272.338928 -272.366913 -272.344910 -272.300171 -272.344025 -272.529602 -271.960846 -272.106049 -271.434753 -270.815796 -269.765747 -270.904053 -271.076752 -270.596252 -269.575165 -269.906372 -270.420135 -270.993347 -271.639069 -272.295746 -272.596527 -272.429657 -272.177795 -271.767914 -271.182892 -270.742615 -270.604034 -270.811249 -271.808197 -272.850616 -272.873932 -272.858429 -272.834503 -272.867859 -272.926483 -273.047272 -273.105011 -273.119690 -273.035370 -272.877747 -272.698700 -272.563263 -272.483459 -273.604492 -274.638000 -273.375793 -275.342743 -275.439850 -275.498962 -275.727539 -275.303680 -273.061188 -275.698944 -275.788361 -275.482117 -271.949463 -275.268127 -274.058044 -273.240234 -272.791290 -271.514191 -272.797028 -275.252563 -275.276459 -274.384155 -275.357208 -276.268799 -276.968811 -265.696289 -262.326385 -257.855072 -255.296890 -252.147491 -252.953232 -256.956635 -261.638367 -265.078094 -268.167389 -271.389618 -273.861542 -273.160004 -273.160004 -276.169525 -277.746094 -278.645752 -279.184052 -279.705261 -278.039154 -278.584869 -279.159119 -279.617157 -279.910339 -279.924500 -279.565674 -279.063934 -278.878143 -278.948883 -279.064972 -279.138123 -278.847107 -278.304138 -277.968506 -277.865936 -277.850494 -277.755096 -277.486450 -277.180725 -278.671082 -277.404633 -275.843719 -275.573242 -275.554840 -275.609039 -275.729858 -273.631012 -273.479858 -273.139282 -272.884949 -272.983368 -273.661926 -273.419495 -273.039825 -273.103546 -273.179749 -272.896027 -272.634186 -272.196075 -271.390747 -270.197266 -272.271057 -272.860565 -273.858368 -274.348450 -274.853302 -274.837219 -274.203217 -273.936371 -273.567108 -270.862579 -270.774323 -270.608246 -270.513672 -270.400970 -270.157867 -269.543579 -269.149811 -268.693756 -268.821198 -268.989990 -269.261353 -269.653046 -270.379242 -271.329132 -272.402740 -271.838348 -272.146545 -272.861603 -272.880798 -272.829437 -272.836121 -272.818420 -272.764893 -272.683319 -272.550415 -272.453705 -272.373444 -272.341339 -272.338257 -272.336487 -272.311920 -272.224426 -273.224152 -273.308563 -273.080780 -272.001465 -272.044373 -272.149902 -272.187225 -272.029205 -271.639709 -274.132874 -270.146179 -274.175171 -269.346649 -274.315613 -274.654999 -274.267303 -272.741974 -274.416382 -274.731842 -274.996582 -274.661987 -275.066620 -275.517731 -276.180023 -264.799500 -260.009399 -258.191284 -256.258545 -253.799637 -249.704056 -248.135910 -251.185364 -256.387390 -262.733856 -266.038208 -268.558319 -271.113647 -273.262848 -273.160004 -273.160004 -273.160004 -275.783386 -276.847076 -277.442169 -274.315979 -276.040466 -277.468323 -277.956421 -278.123810 -277.876099 -278.324493 -276.778076 -275.282959 -275.359131 -275.527832 -275.747528 -275.658783 -275.214935 -275.103058 -275.361938 -275.679443 -275.725128 -275.617920 -275.559448 -275.515869 -274.983154 -274.023132 -273.061707 -272.701721 -272.378937 -272.396088 -272.361511 -272.121002 -269.743958 -270.946259 -271.461761 -271.902924 -271.938385 -271.863281 -271.728851 -272.423676 -272.328857 -271.852661 -271.462738 -270.531281 -270.391083 -270.218658 -269.991028 -269.766144 -269.433044 -269.094299 -269.118835 -269.290833 -271.382965 -269.774231 -269.934052 -270.094147 -270.339355 -270.690765 -270.787140 -270.638855 -270.437897 -270.225403 -270.286011 -270.460815 -271.251251 -271.857697 -272.196381 -272.573975 -272.875183 -273.076843 -273.148865 -273.153290 -273.151276 -273.079346 -272.962372 -272.850281 -272.665710 -272.463623 -272.282990 -272.146576 -272.040558 -271.966400 -271.867615 -271.737488 -271.629791 -271.589142 -271.603607 -271.518494 -271.346649 -271.156281 -271.867126 -270.971954 -271.886108 -270.702209 -270.627838 -270.403473 -272.796844 -273.185760 -273.437592 -273.411621 -273.180054 -271.949127 -271.121124 -273.887085 -273.884369 -274.073669 -273.046143 -268.846649 -267.447021 -266.081024 -262.998810 -258.428864 -256.790771 -254.743103 -251.862961 -248.482697 -245.968689 -245.964249 -248.300507 -251.218216 -257.772980 -264.981812 -268.133484 -270.124542 -272.009338 -272.524567 -273.056274 -273.160004 -273.160004 -273.160004 -273.160004 -272.515106 -272.538910 -272.617493 -272.660431 -272.678772 -272.691162 -272.819214 -274.043060 -274.012238 -273.141235 -273.111877 -273.084381 -273.092804 -273.090546 -273.129883 -273.110474 -273.001617 -272.898895 -272.699463 -272.475250 -272.018005 -271.310883 -270.301239 -268.845764 -266.873291 -266.021576 -266.085632 -266.233246 -266.405640 -266.786560 -267.358612 -267.838715 -268.463226 -269.070129 -269.575287 -269.388885 -269.661407 -269.916626 -269.793457 -269.503723 -269.204376 -268.936523 -268.860168 -268.709961 -268.580322 -268.581757 -268.614655 -268.552612 -268.504486 -268.717133 -268.613953 -268.580170 -268.685486 -268.836395 -268.991455 -269.163574 -269.340210 -269.578674 -269.826202 -270.054291 -270.239075 -270.416290 -270.549927 -270.700012 -270.833649 -270.931885 -271.016937 -271.059784 -270.968689 -270.800354 -270.516602 -269.985443 -269.436615 -268.954010 -268.625427 -268.393585 -268.106873 -267.878906 -267.749756 -267.721008 -267.772797 -267.921448 -268.158295 -268.402313 -268.550537 -268.658905 -268.706726 -268.731750 -268.755554 -268.829071 -268.936005 -269.066864 -269.228516 -269.376312 -270.570587 -270.000854 -269.390900 -268.719604 -268.009583 -266.747009 -259.411224 -258.847107 -265.733734 -267.014282 -272.066895 -259.051941 -255.327560 -255.465134 -254.452377 -253.838074 -253.049667 -251.834518 -250.848831 -250.031586 -249.872620 -251.120132 -253.707199 -257.204590 -262.515076 -268.323853 -270.448242 -271.562775 -271.861420 -272.159607 -272.390808 -272.598969 -272.809082 -272.916901 -273.006805 -273.024811 -272.965057 -272.955872 -272.901886 -272.647552 -272.739227 -272.765259 -272.779633 -272.670349 -272.505676 -272.329437 -272.013428 -271.722076 -271.546295 -271.287018 -271.000671 -270.696045 -270.350555 -269.909515 -269.317200 -268.497894 -267.461426 -266.589539 -266.018036 -265.668945 -265.411194 -265.199554 -265.182709 -265.301422 -265.490265 -265.724274 -266.055878 -266.427887 -267.129089 -267.936890 -268.668762 -269.182281 -269.876038 -270.670166 -270.844208 -271.045349 -270.980164 -270.827881 -270.675842 -270.533264 -270.401947 -270.281006 -270.165741 -270.056396 -269.974701 -269.913605 -269.764679 -268.978210 -267.489990 -266.824677 -265.655792 -265.206177 -265.117554 -265.093445 -265.384918 -265.941223 -266.335297 -266.520172 -266.523773 -266.430298 -266.311829 -266.166779 -266.028290 -265.859619 -265.732605 -265.598480 -265.397980 -265.188354 -265.060730 -265.082520 -265.246826 -265.392609 -265.504211 -265.649658 -265.869019 -266.121185 -266.347473 -266.557953 -266.777985 -267.141174 -267.922394 -268.623871 -269.416595 -270.117462 -270.460632 -270.604523 -270.626038 -270.586029 -270.554321 -270.605072 -270.897797 -270.806641 -270.679626 -269.667542 -268.787201 -268.285431 -267.963287 -267.677979 -267.422699 -267.336365 -266.865265 -266.589355 -266.347504 -266.137726 -264.177368 -262.639130 -261.067261 -261.915771 -261.225983 -259.934723 -259.434235 -261.237000 -264.277039 -267.839355 -270.397491 -270.681824 -271.313049 -271.869110 -272.258057 -272.537476 -272.772614 -272.915649 -272.630951 -272.452972 -272.327606 -272.134186 -272.021606 -271.924225 -271.841705 -271.746307 -271.617859 -271.437775 -271.271545 -271.083832 -270.872406 -270.692871 -270.521881 -270.338348 -270.143646 -269.937042 -269.705017 -269.433960 -269.108490 -268.706482 -268.249878 -267.821686 -267.410828 -267.058868 -266.787811 -266.613831 -266.514099 -266.468842 -266.467743 -266.827301 -267.515137 -268.799683 -269.790314 -271.181885 -271.801514 -272.356506 -272.584961 -272.656281 -272.695587 -272.717926 -272.721375 -272.710815 -272.681854 -272.642883 -272.598602 -272.548309 -272.481354 -272.397095 -272.280701 -272.042236 -271.515900 -270.179199 -268.577240 -268.098663 -267.992035 -268.031433 -267.947296 -267.936035 -267.907562 -267.928711 -267.874725 -267.860565 -267.999725 -268.316040 -268.576904 -268.648102 -268.702881 -268.727905 -268.912262 -269.044617 -269.256561 -269.321411 -269.381561 -269.420685 -269.525116 -269.754272 -269.957825 -270.261780 -270.537781 -270.841003 -271.272034 -271.702484 -272.089661 -272.397888 -272.519928 -272.582703 -272.595520 -272.539429 -272.450256 -272.349091 -272.245850 -272.144348 -272.050354 -271.957184 -271.839325 -271.720734 -271.662537 -271.610321 -271.512329 -271.369904 -271.299072 -271.211426 -271.063629 -270.876770 -270.705383 -270.365082 -270.354797 -270.425934 -270.507050 -270.636841 -270.814575 -271.046600 -271.274689 -271.479889 -271.647766 -271.832977 -271.966858 -272.099579 -272.244080 -272.356567 -272.449524 -272.522644 -272.576599 -272.709167 -272.771149 -272.748962 -270.299133 -270.284485 -270.265839 -270.243866 -270.216736 -270.182800 -270.144928 -270.103485 -270.056671 -270.004364 -269.948120 -269.885956 -269.817047 -269.728088 -269.631226 -269.549683 -269.471008 -269.382660 -269.308655 -269.233307 -269.111145 -268.972717 -268.886963 -268.812866 -268.751740 -268.696014 -268.654663 -268.611206 -268.575897 -268.547058 -268.517487 -268.492401 -268.476654 -268.463959 -268.436737 -268.471680 -268.477600 -268.498291 -268.510345 -268.539825 -268.574036 -268.598785 -268.644409 -268.695435 -268.743225 -268.799744 -268.858154 -268.899445 -268.937866 -268.976562 -269.036255 -269.084869 -269.151337 -269.184143 -269.214539 -269.228210 -269.258606 -269.246552 -269.243011 -269.233185 -269.220795 -269.156250 -269.172089 -269.167297 -269.157379 -269.179779 -269.208130 -269.231079 -269.248688 -269.291931 -269.372620 -269.427155 -269.498596 -269.551178 -269.611023 -269.677307 -269.729370 -269.754578 -269.798462 -269.841583 -269.882172 -269.897278 -269.920227 -269.939758 -269.961273 -269.986816 -270.036224 -270.109283 -270.154083 -270.298187 -270.337616 -270.443970 -270.510345 -270.540314 -270.619202 -270.677979 -270.613495 -270.584045 -270.471680 -270.441010 -270.392487 -270.276031 -270.250977 -270.208801 -270.130859 -270.083374 -270.041534 -270.046814 -270.027893 -270.041870 -270.011993 -270.018951 -270.033447 -270.072815 -270.109467 -270.124359 -270.133179 -270.185852 -270.210388 -270.235107 -270.241913 -270.250580 -270.257477 -270.277802 -270.307007 -270.311890 -270.308350 -270.308655 diff --git a/cesm/models/utils/mct/examples/climate_sequen1/coupler.F90 b/cesm/models/utils/mct/examples/climate_sequen1/coupler.F90 deleted file mode 100644 index 9288f98..0000000 --- a/cesm/models/utils/mct/examples/climate_sequen1/coupler.F90 +++ /dev/null @@ -1,214 +0,0 @@ -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!----------------------------------------------------------------------- -! CVS $Id: coupler.F90,v 1.6 2006-10-17 21:46:35 jacob Exp $ -! CVS $Name: $ -!BOP ------------------------------------------------------------------- -! -! !ROUTINE: coupler -- coupler for sequential model example -! -! !DESCRIPTION: -! A coupler subroutine for sequential climate model example. -! -! !INTERFACE: -! -module coupler -! -! !USES: -! -! Get the things needed from MCT by "Use,only" with renaming: -! -!---Domain Decomposition Descriptor DataType and associated methods -use m_GlobalSegMap,only: GlobalSegMap - -!---Field Storage DataType and associated methods -use m_AttrVect,only : AttrVect - -!---Sparse Matrix DataType and associated methods -use m_SparseMatrix, only : SparseMatrix -use m_SparseMatrix, only : SparseMatrix_clean => clean -use m_SparseMatrix, only : SparseMatrix_init => init -use m_SparseMatrix, only : SparseMatrix_importGRowInd => & - importGlobalRowIndices -use m_SparseMatrix, only : SparseMatrix_importGColInd => & - importGlobalColumnIndices -use m_SparseMatrix, only : SparseMatrix_importMatrixElts => & - importMatrixElements -use m_SparseMatrixPlus, only : SparseMatrixPlus -use m_SparseMatrixPlus, only : SparseMatrixPlus_init => init -use m_SparseMatrixPlus, only : SparseMatrixPlus_clean => clean -use m_SparseMatrixPlus, only : Xonly ! Decompose matrix by row -!---Matrix-Vector multiply methods -use m_MatAttrVectMul, only: MCT_MatVecMul => sMatAvMult - -!---MPEU I/O utilities -use m_stdio -use m_ioutil - -implicit none - -private - -! !PUBLIC MEMBER FUNCTIONS: - -public cplinit -public cplrun -public cplfin - -! !PRIVATE DATA MEMBERS -type(SparseMatrixPlus) :: Src2DstMatPlus ! the mapping weights - -character(len=*), parameter :: cplname='coupler.F90' -integer :: rank - -!EOP ___________________________________________________________________ - -contains - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: cplinit - initialize the coupler -! -! !INTERFACE: - -subroutine cplinit(SrcGSMap,DstGSMap,comm,compid) - -! !INPUT PARAMETERS: - - type(GlobalSegMap),intent(in) :: SrcGSMap,DstGSMap ! GSmaps for source and dst - integer,intent(in) :: comm ! local MPI communicator - integer,intent(in) :: compid ! coupler's component ID -! -!EOP ___________________________________________________________________ - -! Local variables - character(len=100),parameter :: & - RemapMatrixFile='../../data/t42_to_popx1_c_mat.asc' - -! Loop indicies - integer :: i,j,k,n - -! MPI variables - integer :: nprocs, root, ierr -! SparseMatrix variables - integer :: mdev - integer :: num_elements, nRows, nColumns - integer, dimension(2) :: src_dims, dst_dims - integer, dimension(:), pointer :: rows, columns - real, dimension(:), pointer :: weights -! SparseMatrix elements on root - type(SparseMatrix) :: sMat -! _____________________________________________________________________ - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! INITIALIZATION PHASE -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - - ! LOCAL RANK AND SIZE - call MPI_COMM_RANK(comm,rank,ierr) - call MPI_COMM_SIZE(comm,nprocs,ierr) - root = 0 - - if(rank==0) write(6,*) cplname,' init start' - if(rank==0) write(6,*) cplname,' MyID ', compid - if(rank==0) write(6,*) cplname,' Num procs ', nprocs - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! Read matrix weights for interpolation from a file. - if (rank == root) then - mdev = luavail() - open(mdev, file=trim(RemapMatrixFile), status="old") - read(mdev,*) num_elements - read(mdev,*) src_dims(1), src_dims(2) - read(mdev,*) dst_dims(1), dst_dims(2) - - allocate(rows(num_elements), columns(num_elements), & - weights(num_elements), stat=ierr) - - do n=1, num_elements - read(mdev,*) rows(n), columns(n), weights(n) - end do - - close(mdev) - - ! Initialize a Sparsematrix - nRows = dst_dims(1) * dst_dims(2) - nColumns = src_dims(1) * src_dims(2) - call SparseMatrix_init(sMat,nRows,nColumns,num_elements) - call SparseMatrix_importGRowInd(sMat, rows, size(rows)) - call SparseMatrix_importGColInd(sMat, columns, size(columns)) - call SparseMatrix_importMatrixElts(sMat, weights, size(weights)) - - deallocate(rows, columns, weights, stat=ierr) - - endif - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! Build a SparseMatrixPlus for doing the interpolation - ! Specify matrix decomposition to be by row. - ! following the atmosphere's decomposition. - call SparseMatrixPlus_init(Src2DstMatPlus, sMat, SrcGSMap, DstGSMap, & - Xonly, root, comm, compid) - - ! no longer need the matrix defined on root - if(rank==0) call SparseMatrix_clean(sMat) - if(rank==0) write(6,*) cplname, ' init done' - - -!!! END OF INIT !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -end subroutine cplinit - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! RUN PHASE -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: cplrun - coupler's run method - -subroutine cplrun(IMPORT,EXPORT) - -! !INPUT PARAMETERS: - type(AttrVect),intent(in) :: IMPORT - type(AttrVect),intent(out) :: EXPORT -!EOP ------------------------------------------------------------------- - - if(rank==0) write(6,*) cplname, ' run start' - - ! Interpolate by doing a parallel sparsematrix-attrvect multiply - ! Note: this will interpolate all fields with the same names - - call MCT_MatVecMul(IMPORT, Src2DstMatPlus, EXPORT) - - ! possibly do more calculations - - if(rank==0) write(6,*) cplname, ' run done' -!!! END OF RUN !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -end subroutine cplrun - - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! FINALIZE PHASE -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: cplfin - coupler's finalize method - -subroutine cplfin - -! -!EOP ------------------------------------------------------------------- - - call SparseMatrixPlus_clean(Src2DstMatPlus) - if(rank==0) write(6,*) cplname, " done" -end subroutine cplfin - -end module coupler - diff --git a/cesm/models/utils/mct/examples/climate_sequen1/dst.rc b/cesm/models/utils/mct/examples/climate_sequen1/dst.rc deleted file mode 100644 index cbb9449..0000000 --- a/cesm/models/utils/mct/examples/climate_sequen1/dst.rc +++ /dev/null @@ -1,6 +0,0 @@ -# Resource file for dst model -# nx and ny:: global grid size in x and y - - nx: 320 - ny: 384 - decomp: R diff --git a/cesm/models/utils/mct/examples/climate_sequen1/dstmodel.F90 b/cesm/models/utils/mct/examples/climate_sequen1/dstmodel.F90 deleted file mode 100644 index 4f53ebf..0000000 --- a/cesm/models/utils/mct/examples/climate_sequen1/dstmodel.F90 +++ /dev/null @@ -1,231 +0,0 @@ -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!----------------------------------------------------------------------- -! CVS $Id: dstmodel.F90,v 1.8 2006-10-17 21:47:56 jacob Exp $ -! CVS $Name: $ -!BOP ------------------------------------------------------------------- -! -! !MODULE: dstmodel -- generic model for sequential climate model -! -! !DESCRIPTION: -! init run and finalize methods for destination model -! -! !INTERFACE: -! -module dstmodel - -! -! !USES: -! -! Get the things needed from MCT by "Use,only" with renaming: -! -!---Domain Decomposition Descriptor DataType and associated methods -use m_GlobalSegMap,only: GlobalSegMap -use m_GlobalSegMap,only: GlobalSegMap_init => init -use m_GlobalSegMap,only: GlobalSegMap_lsize => lsize -use m_GlobalSegMap,only: GlobalSegMap_clean => clean -!---Field Storage DataType and associated methods -use m_AttrVect,only : AttrVect -use m_AttrVect,only : AttrVect_init => init -use m_AttrVect,only : AttrVect_lsize => lsize -use m_AttrVect,only : AttrVect_clean => clean -use m_AttrVect,only : AttrVect_copy => copy -use m_AttrVect,only : AttrVect_indxR => indexRA -use m_AttrVect,only : AttrVect_importRAttr => importRAttr -use m_AttrVectcomms,only : AttrVect_gather => gather - -! Get things from MPEU -use m_inpak90 ! Resource files -use m_stdio ! I/O utils -use m_ioutil - - -! Get utilities for this program. -use mutils - -implicit none - -private -! except - -! !PUBLIC MEMBER FUNCTIONS: -! -public dstinit -public dstrun -public dstfin - -! module variables -character(len=*), parameter :: modelname='dstmodel.F90' -integer :: rank, lcomm - -!EOP ------------------------------------------------------------------- - -contains -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: dstinit - Destination model initialization - -subroutine dstinit(GSMap,IMPORT,EXPORT,comm,compid) - -! !INPUT PARAMETERS: - type(GlobalSegMap),intent(inout) :: GSMap ! decomposition - type(AttrVect),intent(inout) :: IMPORT,EXPORT ! state data - integer,intent(in) :: comm ! MPI communicator - integer,intent(in) :: compid ! component ID -! -!EOP ___________________________________________________________________ - -! local variables - -! parameters for this model - integer :: nxa ! number of points in x-direction - integer :: nya ! number of points in y-direction - - integer :: i,j,k,idx - - integer :: nprocs, root, ier - -! GlobalSegMap variables - integer,dimension(:),pointer :: lindex - -! AttrVect variables - integer :: avsize - - character*2, ldecomp - - - call MPI_COMM_RANK(comm,rank, ier) - call MPI_COMM_SIZE(comm,nprocs,ier) - -! save local communicator - lcomm=comm - - if(rank==0) then - write(6,*) modelname, ' init start' - write(6,*) modelname,' MyID ', compid - write(6,*) modelname,' Num procs ', nprocs - endif - -! Get configuration - call i90_LoadF('dst.rc',ier) - - call i90_label('nx:',ier) - nxa=i90_gint(ier) - call i90_label('ny:',ier) - nya=i90_gint(ier) - if(rank==0) write(6,*) modelname, ' x,y ', nxa,nya - - call i90_label('decomp:',ier) - call i90_Gtoken(ldecomp, ier) - if(rank==0) write(6,*) modelname, ' decomp ', ldecomp - - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! Initialize a Global Segment Map - - - call get_index(ldecomp,nprocs,rank,nxa,nya,lindex) - - call GlobalSegMap_init(GSMap,lindex,comm,compid,gsize=nxa*nya) - - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - - if(rank==0) write(6,*) modelname, ' GSMap ',GSMap%ngseg,GSMap%gsize - - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! Initialize import and export Attribute vectors - -! size is the number of grid points on this processor - avsize = GlobalSegMap_lsize(GSMap,comm) - if(rank==0) write(6,*) modelname, ' localsize ', avsize - -! initialize Avs with two real attributes. - call AttrVect_init(IMPORT,rList="field3:field4",lsize=avsize) - call AttrVect_init(EXPORT,rList="field5:field6",lsize=avsize) -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - if(rank==0) write(6,*) modelname, ' init done' -end subroutine dstinit -!!! END OF INIT !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! RUN PHASE -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: dstrun - Destination model run method - -subroutine dstrun(IMPORT,EXPORT) - -! !INPUT PARAMETERS: - type(AttrVect),intent(inout) :: IMPORT,EXPORT ! Input and Output states - -!EOP ------------------------------------------------------------------- - -! local variables - integer :: avsize,ier,i,index - - if(rank==0) write(6,*) modelname, ' run start' - -! Copy input data to output data using translation between different names - call AttrVect_copy(IMPORT,EXPORT,rList="field3:field4", & - TrList="field5:field6") - - if(rank==0) write(6,*) modelname, ' run done' - -end subroutine dstrun -!!! END OF RUN !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! FINALIZE PHASE -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: dstfin - Destination model finalize method - -subroutine dstfin(IMPORT,EXPORT,GSMap) - -! !INPUT PARAMETERS: - type(AttrVect),intent(inout) :: IMPORT,EXPORT ! MCT defined type - type(GlobalSegMap),intent(inout) :: GSMap - -!EOP ------------------------------------------------------------------- - type(AttrVect) :: GlobalD - integer :: lsize,ier,mdev,i - - if(rank==0) write(6,*) modelname,' fin start' -! gather data to node 0 and write it out - call AttrVect_gather(EXPORT,GlobalD,GSMap,0,lcomm,ier) - -! write out gathered data - if(rank==0) then - mdev=luavail() - lsize=AttrVect_lsize(GlobalD) - open(mdev, file="TS1out.dat") - do i=1,lsize - write(mdev,*) GlobalD%rAttr(1,i) - enddo - close(mdev) - endif - - ! clean up - call AttrVect_clean(IMPORT) - call AttrVect_clean(EXPORT) - if(rank==0)call AttrVect_clean(GlobalD) - call GlobalSegMap_clean(GSMap) - if(rank==0) write(6,*) modelname,' fin done' -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -endsubroutine dstfin - -end module dstmodel diff --git a/cesm/models/utils/mct/examples/climate_sequen1/master.F90 b/cesm/models/utils/mct/examples/climate_sequen1/master.F90 deleted file mode 100644 index fbcd89e..0000000 --- a/cesm/models/utils/mct/examples/climate_sequen1/master.F90 +++ /dev/null @@ -1,103 +0,0 @@ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!----------------------------------------------------------------------- -! CVS $Id: master.F90,v 1.5 2009-02-23 23:22:47 jacob Exp $ -! CVS $Name: $ -!BOP ------------------------------------------------------------------- -! -! !PROGRAM: master -- driver for sequential coupled model example -! -! !DESCRIPTION: Provide a simple example of using MCT to connect to -! components executing sequentially in a single executable. -! -program master - -! -! !USES: -! - - use m_AttrVect,only : AttrVect - use m_GlobalSegMap,only: GlobalSegMap - use m_MCTWorld,only: MCTWorld_init => init - - use srcmodel - use dstmodel - use coupler - - implicit none - - include "mpif.h" - -! -!EOP ------------------------------------------------------------------- - -! local variables - - character(len=*), parameter :: mastername='master.F90' - - integer :: ncomps = 3 ! Must know total number of - ! components in coupled system - - integer,dimension(:),pointer :: comps ! array with component ids - - - type(AttrVect) :: srcImp,srcExp ! import and export states for src and - type(AttrVect) :: dstImp,dstExp ! destination models - - type(GlobalSegMap) :: srcGSMap ! decomposition descriptors for src and - type(GlobalSegMap) :: dstGSMap ! desitnation models - -! other variables - integer :: comm1, comm2, rank, nprocs,compid, myID, ier,color - integer :: anprocs,cnprocs - -!----------------------------------------------------------------------- -! The Main program. -! We are implementing a single-executable, sequential-execution system. -! -! This main program initializes MCT and runs the whole model. - -! Initialize MPI - call MPI_INIT(ier) - -! Get basic MPI information - call MPI_COMM_SIZE(MPI_COMM_WORLD,nprocs,ier) - call MPI_COMM_RANK(MPI_COMM_WORLD,rank,ier) - -! Get communicators for each model - call mpi_comm_dup(MPI_COMM_WORLD,comm1,ier) - call mpi_comm_dup(MPI_COMM_WORLD,comm2,ier) - -! Initialize MCT - allocate(comps(ncomps),stat=ier) - comps(1)=1 - comps(2)=2 - comps(3)=3 - call MCTWorld_init(ncomps,MPI_COMM_WORLD,comm1,myids=comps) - - -! Initialize the model - call srcinit(srcGSMap,srcImp,srcExp,comm1,1) - call dstinit(dstGSMap,dstImp,dstExp,comm2,2) - call cplinit(srcGSMap,dstGSMap,comm1,3) - -! Run the model - -! source does something with srcImp and produces export - call srcrun(srcImp,srcExp) - -! map the source model's Export to the destination model's Import - call cplrun(srcExp,dstImp) - -! destination model does something with dstImp - call dstrun(dstImp,dstExp) - -! Finalize - call srcfin(srcImp,srcExp,srcGSMap) - call dstfin(dstImp,dstExp,dstGSMap) - call cplfin - - call MPI_FINALIZE(ier) - -end program master diff --git a/cesm/models/utils/mct/examples/climate_sequen1/mutils.F90 b/cesm/models/utils/mct/examples/climate_sequen1/mutils.F90 deleted file mode 100644 index 897d4b2..0000000 --- a/cesm/models/utils/mct/examples/climate_sequen1/mutils.F90 +++ /dev/null @@ -1,139 +0,0 @@ -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!----------------------------------------------------------------------- -! CVS $Id: mutils.F90,v 1.8 2005-11-18 23:15:38 rloy Exp $ -! CVS $Name: $ -!BOP ------------------------------------------------------------------- -! -! !MODULE: mutils -- utilities for the sequential climate example -! -! !DESCRIPTION: -! -! !INTERFACE: -! -module mutils - -! module of utilties for the sequential climate example -! - - implicit none - - private -! except - -! !PUBLIC TYPES: - - public get_index - - contains -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: get_index - get local index array and size -! for 3 standard decompositions of a grid. -! -! !DESCRIPTION: -! The routine get_index will return a local index array and size that can -! be passed to a GSMap_init routine for three possible decompositions: -! R - by row or latitude -! C - by column or longitude -! RC - row and column or checkerboard -! choice is determined by the value of ldecomp. -! -! !INTERFACE: - -subroutine get_index(ldecomp,nprocs,myproc,gnx,gny,gridbuf) -! !INPUT PARAMETERS: -! - character(len=*),intent(inout) :: ldecomp ! decomp choice - integer,intent(in) :: nprocs ! total number of MPI processes - integer,intent(in) :: myproc ! my rank in local communicator - integer,intent(in) :: gnx ! total points in X direction - integer,intent(in) :: gny ! total points in Y direction - -! !OUTPUT PARAMETERS: -! - integer,dimension(:),pointer :: gridbuf ! local index array -! -!EOP ___________________________________________________________________ - - integer :: npesx,npesy,ng,ny,n,i,j,nx,ig,jg,nseg,factor - - -! default decomp is R - if((trim(ldecomp) .ne. 'R') .and. (ldecomp .ne. 'C') .and. (ldecomp .ne. 'RC')) then - ldecomp = 'R' - endif - -! A 'by-row' or 'by-latitude' decomposition - if(trim(ldecomp) .eq. 'R') then - npesx=1 - npesy=nprocs - nx=gnx - ny=gny/npesy - allocate(gridbuf(nx*ny)) - n=0 - do j=1,ny - do i=1,nx - n=n+1 - ig=i - jg = j + myProc*ny - ng =(jg-1)*gnx + ig - gridbuf(n)=ng - enddo - enddo - -! A 'by-column' or 'by-longitude' decomposition - else if (ldecomp .eq. 'C') then - npesx=nprocs - npesy=1 - nx=gnx/npesx - ny=gny - allocate(gridbuf(nx*ny)) - n=0 - do j=1,ny - do i=1,nx - n=n+1 - ig=i + myProc*nx - jg= j - ng=(jg-1)*gnx + ig - gridbuf(n)=ng - enddo - enddo - -! A 'row-columen' or 'checkerboard' decomposition - else if (ldecomp .eq. 'RC') then - ! find the closest square - factor=1 - do i=2,INT(sqrt(FLOAT(nprocs))) - if ( (nprocs/i) * i .eq. nprocs) then - factor = i - endif - enddo - npesx=factor - npesy=nprocs/factor - nx=gnx/npesx - ny=gny/npesy -! write(6,*) 'RC',factor,npesy,nx,ny - allocate(gridbuf(nx*ny)) - n=0 - do j=1,ny - do i=1,nx - n=n+1 - ig=mod(myProc,npesx)*nx+i - jg=(myProc/npesx)*ny+j - ng=(jg-1)*gnx + ig - gridbuf(n)=ng - enddo - enddo - - - endif - -end subroutine get_index - - - - -end module mutils diff --git a/cesm/models/utils/mct/examples/climate_sequen1/src.rc b/cesm/models/utils/mct/examples/climate_sequen1/src.rc deleted file mode 100644 index 1dd5275..0000000 --- a/cesm/models/utils/mct/examples/climate_sequen1/src.rc +++ /dev/null @@ -1,6 +0,0 @@ -# Resource file for src model -# nx and ny:: global grid size in x and y - - nx: 128 - ny: 64 - decomp: R diff --git a/cesm/models/utils/mct/examples/climate_sequen1/srcmodel.F90 b/cesm/models/utils/mct/examples/climate_sequen1/srcmodel.F90 deleted file mode 100644 index c2d507e..0000000 --- a/cesm/models/utils/mct/examples/climate_sequen1/srcmodel.F90 +++ /dev/null @@ -1,248 +0,0 @@ -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!----------------------------------------------------------------------- -! CVS $Id: srcmodel.F90,v 1.8 2005-11-18 23:15:38 rloy Exp $ -! CVS $Name: $ -!BOP ------------------------------------------------------------------- -! -! !MODULE: srcmodel -- generic model for unit tester -! -! !DESCRIPTION: -! init run and finalize methods for source model -! -module srcmodel - -! -! !USES: -! -! Get the things needed from MCT by "Use,only" with renaming: -! -!---Domain Decomposition Descriptor DataType and associated methods -use m_GlobalSegMap,only: GlobalSegMap -use m_GlobalSegMap,only: GlobalSegMap_init => init -use m_GlobalSegMap,only: GlobalSegMap_lsize => lsize -use m_GlobalSegMap,only: GlobalSegMap_clean => clean -!---Field Storage DataType and associated methods -use m_AttrVect,only : AttrVect -use m_AttrVect,only : AttrVect_init => init -use m_AttrVect,only : AttrVect_lsize => lsize -use m_AttrVect,only : AttrVect_clean => clean -use m_AttrVect,only : AttrVect_copy => copy -use m_AttrVect,only : AttrVect_zero => zero -use m_AttrVect,only : AttrVect_indxR => indexRA -use m_AttrVect,only : AttrVect_importRAttr => importRAttr -use m_AttrVectComms,only : AttrVect_scatter => scatter - -! Get things from MPEU -use m_inpak90 ! Resource files -use m_stdio ! I/O utils -use m_ioutil - -! Get utilities for this program. -use mutils - -implicit none - -private -! except - -! !PUBLIC MEMBER FUNCTIONS: - -public srcinit -public srcrun -public srcfin - -! private module variables -character(len=*), parameter :: modelname='srcmodel.F90' -integer :: rank -real, dimension(:), pointer :: avdata - -!EOP ------------------------------------------------------------------- - -contains - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: srcinit - Source model initialization - -subroutine srcinit(GSMap,IMPORT,EXPORT,comm,compid) - -! !INPUT PARAMETERS: - type(GlobalSegMap),intent(inout) :: GSMap ! decomposition - type(AttrVect),intent(inout) :: IMPORT,EXPORT ! state data - integer,intent(in) :: comm ! MPI communicator - integer,intent(in) :: compid ! component ID -! -!EOP ___________________________________________________________________ - -! local variables - -! parameters for this model - integer :: nxa ! number of points in x-direction - integer :: nya ! number of points in y-direction - - integer :: i,j,k,mdev,fx,fy - integer :: nprocs, root, ier,fileno - -! GlobalSegMap variables - integer,dimension(:),pointer :: lindex - -! AttrVect variables - integer :: avsize - type(AttrVect) :: GlobalD ! Av to hold global data - - real,dimension(:),pointer :: rootdata - - character*2 :: ldecomp - - - call MPI_COMM_RANK(comm,rank, ier) - call MPI_COMM_SIZE(comm,nprocs,ier) - - if(rank==0) then - write(6,*) modelname, ' init start' - write(6,*) modelname,' MyID ', compid - write(6,*) modelname,' Num procs ', nprocs - endif - -! Get configuration - call i90_LoadF('src.rc',ier) - - call i90_label('nx:',ier) - nxa=i90_gint(ier) - call i90_label('ny:',ier) - nya=i90_gint(ier) - if(rank==0) write(6,*) modelname, ' x,y ', nxa,nya - - call i90_label('decomp:',ier) - call i90_Gtoken(ldecomp, ier) - if(rank==0) write(6,*) modelname, ' decomp ', ldecomp - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! Initialize a Global Segment Map - - - call get_index(ldecomp,nprocs,rank,nxa,nya,lindex) - - call GlobalSegMap_init(GSMap,lindex,comm,compid,gsize=nxa*nya) - - - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - if(rank==0) write(6,*) modelname, ' GSMap ',GSMap%ngseg,GSMap%gsize - - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! Initialize import and export Attribute vectors - -! size is the number of grid points on this processor - avsize = GlobalSegMap_lsize(GSMap,comm) - if(rank==0) write(6,*) modelname, ' localsize ', avsize - -! Initialize the IMPORT Av by scattering from a root Av -! with real data. - -! Read in data from root and scatter to nodes - if(rank==0) then - call AttrVect_init(GlobalD,rList="field1:field2",lsize=nxa*nya) - mdev=luavail() - open(mdev, file="TS1.dat",status="old") - read(mdev,*) fx,fy - do i=1,nxa*nya - read(mdev,*) GlobalD%rAttr(1,i) - enddo - write(6,*) modelname,'Global init ',GlobalD%rAttr(1,1),GlobalD%rAttr(1,8000) - endif - -! this scatter will create IMPORT if it hasn't already been initialized - call AttrVect_scatter(GlobalD,IMPORT,GSMap,0,comm,ier) - -! initialize EXPORT Av with two real attributes. - call AttrVect_init(EXPORT,rList="field3:field4",lsize=avsize) - - call AttrVect_zero(EXPORT) - - if(rank==0) then - write(6,*) modelname, rank,' IMPORT field1', IMPORT%rAttr(1,1) - write(6,*) modelname, rank,' IMPORt field2', IMPORT%rAttr(2,1) - write(6,*) modelname, rank,' EXPORT field3', EXPORT%rAttr(1,1) - write(6,*) modelname, rank,' EXPORT field4', EXPORT%rAttr(2,1) - endif - -! allocate buffer for use in run method - allocate(avdata(avsize),stat=ier) - - if(rank==0) write(6,*) modelname, ' init done' -end subroutine srcinit -!!! END OF INIT !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! RUN PHASE -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: srcrun - Source model run method - -subroutine srcrun(IMPORT,EXPORT) - -! !INPUT PARAMETERS: - type(AttrVect),intent(inout) :: IMPORT,EXPORT ! Input and Output states - -!EOP ------------------------------------------------------------------- -! local variables - integer :: avsize,ier,i - -! Nothing to do with IMPORT - - -! Fill EXPORT with data - if(rank==0) write(6,*) modelname, ' run start' - -! Use Av copy to copy input data from field1 in Imp to field3 in EXPORT - call AttrVect_copy(IMPORT,EXPORT,rList='field1',TrList='field3') - -! Use import to load data in second field - avdata=30.0 - call AttrVect_importRAttr(EXPORT,"field4",avdata) - - if(rank==0) write(6,*) modelname, ' In field1', IMPORT%rAttr(1,1) - if(rank==0) write(6,*) modelname, ' In field2', IMPORT%rAttr(2,1) - if(rank==0) write(6,*) modelname, ' Out field3', EXPORT%rAttr(1,1) - if(rank==0) write(6,*) modelname, ' Out field4', EXPORT%rAttr(2,1) - - if(rank==0) write(6,*) modelname, ' run done' - -end subroutine srcrun -!!! END OF RUN !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! FINALIZE PHASE -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: srcfin - Source model finalize method - -subroutine srcfin(IMPORT,EXPORT,GSMap) - -! !INPUT PARAMETERS: - type(AttrVect),intent(inout) :: IMPORT,EXPORT ! imp,exp states - type(GlobalSegMap),intent(inout) :: GSMap -!EOP ------------------------------------------------------------------- - ! clean up - call AttrVect_clean(IMPORT) - call AttrVect_clean(EXPORT) - call GlobalSegMap_clean(GSMap) - deallocate(avdata) - if(rank==0) write(6,*) modelname,' fin done' -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -endsubroutine srcfin - -end module srcmodel diff --git a/cesm/models/utils/mct/examples/simple/.gitignore b/cesm/models/utils/mct/examples/simple/.gitignore deleted file mode 100644 index 4029698..0000000 --- a/cesm/models/utils/mct/examples/simple/.gitignore +++ /dev/null @@ -1,4 +0,0 @@ -twocon -twoseq -twosequn -twoseqNB diff --git a/cesm/models/utils/mct/examples/simple/Makefile b/cesm/models/utils/mct/examples/simple/Makefile deleted file mode 100644 index 4f64bbf..0000000 --- a/cesm/models/utils/mct/examples/simple/Makefile +++ /dev/null @@ -1,53 +0,0 @@ - -SHELL = /bin/sh - -# SOURCE FILES - -SRCS_F90 = twocmp.con.F90 \ - twocmp.seq.F90 \ - twocmp.seqUnvn.F90 \ - twocmp.seqNB.F90 \ - -OBJS_ALL = $(SRCS_F90:.F90=.o) - -# MACHINE AND COMPILER FLAGS - -include ../../Makefile.conf - -# ADDITIONAL DEFINITIONS SPECIFIC FOR UTMCT COMPILATION - -MCTLIBS = -L$(MPEUPATH) -L$(MCTPATH) -lmct -lmpeu -UTLDFLAGS = $(REAL8) -UTCMPFLAGS = $(REAL8) $(INCFLAG)$(MPEUPATH) $(INCFLAG)$(MCTPATH) - -# TARGETS - -all: twocon twoseq twosequn twoseqNB - -twocon: twocmp.con.o - $(FC) -o $@ twocmp.con.o $(FCFLAGS) $(UTLDFLAGS) $(MCTLIBS) $(MPILIBS) - -twoseq: twocmp.seq.o - $(FC) -o $@ twocmp.seq.o $(FCFLAGS) $(UTLDFLAGS) $(MCTLIBS) $(MPILIBS) - -twosequn: twocmp.seqUnvn.o - $(FC) -o $@ twocmp.seqUnvn.o $(FCFLAGS) $(UTLDFLAGS) $(MCTLIBS) $(MPILIBS) - -twoseqNB: twocmp.seqNB.o - $(FC) -o $@ twocmp.seqNB.o $(FCFLAGS) $(MCTLIBS) $(MPILIBS) - -# RULES - -.SUFFIXES: -.SUFFIXES: .F90 .o - -.F90.o: - $(FC) -c $(INCPATH) $(FPPDEFS) $(FCFLAGS) $(MCTFLAGS) $(UTCMPFLAGS) $< - - -clean: - ${RM} *.o *.mod twocon twoseq twosequn twoseqNB - -# DEPENDENCIES: - -$(OBJS_ALL): $(MCTPATH)/libmct.a diff --git a/cesm/models/utils/mct/examples/simple/README b/cesm/models/utils/mct/examples/simple/README deleted file mode 100644 index aff380d..0000000 --- a/cesm/models/utils/mct/examples/simple/README +++ /dev/null @@ -1,51 +0,0 @@ - - -The programs in this directory demonstrate how to use basic -functions of MCT in several possible coupled configurations of -two components. - -Each example is contained in one .F90 file. - -To compile: -First make sure you have compiled MCT. See instructions in -MCT/README - -Type "make" here or "make examples" in the top-level directory. - -To run: Consult your local documentation for how to run a parallel -program. The examples below assume mpirun is available and you -can run interactively. "script.babyblue" is an example of run script -for IBM systems which use a queue manager. - ----------------------------------------------------------------------- -twocomponent.concurrent.F90 - two components running concurrently on - separate pools of processors. - - requires: at least 3 MPI processes - to run: mpirun -np 3 twocon - note: will not work with mpi-serial - ------------------------------------------- -twocomponent.sequential.F90 - two components running sequentially on - the same processors. Uses arguments to pass data between models. - Shows use of Rearranger. - - requires: at least 1 MPI process - to run: mpirun -np 1 twoseq - ------------------------------------------- -twocomponent.seqNB.F90 - two components running sequentially on - the same processors. Uses non-blocking MCT calls to pass data between - models - - requires: at least 1 MPI process - to run: mpirun -np 1 twoseqNB - ------------------------------------------- -twocomponentUneven.sequential.F90 - two components running sequentially but - one model is only running on some of the shared processors. - - requires: no more than 12 processors - to run: mpirun -np 2 twosequn - ------------------------------------------- diff --git a/cesm/models/utils/mct/examples/simple/script.babyblue b/cesm/models/utils/mct/examples/simple/script.babyblue deleted file mode 100644 index 1937a2f..0000000 --- a/cesm/models/utils/mct/examples/simple/script.babyblue +++ /dev/null @@ -1,29 +0,0 @@ -#! /usr/bin/csh -f -#################################################### -# -# Example run script for LoadLeveler, the queue -# system used on most IBM's. -# -# Your site may require different options. -# -#################################################### -# @ output = utmct.stdout.$(jobid).$(stepid) -# @ error = utmct.stderr.$(jobid).$(stepid) -# @ job_name = mctsimple -# @ job_type = parallel -# @ node = 4,4 -# @ tasks_per_node = 4 -# @ checkpoint = no -# @ node_usage = not_shared -# @ network.MPI = csss,not_shared,us -# @ class = share -# @ notification = never -# @ queue - -setenv MP_STDOUTMODE ordered -setenv MP_INFOLEVEL 2 - -echo "`date` -- UTMCT EXECUTION BEGINS HERE" -poe twocon -echo "`date` -- UTMCT EXECUTION finishes HERE" - diff --git a/cesm/models/utils/mct/examples/simple/twocmp.con.F90 b/cesm/models/utils/mct/examples/simple/twocmp.con.F90 deleted file mode 100644 index 2ba4720..0000000 --- a/cesm/models/utils/mct/examples/simple/twocmp.con.F90 +++ /dev/null @@ -1,222 +0,0 @@ -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!----------------------------------------------------------------------- -! CVS $Id: twocmp.con.F90,v 1.4 2006-07-25 22:31:34 jacob Exp $ -! CVS $Name: $ -!BOP ------------------------------------------------------------------- -! -! !ROUTINE: twocomponent.concurrent -! -! !DESCRIPTION: Provide a simple example of using MCT to connect two -! components executing concurrently in a single executable. -! -! -! !INTERFACE: -! - program twocon -! -! !USES: -! -!--- Use only the things needed from MCT - use m_MCTWorld,only: MCTWorld_init => init - - use m_GlobalSegMap,only: GlobalSegMap - use m_GlobalSegMap,only: MCT_GSMap_init => init - use m_GlobalSegMap,only: MCT_GSMap_lsize => lsize - - use m_AttrVect,only : AttrVect - use m_AttrVect,only : MCT_AtrVt_init => init - use m_AttrVect,only : MCT_AtrVt_zero => zero - use m_AttrVect,only : MCT_AtrVt_lsize => lsize - use m_AttrVect,only : MCT_AtrVt_indexRA => indexRA - use m_AttrVect,only : MCT_AtrVt_importRA => importRAttr - - use m_Router,only: Router - use m_Router,only: MCT_Router_init => init - - use m_Transfer,only : MCT_Send => send - use m_Transfer,only : MCT_Recv => recv - - implicit none - - include 'mpif.h' -!----------------------------------------------------------------------- - ! Local variables - - integer,parameter :: npoints = 24 ! number of grid points - - integer ier,nprocs - integer color,myrank,mycomm -!----------------------------------------------------------------------- -! The Main program. -! We are implementing a single-executable, concurrent-execution system. -! This small main program carves up MPI_COMM_WORLD and then starts -! each component on its own processor set. - - call MPI_init(ier) - - call mpi_comm_size(MPI_COMM_WORLD, nprocs,ier) - call mpi_comm_rank(MPI_COMM_WORLD, myrank,ier) - - if((nprocs .gt. 14).or.(nprocs .lt. 3)) then - write(6,*)"The small problem size in this example & - &requires between 3 and 14 processors." - write(6,*)"nprocs =",nprocs - stop - endif - - -! Force the model1 to run on the first 2 processors - color =1 - if (myrank .lt. 2) then - color = 0 - endif - -! Split MPI_COMM_WORLD into a communicator for each model - call mpi_comm_split(MPI_COMM_WORLD,color,0,mycomm,ier) - -! Start up the the models, pass in the communicators - if(color .eq. 0) then - call model1(mycomm) - else - call model2(mycomm) - endif - -! Models are finished. - call mpi_finalize(ier) - - contains - -!----------------------------------------------------------------------- -!----------------------------------------------------------------------- -! !ROUTINE: - subroutine model1(comm1) ! the first model - - implicit none - - integer :: comm1,mysize,ier,asize,myproc - integer :: fieldindx,avsize,i - integer,dimension(1) :: start,length - real,pointer :: testarray(:) - - type(GlobalSegMap) :: GSmap - type(AttrVect) :: av1 - type(Router) :: Rout -!--------------------------- - -! find local rank and size - call mpi_comm_size(comm1,mysize,ier) - call mpi_comm_rank(comm1,myproc,ier) - write(6,*)"model1 size",mysize - -! initialize ThisMCTWorld - call MCTWorld_init(2,MPI_COMM_WORLD,comm1,1) - -! set up a grid and decomposition - asize = npoints/mysize - - start(1)= (myproc*asize) +1 - length(1)=asize - -! describe decomposition with MCT GSmap type - call MCT_GSMap_init(GSMap,start,length,0,comm1,1) - - write(6,*)"model 1 GSMap ngseg",myproc,GSMap%ngseg,start(1) - -! Initialize an Attribute Vector - call MCT_AtrVt_init(av1,rList="field1:field2",lsize=MCT_GSMap_lsize(GSMap,comm1)) - - avsize = MCT_AtrVt_lsize(av1) - write(6,*)"model 1 av size", avsize - -! Fill Av with some data -! fill first attribute the direct way - fieldindx = MCT_AtrVt_indexRA(av1,"field1") - do i=1,avsize - av1%rAttr(fieldindx,i) = float(i) - enddo - -! fill second attribute using Av import function - allocate(testarray(avsize)) - do i=1,avsize - testarray(i)= cos((float(i)/npoints) * 3.14) - enddo - call MCT_AtrVt_importRA(av1,"field2",testarray) - -! initialize a Router - call MCT_Router_init(2,GSMap,comm1,Rout) - -! print out Av data - do i=1,asize - write(6,*) "model 1 data", myproc,i,av1%rAttr(1,i),av1%rAttr(2,i) - enddo - -! send the data - call MCT_Send(av1,Rout) - - - - end subroutine model1 - -!----------------------------------------------------------------------- -!----------------------------------------------------------------------- -! !ROUTINE: - subroutine model2(comm2) - - implicit none - - integer :: comm2,mysize,ier,asize,myproc - integer :: i - integer,dimension(1) :: start,length - type(GlobalSegMap) :: GSmap - type(AttrVect) :: av1 - type(Router) :: Rout -!--------------------------- - -! find local rank and size - call mpi_comm_size(comm2,mysize,ier) - call mpi_comm_rank(comm2,myproc,ier) - write(6,*)"model2 size",mysize - -! initialize ThisMCTWorld - call MCTWorld_init(2,MPI_COMM_WORLD,comm2,2) - -! set up a grid and decomposition - asize = npoints/mysize - - start(1)= (myproc*asize) +1 - length(1)=asize - -! describe decomposition with MCT GSmap type - call MCT_GSMap_init(GSMap,start,length,0,comm2,2) - - write(6,*)"model 2 GSMap ngseg",myproc,GSMap%ngseg,start(1) - -! Initialize an Attribute Vector - call MCT_AtrVt_init(av1,rList="field1:field2",lsize=MCT_GSMap_lsize(GSMap,comm2)) - - write(6,*)"model 2 av size", MCT_AtrVt_lsize(av1) - -! initialize Av to be zero everywhere - call MCT_AtrVt_zero(av1) - -! initialize a Router - call MCT_Router_init(1,GSMap,comm2,Rout) - -! print out Av data before Recv - do i=1,asize - write(6,*) "model 2 data", myproc,i,av1%rAttr(1,i),av1%rAttr(2,i) - enddo - -! Recv the data - call MCT_Recv(av1,Rout) - -! print out Av data after Recv. - do i=1,asize - write(6,*) "model 2 data after", myproc,i,av1%rAttr(1,i),av1%rAttr(2,i) - enddo - - - end subroutine model2 - - end diff --git a/cesm/models/utils/mct/examples/simple/twocmp.seq.F90 b/cesm/models/utils/mct/examples/simple/twocmp.seq.F90 deleted file mode 100644 index 95d754b..0000000 --- a/cesm/models/utils/mct/examples/simple/twocmp.seq.F90 +++ /dev/null @@ -1,204 +0,0 @@ -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!----------------------------------------------------------------------- -! CVS $Id: twocmp.seq.F90,v 1.6 2006-07-25 17:09:42 jacob Exp $ -! CVS $Name: $ -!BOP ------------------------------------------------------------------- -! -! !ROUTINE: twocomponent.sequential -! -! -! !DESCRIPTION: Provide a simple example of using MCT to connect -! two components executing in sequence in a single executable. -! -! Data is passed between models by using input/output arguments -! in the run method. Compare with twocmp.seqNB.F90 -! -! !INTERFACE: -! - program twoseq -! -! !USES: -! -!--- Get only the things needed from MCT - use m_MCTWorld,only: MCTWorld_init => init - - use m_GlobalSegMap,only: GlobalSegMap - use m_GlobalSegMap,only: MCT_GSMap_init => init - use m_GlobalSegMap,only: MCT_GSMap_lsize => lsize - - use m_AttrVect,only : AttrVect - use m_AttrVect,only : MCT_AtrVt_init => init - use m_AttrVect,only : MCT_AtrVt_zero => zero - use m_AttrVect,only : MCT_AtrVt_lsize => lsize - use m_AttrVect,only : MCT_AtrVt_indexRA => indexRA - use m_AttrVect,only : MCT_AtrVt_importRA => importRAttr - - use m_Rearranger,only: Rearranger - use m_Rearranger,only: MCT_Rearranger_init => init - use m_Rearranger,only: MCT_Rearrange => Rearrange - - implicit none - - include 'mpif.h' - - integer,parameter :: ngx = 6 ! points in x-direction - integer,parameter :: ngy = 4 ! points in y-direction - integer ier,nprocs - integer,dimension(:),pointer :: myids - integer :: comm1,comm2,asize,mysize,i,myproc - integer,dimension(1) :: start1,length1 - integer,dimension(:),pointer :: start2,length2 -!----------------------------------------------------------------------- -! The Main program. -! We are implementing a single-executable, sequential-execution system. -! In this example, communication occurs through main using -! arguments. Both components share the same processors. - - type(GlobalSegMap) :: GSmap1,GSmap2 - type(AttrVect) :: av1,av2 - type(Rearranger) :: Rearr -!----------------------------------------------------------------------- - - call MPI_init(ier) - - call mpi_comm_size(MPI_COMM_WORLD, mysize,ier) - if(mysize .gt. 4) then - write(6,*)"The small problem size in this example & - &requires ", ngy,"or fewer processors." - stop - endif - call mpi_comm_rank(MPI_COMM_WORLD, myproc,ier) - - call mpi_comm_dup(MPI_COMM_WORLD,comm1,ier) - call mpi_comm_dup(MPI_COMM_WORLD,comm2,ier) - - allocate(myids(2)) - myids(1)=1 - myids(2)=2 - - call MCTWorld_init(2,MPI_COMM_WORLD,comm1,myids=myids) - -! set up a grid and decomposition -! first gsmap is the grid decomposed by rows -! theres 1 segment per processor - length1(1)= ngx * (ngy/mysize) - start1(1)= myproc * length1(1) + 1 - - write(6,*)'gsmap1', myproc,length1(1),start1(1) - call MCT_GSMap_init(GSMap1,start1,length1,0,comm1,1) - -! second gsmap is the grid decomposed by columns - allocate(length2(ngy),start2(ngy)) - - do i=1,ngy - length2(i)=ngx/mysize - start2(i)= (i-1)*ngx + 1 + myproc*length2(i) - write(6,*) 'gsmap2',myproc,i,length2(i),start2(i) - enddo - - - call MCT_GSMap_init(GSMap2,start2,length2,0,comm2,2) - - call MCT_AtrVt_init(av1,rList="field1:field2",lsize=MCT_GSMap_lsize(GSMap1,comm1)) - - call MCT_AtrVt_init(av2,rList="field1:field2",lsize=MCT_GSMap_lsize(GSMap2,comm2)) - - -! create a rearranger - call MCT_Rearranger_init(GSMap1,GSMap2,MPI_COMM_WORLD,Rearr) - -!-------------end of initialization steps - - -! Start up model1 which fills av1 with data. - call model1(comm1,av1) - -! print out Av data - do i=1,MCT_AtrVt_lsize(av1) - write(6,*) "model 1 data", myproc,i,av1%rAttr(1,i),av1%rAttr(2,i) - enddo - -! rearrange data from model1 so that model2 can use it. - call MCT_Rearrange(av1,av2,Rearr) - -! pass data to model2 (which will print it out) - call model2(comm2,av2) - - -! all done - call mpi_finalize(ier) - - contains - -!----------------------------------------------------------------------- -!----------------------------------------------------------------------- -! !ROUTINE: - subroutine model1(comm1,mod1av) ! the first model - - implicit none - - integer :: comm1,mysize,ier,asize,myproc - integer :: fieldindx,avsize,i - integer,dimension(1) :: start,length - real,pointer :: testarray(:) - - type(GlobalSegMap) :: GSmap - type(AttrVect) :: mod1av -!--------------------------- - -! find local rank and size - call mpi_comm_size(comm1,mysize,ier) - call mpi_comm_rank(comm1,myproc,ier) - write(6,*)"model1 size",mysize - - - avsize = MCT_AtrVt_lsize(mod1av) - write(6,*)"model 1 av size", avsize - -! Fill Av with some data -! fill first attribute the direct way - fieldindx = MCT_AtrVt_indexRA(mod1av,"field1") - do i=1,avsize - mod1av%rAttr(fieldindx,i) = float(i+ 20*myproc) - enddo - -! fill second attribute using Av import function - allocate(testarray(avsize)) - do i=1,avsize - testarray(i)= cos((float(i+ 20*myproc)/24.) * 3.14) - enddo - call MCT_AtrVt_importRA(mod1av,"field2",testarray) - - - end subroutine model1 - -!----------------------------------------------------------------------- -!----------------------------------------------------------------------- -! !ROUTINE: - subroutine model2(comm2,mod2av) - - implicit none - - integer :: comm2,mysize,ier,asize,myproc - integer :: i - type(AttrVect) :: mod2av -!--------------------------- - -! find local rank and size - call mpi_comm_size(comm2,mysize,ier) - call mpi_comm_rank(comm2,myproc,ier) - write(6,*)"model2 size",mysize - - asize = MCT_AtrVt_lsize(mod2av) - write(6,*)"model 2 av size", asize - -! print out Av data - do i=1,asize - write(6,*) "model 2 data after", myproc,i,mod2av%rAttr(1,i),mod2av%rAttr(2,i) - enddo - - - end subroutine model2 - - end diff --git a/cesm/models/utils/mct/examples/simple/twocmp.seqNB.F90 b/cesm/models/utils/mct/examples/simple/twocmp.seqNB.F90 deleted file mode 100644 index 3d6fe87..0000000 --- a/cesm/models/utils/mct/examples/simple/twocmp.seqNB.F90 +++ /dev/null @@ -1,283 +0,0 @@ -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!----------------------------------------------------------------------- -! CVS $Id: twocmp.seqNB.F90,v 1.4 2004-06-24 21:07:01 eong Exp $ -! CVS $Name: $ -!BOP ------------------------------------------------------------------- -! -! !ROUTINE: twocmp.seqNB -! -! !DESCRIPTION: Provide a simple example of using MCT to connect to -! components executing sequentially in a single executable using -! the non-blocking communications to transfer data. -! -! -! !INTERFACE: -! - program twocmpseqNB -! -! !USES: -! -!--- Use only the things needed from MCT - use m_MCTWorld,only: MCTWorld_init => init - - use m_GlobalSegMap,only: GlobalSegMap - use m_GlobalSegMap,only: MCT_GSMap_init => init - use m_GlobalSegMap,only: MCT_GSMap_lsize => lsize - use m_GlobalSegMapComms,only: MCT_GSMap_recv => recv - use m_GlobalSegMapComms,only: MCT_GSMap_isend => isend - use m_GlobalSegMapComms,only: MCT_GSMap_bcast => bcast - - use m_AttrVect,only : AttrVect - use m_AttrVect,only : MCT_AtrVt_init => init - use m_AttrVect,only : MCT_AtrVt_zero => zero - use m_AttrVect,only : MCT_AtrVt_lsize => lsize - use m_AttrVect,only : MCT_AtrVt_indexRA => indexRA - use m_AttrVect,only : MCT_AtrVt_importRA => importRAttr - - use m_Router,only: Router - use m_Router,only: MCT_Router_init => init - - use m_Transfer,only : MCT_ISend => isend - use m_Transfer,only : MCT_Recv => recv - - implicit none - - include 'mpif.h' - - integer,parameter :: npoints = 24 ! total number of grid points - integer ier,nprocs,i - integer color,myrank,comm1,comm2 - integer,dimension(:),pointer :: myids - integer,dimension(:),pointer :: req1,req2 -!----------------------------------------------------------------------- -! The Main program. -! We are implementing a single-executable, seqeuntial-execution system. -! This small main program sets up MCTWorld, calls each "init" method -! and then calls each component in turn. - - type(GlobalSegMap) :: GSMap1,GSMap2 - type(AttrVect) :: Av1,Av2 - - call MPI_init(ier) - - call mpi_comm_size(MPI_COMM_WORLD, nprocs,ier) - call mpi_comm_rank(MPI_COMM_WORLD, myrank,ier) - -! Duplicate MPI_COMM_WORLD into a communicator for each model - call mpi_comm_dup(MPI_COMM_WORLD,comm1,ier) - call mpi_comm_dup(MPI_COMM_WORLD,comm2,ier) - - allocate(myids(2)) - myids(1)=1 - myids(2)=2 - -! Initialize MCT world - call MCTWorld_init(2,MPI_COMM_WORLD,comm1,myids=myids) - -! Initialize the models, pass in the communicators - call model1init(comm1,req1,GSMap1,Av1) - call model2init(comm2,req2,GSMap2,Av2) - -!-----------------end of initialization phase ------ -! Run the models, pass in the communicators - do i=1,5 - write(6,*) " " - write(6,*) "Step ",i - call model1(comm1,GSMap1,Av1) - call model2(comm2,GSMap2,Av2) - enddo - -! Models are finished. - call mpi_finalize(ier) - - contains - -!----------------------------------------------------------------------- -!----------------------------------------------------------------------- -! !ROUTINE: - subroutine model1init(comm1,req1,GSmap,av1) ! init the first model - - implicit none - - integer :: comm1,mysize,ier,asize,myproc - integer :: fieldindx,avsize,i - integer,dimension(1) :: start,length - real,pointer :: testarray(:) - integer,pointer :: req1(:) - - type(GlobalSegMap) :: GSmap - type(AttrVect) :: av1 -!--------------------------- - -! find local rank and size - call mpi_comm_size(comm1,mysize,ier) - call mpi_comm_rank(comm1,myproc,ier) - write(6,*)myproc,"model1 size",mysize - -! set up a grid and decomposition - asize = npoints/mysize - - start(1)= (myproc*asize) +1 - length(1)=asize - -! describe decomposition with MCT GSmap type - call MCT_GSMap_init(GSMap,start,length,0,comm1,1) - - write(6,*)myproc,"model 1 GSMap ngseg",GSMap%ngseg,start(1) - - if(myproc .eq. 0) call MCT_GSMap_Isend(GSMap,2,100,req1) - -! Initialize an Attribute Vector - call MCT_AtrVt_init(av1,rList="field1:field2",lsize=MCT_GSMap_lsize(GSMap,comm1)) - write(6,*)myproc,"model1 got an aV" - - avsize = MCT_AtrVt_lsize(av1) - write(6,*)myproc,"model 1 av size", avsize - - end subroutine model1init - -!----------------------------------------------------------------------- -!----------------------------------------------------------------------- - subroutine model1(comm1,GSmap,av1) ! run the first model - - implicit none - - integer :: comm1,mysize,ier,asize,myproc - integer :: fieldindx,avsize,i - integer,dimension(1) :: start,length - real,pointer :: testarray(:) - - type(GlobalSegMap) :: GSmap,GSmap2 - type(AttrVect) :: av1 - type(Router),save :: Rout - logical,save :: firsttime=.FALSE. - - call mpi_comm_rank(comm1,myproc,ier) - - if(.not.firsttime) then -! get other GSMap - if(myproc .eq. 0) call MCT_GSMap_recv(GSmap2,2,110) - call MCT_GSMap_bcast(GSmap2,0,comm1) -! initialize a router - call MCT_Router_init(GSMap,GSmap2,comm1,Rout) - endif - firsttime=.TRUE. - - avsize = MCT_AtrVt_lsize(av1) - -! Fill Av with some data -! fill first attribute the direct way - fieldindx = MCT_AtrVt_indexRA(av1,"field1") - do i=1,avsize - av1%rAttr(fieldindx,i) = float(i +20*myproc) - enddo - -! fill second attribute using Av import function - allocate(testarray(avsize)) - do i=1,avsize - testarray(i)= cos((float(i+ 20*myproc)/npoints) * 3.14) - enddo - call MCT_AtrVt_importRA(av1,"field2",testarray) - -! print out Av data - do i=1,avsize - write(6,*)myproc, "model 1 data", i,av1%rAttr(1,i),av1%rAttr(2,i) - enddo - -! send the data - call MCT_ISend(av1,Rout) - - - - end subroutine model1 - -!----------------------------------------------------------------------- -!----------------------------------------------------------------------- -! !ROUTINE: - subroutine model2init(comm2,req2,GSmap,av1) ! init model 2 - - implicit none - - integer :: comm2,mysize,ier,asize,myproc - integer :: i - integer,dimension(1) :: start,length - type(GlobalSegMap) :: GSmap - type(AttrVect) :: av1 - integer,pointer :: req2(:) -!--------------------------- - -! find local rank and size - call mpi_comm_size(comm2,mysize,ier) - call mpi_comm_rank(comm2,myproc,ier) - write(6,*)myproc,"model2 size",mysize - -! set up a grid and decomposition - asize = npoints/mysize - - start(1)= (myproc*asize) +1 - length(1)=asize - -! describe decomposition with MCT GSmap type - call MCT_GSMap_init(GSMap,start,length,0,comm2,2) - - write(6,*)myproc, "model 2 GSMap ngseg",GSMap%ngseg,start(1) - - if(myproc .eq. 0) call MCT_GSMap_Isend(GSMap,1,110,req2) - -! Initialize an Attribute Vector - call MCT_AtrVt_init(av1,rList="field1:field2",lsize=MCT_GSMap_lsize(GSMap,comm2)) - write(6,*)myproc,"model2 got an aV" - - write(6,*)myproc, "model 2 av size", MCT_AtrVt_lsize(av1) - - end subroutine model2init - -!----------------------------------------------------------------------- -!----------------------------------------------------------------------- -! !ROUTINE: - subroutine model2(comm2,GSmap,av1) - - implicit none - - integer :: comm2,mysize,ier,avsize,myproc - integer :: i - integer,dimension(1) :: start,length - type(GlobalSegMap) :: GSmap,GSmap2 - type(AttrVect) :: av1 - type(Router),save :: Rout - logical,save :: firsttime=.FALSE. -!--------------------------- - -! initialize Av to be zero everywhere - call MCT_AtrVt_zero(av1) - - call mpi_comm_rank(comm2,myproc,ier) - if(.not.firsttime) then -! receive other GSMap - if(myproc .eq. 0) call MCT_GSMap_recv(GSmap2,1,100) - call MCT_GSMap_bcast(GSmap2,0,comm2) -! initialize a Router - call MCT_Router_init(GSMap,GSmap2,comm2,Rout) - endif - firsttime=.TRUE. - - avsize = MCT_AtrVt_lsize(av1) - -! print out Av data before Recv - do i=1,avsize - write(6,*) myproc,"model 2 data", i,av1%rAttr(1,i),av1%rAttr(2,i) - enddo - -! Recv the data - call MCT_Recv(av1,Rout) - -! print out Av data after Recv. - do i=1,avsize - write(6,*) myproc,"model 2 data after", i,av1%rAttr(1,i),av1%rAttr(2,i) - enddo - - - end subroutine model2 - - end diff --git a/cesm/models/utils/mct/examples/simple/twocmp.seqUnvn.F90 b/cesm/models/utils/mct/examples/simple/twocmp.seqUnvn.F90 deleted file mode 100644 index 818221a..0000000 --- a/cesm/models/utils/mct/examples/simple/twocmp.seqUnvn.F90 +++ /dev/null @@ -1,242 +0,0 @@ -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!----------------------------------------------------------------------- -! CVS $Id: twocmp.seqUnvn.F90,v 1.6 2007-12-19 17:13:17 rloy Exp $ -! CVS $Name: $ -!BOP ------------------------------------------------------------------- -! -! !ROUTINE: twocomponentUneven.sequential -! -! !DESCRIPTION: Provide a simple example of using MCT to connect two components -! In this case the models are running sequentialy but the second model -! is only running on 1 processor. -! -! !INTERFACE: -! - program twosequn -! -! !USES: -! -!--- Get only the things needed from MCT - use m_MCTWorld,only: MCTWorld_init => init - - use m_GlobalSegMap,only: GlobalSegMap - use m_GlobalSegMap,only: MCT_GSMap_init => init - use m_GlobalSegMap,only: MCT_GSMap_lsize => lsize - - use m_AttrVect,only : AttrVect - use m_AttrVect,only : MCT_AtrVt_init => init - use m_AttrVect,only : MCT_AtrVt_zero => zero - use m_AttrVect,only : MCT_AtrVt_lsize => lsize - use m_AttrVect,only : MCT_AtrVt_indexRA => indexRA - use m_AttrVect,only : MCT_AtrVt_importRA => importRAttr - - use m_Rearranger,only: Rearranger - use m_Rearranger,only: MCT_Rearranger_init => init - use m_Rearranger,only: MCT_Rearrange => Rearrange - - implicit none - - include 'mpif.h' - - integer,parameter :: ngx = 6 ! points in x-direction - integer,parameter :: ngy = 4 ! points in y-direction - - integer ier,world_group,model2_group,myrank2,myrank3 - integer,dimension(:),pointer :: myids,mycomms,peloc2 - integer,dimension(:,:),pointer :: GlobalId - integer :: comm1,comm2,asize,mysize,i,myproc - integer :: commsize - integer,dimension(1) :: start1,length1,ranks - integer,dimension(:),allocatable :: start2,length2 -!----------------------------------------------------------------------- -! The Main program. -! We are implementing a single-executable, sequential-execution system. -! Because its sequential, communication occurs through the main using -! arguments. The second component is only running on 1 processor - - type(GlobalSegMap) :: GSmap1,GSmap2 - type(AttrVect) :: av1,av2 - type(Rearranger) :: Rearr - - call MPI_init(ier) - - call mpi_comm_size(MPI_COMM_WORLD, mysize,ier) - if(mysize .gt. 12) then - write(6,*)"Must run on less than 12 processors" - stop - endif - call mpi_comm_rank(MPI_COMM_WORLD, myproc,ier) - -! the first model is running on all the processors so give -! it a dubplicate of MPI_COMM_WORLD for its communicator - call mpi_comm_dup(MPI_COMM_WORLD,comm1,ier) - -! the second model is only running on one processor -! so use mpi_groups methods to define its communicator - call mpi_comm_group(MPI_COMM_WORLD,world_group,ier) - -! need a communicator that only has the first processor - ranks(1)=0 -! define the group - call mpi_group_incl(world_group,1,ranks,model2_group,ier) -! now define the communicator - ! first initialize it - comm2=MPI_COMM_NULL - call mpi_comm_create(MPI_COMM_WORLD,model2_group,comm2,ier) - -! don't need the groups anymore - call mpi_group_free(world_group,ier) - call mpi_group_free(model2_group,ier) - -! allocate arrays for the ids and comms - allocate(myids(2),mycomms(2)) - -! Set the arrays to their values. - myids(1)=1 - myids(2)=2 - mycomms(1)=comm1 - mycomms(2)=comm2 - -! now call the initm_ version of MCTWorld_init - call MCTWorld_init(2,MPI_COMM_WORLD,mycomms,myids) - - -! first gsmap is the grid decomposed in one dimension -! there is 1 segment per processor - length1(1)= (ngx * ngy)/mysize - start1(1)= myproc * length1(1) + 1 - - write(6,*)'gsmap1', myproc,length1(1),start1(1) - call MCT_GSMap_init(GSMap1,start1,length1,0,comm1,1) - -! second gsmap is the grid on one processor - -! for GSMap init to work, the size of the start and length arrays -! must equal the number of local segments. So I must allocate -! size zero arrays on the other processors. - if(myproc .eq. 0) then - allocate(start2(1),length2(1)) - length2(1) = ngx*ngy - start2(1) = 1 - else - allocate(start2(0),length2(0)) - endif - - call MCT_GSMap_init(GSMap2,start2,length2,0,comm1,2) - write(6,*)'gsmap2', myproc,GSMap2%ngseg,GSmap2%gsize,GSmap2%start(1), & - GSmap2%pe_loc(1),GSmap2%length(1) - - -! initialize an Av on each GSMap - call MCT_AtrVt_init(av1,rList="field1:field2",lsize=MCT_GSMap_lsize(GSMap1,comm1)) - -! Use comm1 because lsize of GSMap2 on comm1 will return 0 on non-root processors. -! We need av2 to be full-sized on proc 0 and 0 size on other processors. - call MCT_AtrVt_init(av2,rList="field1:field2",lsize=MCT_GSMap_lsize(GSMap2,comm1)) - - -! create a rearranger. Use the communicator which contains all processors -! involved in the rearrangement, comm1 - call MCT_Rearranger_init(GSMap1,GSMap2,comm1,Rearr) - -!-------------end of initialization steps - - -! Start up model1 which fills av1 with data. - call model1(comm1,av1) - -! print out Av data - do i=1,MCT_AtrVt_lsize(av1) - write(6,*) "model 1 data", myproc,i,av1%rAttr(1,i),av1%rAttr(2,i) - enddo - -! rearrange data from model1 so that model2 can use it. - call MCT_Rearrange(av1,av2,Rearr) - -! pass data to model2 (which will print it out) -! model2 should only run on one processor. - if(myproc .eq. 0) then - call model2(comm2,av2) - endif - - -! all done - call MPI_Barrier(MPI_COMM_WORLD,ier) - if (myproc==0) write(6,*) 'All Done' - - call mpi_finalize(ier) - - contains - -!----------------------------------------------------------------------- -!----------------------------------------------------------------------- -! !ROUTINE: - subroutine model1(comm1,mod1av) ! the first model - - implicit none - - integer :: comm1,mysize,ier,asize,myproc - integer :: fieldindx,avsize,i - integer,dimension(1) :: start,length - real,pointer :: testarray(:) - - type(GlobalSegMap) :: GSmap - type(AttrVect) :: mod1av -!--------------------------- - -! find local rank and size - call mpi_comm_size(comm1,mysize,ier) - call mpi_comm_rank(comm1,myproc,ier) - write(6,*)"model1 myproc,mysize",myproc,mysize - - - avsize = MCT_AtrVt_lsize(mod1av) - write(6,*)"model 1 myproc, av size", myproc,avsize - -! Fill Av with some data -! fill first attribute the direct way - fieldindx = MCT_AtrVt_indexRA(mod1av,"field1") - do i=1,avsize - mod1av%rAttr(fieldindx,i) = float(i+ 20*myproc) - enddo - -! fill second attribute using Av import function - allocate(testarray(avsize)) - do i=1,avsize - testarray(i)= cos((float(i+ 20*myproc)/24.) * 3.14) - enddo - call MCT_AtrVt_importRA(mod1av,"field2",testarray) - - - end subroutine model1 - -!----------------------------------------------------------------------- -!----------------------------------------------------------------------- -! !ROUTINE: - subroutine model2(comm2,mod2av) - - implicit none - - integer :: comm2,mysize,ier,asize,myproc - integer :: i - type(AttrVect) :: mod2av -!--------------------------- - -! find local rank and size - call mpi_comm_size(comm2,mysize,ier) - call mpi_comm_rank(comm2,myproc,ier) - write(6,*)"model2 myproc,mysize",myproc,mysize - - asize = MCT_AtrVt_lsize(mod2av) - write(6,*)"model 2 myproc, av size", myproc,asize - -! print out Av data - do i=1,asize - write(6,*) "model 2 data after", myproc,i,mod2av%rAttr(1,i),mod2av%rAttr(2,i) - enddo - - - end subroutine model2 - - end diff --git a/cesm/models/utils/mct/install-sh b/cesm/models/utils/mct/install-sh deleted file mode 100755 index 36f96f3..0000000 --- a/cesm/models/utils/mct/install-sh +++ /dev/null @@ -1,276 +0,0 @@ -#!/bin/sh -# -# install - install a program, script, or datafile -# This comes from X11R5 (mit/util/scripts/install.sh). -# -# Copyright 1991 by the Massachusetts Institute of Technology -# -# Permission to use, copy, modify, distribute, and sell this software and its -# documentation for any purpose is hereby granted without fee, provided that -# the above copyright notice appear in all copies and that both that -# copyright notice and this permission notice appear in supporting -# documentation, and that the name of M.I.T. not be used in advertising or -# publicity pertaining to distribution of the software without specific, -# written prior permission. M.I.T. makes no representations about the -# suitability of this software for any purpose. It is provided "as is" -# without express or implied warranty. -# -# Calling this script install-sh is preferred over install.sh, to prevent -# `make' implicit rules from creating a file called install from it -# when there is no Makefile. -# -# This script is compatible with the BSD install script, but was written -# from scratch. It can only install one file at a time, a restriction -# shared with many OS's install programs. - - -# set DOITPROG to echo to test this script - -# Don't use :- since 4.3BSD and earlier shells don't like it. -doit="${DOITPROG-}" - - -# put in absolute paths if you don't have them in your path; or use env. vars. - -mvprog="${MVPROG-mv}" -cpprog="${CPPROG-cp}" -chmodprog="${CHMODPROG-chmod}" -chownprog="${CHOWNPROG-chown}" -chgrpprog="${CHGRPPROG-chgrp}" -stripprog="${STRIPPROG-strip}" -rmprog="${RMPROG-rm}" -mkdirprog="${MKDIRPROG-mkdir}" - -transformbasename="" -transform_arg="" -instcmd="$mvprog" -chmodcmd="$chmodprog 0755" -chowncmd="" -chgrpcmd="" -stripcmd="" -rmcmd="$rmprog -f" -mvcmd="$mvprog" -src="" -dst="" -dir_arg="" - -while [ x"$1" != x ]; do - case $1 in - -c) instcmd=$cpprog - shift - continue;; - - -d) dir_arg=true - shift - continue;; - - -m) chmodcmd="$chmodprog $2" - shift - shift - continue;; - - -o) chowncmd="$chownprog $2" - shift - shift - continue;; - - -g) chgrpcmd="$chgrpprog $2" - shift - shift - continue;; - - -s) stripcmd=$stripprog - shift - continue;; - - -t=*) transformarg=`echo $1 | sed 's/-t=//'` - shift - continue;; - - -b=*) transformbasename=`echo $1 | sed 's/-b=//'` - shift - continue;; - - *) if [ x"$src" = x ] - then - src=$1 - else - # this colon is to work around a 386BSD /bin/sh bug - : - dst=$1 - fi - shift - continue;; - esac -done - -if [ x"$src" = x ] -then - echo "$0: no input file specified" >&2 - exit 1 -else - : -fi - -if [ x"$dir_arg" != x ]; then - dst=$src - src="" - - if [ -d "$dst" ]; then - instcmd=: - chmodcmd="" - else - instcmd=$mkdirprog - fi -else - -# Waiting for this to be detected by the "$instcmd $src $dsttmp" command -# might cause directories to be created, which would be especially bad -# if $src (and thus $dsttmp) contains '*'. - - if [ -f "$src" ] || [ -d "$src" ] - then - : - else - echo "$0: $src does not exist" >&2 - exit 1 - fi - - if [ x"$dst" = x ] - then - echo "$0: no destination specified" >&2 - exit 1 - else - : - fi - -# If destination is a directory, append the input filename; if your system -# does not like double slashes in filenames, you may need to add some logic - - if [ -d "$dst" ] - then - dst=$dst/`basename "$src"` - else - : - fi -fi - -## this sed command emulates the dirname command -dstdir=`echo "$dst" | sed -e 's,[^/]*$,,;s,/$,,;s,^$,.,'` - -# Make sure that the destination directory exists. -# this part is taken from Noah Friedman's mkinstalldirs script - -# Skip lots of stat calls in the usual case. -if [ ! -d "$dstdir" ]; then -defaultIFS=' - ' -IFS="${IFS-$defaultIFS}" - -oIFS=$IFS -# Some sh's can't handle IFS=/ for some reason. -IFS='%' -set - `echo "$dstdir" | sed -e 's@/@%@g' -e 's@^%@/@'` -IFS=$oIFS - -pathcomp='' - -while [ $# -ne 0 ] ; do - pathcomp=$pathcomp$1 - shift - - if [ ! -d "$pathcomp" ] ; - then - $mkdirprog "$pathcomp" - else - : - fi - - pathcomp=$pathcomp/ -done -fi - -if [ x"$dir_arg" != x ] -then - $doit $instcmd "$dst" && - - if [ x"$chowncmd" != x ]; then $doit $chowncmd "$dst"; else : ; fi && - if [ x"$chgrpcmd" != x ]; then $doit $chgrpcmd "$dst"; else : ; fi && - if [ x"$stripcmd" != x ]; then $doit $stripcmd "$dst"; else : ; fi && - if [ x"$chmodcmd" != x ]; then $doit $chmodcmd "$dst"; else : ; fi -else - -# If we're going to rename the final executable, determine the name now. - - if [ x"$transformarg" = x ] - then - dstfile=`basename "$dst"` - else - dstfile=`basename "$dst" $transformbasename | - sed $transformarg`$transformbasename - fi - -# don't allow the sed command to completely eliminate the filename - - if [ x"$dstfile" = x ] - then - dstfile=`basename "$dst"` - else - : - fi - -# Make a couple of temp file names in the proper directory. - - dsttmp=$dstdir/#inst.$$# - rmtmp=$dstdir/#rm.$$# - -# Trap to clean up temp files at exit. - - trap 'status=$?; rm -f "$dsttmp" "$rmtmp" && exit $status' 0 - trap '(exit $?); exit' 1 2 13 15 - -# Move or copy the file name to the temp name - - $doit $instcmd "$src" "$dsttmp" && - -# and set any options; do chmod last to preserve setuid bits - -# If any of these fail, we abort the whole thing. If we want to -# ignore errors from any of these, just make sure not to ignore -# errors from the above "$doit $instcmd $src $dsttmp" command. - - if [ x"$chowncmd" != x ]; then $doit $chowncmd "$dsttmp"; else :;fi && - if [ x"$chgrpcmd" != x ]; then $doit $chgrpcmd "$dsttmp"; else :;fi && - if [ x"$stripcmd" != x ]; then $doit $stripcmd "$dsttmp"; else :;fi && - if [ x"$chmodcmd" != x ]; then $doit $chmodcmd "$dsttmp"; else :;fi && - -# Now remove or move aside any old file at destination location. We try this -# two ways since rm can't unlink itself on some systems and the destination -# file might be busy for other reasons. In this case, the final cleanup -# might fail but the new file should still install successfully. - -{ - if [ -f "$dstdir/$dstfile" ] - then - $doit $rmcmd -f "$dstdir/$dstfile" 2>/dev/null || - $doit $mvcmd -f "$dstdir/$dstfile" "$rmtmp" 2>/dev/null || - { - echo "$0: cannot unlink or rename $dstdir/$dstfile" >&2 - (exit 1); exit - } - else - : - fi -} && - -# Now rename the file to the real destination. - - $doit $mvcmd "$dsttmp" "$dstdir/$dstfile" - -fi && - -# The final little trick to "correctly" pass the exit status to the exit trap. - -{ - (exit 0); exit -} diff --git a/cesm/models/utils/mct/m4/README b/cesm/models/utils/mct/m4/README deleted file mode 100644 index b748178..0000000 --- a/cesm/models/utils/mct/m4/README +++ /dev/null @@ -1,5 +0,0 @@ -This directory contains some specific tests used in the MCT autoconf system. -They are placed here to make the configure.ac a little cleaner. - -These are only needed if you are trying to recreate the "configure" script from -the "configure.ac" file. diff --git a/cesm/models/utils/mct/m4/acx_mpi.m4 b/cesm/models/utils/mct/m4/acx_mpi.m4 deleted file mode 100644 index 77f433d..0000000 --- a/cesm/models/utils/mct/m4/acx_mpi.m4 +++ /dev/null @@ -1,146 +0,0 @@ -dnl @synopsis ACX_MPI([ACTION-IF-FOUND[, ACTION-IF-NOT-FOUND]]) -dnl -dnl @summary figure out how to compile/link code with MPI -dnl -dnl This macro tries to find out how to compile programs that use MPI -dnl (Message Passing Interface), a standard API for parallel process -dnl communication (see http://www-unix.mcs.anl.gov/mpi/) -dnl -dnl On success, it sets the MPICC, MPICXX, or MPIF77 output variable to -dnl the name of the MPI compiler, depending upon the current language. -dnl (This may just be $CC/$CXX/$F77, but is more often something like -dnl mpicc/mpiCC/mpif77.) It also sets MPILIBS to any libraries that are -dnl needed for linking MPI (e.g. -lmpi, if a special -dnl MPICC/MPICXX/MPIF77 was not found). -dnl -dnl If you want to compile everything with MPI, you should set: -dnl -dnl CC="$MPICC" #OR# CXX="$MPICXX" #OR# F77="$MPIF77" -dnl LIBS="$MPILIBS $LIBS" -dnl -dnl NOTE: The above assumes that you will use $CC (or whatever) for -dnl linking as well as for compiling. (This is the default for automake -dnl and most Makefiles.) -dnl -dnl The user can force a particular library/compiler by setting the -dnl MPICC/MPICXX/MPIF77 and/or MPILIBS environment variables. -dnl -dnl ACTION-IF-FOUND is a list of shell commands to run if an MPI -dnl library is found, and ACTION-IF-NOT-FOUND is a list of commands to -dnl run it if it is not found. If ACTION-IF-FOUND is not specified, the -dnl default action will define HAVE_MPI. -dnl -dnl @category InstalledPackages -dnl @author Steven G. Johnson -dnl @author Julian Cummings -dnl @version 2006-10-13 -dnl @license GPLWithACException - -AC_DEFUN([ACX_MPI], [ -AC_PREREQ(2.50) dnl for AC_LANG_CASE - -AC_LANG_CASE([C], [ - AC_REQUIRE([AC_PROG_CC]) - AC_ARG_VAR(MPICC,[MPI C compiler command]) - AC_CHECK_PROGS(MPICC, mpicc hcc mpxlc_r mpxlc mpcc cmpicc, $CC) - acx_mpi_save_CC="$CC" - CC="$MPICC" - AC_SUBST(MPICC) -], -[C++], [ - AC_REQUIRE([AC_PROG_CXX]) - AC_ARG_VAR(MPICXX,[MPI C++ compiler command]) - AC_CHECK_PROGS(MPICXX, mpic++ mpicxx mpiCC hcp mpxlC_r mpxlC mpCC cmpic++, $CXX) - acx_mpi_save_CXX="$CXX" - CXX="$MPICXX" - AC_SUBST(MPICXX) -], -[Fortran 77], [ - AC_REQUIRE([AC_PROG_F77]) - AC_ARG_VAR(MPIF77,[MPI Fortran 77 compiler command]) - AC_CHECK_PROGS(MPIF77, mpif77 hf77 mpxlf mpf77 mpif90 mpf90 mpxlf90 mpxlf95 mpxlf_r cmpifc cmpif90c, $F77) - acx_mpi_save_F77="$F77" - F77="$MPIF77" - AC_SUBST(MPIF77) -], -[Fortran], [ - AC_REQUIRE([AC_PROG_FC]) - AC_ARG_VAR(MPIFC,[MPI Fortran compiler command]) - AC_CHECK_PROGS(MPIFC, mpif90 hf90 mpxlf90 mpxlf95 mpf90 cmpifc cmpif90c, $FC) - acx_mpi_save_FC="$FC" - FC="$MPIFC" - AC_SUBST(MPIFC) -]) - -if test x = x"$MPILIBS"; then - AC_LANG_CASE([C], [AC_CHECK_FUNC(MPI_Init, [MPILIBS=" "])], - [C++], [AC_CHECK_FUNC(MPI_Init, [MPILIBS=" "])], - [Fortran 77], [AC_MSG_CHECKING([for MPI_Init]) - AC_LINK_IFELSE([AC_LANG_PROGRAM([],[ call MPI_Init])],[MPILIBS=" " - AC_MSG_RESULT(yes)], [AC_MSG_RESULT(no)])], - [Fortran], [AC_MSG_CHECKING([for MPI_Init]) - AC_LINK_IFELSE([AC_LANG_PROGRAM([],[ call MPI_Init])],[MPILIBS=" " - AC_MSG_RESULT(yes)], [AC_MSG_RESULT(no)])]) -fi -AC_LANG_CASE([Fortran 77], [ - if test x = x"$MPILIBS"; then - AC_CHECK_LIB(fmpi, MPI_Init, [MPILIBS="-lfmpi"]) - fi - if test x = x"$MPILIBS"; then - AC_CHECK_LIB(fmpich, MPI_Init, [MPILIBS="-lfmpich"]) - fi -], -[Fortran], [ - if test x = x"$MPILIBS"; then - AC_CHECK_LIB(fmpi, MPI_Init, [MPILIBS="-lfmpi"]) - fi - if test x = x"$MPILIBS"; then - AC_CHECK_LIB(mpichf90, MPI_Init, [MPILIBS="-lmpichf90"]) - fi -]) -if test x = x"$MPILIBS"; then - AC_CHECK_LIB(mpi, MPI_Init, [MPILIBS="-lmpi"]) -fi -if test x = x"$MPILIBS"; then - AC_CHECK_LIB(mpich, MPI_Init, [MPILIBS="-lmpich"]) -fi - -dnl We have to use AC_TRY_COMPILE and not AC_CHECK_HEADER because the -dnl latter uses $CPP, not $CC (which may be mpicc). -AC_LANG_CASE([C], [if test x != x"$MPILIBS"; then - AC_MSG_CHECKING([for mpi.h]) - AC_TRY_COMPILE([#include ],[],[AC_MSG_RESULT(yes)], [MPILIBS="" - AC_MSG_RESULT(no)]) -fi], -[C++], [if test x != x"$MPILIBS"; then - AC_MSG_CHECKING([for mpi.h]) - AC_TRY_COMPILE([#include ],[],[AC_MSG_RESULT(yes)], [MPILIBS="" - AC_MSG_RESULT(no)]) -fi], -[Fortran 77], [if test x != x"$MPILIBS"; then - AC_MSG_CHECKING([for mpif.h]) - AC_COMPILE_IFELSE([AC_LANG_PROGRAM([],[ include 'mpif.h'])],[AC_MSG_RESULT(yes)], [MPILIBS="" - AC_MSG_RESULT(no)]) -fi], -[Fortran], [if test x != x"$MPILIBS"; then - AC_MSG_CHECKING([for mpif.h]) - AC_COMPILE_IFELSE([AC_LANG_PROGRAM([],[ include 'mpif.h'])],[AC_MSG_RESULT(yes)], [MPILIBS="" - AC_MSG_RESULT(no)]) -fi]) - -AC_LANG_CASE([C], [CC="$acx_mpi_save_CC"], - [C++], [CXX="$acx_mpi_save_CXX"], - [Fortran 77], [F77="$acx_mpi_save_F77"], - [Fortran], [FC="$acx_mpi_save_FC"]) - -AC_SUBST(MPILIBS) - -# Finally, execute ACTION-IF-FOUND/ACTION-IF-NOT-FOUND: -if test x = x"$MPILIBS"; then - $2 - : -else - ifelse([$1],,[AC_DEFINE(HAVE_MPI,1,[Define if you have the MPI library.])],[$1]) - : -fi -])dnl ACX_MPI diff --git a/cesm/models/utils/mct/m4/ax_fc_version.m4 b/cesm/models/utils/mct/m4/ax_fc_version.m4 deleted file mode 100644 index fa2bf04..0000000 --- a/cesm/models/utils/mct/m4/ax_fc_version.m4 +++ /dev/null @@ -1,51 +0,0 @@ -#AX_FC_VERSION_OUTPUT([FLAG = $ac_cv_prog_fc_version]) -# ------------------------------------------------- -# Link a trivial Fortran program, compiling with a version output FLAG -# (which default value, $ac_cv_prog_fc_version, is computed by -# AX_FC_VERSION), and return the output in $ac_fc_version_output. -AC_DEFUN([AX_FC_VERSION_OUTPUT], -[AC_REQUIRE([AC_PROG_FC])dnl -AC_LANG_PUSH(Fortran)dnl - -AC_LANG_CONFTEST([AC_LANG_PROGRAM([])]) - -# Compile and link our simple test program by passing a flag (argument -# 1 to this macro) to the Fortran 90 compiler in order to get "version" output -ac_save_FCFLAGS=$FCFLAGS -FCFLAGS="$FCFLAGS m4_default([$1], [$ac_cv_prog_fc_version])" -(eval echo $as_me:__oline__: \"$ac_link\") >&AS_MESSAGE_LOG_FD -ac_fc_version_output=`eval $ac_link AS_MESSAGE_LOG_FD>&1 2>&1 | grep -v 'Driving:'` -echo "$ac_fc_version_output" >&AS_MESSAGE_LOG_FD -FCFLAGS=$ac_save_FCFLAGS - -rm -f conftest.* -AC_LANG_POP(Fortran)dnl - -])# AX_FC_VERSION_OUTPUT - -# AX_FC_VERSION -# -------------- -# -AC_DEFUN([AX_FC_VERSION], -[AC_CACHE_CHECK([how to get the version output from $FC], - [ac_cv_prog_fc_version], -[AC_LANG_ASSERT(Fortran) -AC_COMPILE_IFELSE([AC_LANG_PROGRAM()], -[ac_cv_prog_fc_version= -# Try some options frequently used verbose output -for ac_version in -V -version --version +version -qversion; do - AX_FC_VERSION_OUTPUT($ac_version) - # look for "copyright" constructs in the output - for ac_arg in $ac_fc_version_output; do - case $ac_arg in - COPYRIGHT | copyright | Copyright | '(c)' | '(C)' | Compiler | Compilers | Version | Version:) - ac_cv_prog_fc_version=$ac_version - break 2 ;; - esac - done -done -if test -z "$ac_cv_prog_fc_version"; then - AC_MSG_WARN([cannot determine how to obtain version information from $FC]) -fi], - [AC_MSG_WARN([compilation failed])]) -])])# AX_FC_VERSION diff --git a/cesm/models/utils/mct/m4/fortran.m4 b/cesm/models/utils/mct/m4/fortran.m4 deleted file mode 100644 index 23c44e7..0000000 --- a/cesm/models/utils/mct/m4/fortran.m4 +++ /dev/null @@ -1,855 +0,0 @@ -# This file is part of Autoconf. -*- Autoconf -*- -# Fortran languages support. -# Copyright (C) 2001, 2003-2011 Free Software Foundation, Inc. - -# This file is part of Autoconf. 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 3 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. -# -# Under Section 7 of GPL version 3, you are granted additional -# permissions described in the Autoconf Configure Script Exception, -# version 3.0, as published by the Free Software Foundation. -# -# You should have received a copy of the GNU General Public License -# and a copy of the Autoconf Configure Script Exception along with -# this program; see the files COPYINGv3 and COPYING.EXCEPTION -# respectively. If not, see . - -# Written by David MacKenzie, with help from -# Franc,ois Pinard, Karl Berry, Richard Pixley, Ian Lance Taylor, -# Roland McGrath, Noah Friedman, david d zuhn, and many others. - - -# Table of Contents: -# -# Preamble -# -# 0. Utility macros -# -# 1. Language selection -# and routines to produce programs in a given language. -# -# 2. Producing programs in a given language. -# -# 3. Looking for a compiler -# And possibly the associated preprocessor. -# -# 4. Compilers' characteristics. - -# AC_FC_PP_SRCEXT(EXT, [ACTION-IF-SUCCESS], [ACTION-IF-FAILURE]) -# -------------------------------------------------------------- -# Like AC_FC_SRCEXT, set the source-code extension used in Fortran (FC) tests -# to EXT (which defaults to f). Also, look for any necessary additional -# FCFLAGS needed to allow this extension for preprocessed Fortran, and store -# them in the output variable FCFLAGS_ (e.g. FCFLAGS_f90 for EXT=f90). -# If successful, call ACTION-IF-SUCCESS. If unable to compile preprocessed -# source code with EXT, call ACTION-IF-FAILURE, which defaults to failing with -# an error message. -# -# Some compilers allow preprocessing with either a Fortran preprocessor or -# with the C preprocessor (cpp). Prefer the Fortran preprocessor, to deal -# correctly with continuation lines, `//' (not a comment), and preserve white -# space (for fixed form). -# -# (The flags for the current source-code extension, if any, are stored in -# $ac_fcflags_srcext and used automatically in subsequent autoconf tests.) -# -# For ordinary extensions like f90, etcetera, the modified FCFLAGS -# are needed for IBM's xlf*. Also, for Intel's ifort compiler, the -# $FCFLAGS_ variable *must* go immediately before the source file on the -# command line, unlike other $FCFLAGS. Ugh. -# -# Known extensions that enable preprocessing by default, and flags to force it: -# GNU: .F .F90 .F95 .F03 .F08, -cpp for most others, -# -x f77-cpp-input for .f77 .F77; -x f95-cpp-input for gfortran < 4.4 -# SGI: .F .F90, -ftpp or -cpp for .f .f90, -E write preproc to stdout -# -macro_expand enable macro expansion everywhere (with -ftpp) -# -P preproc only, save in .i, no #line's -# SUN: .F .F95, -fpp for others; -xpp={fpp,cpp} for preprocessor selection -# -F preprocess only (save in lowercase extension) -# IBM: .F .F77 .F90 .F95 .F03, -qsuffix=cpp=EXT for extension .EXT to invoke cpp -# -WF,-qnofpp -WF,-qfpp=comment:linecont:nocomment:nolinecont -# -WF,-qlanglvl=classic or not -qnoescape (trigraph problems) -# -d no #line in output, -qnoobject for preprocessing only (output in .f) -# -q{no,}ppsuborigarg substitute original macro args before expansion -# HP: .F, +cpp={yes|no|default} use cpp, -cpp, +cpp_keep save in .i/.i90 -# PGI: -Mpreprocess -# Absoft: .F .FOR .F90 .F95, -cpp for others -# Cray: .F .F90 .FTN, -e Z for others; -F enable macro expansion everywhere -# Intel: .F .F90, -fpp for others, but except for .f and .f90, -Tf may also be -# needed right before the source file name -# PathScale: .F .F90 .F95, -ftpp or -cpp for .f .f90 .f95 -# -macro_expand for expansion everywhere, -P for no #line in output -# Lahey: .F .FOR .F90 .F95, -Cpp -# NAGWare: .F .F90 .F95, .ff .ff90 .ff95 (new), -fpp for others -# Compaq/Tru64: .F .F90, -cpp, -P keep .i file, -P keep .i file -# f2c: .F, -cpp -# g95: .F .FOR .F90 .F95 .F03, -cpp -no-cpp, -E for stdout -AC_DEFUN([AC_FC_PP_SRCEXT], -[AC_LANG_PUSH(Fortran)dnl -AC_CACHE_CHECK([for Fortran flag to compile preprocessed .$1 files], - ac_cv_fc_pp_srcext_$1, -[ac_ext=$1 -ac_fcflags_pp_srcext_save=$ac_fcflags_srcext -ac_fcflags_srcext= -ac_cv_fc_pp_srcext_$1=unknown -case $ac_ext in #( - [[fF]]77) ac_try=f77-cpp-input;; #( - *) ac_try=f95-cpp-input;; -esac -for ac_flag in none -ftpp -fpp -Tf "-fpp -Tf" -xpp=fpp -Mpreprocess "-e Z" \ - -cpp -xpp=cpp -qsuffix=cpp=$1 "-x $ac_try" +cpp -Cpp; do - test "x$ac_flag" != xnone && ac_fcflags_srcext="$ac_flag" - AC_COMPILE_IFELSE([AC_LANG_PROGRAM([], [[ -#if 0 -#include - choke me -#endif]])], - [AC_COMPILE_IFELSE([AC_LANG_PROGRAM([], [[ -#if 1 -#include - choke me -#endif]])], - [], - [ac_cv_fc_pp_srcext_$1=$ac_flag; break])]) -done -rm -f conftest.$ac_objext conftest.$1 -ac_fcflags_srcext=$ac_fcflags_pp_srcext_save -]) -if test "x$ac_cv_fc_pp_srcext_$1" = xunknown; then - m4_default([$3], - [AC_MSG_ERROR([Fortran could not compile preprocessed .$1 files])]) -else - ac_fc_srcext=$1 - if test "x$ac_cv_fc_pp_srcext_$1" = xnone; then - ac_fcflags_srcext="" - FCFLAGS_[]$1[]="" - else - ac_fcflags_srcext=$ac_cv_fc_pp_srcext_$1 - FCFLAGS_[]$1[]=$ac_cv_fc_pp_srcext_$1 - fi - AC_SUBST(FCFLAGS_[]$1) - $2 -fi -AC_LANG_POP(Fortran)dnl -])# AC_FC_PP_SRCEXT - -# AC_FC_PP_DEFINE([ACTION-IF-SUCCESS], [ACTION-IF-FAILURE = FAILURE]) -# ------------------------------------------------------------------- -# Find a flag to specify defines for preprocessed Fortran. Not all -# Fortran compilers use -D. Substitute FC_DEFINE with the result and -# call ACTION-IF-SUCCESS (defaults to nothing) if successful, and -# ACTION-IF-FAILURE (defaults to failing with an error message) if not. -# -# Known flags: -# IBM: -WF,-D -# Lahey/Fujitsu: -Wp,-D older versions??? -# f2c: -D or -Wc,-D -# others: -D -AC_DEFUN([AC_FC_PP_DEFINE], -[AC_LANG_PUSH([Fortran])dnl -ac_fc_pp_define_srcext_save=$ac_fc_srcext -AC_FC_PP_SRCEXT([F]) -AC_CACHE_CHECK([how to define symbols for preprocessed Fortran], - [ac_cv_fc_pp_define], -[ac_fc_pp_define_srcext_save=$ac_fc_srcext -ac_cv_fc_pp_define=unknown -ac_fc_pp_define_FCFLAGS_save=$FCFLAGS -for ac_flag in -D -WF,-D -Wp,-D -Wc,-D -do - FCFLAGS="$ac_fc_pp_define_FCFLAGS_save ${ac_flag}FOOBAR ${ac_flag}ZORK=42" - AC_COMPILE_IFELSE([AC_LANG_PROGRAM([], [[ -#ifndef FOOBAR - choke me -#endif -#if ZORK != 42 - choke me -#endif]])], - [ac_cv_fc_pp_define=$ac_flag]) - test x"$ac_cv_fc_pp_define" != xunknown && break -done -FCFLAGS=$ac_fc_pp_define_FCFLAGS_save -]) -ac_fc_srcext=$ac_fc_pp_define_srcext_save -if test "x$ac_cv_fc_pp_define" = xunknown; then - FC_DEFINE= - m4_default([$2], - [AC_MSG_ERROR([Fortran does not allow to define preprocessor symbols], 77)]) -else - FC_DEFINE=$ac_cv_fc_pp_define - $1 -fi -AC_SUBST([FC_DEFINE])dnl -AC_LANG_POP([Fortran])dnl -]) - - -# AC_FC_FREEFORM([ACTION-IF-SUCCESS], [ACTION-IF-FAILURE = FAILURE]) -# ------------------------------------------------------------------ -# Look for a compiler flag to make the Fortran (FC) compiler accept -# free-format source code, and adds it to FCFLAGS. Call -# ACTION-IF-SUCCESS (defaults to nothing) if successful (i.e. can -# compile code using new extension) and ACTION-IF-FAILURE (defaults to -# failing with an error message) if not. (Defined via DEFUN_ONCE to -# prevent flag from being added to FCFLAGS multiple times.) -# -# The known flags are: -# -ffree-form: GNU g77, gfortran, g95 -# -FR, -free: Intel compiler (icc, ecc, ifort) -# -free: Compaq compiler (fort), Sun compiler (f95) -# -qfree: IBM compiler (xlf) -# -Mfree, -Mfreeform: Portland Group compiler -# -freeform: SGI compiler -# -8, -f free: Absoft Fortran -# +source=free: HP Fortran -# (-)-nfix, -Free: Lahey/Fujitsu Fortran -# -free: NAGWare -# -f, -Wf,-f: f2c (but only a weak form of "free-form" and long lines) -# We try to test the "more popular" flags first, by some prejudiced -# notion of popularity. -AC_DEFUN_ONCE([AC_FC_FREEFORM], -[AC_LANG_PUSH([Fortran])dnl -AC_CACHE_CHECK([for Fortran flag needed to accept free-form source], - [ac_cv_fc_freeform], -[ac_cv_fc_freeform=unknown -ac_fc_freeform_FCFLAGS_save=$FCFLAGS -for ac_flag in none -ffree-form -FR -free -qfree -Mfree -Mfreeform \ - -freeform "-f free" -8 +source=free -nfix --nfix -Free -do - test "x$ac_flag" != xnone && FCFLAGS="$ac_fc_freeform_FCFLAGS_save $ac_flag" -dnl Use @&t@ below to ensure that editors don't turn 8+ spaces into tab. - AC_COMPILE_IFELSE([[ - program freeform - ! FIXME: how to best confuse non-freeform compilers? - print *, 'Hello ', & - @&t@ 'world.' - end]], - [ac_cv_fc_freeform=$ac_flag; break]) -done -rm -f conftest.err conftest.$ac_objext conftest.$ac_ext -FCFLAGS=$ac_fc_freeform_FCFLAGS_save -]) -if test "x$ac_cv_fc_freeform" = xunknown; then - m4_default([$2], - [AC_MSG_ERROR([Fortran does not accept free-form source], 77)]) -else - if test "x$ac_cv_fc_freeform" != xnone; then - FCFLAGS="$FCFLAGS $ac_cv_fc_freeform" - fi - $1 -fi -AC_LANG_POP([Fortran])dnl -])# AC_FC_FREEFORM - - -# AC_FC_FIXEDFORM([ACTION-IF-SUCCESS], [ACTION-IF-FAILURE = FAILURE]) -# ------------------------------------------------------------------ -# Look for a compiler flag to make the Fortran (FC) compiler accept -# fixed-format source code, and adds it to FCFLAGS. Call -# ACTION-IF-SUCCESS (defaults to nothing) if successful (i.e. can -# compile code using new extension) and ACTION-IF-FAILURE (defaults to -# failing with an error message) if not. (Defined via DEFUN_ONCE to -# prevent flag from being added to FCFLAGS multiple times.) -# -# The known flags are: -# -ffixed-form: GNU g77, gfortran, g95 -# -fixed: Intel compiler (ifort), Sun compiler (f95) -# -qfixed: IBM compiler (xlf*) -# -Mfixed: Portland Group compiler -# -fixedform: SGI compiler -# -f fixed: Absoft Fortran -# +source=fixed: HP Fortran -# (-)-fix, -Fixed: Lahey/Fujitsu Fortran -# -fixed: NAGWare -# Since compilers may accept fixed form based on file name extension, -# but users may want to use it with others as well, call AC_FC_SRCEXT -# with the respective source extension before calling this macro. -AC_DEFUN_ONCE([AC_FC_FIXEDFORM], -[AC_LANG_PUSH([Fortran])dnl -AC_CACHE_CHECK([for Fortran flag needed to accept fixed-form source], - [ac_cv_fc_fixedform], -[ac_cv_fc_fixedform=unknown -ac_fc_fixedform_FCFLAGS_save=$FCFLAGS -for ac_flag in none -ffixed-form -fixed -qfixed -Mfixed -fixedform "-f fixed" \ - +source=fixed -fix --fix -Fixed -do - test "x$ac_flag" != xnone && FCFLAGS="$ac_fc_fixedform_FCFLAGS_save $ac_flag" - AC_COMPILE_IFELSE([[ -C This comment should confuse free-form compilers. - program main - end]], - [ac_cv_fc_fixedform=$ac_flag; break]) -done -rm -f conftest.err conftest.$ac_objext conftest.$ac_ext -FCFLAGS=$ac_fc_fixedform_FCFLAGS_save -]) -if test "x$ac_cv_fc_fixedform" = xunknown; then - m4_default([$2], - [AC_MSG_ERROR([Fortran does not accept fixed-form source], 77)]) -else - if test "x$ac_cv_fc_fixedform" != xnone; then - FCFLAGS="$FCFLAGS $ac_cv_fc_fixedform" - fi - $1 -fi -AC_LANG_POP([Fortran])dnl -])# AC_FC_FIXEDFORM - - -# AC_FC_LINE_LENGTH([LENGTH], [ACTION-IF-SUCCESS], -# [ACTION-IF-FAILURE = FAILURE]) -# ------------------------------------------------ -# Look for a compiler flag to make the Fortran (FC) compiler accept long lines -# in the current (free- or fixed-format) source code, and adds it to FCFLAGS. -# The optional LENGTH may be 80, 132 (default), or `unlimited' for longer -# lines. Note that line lengths above 254 columns are not portable, and some -# compilers (hello ifort) do not accept more than 132 columns at least for -# fixed format. Call ACTION-IF-SUCCESS (defaults to nothing) if successful -# (i.e. can compile code using new extension) and ACTION-IF-FAILURE (defaults -# to failing with an error message) if not. (Defined via DEFUN_ONCE to -# prevent flag from being added to FCFLAGS multiple times.) -# You should call AC_FC_FREEFORM or AC_FC_FIXEDFORM to set the desired format -# prior to using this macro. -# -# The known flags are: -# -f{free,fixed}-line-length-N with N 72, 80, 132, or 0 or none for none. -# -ffree-line-length-none: GNU gfortran -# -ffree-line-length-huge: g95 (also -ffixed-line-length-N as above) -# -qfixed=132 80 72: IBM compiler (xlf) -# -Mextend: Cray -# -132 -80 -72: Intel compiler (ifort) -# Needs to come before -extend_source because ifort -# accepts that as well with an optional parameter and -# doesn't fail but only warns about unknown arguments. -# -extend_source: SGI compiler -# -W, -WNN (132, 80, 72): Absoft Fortran -# +es, +extend_source: HP Fortran (254 in either form, default is 72 fixed, -# 132 free) -# -w, (-)-wide: Lahey/Fujitsu Fortran (255 cols in fixed form) -# -e: Sun Fortran compiler (132 characters) -# -132: NAGWare -# -72, -f, -Wf,-f: f2c (a weak form of "free-form" and long lines). -# /XLine: Open Watcom -AC_DEFUN_ONCE([AC_FC_LINE_LENGTH], -[AC_LANG_PUSH([Fortran])dnl -m4_case(m4_default([$1], [132]), - [unlimited], [ac_fc_line_len_string=unlimited - ac_fc_line_len=0 - ac_fc_line_length_test=' - subroutine longer_than_132(arg1,arg2,arg3,arg4,arg5,arg6,arg7,arg8,'\ -'arg9,arg10,arg11,arg12,arg13,arg14,arg15,arg16,arg17,arg18,arg19)'], - [132], [ac_fc_line_len=132 - ac_fc_line_length_test=' - subroutine longer_than_80(arg1,arg2,arg3,arg4,arg5,arg6,arg7,arg8,arg9,'\ -'arg10)'], - [80], [ac_fc_line_len=80 - ac_fc_line_length_test=' - subroutine longer_than_72(arg1,arg2,arg3,arg4,arg5,arg6,arg7,arg8,arg9)'], - [m4_warning([Invalid length argument `$1'])]) -: ${ac_fc_line_len_string=$ac_fc_line_len} -AC_CACHE_CHECK( -[for Fortran flag needed to accept $ac_fc_line_len_string column source lines], - [ac_cv_fc_line_length], -[ac_cv_fc_line_length=unknown -ac_fc_line_length_FCFLAGS_save=$FCFLAGS -for ac_flag in none \ - -ffree-line-length-none -ffixed-line-length-none \ - -ffree-line-length-huge \ - -ffree-line-length-$ac_fc_line_len \ - -ffixed-line-length-$ac_fc_line_len \ - -qfixed=$ac_fc_line_len -Mextend \ - -$ac_fc_line_len -extend_source \ - -W$ac_fc_line_len -W +extend_source +es -wide --wide -w -e \ - -f -Wf,-f -xline -do - test "x$ac_flag" != xnone && FCFLAGS="$ac_fc_line_length_FCFLAGS_save $ac_flag" - AC_COMPILE_IFELSE([[$ac_fc_line_length_test - end subroutine]], - [ac_cv_fc_line_length=$ac_flag; break]) -done -rm -f conftest.err conftest.$ac_objext conftest.$ac_ext -FCFLAGS=$ac_fc_line_length_FCFLAGS_save -]) -if test "x$ac_cv_fc_line_length" = xunknown; then - m4_default([$3], - [AC_MSG_ERROR([Fortran does not accept long source lines], 77)]) -else - if test "x$ac_cv_fc_line_length" != xnone; then - FCFLAGS="$FCFLAGS $ac_cv_fc_line_length" - fi - $2 -fi -AC_LANG_POP([Fortran])dnl -])# AC_FC_LINE_LENGTH - - -# AC_FC_CHECK_BOUNDS([ACTION-IF-SUCCESS], [ACTION-IF-FAILURE = FAILURE]) -# ---------------------------------------------------------------------- -# Look for a compiler flag to turn on array bounds checking for the -# Fortran (FC) compiler, and adds it to FCFLAGS. Call -# ACTION-IF-SUCCESS (defaults to nothing) if successful (i.e. can -# compile code using new extension) and ACTION-IF-FAILURE (defaults to -# failing with an error message) if not. (Defined via DEFUN_ONCE to -# prevent flag from being added to FCFLAGS multiple times.) -# -# The known flags are: -# -fcheck=all, -fbounds-check: gfortran -# -fbounds-check: g77, g95 -# -CB, -check bounds: Intel compiler (icc, ecc, ifort) -# -C: Sun/Oracle compiler (f95) -# -C, -qcheck: IBM compiler (xlf) -# -Mbounds: Portland Group compiler -# -C ,-Mbounds: Cray -# -C, -check_bounds: SGI compiler -# -check_bounds, +check=all: HP Fortran -# -C, -Rb -Rc: Absoft (-Rb: array boundaries, -Rc: array conformance) -# --chk e,s -chk (e,s): Lahey -# -C -C=all: NAGWare -# -C, -ffortran-bounds-check: PathScale pathf90 -# -C: f2c -# -BOunds: Open Watcom -AC_DEFUN_ONCE([AC_FC_CHECK_BOUNDS], -[AC_LANG_PUSH([Fortran])dnl -AC_CACHE_CHECK([for Fortran flag to enable array-bounds checking], - [ac_cv_fc_check_bounds], -[ac_cv_fc_check_bounds=unknown -ac_fc_check_bounds_FCFLAGS_save=$FCFLAGS -for ac_flag in -fcheck=bounds -fbounds-check -check_bounds -Mbounds -qcheck \ - '-check bounds' +check=all --check '-Rb -Rc' -CB -C=all -C \ - -ffortran-bounds-check "--chk e,s" "-chk e -chk s" -bounds -do - FCFLAGS="$ac_fc_check_bounds_FCFLAGS_save $ac_flag" - # We should be able to link a correct program. - AC_LINK_IFELSE([AC_LANG_PROGRAM([], [])], - [AC_LINK_IFELSE([[ - subroutine sub(a) - integer a(:) - a(8) = 0 - end subroutine - - program main - integer a(1:7) - interface - subroutine sub(a) - integer a(:) - end subroutine - end interface - - call sub(a) - end program]], - [# If we can run the program, require failure at run time. - # In cross-compiling mode, we rely on the compiler not accepting - # unknown options. - AS_IF([test "$cross_compiling" = yes], - [ac_cv_fc_check_bounds=$ac_flag; break], - [AS_IF([_AC_DO_TOKENS(./conftest$ac_exeext)], - [], - [ac_cv_fc_check_bounds=$ac_flag; break])])])]) -done -rm -f conftest$ac_exeext conftest.err conftest.$ac_objext conftest.$ac_ext -FCFLAGS=$ac_fc_check_bounds_FCFLAGS_save -]) -if test "x$ac_cv_fc_check_bounds" = xunknown; then - m4_default([$2], - [AC_MSG_ERROR([no Fortran flag for bounds checking found], 77)]) -else - if test "x$ac_cv_fc_check_bounds" != xnone; then - FCFLAGS="$FCFLAGS $ac_cv_fc_check_bounds" - fi - $1 -fi -AC_LANG_POP([Fortran])dnl -])# AC_FC_CHECK_BOUNDS - - -# _AC_FC_IMPLICIT_NONE([ACTION-IF-SUCCESS], [ACTION-IF-FAILURE = FAILURE]) -# ------------------------------------------------------------------------ -# Look for a flag to disallow implicit declarations, and add it to FCFLAGS. -# Call ACTION-IF-SUCCESS (defaults to nothing) if successful and -# ACTION-IF-FAILURE (defaults to failing with an error message) if not. -# -# Known flags: -# GNU gfortran, g95: -fimplicit-none, g77: -Wimplicit -# Intel: -u, -implicitnone; might also need '-warn errors' to turn into error. -# Sun/Oracle: -u -# HP: +implicit_none -# IBM: -u, -qundef -# SGI: -u -# Compaq: -u, -warn declarations -# NAGWare: -u -# Lahey: -in, --in, -AT -# Cray: -Mdclchk -e I -# PGI: -Mcdlchk -# f2c: -u -AC_DEFUN([_AC_FC_IMPLICIT_NONE], -[_AC_FORTRAN_ASSERT()dnl -AC_CACHE_CHECK([for flag to disallow _AC_LANG implicit declarations], - [ac_cv_[]_AC_LANG_ABBREV[]_implicit_none], -[ac_cv_[]_AC_LANG_ABBREV[]_implicit_none=unknown -ac_fc_implicit_none_[]_AC_LANG_PREFIX[]FLAGS_save=$[]_AC_LANG_PREFIX[]FLAGS -for ac_flag in none -fimplicit-none -u -Wimplicit -implicitnone +implicit_none \ - -qundef "-warn declarations" -in --in -AT "-e I" -Mdclchk \ - "-u -warn errors" -do - if test "x$ac_flag" != xnone; then - _AC_LANG_PREFIX[]FLAGS="$ac_fc_implicit_none_[]_AC_LANG_PREFIX[]FLAGS_save $ac_flag" - fi - AC_COMPILE_IFELSE([AC_LANG_PROGRAM([], [])], - [AC_COMPILE_IFELSE([AC_LANG_PROGRAM([], [[ - i = 0 - print *, i]])], - [], - [ac_cv_[]_AC_LANG_ABBREV[]_implicit_none=$ac_flag; break])]) -done -rm -f conftest.err conftest.$ac_objext conftest.$ac_ext -_AC_LANG_PREFIX[]FLAGS=$ac_fc_implicit_none_[]_AC_LANG_PREFIX[]FLAGS_save -]) -if test "x$ac_cv_[]_AC_LANG_ABBREV[]_implicit_none" = xunknown; then - m4_default([$3], - [AC_MSG_ERROR([no Fortran flag to disallow implicit declarations found], 77)]) -else - if test "x$ac_cv_[]_AC_LANG_ABBREV[]_implicit_none" != xnone; then - _AC_LANG_PREFIX[]FLAGS="$_AC_LANG_PREFIX[]FLAGS $ac_cv_[]_AC_LANG_ABBREV[]_implicit_none" - fi - $2 -fi -])# _AC_FC_IMPLICIT_NONE - - -# AC_F77_IMPLICIT_NONE([ACTION-IF-SUCCESS], [ACTION-IF-FAILURE = FAILURE]) -# ------------------------------------------------------------------------ -AC_DEFUN([AC_F77_IMPLICIT_NONE], -[AC_LANG_PUSH([Fortran 77])dnl -_AC_FC_IMPLICIT_NONE($@) -AC_LANG_POP([Fortran 77])dnl -])# AC_F77_IMPLICIT_NONE - - -# AC_FC_IMPLICIT_NONE([ACTION-IF-SUCCESS], [ACTION-IF-FAILURE = FAILURE]) -# ----------------------------------------------------------------------- -AC_DEFUN([AC_FC_IMPLICIT_NONE], -[AC_LANG_PUSH([Fortran])dnl -_AC_FC_IMPLICIT_NONE($@) -AC_LANG_POP([Fortran])dnl -])# AC_FC_IMPLICIT_NONE - - -# AC_FC_MODULE_EXTENSION -# ---------------------- -# Find the Fortran 90 module file extension. The module extension is stored -# in the variable FC_MODEXT and empty if it cannot be determined. The result -# or "unknown" is cached in the cache variable ac_cv_fc_module_ext. -AC_DEFUN([AC_FC_MODULE_EXTENSION], -[AC_CACHE_CHECK([Fortran 90 module extension], [ac_cv_fc_module_ext], -[AC_LANG_PUSH(Fortran) -mkdir conftest.dir -cd conftest.dir -ac_cv_fc_module_ext=unknown -AC_COMPILE_IFELSE([[ - module conftest_module - contains - subroutine conftest_routine - write(*,'(a)') 'gotcha!' - end subroutine - end module]], - [ac_cv_fc_module_ext=`ls | sed -n 's,conftest_module\.,,p'` - if test x$ac_cv_fc_module_ext = x; then -dnl Some F90 compilers use upper case characters for the module file name. - ac_cv_fc_module_ext=`ls | sed -n 's,CONFTEST_MODULE\.,,p'` - fi]) -cd .. -rm -rf conftest.dir -AC_LANG_POP(Fortran) -]) -FC_MODEXT=$ac_cv_fc_module_ext -if test "$FC_MODEXT" = unknown; then - FC_MODEXT= -fi -AC_SUBST([FC_MODEXT])dnl -]) - - -# AC_FC_MODULE_FLAG([ACTION-IF-SUCCESS], [ACTION-IF-FAILURE = FAILURE]) -# --------------------------------------------------------------------- -# Find a flag to include Fortran 90 modules from another directory. -# If successful, run ACTION-IF-SUCCESS (defaults to nothing), otherwise -# run ACTION-IF-FAILURE (defaults to failing with an error message). -# The module flag is cached in the ac_cv_fc_module_flag variable. -# It may contain significant trailing whitespace. -# -# Known flags: -# gfortran: -Idir, -I dir (-M dir, -Mdir (deprecated), -Jdir for writing) -# g95: -I dir (-fmod=dir for writing) -# SUN: -Mdir, -M dir (-moddir=dir for writing; -# -Idir for includes is also searched) -# HP: -Idir, -I dir (+moddir=dir for writing) -# IBM: -Idir (-qmoddir=dir for writing) -# Intel: -Idir -I dir (-mod dir for writing) -# Absoft: -pdir -# Lahey: -Idir (-Mdir or -mod dir for writing) -# Cray: -module dir, -p dir (-J dir for writing) -# -e m is needed to enable writing .mod files at all -# Compaq: -Idir -# NAGWare: -I dir -# PathScale: -I dir (but -module dir is looked at first) -# Portland: -module dir (first -module also names dir for writing) -# Fujitsu: -Am -Idir (-Mdir for writing is searched first, then '.', then -I) -# (-Am indicates how module information is saved) -AC_DEFUN([AC_FC_MODULE_FLAG],[ -AC_CACHE_CHECK([Fortran 90 module inclusion flag], [ac_cv_fc_module_flag], -[AC_LANG_PUSH([Fortran]) -ac_cv_fc_module_flag=unknown -mkdir conftest.dir -cd conftest.dir -AC_COMPILE_IFELSE([[ - module conftest_module - contains - subroutine conftest_routine - write(*,'(a)') 'gotcha!' - end subroutine - end module]], - # For Lahey -M will also write module and object files to that directory - # make it read-only so that lahey fails over to -I - [chmod -w . - cd .. - ac_fc_module_flag_FCFLAGS_save=$FCFLAGS - # Flag ordering is significant for gfortran and Sun. - for ac_flag in -M -I '-I ' '-M ' -p '-mod ' '-module ' '-Am -I'; do - # Add the flag twice to prevent matching an output flag. - FCFLAGS="$ac_fc_module_flag_FCFLAGS_save ${ac_flag}conftest.dir ${ac_flag}conftest.dir" - AC_COMPILE_IFELSE([[ - module conftest_main - use conftest_module - contains - subroutine conftest - call conftest_routine - end subroutine - end module]], - [ac_cv_fc_module_flag="$ac_flag"]) - if test "$ac_cv_fc_module_flag" != unknown; then - break - fi - done - FCFLAGS=$ac_fc_module_flag_FCFLAGS_save -]) -chmod +w conftest.dir -rm -rf conftest.dir -AC_LANG_POP([Fortran]) -]) -if test "$ac_cv_fc_module_flag" != unknown; then - FC_MODINC=$ac_cv_fc_module_flag - $1 -else - FC_MODINC= - m4_default([$2], - [AC_MSG_ERROR([unable to find compiler flag for module search path])]) -fi -AC_SUBST([FC_MODINC]) -# Ensure trailing whitespace is preserved in a Makefile. -AC_SUBST([ac_empty], [""]) -AC_CONFIG_COMMANDS_PRE([case $FC_MODINC in #( - *\ ) FC_MODINC=$FC_MODINC'${ac_empty}' ;; -esac])dnl -]) - - -# AC_FC_MODULE_OUTPUT_FLAG([ACTION-IF-SUCCESS], [ACTION-IF-FAILURE = FAILURE]) -# ---------------------------------------------------------------------------- -# Find a flag to write Fortran 90 module information to another directory. -# If successful, run ACTION-IF-SUCCESS (defaults to nothing), otherwise -# run ACTION-IF-FAILURE (defaults to failing with an error message). -# The module flag is cached in the ac_cv_fc_module_output_flag variable. -# It may contain significant trailing whitespace. -# -# For known flags, see the documentation of AC_FC_MODULE_FLAG above. -AC_DEFUN([AC_FC_MODULE_OUTPUT_FLAG],[ -AC_CACHE_CHECK([Fortran 90 module output flag], [ac_cv_fc_module_output_flag], -[AC_LANG_PUSH([Fortran]) -mkdir conftest.dir conftest.dir/sub -cd conftest.dir -ac_cv_fc_module_output_flag=unknown -ac_fc_module_output_flag_FCFLAGS_save=$FCFLAGS -# Flag ordering is significant: put flags late which some compilers use -# for the search path. -for ac_flag in -J '-J ' -fmod= -moddir= +moddir= -qmoddir= '-mod ' \ - '-module ' -M '-Am -M' '-e m -J '; do - FCFLAGS="$ac_fc_module_output_flag_FCFLAGS_save ${ac_flag}sub" - AC_COMPILE_IFELSE([[ - module conftest_module - contains - subroutine conftest_routine - write(*,'(a)') 'gotcha!' - end subroutine - end module]], - [cd sub - AC_COMPILE_IFELSE([[ - program main - use conftest_module - call conftest_routine - end program]], - [ac_cv_fc_module_output_flag="$ac_flag"]) - cd .. - if test "$ac_cv_fc_module_output_flag" != unknown; then - break - fi]) -done -FCFLAGS=$ac_fc_module_output_flag_FCFLAGS_save -cd .. -rm -rf conftest.dir -AC_LANG_POP([Fortran]) -]) -if test "$ac_cv_fc_module_output_flag" != unknown; then - FC_MODOUT=$ac_cv_fc_module_output_flag - $1 -else - FC_MODOUT= - m4_default([$2], - [AC_MSG_ERROR([unable to find compiler flag to write module information to])]) -fi -AC_SUBST([FC_MODOUT]) -# Ensure trailing whitespace is preserved in a Makefile. -AC_SUBST([ac_empty], [""]) -AC_CONFIG_COMMANDS_PRE([case $FC_MODOUT in #( - *\ ) FC_MODOUT=$FC_MODOUT'${ac_empty}' ;; -esac])dnl -]) - -# _AC_FC_LIBRARY_LDFLAGS -# ---------------------- -# -# Determine the linker flags (e.g. "-L" and "-l") for the Fortran -# intrinsic and runtime libraries that are required to successfully -# link a Fortran program or shared library. The output variable -# FLIBS/FCLIBS is set to these flags. -# -# This macro is intended to be used in those situations when it is -# necessary to mix, e.g. C++ and Fortran, source code into a single -# program or shared library. -# -# For example, if object files from a C++ and Fortran compiler must -# be linked together, then the C++ compiler/linker must be used for -# linking (since special C++-ish things need to happen at link time -# like calling global constructors, instantiating templates, enabling -# exception support, etc.). -# -# However, the Fortran intrinsic and runtime libraries must be -# linked in as well, but the C++ compiler/linker doesn't know how to -# add these Fortran libraries. Hence, the macro -# "AC_F77_LIBRARY_LDFLAGS" was created to determine these Fortran -# libraries. -# -# This macro was packaged in its current form by Matthew D. Langston. -# However, nearly all of this macro came from the "OCTAVE_FLIBS" macro -# in "octave-2.0.13/aclocal.m4", and full credit should go to John -# W. Eaton for writing this extremely useful macro. Thank you John. -AC_DEFUN([_AC_FC_LIBRARY_LDFLAGS], -[_AC_FORTRAN_ASSERT()dnl -_AC_PROG_FC_V -AC_CACHE_CHECK([for _AC_LANG libraries of $[]_AC_FC[]], ac_cv_[]_AC_LANG_ABBREV[]_libs, -[if test "x$[]_AC_LANG_PREFIX[]LIBS" != "x"; then - ac_cv_[]_AC_LANG_ABBREV[]_libs="$[]_AC_LANG_PREFIX[]LIBS" # Let the user override the test. -else - -_AC_PROG_FC_V_OUTPUT - -ac_cv_[]_AC_LANG_ABBREV[]_libs= - -# Save positional arguments (if any) -ac_save_positional="$[@]" - -set X $ac_[]_AC_LANG_ABBREV[]_v_output -while test $[@%:@] != 1; do - shift - ac_arg=$[1] - case $ac_arg in - [[\\/]]*.a | ?:[[\\/]]*.a) - _AC_LIST_MEMBER_IF($ac_arg, $ac_cv_[]_AC_LANG_ABBREV[]_libs, , - ac_cv_[]_AC_LANG_ABBREV[]_libs="$ac_cv_[]_AC_LANG_ABBREV[]_libs $ac_arg") - ;; - -bI:*) - _AC_LIST_MEMBER_IF($ac_arg, $ac_cv_[]_AC_LANG_ABBREV[]_libs, , - [_AC_LINKER_OPTION([$ac_arg], ac_cv_[]_AC_LANG_ABBREV[]_libs)]) - ;; - # Ignore these flags. - -lang* | -lcrt*.o | -lc | -lgcc* | -lSystem | -libmil | -little \ - |-LANG:=* | -LIST:* | -LNO:* | -link | -list | -lnuma ) - ;; - -lkernel32) - test x"$CYGWIN" != xyes && ac_cv_[]_AC_LANG_ABBREV[]_libs="$ac_cv_[]_AC_LANG_ABBREV[]_libs $ac_arg" - ;; - -[[LRuYz]]) - # These flags, when seen by themselves, take an argument. - # We remove the space between option and argument and re-iterate - # unless we find an empty arg or a new option (starting with -) - case $[2] in - "" | -*);; - *) - ac_arg="$ac_arg$[2]" - shift; shift - set X $ac_arg "$[@]" - ;; - esac - ;; - -YP,*) - for ac_j in `AS_ECHO(["$ac_arg"]) | sed -e 's/-YP,/-L/;s/:/ -L/g'`; do - _AC_LIST_MEMBER_IF($ac_j, $ac_cv_[]_AC_LANG_ABBREV[]_libs, , - [ac_arg="$ac_arg $ac_j" - ac_cv_[]_AC_LANG_ABBREV[]_libs="$ac_cv_[]_AC_LANG_ABBREV[]_libs $ac_j"]) - done - ;; - -[[lLR]]*) - _AC_LIST_MEMBER_IF($ac_arg, $ac_cv_[]_AC_LANG_ABBREV[]_libs, , - ac_cv_[]_AC_LANG_ABBREV[]_libs="$ac_cv_[]_AC_LANG_ABBREV[]_libs $ac_arg") - ;; - -zallextract*| -zdefaultextract) - ac_cv_[]_AC_LANG_ABBREV[]_libs="$ac_cv_[]_AC_LANG_ABBREV[]_libs $ac_arg" - ;; - # Ignore everything else. - esac -done -# restore positional arguments -set X $ac_save_positional; shift - -# We only consider "LD_RUN_PATH" on Solaris systems. If this is seen, -# then we insist that the "run path" must be an absolute path (i.e. it -# must begin with a "/"). -case `(uname -sr) 2>/dev/null` in - "SunOS 5"*) - ac_ld_run_path=`AS_ECHO(["$ac_[]_AC_LANG_ABBREV[]_v_output"]) | - sed -n 's,^.*LD_RUN_PATH *= *\(/[[^ ]]*\).*$,-R\1,p'` - test "x$ac_ld_run_path" != x && - _AC_LINKER_OPTION([$ac_ld_run_path], ac_cv_[]_AC_LANG_ABBREV[]_libs) - ;; -esac -fi # test "x$[]_AC_LANG_PREFIX[]LIBS" = "x" -]) -[]_AC_LANG_PREFIX[]LIBS="$ac_cv_[]_AC_LANG_ABBREV[]_libs" -AC_SUBST([]_AC_LANG_PREFIX[]LIBS) -])# _AC_FC_LIBRARY_LDFLAGS - - -# AC_F77_LIBRARY_LDFLAGS -# ---------------------- -AC_DEFUN([AC_F77_LIBRARY_LDFLAGS], -[AC_REQUIRE([AC_PROG_F77])dnl -AC_LANG_PUSH(Fortran 77)dnl -_AC_FC_LIBRARY_LDFLAGS -AC_LANG_POP(Fortran 77)dnl -])# AC_F77_LIBRARY_LDFLAGS - - -# AC_FC_LIBRARY_LDFLAGS -# --------------------- -AC_DEFUN([AC_FC_LIBRARY_LDFLAGS], -[AC_REQUIRE([AC_PROG_FC])dnl -AC_LANG_PUSH(Fortran)dnl -_AC_FC_LIBRARY_LDFLAGS -AC_LANG_POP(Fortran)dnl -])# AC_FC_LIBRARY_LDFLAGS diff --git a/cesm/models/utils/mct/mct/Makefile b/cesm/models/utils/mct/mct/Makefile deleted file mode 100644 index 6cae8f4..0000000 --- a/cesm/models/utils/mct/mct/Makefile +++ /dev/null @@ -1,108 +0,0 @@ -.NOTPARALLEL: -SHELL = /bin/sh -VPATH=$(SRCDIR)/mct -# SOURCE FILES - -MODULE = mct - -SRCS_F90 = m_MCTWorld.F90 \ - m_AttrVect.F90 \ - m_GlobalMap.F90 \ - m_GlobalSegMap.F90 \ - m_GlobalSegMapComms.F90 \ - m_Accumulator.F90 \ - m_SparseMatrix.F90 \ - m_Navigator.F90 \ - m_AttrVectComms.F90 \ - m_AttrVectReduce.F90 \ - m_AccumulatorComms.F90 \ - m_GeneralGrid.F90 \ - m_GeneralGridComms.F90 \ - m_SpatialIntegral.F90 \ - m_SpatialIntegralV.F90 \ - m_MatAttrVectMul.F90 \ - m_Merge.F90 \ - m_GlobalToLocal.F90 \ - m_ExchangeMaps.F90 \ - m_ConvertMaps.F90 \ - m_SparseMatrixDecomp.F90 \ - m_SparseMatrixToMaps.F90 \ - m_SparseMatrixComms.F90 \ - m_SparseMatrixPlus.F90 \ - m_Router.F90 \ - m_Rearranger.F90 \ - m_Transfer.F90 - -OBJS_ALL = $(SRCS_F90:.F90=.o) - -# MACHINE AND COMPILER FLAGS - -include ../Makefile.conf - -# TARGETS - -all: lib$(MODULE).a - -lib$(MODULE).a: $(OBJS_ALL) - $(RM) $@ - $(AR) $@ $(OBJS_ALL) - $(RANLIB) $@ - -# ADDITIONAL FLAGS SPECIFIC FOR MCT COMPILATION - -MCTFLAGS = $(INCFLAG)$(MPEUPATH) - -# RULES - -.SUFFIXES: -.SUFFIXES: .F90 .o - -.F90.o: - $(FC) -c $(INCPATH) $(FPPDEFS) $(FCFLAGS) $(MCTFLAGS) $< - - -clean: - ${RM} *.o *.mod lib$(MODULE).a - -install: all - $(MKINSTALLDIRS) $(libdir) $(includedir) - $(INSTALL) lib$(MODULE).a -m 644 $(libdir) - @for modfile in *.mod; do \ - echo $(INSTALL) $$modfile -m 644 $(includedir); \ - $(INSTALL) $$modfile -m 644 $(includedir); \ - done - -# DEPENDENCIES - -$(OBJS_ALL): $(MPEUPATH)/libmpeu.a - -m_AttrVect.o: -m_Accumulator.o: m_AttrVect.o -m_GlobalMap.o: -m_GlobalSegMap.o: -m_GlobalSegMapComms.o: m_GlobalSegMap.o -m_Navigator.o: -m_AttrVectComms.o: m_AttrVect.o m_GlobalMap.o -m_AttrVectReduce.o: m_AttrVect.o -m_AccumulatorComms.o: m_AttrVect.o m_GlobalMap.o m_AttrVectComms.o -m_SparseMatrix.o: m_AttrVect.o m_GlobalMap.o m_AttrVectComms.o -m_GeneralGrid.o: m_AttrVect.o -m_GeneralGridComms.o: m_AttrVect.o m_GeneralGrid.o m_AttrVectComms.o m_GlobalMap.o m_GlobalSegMap.o -m_MatAttrVectMul.o: m_AttrVect.o m_SparseMatrix.o m_GlobalMap.o m_GlobalSegMap.o m_SparseMatrixPlus.o m_Rearranger.o -m_Merge.o: m_AttrVect.o m_GeneralGrid.o -m_Router.o: m_GlobalToLocal.o m_MCTWorld.o m_GlobalSegMap.o m_ExchangeMaps.o -m_Rearranger.o: m_Router.o m_MCTWorld.o m_GlobalSegMap.o m_AttrVect.o -m_GlobalToLocal.o: m_GlobalSegMap.o -m_ExchangeMaps.o: m_GlobalMap.o m_GlobalSegMap.o m_MCTWorld.o m_ConvertMaps.o -m_ConvertMaps.o: m_GlobalMap.o m_GlobalSegMap.o m_MCTWorld.o -m_SparseMatrixDecomp.o: m_SparseMatrix.o m_GlobalSegMap.o -m_SparseMatrixToMaps.o: m_SparseMatrix.o m_GlobalSegMap.o -m_SparseMatrixComms.o: m_SparseMatrix.o m_SparseMatrixDecomp.o m_GlobalSegMap.o m_AttrVectComms.o -accumulate.o: m_AttrVect.o m_Accumulator.o -m_SpatialIntegral.o: m_SpatialIntegralV.o m_GeneralGrid.o m_AttrVect.o m_AttrVectReduce.o -m_SpatialIntegralV.o: m_AttrVect.o m_AttrVectReduce.o -m_Transfer.o: m_AttrVect.o m_Router.o m_MCTWorld.o -m_SparseMatrixPlus.o: m_GlobalSegMap.o m_Rearranger.o m_SparseMatrix.o m_SparseMatrixComms.o m_SparseMatrixToMaps.o m_GlobalToLocal.o - - - diff --git a/cesm/models/utils/mct/mct/README b/cesm/models/utils/mct/mct/README deleted file mode 100644 index adabc56..0000000 --- a/cesm/models/utils/mct/mct/README +++ /dev/null @@ -1,39 +0,0 @@ -###################################################################### - - -- Mathematics + Computer Science Div. / Argonne National Laboratory - - Model Coupling Toolkit (MCT) - - Jay Larson - Robert Jacob - Everest Ong - - For more information, see http://www.mcs.anl.gov/mct - -###################################################################### -!----------------------------------------------------------------------- -! CVS $Id$ -! CVS $Name$ -!----------------------------------------------------------------------- - -This directory contains the basic MCT source code. - -MCT distribution contents: -MCT/ -MCT/COPYRIGHT -MCT/doc/ -MCT/examples/ -MCT/mct/ <- You are here -MCT/mpeu/ -MCT/protex/ - -A complete distribution of MCT can be obtained from http://www.mcs.anl.gov/mct. - ---------------------------------------------------- -Build instructions: -In the top level, type "make" to build mct and mpeu. - -If ./configure was already run and mpeu was already built, -you can type "make" in this directory. - ---------------------------------------------------- diff --git a/cesm/models/utils/mct/mct/m_Accumulator.F90 b/cesm/models/utils/mct/mct/m_Accumulator.F90 deleted file mode 100644 index 8d67805..0000000 --- a/cesm/models/utils/mct/mct/m_Accumulator.F90 +++ /dev/null @@ -1,2471 +0,0 @@ -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!----------------------------------------------------------------------- -! CVS $Id$ -! CVS $Name$ -!BOP ------------------------------------------------------------------- -! -! !MODULE: m_Accumulator - Time Averaging/Accumlation Buffer -! -! !DESCRIPTION: -! -! An {\em accumulator} is a data class used for computing running sums -! and/or time averages of {\tt AttrVect} class data. -! The period of time over which data are accumulated/averaged is the -! {\em accumulation cycle}, which is defined by the total number -! of accumulation steps (the component {\tt Accumulator\%num\_steps}). When -! the accumulation routine {\tt accumulate\_} is invoked, the number -! of accumulation cycle steps (the component -! {\tt Accumulator\%steps\_done})is incremented, and compared with -! the number of steps in the accumulation cycle to determine if the -! accumulation cycle has been completed. The accumulation buffers -! of the {\tt Accumulator} are stored in an {\tt AttrVect} (namely -! the component {\tt Accumulator\%data}), which allows the user to -! define the number of variables and their names at run-time. -! Finally, one can define for each field -! being accumulated the specific accumulation {\em action}. Currently, -! there are two options: Time Averaging and Time Summation. The -! user chooses the specific action by setting an integer action -! flag for each attribute being accumulated. The supported options -! are defined by the public data member constants {\tt MCT\_SUM} and -! {\tt MCT\_AVG}. -! \\ -! This module also supports a simple usage of accumulator where all -! the actions are SUM ({\tt inits\_} and {\tt initavs\_}) and the user -! must call {\tt average\_} to calculate the average from the current -! value of {\tt Accumulator\%steps\_done}. {\tt Accumulator\%num\_steps} -! is ignored in this case. -! -! !INTERFACE: - - module m_Accumulator -! -! !USES: -! - use m_List, only : List - use m_AttrVect, only : AttrVect - use m_realkinds,only : SP,DP,FP - - implicit none - - private ! except - -! !PUBLIC TYPES: - - public :: Accumulator ! The class data structure - - Type Accumulator -#ifdef SEQUENCE - sequence -#endif - integer :: num_steps ! total number of accumulation steps - integer :: steps_done ! number of accumulation steps performed - integer, pointer, dimension(:) :: iAction ! index of integer actions - integer, pointer, dimension(:) :: rAction ! index of real actions - type(AttrVect) :: data ! accumulated sum field storage - End Type Accumulator - -! !PUBLIC MEMBER FUNCTIONS: -! - public :: init ! creation method - public :: initp ! partial creation method (MCT USE ONLY) - public :: clean ! destruction method - public :: initialized ! check if initialized - public :: lsize ! local length of the data arrays - public :: NumSteps ! number of steps in a cycle - public :: StepsDone ! number of steps completed in the - ! current cycle - public :: nIAttr ! number of integer fields - public :: nRAttr ! number of real fields - public :: indexIA ! index the integer fields - public :: indexRA ! index the real fields - public :: getIList ! Return tag from INTEGER - ! attribute list - public :: getRList ! Return tag from REAL attribute - ! list - public :: exportIAttr ! Return INTEGER attribute as a vector - public :: exportRAttr ! Return REAL attribute as a vector - public :: importIAttr ! Insert INTEGER vector as attribute - public :: importRAttr ! Insert REAL vector as attribute - public :: zero ! Clear an accumulator - public :: SharedAttrIndexList ! Returns the number of shared - ! attributes, and lists of the - ! respective locations of these - ! shared attributes - public :: accumulate ! Add AttrVect data into an Accumulator - public :: average ! Calculate an average in an Accumulator - -! Definition of interfaces for the methods for the Accumulator: - - interface init ; module procedure & - init_, & - inits_, & - initv_, & - initavs_ - end interface - interface initp ; module procedure initp_ ; end interface - interface clean ; module procedure clean_ ; end interface - interface initialized; module procedure initialized_ ; end interface - interface lsize ; module procedure lsize_ ; end interface - interface NumSteps ; module procedure NumSteps_ ; end interface - interface StepsDone ; module procedure StepsDone_ ; end interface - interface nIAttr ; module procedure nIAttr_ ; end interface - interface nRAttr ; module procedure nRAttr_ ; end interface - interface indexIA; module procedure indexIA_; end interface - interface indexRA; module procedure indexRA_; end interface - interface getIList; module procedure getIList_; end interface - interface getRList; module procedure getRList_; end interface - interface exportIAttr ; module procedure exportIAttr_ ; end interface - interface exportRAttr ; module procedure & - exportRAttrSP_, & - exportRAttrDP_ - end interface - interface importIAttr ; module procedure importIAttr_ ; end interface - interface importRAttr ; module procedure & - importRAttrSP_, & - importRAttrDP_ - end interface - interface zero ; module procedure zero_ ; end interface - interface SharedAttrIndexList ; module procedure & - aCaCSharedAttrIndexList_, & - aVaCSharedAttrIndexList_ - end interface - interface accumulate ; module procedure accumulate_ ; end interface - interface average ; module procedure average_ ; end interface - -! !PUBLIC DATA MEMBERS: -! - public :: MCT_SUM - public :: MCT_AVG - - integer, parameter :: MCT_SUM = 1 - integer, parameter :: MCT_AVG = 2 - -! !REVISION HISTORY: -! 7Sep00 - Jay Larson - initial prototype -! 7Feb01 - Jay Larson - Public interfaces -! to getIList() and getRList(). -! 9Aug01 - E.T. Ong - added initialized and -! initp_ routines. Added 'action' in Accumulator type. -! 6May02 - Jay Larson - added import/export -! routines. -! 26Aug02 - E.T. Ong - thourough code revision; -! no added routines -! 10Jan08 - R. Jacob - add simple accumulator -! use support and check documentation. -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname='MCT::m_Accumulator' - - contains - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: init_ - Initialize an Accumulator and its Registers -! -! !DESCRIPTION: -! This routine allocates space for the output {\tt Accumulator} argument -! {\tt aC}, and at a minimum sets the number of time steps in an -! accumulation cycle (defined by the input {\tt INTEGER} argument -! {\tt num\_steps}), and the {\em length} of the {\tt Accumulator} -! register buffer (defined by the input {\tt INTEGER} argument {\tt -! lsize}). If one wishes to accumulate integer fields, the list of -! these fields is defined by the input {\tt CHARACTER} argument -! {\tt iList}, which is specified as a colon-delimited set of -! substrings (further information regarding this is available in the -! routine {\tt init\_()} of the module {\tt m\_AttrVect}). If no -! value of {\tt iList} is supplied, no integer attribute accumulation -! buffers will be allocated. The accumulation action on each of the -! integer attributes can be defined by supplying the input {\tt INTEGER} -! array argument {\tt iAction(:)} (whose length must correspond to the -! number of items in {\tt iList}). The values of the elements of -! {\tt iAction(:)} must be one of the values among the public data -! members defined in the declaration section of this module. If the -! integer attributes are to be accumulated (i.e. one supplies {\tt iList}), -! but {\tt iAction(:)} is not specified, the default action for all -! integer accumulation operations will be summation. The input arguments -! {\tt rList} and {\tt rAction(:)} define the names of the real variables -! to be accumulated and the accumulation action for each. The arguments -! {\tt rList} and {\tt rAction(:)} are related to each other the same -! way as {\tt iList} and {\tt iAction(:)}. Finally, the user can -! manually set the number of completed steps in an accumulation cycle -! (e.g. for restart purposes) by supplying a value for the optional -! input {\tt INTEGER} argument {\tt steps\_done}. -! -! !INTERFACE: - - subroutine init_(aC, iList, iAction, rList, rAction, lsize, & - num_steps,steps_done) -! -! !USES: -! - use m_AttrVect, only : AttrVect_init => init - use m_AttrVect, only : AttrVect_zero => zero - - use m_List, only: List - use m_List, only: List_nullify => nullify - use m_List, only: List_init => init - use m_List, only: List_nitem => nitem - use m_List, only: List_clean => clean - - use m_stdio - use m_die - - implicit none - -! !INPUT PARAMETERS: -! - character(len=*), optional, intent(in) :: iList - integer, dimension(:), optional, intent(in) :: iAction - character(len=*), optional, intent(in) :: rList - integer, dimension(:), optional, intent(in) :: rAction - integer, intent(in) :: lsize - integer, intent(in) :: num_steps - integer, optional, intent(in) :: steps_done - -! !OUTPUT PARAMETERS: -! - type(Accumulator), intent(out) :: aC - -! !REVISION HISTORY: -! 11Sep00 - Jay Larson - initial prototype -! 27JUL01 - E.T. Ong - added iAction, rAction, -! niAction, and nrAction to accumulator type. Also defined -! MCT_SUM and MCT_AVG for accumulator module. -!EOP ___________________________________________________________________ -! - character(len=*),parameter :: myname_=myname//'::init_' - integer :: my_steps_done, nIAttr, nRAttr, ierr - integer, dimension(:), pointer :: my_iAction, my_rAction - logical :: status - type(List) :: temp_iList, temp_rList - - nullify(my_iAction) - nullify(my_rAction) - - call List_nullify(temp_iList) - call List_nullify(temp_rList) - - ! Argument consistency checks: - - ! 1) Terminate with error message if optional argument iAction (rAction) - ! is supplied but optional argument iList (rList) is not. - - if(present(iAction) .and. (.not. present(iList))) then - write(stderr,'(2a)') myname_,'::FATAL--Argument iAction supplied but action iList absent!' - call die(myname_) - endif - - if(present(rAction) .and. (.not. present(rList))) then - write(stderr,'(2a)') myname_,'::FATAL--Argument rAction supplied but action rList absent!' - call die(myname_) - endif - - ! 2) For iList and rList, generate temporary List data structures to facilitate - ! attribute counting. - - if(present(iList)) then ! create temp_iList - call List_init(temp_iList, iList) - nIAttr = List_nitem(temp_iList) - endif - - if(present(rList)) then ! create temp_iList - call List_init(temp_rList, rList) - nRAttr = List_nitem(temp_rList) - endif - - ! 3) Terminate with error message if optional arguments iAction (rAction) - ! and iList (rList) are supplied but the size of iAction (rAction) does not - ! match the number of items in iList (rList). - - if(present(iAction) .and. present(iList)) then - if(size(iAction) /= nIAttr) then - write(stderr,'(2a,2(a,i8))') myname_, & - '::FATAL--Size mismatch between iAction and iList! ', & - 'size(iAction)=',size(iAction),', ','No. items in iList=',nIAttr - call die(myname_) - endif - endif - - if(present(rAction) .and. present(rList)) then - if(size(rAction) /= nRAttr) then - write(stderr,'(2a,2(a,i8))') myname_, & - '::FATAL--Size mismatch between rAction and rList! ', & - 'size(rAction)=',size(rAction),', ','No items in rList=',nRAttr - call die(myname_) - endif - endif - - ! Initialize the Accumulator components. - - ! steps_done: - - if(present(steps_done)) then - my_steps_done = steps_done - else - my_steps_done = 0 - endif - - ! my_iAction (if iList is present) - - if(present(iList)) then ! set up my_iAction - - allocate(my_iAction(nIAttr), stat=ierr) - if(ierr /= 0) then - write(stderr,'(2a,i8)') myname_, & - '::FATAL: allocate(my_iAction) failed with ierr=',ierr - call die(myname_) - endif - - if(present(iAction)) then ! use its values - my_iAction = iAction - else ! go with default summation by assigning value MCT_SUM - my_iAction = MCT_SUM - endif - - endif - - ! my_rAction (if rList is present) - - if(present(rList)) then ! set up my_rAction - - allocate(my_rAction(nRAttr), stat=ierr) - if(ierr /= 0) then - write(stderr,'(2a,i8)') myname_, & - '::FATAL: allocate(my_rAction) failed with ierr=',ierr - call die(myname_) - endif - - if(present(rAction)) then ! use its values - my_rAction = rAction - else ! go with default summation by assigning value MCT_SUM - my_rAction = MCT_SUM - endif - - endif - - ! Build the Accumulator aC minus its data component: - - if(present(iList) .and. present(rList)) then ! Both REAL and INTEGER registers - - call initp_(aC,my_iAction,my_rAction,num_steps,my_steps_done) - - deallocate(my_iAction, my_rAction, stat=ierr) - if(ierr /= 0) then - write(stderr,'(2a,i8)') myname_, & - '::FATAL: deallocate(my_iAction, my_rAction) failed with ierr=',ierr - call die(myname_) - endif - - else ! Either only REAL or only INTEGER registers in aC - - if(present(iList)) then ! Only INTEGER REGISTERS - - call initp_(aC=aC, iAction=my_iAction, num_steps=num_steps, & - steps_done=my_steps_done) - - deallocate(my_iAction, stat=ierr) - if(ierr /= 0) then - write(stderr,'(2a,i8)') myname_, & - '::FATAL: deallocate(my_iAction) failed with ierr=',ierr - call die(myname_) - endif - - endif - - if(present(rList)) then ! Only REAL REGISTERS - - call initp_(aC=aC, rAction=my_rAction, num_steps=num_steps, & - steps_done=my_steps_done) - - deallocate(my_rAction, stat=ierr) - if(ierr /= 0) then - write(stderr,'(2a,i8)') myname_, & - '::FATAL: deallocate(my_rAction) failed with ierr=',ierr - call die(myname_) - endif - - endif - - endif - - ! Initialize the AttrVect data component for aC: - - if(present(iList) .and. present(rList)) then - call AttrVect_init(aC%data,iList,rList,lsize) - else - if(present(iList)) then - call AttrVect_init(aV=aC%data,iList=iList,lsize=lsize) - endif - if(present(rList)) then - call AttrVect_init(aV=aC%data,rList=rList,lsize=lsize) - endif - endif - - call AttrVect_zero(aC%data) - - ! Clean up - - if(present(iList)) call List_clean(temp_iList) - if(present(rList)) call List_clean(temp_rList) - - ! Check that aC has been properly initialized - - status = initialized_(aC=aC,die_flag=.true.,source_name=myname_) - - end subroutine init_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: inits_ - Initialize a simple Accumulator and its Registers -! -! !DESCRIPTION: -! This routine allocates space for the output simple {\tt Accumulator} argument -! {\tt aC}, and sets the {\em length} of the {\tt Accumulator} -! register buffer (defined by the input {\tt INTEGER} argument {\tt -! lsize}). If one wishes to accumulate integer fields, the list of -! these fields is defined by the input {\tt CHARACTER} argument -! {\tt iList}, which is specified as a colon-delimited set of -! substrings (further information regarding this is available in the -! routine {\tt init\_()} of the module {\tt m\_AttrVect}). If no -! value of {\tt iList} is supplied, no integer attribute accumulation -! buffers will be allocated. The input argument {\tt rList} define -! the names of the real variables to be accumulated. Finally, the user can -! manually set the number of completed steps in an accumulation cycle -! (e.g. for restart purposes) by supplying a value for the optional -! input {\tt INTEGER} argument {\tt steps\_done}. -! Its default value is zero. -! -! In a simple accumulator, the action is always SUM. -! -! -! !INTERFACE: - - subroutine inits_(aC, iList, rList, lsize,steps_done) -! -! !USES: -! - use m_List, only : List_init => init - use m_List, only : List_clean => clean - use m_List, only : List_nitem => nitem - use m_AttrVect, only : AttrVect_init => init - use m_AttrVect, only : AttrVect_zero => zero - use m_die - - implicit none - -! !INPUT PARAMETERS: -! - character(len=*), optional, intent(in) :: iList - character(len=*), optional, intent(in) :: rList - integer, intent(in) :: lsize - integer, optional, intent(in) :: steps_done - -! !OUTPUT PARAMETERS: -! - type(Accumulator), intent(out) :: aC - -! !REVISION HISTORY: -! 10Jan08 - R. Jacob - initial version based on init_ -! -!EOP ___________________________________________________________________ -! - character(len=*),parameter :: myname_=myname//'::inits_' - type(List) :: tmplist - integer :: my_steps_done,ier,i,actsize - logical :: status - - ! Initialize the Accumulator components. - - if(present(steps_done)) then - my_steps_done = steps_done - else - my_steps_done = 0 - endif - - aC%num_steps = -1 ! special value for simple aC - aC%steps_done = my_steps_done - - nullify(aC%iAction,aC%rAction) - - if(present(iList)) then - call List_init(tmplist,iList) - actsize=List_nitem(tmplist) - allocate(aC%iAction(actsize),stat=ier) - if(ier /= 0) call die(myname_,"iAction allocate",ier) - do i=1,lsize - aC%iAction=MCT_SUM - enddo - call List_clean(tmplist) - endif - - if(present(rList)) then - call List_init(tmplist,rList) - actsize=List_nitem(tmpList) - allocate(aC%rAction(actsize),stat=ier) - if(ier /= 0) call die(myname_,"rAction allocate",ier) - do i=1,lsize - aC%rAction=MCT_SUM - enddo - call List_clean(tmplist) - endif - - ! Initialize the AttrVect component aC: - - if(present(iList) .and. present(rList)) then - call AttrVect_init(aC%data,iList,rList,lsize) - else - if(present(iList)) then - call AttrVect_init(aV=aC%data,iList=iList,lsize=lsize) - endif - if(present(rList)) then - call AttrVect_init(aV=aC%data,rList=rList,lsize=lsize) - endif - endif - - call AttrVect_zero(aC%data) - - ! Check that aC has been properly initialized - - status = initialized_(aC=aC,die_flag=.true.,source_name=myname_) - - end subroutine inits_ - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: initp_ - Initialize an Accumulator but not its Registers -! -! !DESCRIPTION: -! This routine is an internal service routine for use by the other -! initialization routines in this module. It sets up some---but not -! all---of the components of the output {\tt Accumulator} argument -! {\tt aC}. This routine can set up the following components of -! {\tt aC}: -! \begin{enumerate} -! \item {\tt aC\%iAction}, the array of accumlation actions for the -! integer attributes of {\tt aC} (if the input {\tt INTEGER} array -! argument {\tt iAction(:)} is supplied); -! \item {\tt aC\%rAction}, the array of accumlation actions for the -! real attributes of {\tt aC} (if the input {\tt INTEGER} array -! argument {\tt rAction(:)} is supplied); -! \item {\tt aC\%num\_steps}, the number of steps in an accumulation -! cycle (if the input {\tt INTEGER} argument {\tt num\_steps} is -! supplied); and -! \item {\tt aC\%steps\_done}, the number of steps completed so far -! in an accumulation cycle (if the input {\tt INTEGER} argument -! {\tt steps\_done} is supplied). -! \end{enumerate} -! -! !INTERFACE: - - subroutine initp_(aC, iAction, rAction, num_steps, steps_done) - -! -! !USES: -! - use m_die - - implicit none - -! !INPUT PARAMETERS: -! - integer, dimension(:), optional, intent(in) :: iAction - integer, dimension(:), optional, intent(in) :: rAction - integer, intent(in) :: num_steps - integer, optional, intent(in) :: steps_done - -! !OUTPUT PARAMETERS: -! - type(Accumulator), intent(out) :: aC - -! !REVISION HISTORY: -! 11Sep00 - Jay Larson - initial prototype -! 27JUL01 - E.T. Ong - added iAction, rAction, -! niAction, and nrAction to accumulator type. Also defined -! MCT_SUM and MCT_AVG for accumulator module. -!EOP ___________________________________________________________________ -! - character(len=*),parameter :: myname_=myname//'::initp_' - integer :: i,ier - integer :: steps_completed - - ! if the argument steps_done is not present, assume - ! the accumulator is starting at step zero, that is, - ! set steps_completed to zero - - steps_completed = 0 - if(present(steps_done)) steps_completed = steps_done - - ! Set the stepping info: - - aC%num_steps = num_steps - aC%steps_done = steps_completed - - - ! Assign iAction and niAction components - - nullify(aC%iAction,aC%rAction) - - if(present(iAction)) then - - if(size(iAction)>0) then - - allocate(aC%iAction(size(iAction)),stat=ier) - if(ier /= 0) call die(myname_,"iAction allocate",ier) - - do i=1,size(iAction) - aC%iAction(i) = iAction(i) - enddo - - endif - - endif - - if(present(rAction)) then - - if(size(rAction)>0) then - - allocate(aC%rAction(size(rAction)),stat=ier) - if(ier /= 0) call die(myname_,"iAction allocate",ier) - - do i=1,size(rAction) - aC%rAction(i) = rAction(i) - enddo - - endif - - endif - - end subroutine initp_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: initv_ - Initialize One Accumulator using Another -! -! !DESCRIPTION: -! This routine takes the integer and real attribute information (including -! accumulation action settings for each attribute) from a previously -! initialized {\tt Accumulator} (the input argument {\tt bC}), and uses -! it to create another {\tt Accumulator} (the output argument {\tt aC}). -! In the absence of the {\tt INTEGER} input arguments {\tt lsize}, -! {\tt num\_steps}, and {\tt steps\_done}, {\tt aC} will inherit from -! {\tt bC} its length, the number of steps in its accumulation cycle, and -! the number of steps completed in its present accumulation cycle, -! respectively. -! -! !INTERFACE: - - subroutine initv_(aC, bC, lsize, num_steps, steps_done) -! -! !USES: -! - use m_List, only : List - use m_List, only : ListExportToChar => exportToChar - use m_List, only : List_copy => copy - use m_List, only : List_allocated => allocated - use m_List, only : List_clean => clean - use m_die - - implicit none - -! !INPUT PARAMETERS: -! - type(Accumulator), intent(in) :: bC - integer, optional, intent(in) :: lsize - integer, optional, intent(in) :: num_steps - integer, optional, intent(in) :: steps_done - -! !OUTPUT PARAMETERS: -! - type(Accumulator), intent(out) :: aC - -! !REVISION HISTORY: -! 11Sep00 - Jay Larson - initial prototype -! 17May01 - R. Jacob - change string_get to -! list_get -! 27JUL01 - E.T. Ong - added iaction,raction -! compatibility -! 2Aug02 - J. Larson made argument num_steps -! optional -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::initv_' - - type(List) :: temp_iList, temp_rList - integer :: myNumSteps, myStepsDone - integer :: aC_lsize - integer :: niActions, nrActions - integer, dimension(:), allocatable :: iActionArray, rActionArray - integer :: i,ier - logical :: status - - ! Check that bC has been initialized - - status = initialized(aC=bC,die_flag=.true.,source_name=myname_) - - ! If the argument steps_done is present, set myStepsDone - ! to this value; otherwise, set it to zero - - if(present(num_steps)) then ! set it manually - myNumSteps = num_steps - else ! inherit it from bC - myNumSteps = bC%num_steps - endif - - ! If the argument steps_done is present, set myStepsDone - ! to this value; otherwise, set it to zero - - if(present(steps_done)) then ! set it manually - myStepsDone= steps_done - else ! inherit it from bC - myStepsDone = bC%steps_done - endif - - ! If the argument lsize is present, - ! set aC_lsize to this value; otherwise, set it to the lsize of bC - - if(present(lsize)) then ! set it manually - aC_lsize = lsize - else ! inherit it from bC - aC_lsize = lsize_(bC) - endif - - ! Convert the two Lists to two Strings - - niActions = 0 - nrActions = 0 - - if(List_allocated(bC%data%iList)) then - call List_copy(temp_iList,bC%data%iList) - niActions = nIAttr_(bC) - endif - - if(List_allocated(bC%data%rList)) then - call List_copy(temp_rList,bC%data%rList) - nrActions = nRAttr_(bC) - endif - - ! Convert the pointers to arrays - - allocate(iActionArray(niActions),rActionArray(nrActions),stat=ier) - if(ier /= 0) call die(myname_,"iActionArray/rActionArray allocate",ier) - - if( niActions>0 ) then - do i=1,niActions - iActionArray(i)=bC%iAction(i) - enddo - endif - - if( nrActions>0 ) then - do i=1,nrActions - rActionArray(i)=bC%rAction(i) - enddo - endif - - ! Call init with present arguments - - if( (niActions>0) .and. (nrActions>0) ) then - - call init_(aC, iList=ListExportToChar(temp_iList), & - iAction=iActionArray, & - rList=ListExportToChar(temp_rList), & - rAction=rActionArray, & - lsize=aC_lsize, & - num_steps=myNumSteps, & - steps_done=myStepsDone) - - else - - if( niActions>0 ) then - - call init_(aC, iList=ListExportToChar(temp_iList), & - iAction=iActionArray, & - lsize=aC_lsize, & - num_steps=myNumSteps, & - steps_done=myStepsDone) - - endif - - if( nrActions>0 ) then - - call init_(aC, rList=ListExportToChar(temp_rList), & - rAction=rActionArray, & - lsize=aC_lsize, & - num_steps=myNumSteps, & - steps_done=myStepsDone) - endif - - endif - - if(List_allocated(bC%data%iList)) call List_clean(temp_iList) - if(List_allocated(bC%data%rList)) call List_clean(temp_rList) - - deallocate(iActionArray,rActionArray,stat=ier) - if(ier /= 0) call die(myname_,"iActionArray/rActionArray deallocate",ier) - - ! Check that aC as been properly initialized - - status = initialized(aC=aC,die_flag=.true.,source_name=myname_) - - end subroutine initv_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: initavs_ - Initialize a simple Accumulator from an AttributeVector -! -! !DESCRIPTION: -! This routine takes the integer and real attribute information (including -! from a previously initialized {\tt AttributeVector} (the input argument {\tt aV}), and uses -! it to create a simple (sum only) {\tt Accumulator} (the output argument {\tt aC}). -! In the absence of the {\tt INTEGER} input argument {\tt lsize}, -! {\tt aC} will inherit from {\tt Av} its length. In the absence of the -! optional INTEGER argument, {\tt steps\_done} will be set to zero. -! -! !INTERFACE: - - subroutine initavs_(aC, aV, acsize, steps_done) -! -! !USES: -! - use m_AttrVect, only: AttrVect_lsize => lsize - use m_AttrVect, only: AttrVect_nIAttr => nIAttr - use m_AttrVect, only: AttrVect_nRAttr => nRAttr - use m_AttrVect, only: AttrVect_exIL2c => exportIListToChar - use m_AttrVect, only: AttrVect_exRL2c => exportRListToChar - use m_die - - implicit none - -! !INPUT PARAMETERS: -! - type(AttrVect), intent(in) :: aV - integer, optional, intent(in) :: acsize - integer, optional, intent(in) :: steps_done - -! !OUTPUT PARAMETERS: -! - type(Accumulator), intent(out) :: aC - -! !REVISION HISTORY: -! 10Jan08 - R. Jacob - initial version based on initv_ -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::initavs_' - - integer :: myNumSteps, myStepsDone - integer :: aC_lsize - integer :: i,ier - integer :: nIatt,nRatt - logical :: status - - - ! If the argument steps_done is present, set myStepsDone - ! to this value; otherwise, set it to zero - - if(present(steps_done)) then ! set it manually - myStepsDone= steps_done - else ! set it to zero - myStepsDone = 0 - endif - - ! If the argument acsize is present, - ! set aC_lsize to this value; otherwise, set it to the lsize of bC - - if(present(acsize)) then ! set it manually - aC_lsize = acsize - else ! inherit it from bC - aC_lsize = AttrVect_lsize(aV) - endif - nIatt=AttrVect_nIAttr(aV) - nRatt=AttrVect_nRAttr(aV) - - if((nIAtt>0) .and. (nRatt>0)) then - call inits_(aC,AttrVect_exIL2c(aV),AttrVect_exRL2c(aV), & - aC_lsize,myStepsDone) - else - if(nIatt>0) then - call inits_(aC,iList=AttrVect_exIL2c(aV),lsize=aC_lsize, & - steps_done=myStepsDone) - endif - if(nRatt>0) then - call inits_(aC,rList=AttrVect_exRL2c(aV),lsize=aC_lsize, & - steps_done=myStepsDone) - endif - endif - - - ! Check that aC as been properly initialized - - status = initialized(aC=aC,die_flag=.true.,source_name=myname_) - - end subroutine initavs_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: clean_ - Destroy an Accumulator -! -! !DESCRIPTION: -! This routine deallocates all allocated memory structures associated -! with the input/output {\tt Accumulator} argument {\tt aC}. The -! success (failure) of this operation is signified by the zero (non-zero) -! value of the optional {\tt INTEGER} output argument {\tt stat}. If -! {\tt clean\_()} is invoked with {\tt stat} present, it is the user's -! obligation to check this return code and act accordingly. If {\tt stat} -! is not supplied and any of the deallocation operations fail, this -! routine will terminate execution with an error statement. -! -! !INTERFACE: - - subroutine clean_(aC, stat) -! -! !USES: -! - use m_mall - use m_stdio - use m_die - use m_AttrVect, only : AttrVect_clean => clean - - implicit none - -! !INPUT/OUTPUT PARAMETERS: -! - type(Accumulator), intent(inout) :: aC - -! !OUTPUT PARAMETERS: -! - integer, optional, intent(out) :: stat - -! !REVISION HISTORY: -! 11Sep00 - Jay Larson - initial prototype -! 27JUL01 - E.T. Ong - deallocate pointers iAction -! and rAction. -! 1Mar02 - E.T. Ong removed the die to prevent -! crashes and added stat argument. -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::clean_' - integer :: ier - - if(present(stat)) then - stat=0 - call AttrVect_clean(aC%data,stat) - else - call AttrVect_clean(aC%data) - endif - - if( associated(aC%iAction) ) then - - deallocate(aC%iAction,stat=ier) - - if(ier /= 0) then - if(present(stat)) then - stat=ier - else - call warn(myname_,'deallocate(aC%iAction)',ier) - endif - endif - - endif - - if( associated(aC%rAction) ) then - - deallocate(aC%rAction,stat=ier) - - if(ier /= 0) then - if(present(stat)) then - stat=ier - else - call warn(myname_,'deallocate(aC%rAction)',ier) - endif - endif - - endif - - end subroutine clean_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: initialized_ - Check if an Accumulator is Initialized -! -! !DESCRIPTION: -! This logical function returns a value of {\tt .TRUE.} if the input -! {\tt Accumulator} argument {\tt aC} is initialized correctly. The -! term "correctly initialized" means there is internal consistency -! between the number of integer and real attributes in {\tt aC}, and -! their respective data structures for accumulation registers, and -! accumulation action flags. The optional {\tt LOGICAL} input argument -! {\tt die\_flag} if present, can result in messages written to -! {\tt stderr}: -! \begin {itemize} -! \item if {\tt die\_flag} is true and {\tt aC} is correctly initialized, -! and -! \item if {\tt die\_flag} is false and {\tt aC} is incorrectly -! initialized. -! \end{itemize} -! Otherwise, inconsistencies in how {\tt aC} is set up will result in -! termination with an error message. -! The optional {\tt CHARACTER} input argument {\tt source\_name} allows -! the user to, in the event of error, generate traceback information -! (e.g., the name of the routine that invoked this one). -! -! !INTERFACE: - - logical function initialized_(aC, die_flag, source_name) -! -! !USES: -! - - use m_stdio - use m_die - use m_List, only : List - use m_List, only : List_allocated => allocated - - use m_AttrVect, only : AttrVect - use m_AttrVect, only : Attr_nIAttr => nIAttr - use m_AttrVect, only : Attr_nRAttr => nRAttr - - implicit none - -! !INPUT PARAMETERS: -! - type(Accumulator), intent(in) :: aC - logical, optional, intent(in) :: die_flag - character(len=*), optional, intent(in) :: source_name - -! !REVISION HISTORY: -! 7AUG01 - E.T. Ong - initital prototype -! -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::initialized_' - integer :: i - logical :: kill - logical :: aC_associated - - if(present(die_flag)) then - kill = .true. - else - kill = .false. - endif - - ! Initial value - initialized_ = .true. - aC_associated = .true. - - ! Check the association status of pointers in aC - - if( associated(aC%iAction) .or. associated(aC%rAction) ) then - aC_associated = .true. - else - initialized_ = .false. - aC_associated = .false. - if(kill) then - if(present(source_name)) write(stderr,*) source_name, myname_, & - ":: ERROR, Neither aC%iAction nor aC%rAction are associated" - call die(myname_,"Neither aC%iAction nor aC%rAction are associated") - endif - endif - - if( List_allocated(aC%data%iList) .or. List_allocated(aC%data%rList) ) then - aC_associated = .true. - else - initialized_ = .false. - aC_associated = .false. - if(kill) then - if(present(source_name)) write(stderr,*) source_name, myname_, & - ":: ERROR, Neither aC%data%iList nor aC%data%rList are allocated" - call die(myname_,"Neither aC%data%iList nor aC%data%rList are allocated") - endif - endif - - ! Make sure iAction and rAction sizes are greater than zero - - if(associated(aC%iAction)) then - if(size(aC%iAction)<=0) then - initialized_ = .false. - aC_associated = .false. - if(kill) then - if(present(source_name)) write(stderr,*) source_name, myname_, & - ":: ERROR, size(aC%iAction<=0), size = ", size(aC%iAction) - call die(myname_,"size(aC%iAction<=0), size = ", size(aC%iAction)) - endif - endif - endif - - if(associated(aC%rAction)) then - if(size(aC%rAction)<=0) then - initialized_ = .false. - aC_associated = .false. - if(kill) then - if(present(source_name)) write(stderr,*) source_name, myname_, & - ":: ERROR, size(aC%rAction<=0), size = ", size(aC%rAction) - call die(myname_,"size(aC%rAction<=0), size = ", size(aC%rAction)) - endif - endif - endif - - ! More sanity checking... - - if( aC_associated ) then - - if( (Attr_nIAttr(aC%data) == 0) .and. (Attr_nRAttr(aC%data) == 0) ) then - initialized_ = .false. - if(kill) then - if(present(source_name)) write(stderr,*) source_name, myname_, & - ":: ERROR, No attributes found in aC%data" - call die(myname_,"No attributes found in aC%data") - endif - endif - - if(Attr_nIAttr(aC%data) > 0) then - - if( size(aC%iAction) /= Attr_nIAttr(aC%data) ) then - initialized_ = .false. - if(kill) then - if(present(source_name)) write(stderr,*) source_name, myname_, & - ":: ERROR, size(aC%iAction) /= nIAttr(aC%data)" - call die(myname_,"size(aC%iAction) /= nIAttr(aC%data)") - endif - endif - - do i=1,Attr_nIAttr(aC%data) - if( (aC%iAction(i) /= MCT_SUM) .and. & - (aC%iAction(i) /= MCT_AVG) ) then - initialized_ = .false. - if(kill) then - if(present(source_name)) write(stderr,*) source_name, & - myname_, ":: ERROR, Invalid value found in aC%iAction" - call die(myname_,"Invalid value found in aC%iAction", & - aC%iAction(i)) - endif - endif - enddo - - endif ! if(Attr_nIAttr(aC%data) > 0) - - if(Attr_nRAttr(aC%data) > 0) then - - if( size(aC%rAction) /= Attr_nRAttr(aC%data) ) then - initialized_ = .false. - if(kill) then - if(present(source_name)) write(stderr,*) source_name, & - myname_, ":: ERROR, size(aC%rAction) /= nRAttr(aC%data)" - call die(myname_,"size(aC%rAction) /= nRAttr(aC%data)") - endif - endif - - do i=1,Attr_nRAttr(aC%data) - if( (aC%rAction(i) /= MCT_SUM) .and. & - (aC%rAction(i) /= MCT_AVG) ) then - initialized_ = .false. - if(kill) then - if(present(source_name)) write(stderr,*) source_name, & - myname_, ":: ERROR, Invalid value found in aC%rAction", & - aC%rAction(i) - call die(myname_,"Invalid value found in aC%rAction", & - aC%iAction(i)) - endif - endif - enddo - - endif ! if(Attr_nRAttr(aC%data) > 0) - - endif ! if (aC_associated) - - end function initialized_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: lsize_ - Length of an Accumulator -! -! !DESCRIPTION: -! This {\tt INTEGER} query function returns the number of data points -! for which the input {\tt Accumulator} argument {\tt aC} is performing -! accumulation. This value corresponds to the length of the {\tt AttrVect} -! component {\tt aC\%data} that stores the accumulation registers. -! -! !INTERFACE: - - integer function lsize_(aC) -! -! !USES: -! - use m_AttrVect, only : AttrVect_lsize => lsize - - implicit none - -! !INPUT PARAMETERS: -! - type(Accumulator), intent(in) :: aC - -! !REVISION HISTORY: -! 12Sep00 - Jay Larson - initial prototype -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::lsize_' - - - ! The function AttrVect_lsize is called to return - ! its local size data - - lsize_=AttrVect_lsize(aC%data) - - end function lsize_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: NumSteps_ - Number of Accumulation Cycle Time Steps -! -! !DESCRIPTION: -! This {\tt INTEGER} query function returns the number of time steps in an -! accumulation cycle for the input {\tt Accumulator} argument {\tt aC}. -! -! !INTERFACE: - - integer function NumSteps_(aC) -! -! !USES: -! - use m_die, only : die - use m_stdio, only : stderr - - implicit none - -! !INPUT PARAMETERS: -! - type(Accumulator), intent(in) :: aC - -! !REVISION HISTORY: -! 7Aug02 - Jay Larson - initial prototype -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::NumSteps_' - - integer :: myNumSteps - - - ! Retrieve the number of cycle steps from aC: - - myNumSteps = aC%num_steps - - if(myNumSteps <= 0) then - write(stderr,'(2a,i8)') myname_, & - ':: FATAL--illegal number of steps in an accumulation cycle = ',& - myNumSteps - call die(myname_) - endif - - NumSteps_ = myNumSteps - - end function NumSteps_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: StepsDone_ - Number of Completed Steps in the Current Cycle -! -! !DESCRIPTION: -! This {\tt INTEGER} query function returns the of time steps that have -! been completed in the current accumulation cycle for the input -! {\tt Accumulator} argument {\tt aC}. -! -! !INTERFACE: - - integer function StepsDone_(aC) -! -! !USES: -! - use m_die, only : die - use m_stdio, only : stderr - - implicit none - -! !INPUT PARAMETERS: -! - type(Accumulator), intent(in) :: aC - -! !REVISION HISTORY: -! 7Aug02 - Jay Larson - initial prototype -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::StepsDone_' - - integer :: myStepsDone - - ! Retrieve the number of completed steps from aC: - - myStepsDone = aC%steps_done - - if(myStepsDone < 0) then - write(stderr,'(2a,i8)') myname_, & - ':: FATAL--illegal number of completed steps = ',& - myStepsDone - call die(myname_) - endif - - StepsDone_ = myStepsDone - - end function StepsDone_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: nIAttr_ - Return the Number of INTEGER Attributes -! -! !DESCRIPTION: -! This {\tt INTEGER} query function returns the number of integer -! attributes that are stored in the input {\tt Accumulator} argument -! {\tt aC}. This value is equal to the number of integer attributes -! in the {\tt AttrVect} component {\tt aC\%data} that stores the -! accumulation registers. -! -! !INTERFACE: - - integer function nIAttr_(aC) -! -! !USES: -! - use m_AttrVect, only : AttrVect_nIAttr => nIAttr - - implicit none - -! !INPUT PARAMETERS: -! - type(Accumulator),intent(in) :: aC - -! !REVISION HISTORY: -! 12Sep00 - Jay Larson - initial prototype -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::nIAttr_' - - ! The function AttrVect_nIAttr is called to return the - ! number of integer fields - - nIAttr_=AttrVect_nIAttr(aC%data) - - end function nIAttr_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: nRAttr_ - number of REAL fields stored in the Accumulator. -! -! !DESCRIPTION: -! This {\tt INTEGER} query function returns the number of real -! attributes that are stored in the input {\tt Accumulator} argument -! {\tt aC}. This value is equal to the number of real attributes -! in the {\tt AttrVect} component {\tt aC\%data} that stores the -! accumulation registers. -! -! !INTERFACE: - - integer function nRAttr_(aC) -! -! !USES: -! - use m_AttrVect, only : AttrVect_nRAttr => nRAttr - - implicit none - -! !INPUT PARAMETERS: -! - type(Accumulator),intent(in) :: aC - -! !REVISION HISTORY: -! 12Sep00 - Jay Larson - initial prototype -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::nRAttr_' - - ! The function AttrVect_nRAttr is called to return the - ! number of real fields - - nRAttr_=AttrVect_nRAttr(aC%data) - - end function nRAttr_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: getIList_ - Retrieve a Numbered INTEGER Attribute Name -! -! !DESCRIPTION: -! This routine returns as a {\tt String} (see the mpeu module -! {\tt m\_String} for information) the name of the {\tt ith} item in -! the integer registers of the {\tt Accumulator} argument {\tt aC}. -! -! !INTERFACE: - - subroutine getIList_(item, ith, aC) -! -! !USES: -! - use m_AttrVect, only : AttrVect_getIList => getIList - use m_String, only : String - - implicit none - -! !INPUT PARAMETERS: -! - integer, intent(in) :: ith - type(Accumulator), intent(in) :: aC - -! !OUTPUT PARAMETERS: -! - type(String), intent(out) :: item - -! !REVISION HISTORY: -! 12Sep00 - Jay Larson - initial prototype -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::getIList_' - - call AttrVect_getIList(item,ith,aC%data) - - end subroutine getIList_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: getRList_ - Retrieve a Numbered REAL Attribute Name -! -! !DESCRIPTION: -! This routine returns as a {\tt String} (see the mpeu module -! {\tt m\_String} for information) the name of the {\tt ith} item in -! the real registers of the {\tt Accumulator} argument {\tt aC}. -! -! !INTERFACE: - - subroutine getRList_(item, ith, aC) -! -! !USES: -! - use m_AttrVect, only : AttrVect_getRList => getRList - use m_String, only : String - - implicit none - -! !INPUT PARAMETERS: -! - integer, intent(in) :: ith - type(Accumulator),intent(in) :: aC - -! !OUTPUT PARAMETERS: -! - type(String), intent(out) :: item - -! !REVISION HISTORY: -! 12Sep00 - Jay Larson - initial prototype -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::getRList_' - - call AttrVect_getRList(item,ith,aC%data) - - end subroutine getRList_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: indexIA_ - Index an INTEGER Attribute -! -! !DESCRIPTION: -! This {\tt INTEGER} query function returns the index in the integer -! accumulation register buffer of the {\tt Accumulator} argument {\tt aC} -! the attribute named by the {\tt CHARACTER} argument {\tt item}. That -! is, all the accumulator running tallies for the attribute named -! {\tt item} reside in -!\begin{verbatim} -! aC%data%iAttr(indexIA_(aC,item),:). -!\end{verbatim} -! The user may request traceback information (e.g., the name of the -! routine from which this one is called) by providing values for either -! of the optional {\tt CHARACTER} arguments {\tt perrWith} or {\tt dieWith} -! In the event {\tt indexIA\_()} can not find {\tt item} in {\tt aC}, -! the routine behaves as follows: -! \begin{enumerate} -! \item if neither {\tt perrWith} nor {\tt dieWith} are present, -! {\tt indexIA\_()} returns a value of zero; -! \item if {\tt perrWith} is present, but {\tt dieWith} is not, an error -! message is written to {\tt stderr} incorporating user-supplied traceback -! information stored in the argument {\tt perrWith}; -! \item if {\tt dieWith} is present, execution terminates with an error -! message written to {\tt stderr} that incorporates user-supplied traceback -! information stored in the argument {\tt dieWith}. -! \end{enumerate} -! !INTERFACE: - - integer function indexIA_(aC, item, perrWith, dieWith) -! -! !USES: -! - use m_AttrVect, only : AttrVect_indexIA => indexIA - use m_die, only : die - use m_stdio,only : stderr - - implicit none - -! !INPUT PARAMETERS: -! - type(Accumulator), intent(in) :: aC - character(len=*), intent(in) :: item - character(len=*), optional, intent(in) :: perrWith - character(len=*), optional, intent(in) :: dieWith - -! !REVISION HISTORY: -! 14Sep00 - Jay Larson - initial prototype -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::indexIA_' - - indexIA_=AttrVect_indexIA(aC%data,item) - - if(indexIA_==0) then - if(.not.present(dieWith)) then - if(present(perrWith)) write(stderr,'(4a)') perrWith, & - '" indexIA_() error, not found "',trim(item),'"' - else - write(stderr,'(4a)') dieWith, & - '" indexIA_() error, not found "',trim(item),'"' - call die(dieWith) - endif - endif - - end function indexIA_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: indexRA_ - index the Accumulator real attribute list. -! -! !DESCRIPTION: -! This {\tt INTEGER} query function returns the index in the real -! accumulation register buffer of the {\tt Accumulator} argument {\tt aC} -! the attribute named by the {\tt CHARACTER} argument {\tt item}. That -! is, all the accumulator running tallies for the attribute named -! {\tt item} reside in -!\begin{verbatim} -! aC%data%rAttr(indexRA_(aC,item),:). -!\end{verbatim} -! The user may request traceback information (e.g., the name of the -! routine from which this one is called) by providing values for either -! of the optional {\tt CHARACTER} arguments {\tt perrWith} or {\tt dieWith} -! In the event {\tt indexRA\_()} can not find {\tt item} in {\tt aC}, -! the routine behaves as follows: -! \begin{enumerate} -! \item if neither {\tt perrWith} nor {\tt dieWith} are present, -! {\tt indexRA\_()} returns a value of zero; -! \item if {\tt perrWith} is present, but {\tt dieWith} is not, an error -! message is written to {\tt stderr} incorporating user-supplied traceback -! information stored in the argument {\tt perrWith}; -! \item if {\tt dieWith} is present, execution terminates with an error -! message written to {\tt stderr} that incorporates user-supplied traceback -! information stored in the argument {\tt dieWith}. -! \end{enumerate} -! -! !INTERFACE: - - integer function indexRA_(aC, item, perrWith, dieWith) -! -! !USES: -! - use m_AttrVect, only : AttrVect_indexRA => indexRA - use m_die, only : die - use m_stdio,only : stderr - - implicit none - -! !INPUT PARAMETERS: -! - type(Accumulator), intent(in) :: aC - character(len=*), intent(in) :: item - character(len=*), optional, intent(in) :: perrWith - character(len=*), optional, intent(in) :: dieWith - -! !REVISION HISTORY: -! 14Sep00 - Jay Larson - initial prototype -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::indexRA_' - - indexRA_=AttrVect_indexRA(aC%data,item) - - if(indexRA_==0) then - if(.not.present(dieWith)) then - if(present(perrWith)) write(stderr,'(4a)') perrWith, & - '" indexRA_() error, not found "',trim(item),'"' - else - write(stderr,'(4a)') dieWith, & - '" indexRA_() error, not found "',trim(item),'"' - call die(dieWith) - endif - endif - - end function indexRA_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: exportIAttr_ - Export INTEGER Attribute to a Vector -! -! !DESCRIPTION: -! This routine extracts from the input {\tt Accumulator} argument -! {\tt aC} the integer attribute corresponding to the tag defined in -! the input {\tt CHARACTER} argument {\tt AttrTag}, and returns it in -! the {\tt INTEGER} output array {\tt outVect}, and its length in the -! output {\tt INTEGER} argument {\tt lsize}. -! -! {\bf N.B.:} This routine will fail if the {\tt AttrTag} is not in -! the {\tt Accumulator} {\tt List} component {\tt aC\%data\%iList}. -! -! {\bf N.B.:} The flexibility of this routine regarding the pointer -! association status of the output argument {\tt outVect} means the -! user must invoke this routine with care. If the user wishes this -! routine to fill a pre-allocated array, then obviously this array -! must be allocated prior to calling this routine. If the user wishes -! that the routine {\em create} the output argument array {\tt outVect}, -! then the user must ensure this pointer is not allocated (i.e. the user -! must nullify this pointer) at the time this routine is invoked. -! -! {\bf N.B.:} If the user has relied on this routine to allocate memory -! associated with the pointer {\tt outVect}, then the user is responsible -! for deallocating this array once it is no longer needed. Failure to -! do so will result in a memory leak. -! -! !INTERFACE: - - subroutine exportIAttr_(aC, AttrTag, outVect, lsize) -! -! !USES: -! - use m_die - use m_stdio - - use m_AttrVect, only : AttrVect_exportIAttr => exportIAttr - - implicit none - -! !INPUT PARAMETERS: - - type(Accumulator), intent(in) :: aC - character(len=*), intent(in) :: AttrTag - -! !OUTPUT PARAMETERS: - - integer, dimension(:), pointer :: outVect - integer, optional, intent(out) :: lsize - -! !REVISION HISTORY: - -! 6May02 - J.W. Larson - initial prototype. -! -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::exportIAttr_' - - ! Export the data (inheritance from AttrVect) - if(present(lsize)) then - call AttrVect_exportIAttr(aC%data, AttrTag, outVect, lsize) - else - call AttrVect_exportIAttr(aC%data, AttrTag, outVect) - endif - - end subroutine exportIAttr_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: exportRAttrSP_ - Export REAL Attribute to a Vector -! -! !DESCRIPTION: -! This routine extracts from the input {\tt Accumulator} argument -! {\tt aC} the real attribute corresponding to the tag defined in -! the input {\tt CHARACTER} argument {\tt AttrTag}, and returns it in -! the {\tt REAL} output array {\tt outVect}, and its length in the -! output {\tt INTEGER} argument {\tt lsize}. -! -! {\bf N.B.:} This routine will fail if the {\tt AttrTag} is not in -! the {\tt Accumulator} {\tt List} component {\tt aC\%data\%iList}. -! -! {\bf N.B.:} The flexibility of this routine regarding the pointer -! association status of the output argument {\tt outVect} means the -! user must invoke this routine with care. If the user wishes this -! routine to fill a pre-allocated array, then obviously this array -! must be allocated prior to calling this routine. If the user wishes -! that the routine {\em create} the output argument array {\tt outVect}, -! then the user must ensure this pointer is not allocated (i.e. the user -! must nullify this pointer) at the time this routine is invoked. -! -! {\bf N.B.:} If the user has relied on this routine to allocate memory -! associated with the pointer {\tt outVect}, then the user is responsible -! for deallocating this array once it is no longer needed. Failure to -! do so will result in a memory leak. -! -! !INTERFACE: - - subroutine exportRAttrSP_(aC, AttrTag, outVect, lsize) -! -! !USES: -! - use m_die - use m_stdio - - use m_AttrVect, only : AttrVect_exportRAttr => exportRAttr - - implicit none - -! !INPUT PARAMETERS: - - type(Accumulator), intent(in) :: aC - character(len=*), intent(in) :: AttrTag - -! !OUTPUT PARAMETERS: - - real(SP), dimension(:), pointer :: outVect - integer, optional, intent(out) :: lsize - -! !REVISION HISTORY: -! 6May02 - J.W. Larson - initial prototype. -! -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::exportRAttrSP_' - - ! Export the data (inheritance from AttrVect) - - if(present(lsize)) then - call AttrVect_exportRAttr(aC%data, AttrTag, outVect, lsize) - else - call AttrVect_exportRAttr(aC%data, AttrTag, outVect) - endif - - end subroutine exportRAttrSP_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -! ---------------------------------------------------------------------- -! -! !IROUTINE: exportRAttrDP_ - Export REAL Attribute to a Vector -! -! !DESCRIPTION: -! Double precision version of exportRAttrSP_ -! -! !INTERFACE: - - subroutine exportRAttrDP_(aC, AttrTag, outVect, lsize) -! -! !USES: -! - use m_die - use m_stdio - - use m_AttrVect, only : AttrVect_exportRAttr => exportRAttr - - implicit none - -! !INPUT PARAMETERS: - - type(Accumulator), intent(in) :: aC - character(len=*), intent(in) :: AttrTag - -! !OUTPUT PARAMETERS: - - real(DP), dimension(:), pointer :: outVect - integer, optional, intent(out) :: lsize - -! !REVISION HISTORY: -! 6May02 - J.W. Larson - initial prototype. -! -! ______________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::exportRAttrDP_' - - ! Export the data (inheritance from AttrVect) - - if(present(lsize)) then - call AttrVect_exportRAttr(aC%data, AttrTag, outVect, lsize) - else - call AttrVect_exportRAttr(aC%data, AttrTag, outVect) - endif - - end subroutine exportRAttrDP_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: importIAttr_ - Import INTEGER Attribute from a Vector -! -! !DESCRIPTION: -! This routine imports data provided in the input {\tt INTEGER} vector -! {\tt inVect} into the {\tt Accumulator} argument {\tt aC}, storing -! it as the integer attribute corresponding to the tag defined in -! the input {\tt CHARACTER} argument {\tt AttrTag}. The input -! {\tt INTEGER} argument {\tt lsize} is used to ensure there is -! sufficient space in the {\tt Accumulator} to store the data. -! -! {\bf N.B.:} This routine will fail if the {\tt AttrTag} is not in -! the {\tt Accumulator} {\tt List} component {\tt aC\%data\%rList}. -! -! !INTERFACE: - - subroutine importIAttr_(aC, AttrTag, inVect, lsize) -! -! !USES: -! - use m_die - use m_stdio , only : stderr - - use m_AttrVect, only : AttrVect_importIAttr => importIAttr - - implicit none - -! !INPUT PARAMETERS: - - character(len=*), intent(in) :: AttrTag - integer, dimension(:), pointer :: inVect - integer, intent(in) :: lsize - -! !INPUT/OUTPUT PARAMETERS: - - type(Accumulator), intent(inout) :: aC - -! !REVISION HISTORY: -! 6May02 - J.W. Larson - initial prototype. -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::importIAttr_' - - ! Argument Check: - - if(lsize > lsize_(aC)) then - write(stderr,*) myname_,':: ERROR, lsize > lsize_(aC).', & - 'lsize = ',lsize,'lsize_(aC) = ',lsize_(ac) - call die(myname_) - endif - - ! Import the data (inheritance from AttrVect) - - call AttrVect_importIAttr(aC%data, AttrTag, inVect, lsize) - - end subroutine importIAttr_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: importRAttrSP_ - Import REAL Attribute from a Vector -! -! !DESCRIPTION: -! This routine imports data provided in the input {\tt REAL} vector -! {\tt inVect} into the {\tt Accumulator} argument {\tt aC}, storing -! it as the real attribute corresponding to the tag defined in -! the input {\tt CHARACTER} argument {\tt AttrTag}. The input -! {\tt INTEGER} argument {\tt lsize} is used to ensure there is -! sufficient space in the {\tt Accumulator} to store the data. -! -! {\bf N.B.:} This routine will fail if the {\tt AttrTag} is not in -! the {\tt Accumulator} {\tt List} component {\tt aC\%data\%rList}. -! -! !INTERFACE: - - subroutine importRAttrSP_(aC, AttrTag, inVect, lsize) -! -! !USES: -! - use m_die - use m_stdio , only : stderr - - use m_AttrVect, only : AttrVect_importRAttr => importRAttr - - implicit none - -! !INPUT PARAMETERS: - - character(len=*), intent(in) :: AttrTag - real(SP), dimension(:), pointer :: inVect - integer, intent(in) :: lsize - -! !INPUT/OUTPUT PARAMETERS: - - type(Accumulator), intent(inout) :: aC - -! !REVISION HISTORY: -! 6May02 - J.W. Larson - initial prototype. -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::importRAttrSP_' - - ! Argument Check: - - if(lsize > lsize_(aC)) then - write(stderr,*) myname_,':: ERROR, lsize > lsize_(aC).', & - 'lsize = ',lsize,'lsize_(aC) = ',lsize_(ac) - call die(myname_) - endif - - ! Import the data (inheritance from AttrVect) - - call AttrVect_importRAttr(aC%data, AttrTag, inVect, lsize) - - end subroutine importRAttrSP_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -! ---------------------------------------------------------------------- -! -! !IROUTINE: importRAttrDP_ - Import REAL Attribute from a Vector -! -! !DESCRIPTION: -! Double precision version of importRAttrSP_ -! -! !INTERFACE: - - subroutine importRAttrDP_(aC, AttrTag, inVect, lsize) -! -! !USES: -! - use m_die - use m_stdio , only : stderr - - use m_AttrVect, only : AttrVect_importRAttr => importRAttr - - implicit none - -! !INPUT PARAMETERS: - - character(len=*), intent(in) :: AttrTag - real(DP), dimension(:), pointer :: inVect - integer, intent(in) :: lsize - -! !INPUT/OUTPUT PARAMETERS: - - type(Accumulator), intent(inout) :: aC - -! !REVISION HISTORY: -! 6May02 - J.W. Larson - initial prototype. -! ______________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::importRAttrDP_' - - ! Argument Check: - - if(lsize > lsize_(aC)) then - write(stderr,*) myname_,':: ERROR, lsize > lsize_(aC).', & - 'lsize = ',lsize,'lsize_(aC) = ',lsize_(ac) - call die(myname_) - endif - - ! Import the data (inheritance from AttrVect) - - call AttrVect_importRAttr(aC%data, AttrTag, inVect, lsize) - - end subroutine importRAttrDP_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: zero_ - Zero an Accumulator -! -! !DESCRIPTION: -! This subroutine clears the the {\tt Accumulator} argument {\tt aC}. -! This is accomplished by setting the number of completed steps in the -! accumulation cycle to zero, and zeroing out all of the accumlation -! registers. -! -! !INTERFACE: - - subroutine zero_(aC) -! -! !USES: -! - use m_AttrVect, only : AttrVect_zero => zero - - implicit none - -! !INPUT/OUTPUT PARAMETERS: -! - type(Accumulator), intent(inout) :: aC - -! !REVISION HISTORY: -! 7Aug02 - Jay Larson - initial prototype -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::zero_' - - ! Set number of completed cycle steps to zero: - - aC%steps_done = 0 - - ! Zero out the accumulation registers: - - call AttrVect_zero(aC%data) - - end subroutine zero_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: aCaCSharedAttrIndexList_ - Cross-index Two Accumulators -! -! !DESCRIPTION: {\tt aCaCSharedAttrIndexList\_()} takes a pair of -! user-supplied {\tt Accumulator} variables {\tt aC1} and {\tt aC2}, -! and for choice of either {\tt REAL} or {\tt INTEGER} attributes (as -! specified literally in the input {\tt CHARACTER} argument {\tt attrib}) -! returns the number of shared attributes {\tt NumShared}, and arrays of -! indices {\tt Indices1} and {\tt Indices2} to their storage locations -! in {\tt aC1} and {\tt aC2}, respectively. -! -! {\bf N.B.:} This routine returns two allocated arrays---{\tt Indices1(:)} -! and {\tt Indices2(:)}---which must be deallocated once the user no longer -! needs them. Failure to do this will create a memory leak. -! -! !INTERFACE: - - subroutine aCaCSharedAttrIndexList_(aC1, aC2, attrib, NumShared, & - Indices1, Indices2) - -! -! !USES: -! - use m_stdio - use m_die, only : MP_perr_die, die, warn - - use m_List, only : GetSharedListIndices - - implicit none - -! !INPUT PARAMETERS: -! - type(Accumulator), intent(in) :: aC1 - type(Accumulator), intent(in) :: aC2 - character*7, intent(in) :: attrib - -! !OUTPUT PARAMETERS: -! - integer, intent(out) :: NumShared - integer,dimension(:), pointer :: Indices1 - integer,dimension(:), pointer :: Indices2 - -! !REVISION HISTORY: -! 7Feb01 - J.W. Larson - initial version -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::aCaCSharedAttrIndexList_' - - integer :: ierr - - ! Based on the value of the argument attrib, pass the - ! appropriate pair of Lists for comparison... - - select case(trim(attrib)) - case('REAL','real') - call GetSharedListIndices(aC1%data%rList, aC2%data%rList, NumShared, & - Indices1, Indices2) - case('INTEGER','integer') - call GetSharedListIndices(aC1%data%iList, aC2%data%iList, NumShared, & - Indices1, Indices2) - case default - write(stderr,'(4a)') myname_,":: value of argument attrib=",attrib, & - " not recognized. Allowed values: REAL, real, INTEGER, integer" - ierr = 1 - call die(myname_, 'invalid value for attrib', ierr) - end select - - end subroutine aCaCSharedAttrIndexList_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: aVaCSharedAttrIndexList_ - Cross-index with an AttrVect -! -! !DESCRIPTION: {\tt aVaCSharedAttrIndexList\_()} a user-supplied -! {\tt AttrVect} variable {\tt aV} and an {\tt Accumulator} variable -! {\tt aC}, and for choice of either {\tt REAL} or {\tt INTEGER} -! attributes (as ! specified literally in the input {\tt CHARACTER} -! argument {\tt attrib}) returns the number of shared attributes -! {\tt NumShared}, and arrays of indices {\tt Indices1} and {\tt Indices2} -! to their storage locations in {\tt aV} and {\tt aC}, respectively. -! -! {\bf N.B.:} This routine returns two allocated arrays---{\tt Indices1(:)} -! and {\tt Indices2(:)}---which must be deallocated once the user no longer -! needs them. Failure to do this will create a memory leak. -! -! !INTERFACE: - - subroutine aVaCSharedAttrIndexList_(aV, aC, attrib, NumShared, & - Indices1, Indices2) - -! -! !USES: -! - use m_stdio - use m_die, only : MP_perr_die, die, warn - - use m_AttrVect, only : AttrVect - - use m_List, only : GetSharedListIndices - - - implicit none - -! !INPUT PARAMETERS: -! - type(AttrVect), intent(in) :: aV - type(Accumulator), intent(in) :: aC - character(len=*), intent(in) :: attrib - -! !OUTPUT PARAMETERS: -! - integer, intent(out) :: NumShared - integer,dimension(:), pointer :: Indices1 - integer,dimension(:), pointer :: Indices2 - -! !REVISION HISTORY: -! 7Feb01 - J.W. Larson - initial version -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::aVaCSharedAttrIndexList_' - - integer :: ierr - - ! Based on the value of the argument attrib, pass the - ! appropriate pair of Lists for comparison... - - select case(trim(attrib)) - case('REAL','real') - call GetSharedListIndices(aV%rList, aC%data%rList, NumShared, & - Indices1, Indices2) - case('INTEGER','integer') - call GetSharedListIndices(aV%iList, aC%data%iList, NumShared, & - Indices1, Indices2) - case default - write(stderr,'(4a)') myname_,":: value of argument attrib=",attrib, & - " not recognized. Allowed values: REAL, real, INTEGER, integer" - ierr = 1 - call die(myname_, 'invalid value for attrib', ierr) - end select - - end subroutine aVaCSharedAttrIndexList_ - -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: accumulate_--Acumulate from an AttrVect to an Accumulator. -! -! !DESCRIPTION: -! This routine performs time {\em accumlation} of data present in an -! MCT field data {\tt AttrVect} variable {\tt aV} and combines it with -! the running tallies stored in the MCT {\tt Accumulator} variable {\tt aC}. -! This routine automatically identifies which -! fields are held in common by {\tt aV} and {\tt aC} and uses the -! accumulation action information stored in {\tt aC} to decide how -! each field in {\tt aV} is to be combined into its corresponding -! running tally in {\tt aC}. The accumulation operations currently -! supported are: -! \begin {itemize} -! \item {\tt MCT\_SUM}: Add the current values in the {\tt Av} to the current values in {\tt Ac}. -! \item {\tt MCT\_AVG}: Same as {\tt MCT\_SUM} except when {\tt steps\_done} is equal -! to {\tt num\_steps} then perform one more sum and replaced with average. -! \end {itemize} -! -! This routine also automatically increments the counter in {\tt aC} -! signifying the number of steps completed in the accumulation cycle. -! -! NOTE: The user must reset (zero) the {\tt Accumulator} after the average -! has been formed or the next call to {\tt accumulate} will add to the average. -! -! !INTERFACE: - - subroutine accumulate_(aV, aC) - -! -! !USES: -! - use m_stdio, only : stdout,stderr - use m_die, only : die - - use m_AttrVect, only : AttrVect - use m_AttrVect, only : AttrVect_lsize => lsize - use m_AttrVect, only : AttrVect_nIAttr => nIAttr - use m_AttrVect, only : AttrVect_nRAttr => nRAttr - use m_AttrVect, only : AttrVect_indexRA => indexRA - use m_AttrVect, only : AttrVect_indexIA => indexIA - - implicit none - -! !INPUT PARAMETERS: -! - type(AttrVect), intent(in) :: aV ! Input AttrVect - -! !INPUT/OUTPUT PARAMETERS: -! - type(Accumulator), intent(inout) :: aC ! Output Accumulator - -! !REVISION HISTORY: -! 18Sep00 - J.W. Larson -- initial version. -! 7Feb01 - J.W. Larson -- General version. -! 10Jun01 - E.T. Ong -- fixed divide-by-zero problem in integer -! attribute accumulation. -! 27Jul01 - E.T. Ong -- removed action argument. -! Make compatible with new Accumulator type. -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::accumulate_' - -! Overlapping attribute index number - integer :: num_indices - -! Overlapping attribute index storage arrays: - integer, dimension(:), pointer :: aCindices, aVindices - integer :: aCindex, aVindex - -! Error flag and loop indices - integer :: ierr, l, n - -! Averaging time-weighting factor: - real(FP) :: step_weight - integer :: num_steps - -! Character variable used as a data type flag: - character*7 :: data_flag - - ! Sanity check of arguments: - - if(lsize_(aC) /= AttrVect_lsize(aV)) then - write(stderr,'(2a,i8,a,i8)') myname_, & - ':: Mismatched Accumulator/AttrVect lengths. AttrVect_lsize(aV) = ',& - AttrVect_lsize(aV), 'lsize_(aC) = ',lsize_(aC) - call die(myname_) - endif - - if(aC%num_steps == 0) then - write(stderr,'(2a)') myname,':: FATAL--Zero steps in accumulation cycle.' - call die(myname_) - endif - - ! Set num_steps from aC: - - num_steps = aC%num_steps - - ! Accumulation of REAL attribute data: - - if( associated(aC%rAction) ) then ! if summing or avergaging reals... - - ! Accumulate only if fields are present - - data_flag = 'REAL' - call aVaCSharedAttrIndexList_(aV, aC, data_flag, num_indices, & - aVindices, aCindices) - - if(num_indices > 0) then - do n=1,num_indices - aVindex = aVindices(n) - aCindex = aCindices(n) - - ! Accumulate if the action is MCT_SUM or MCT_AVG - if( (aC%rAction(aCindex) == MCT_SUM).or. & - (aC%rAction(aCindex) == MCT_AVG) ) then - do l=1,AttrVect_lsize(aV) - aC%data%rAttr(aCindex,l) = aC%data%rAttr(aCindex,l) + & - aV%rAttr(aVindex,l) - end do - endif - end do - - deallocate(aVindices, aCindices, stat=ierr) - if(ierr /= 0) then - write(stderr,'(2a,i8)') myname_, & - ':: Error in first deallocate(aVindices...), ierr = ',ierr - call die(myname_) - endif - - endif ! if(num_indices > 0) - - endif ! if( associated(aC%rAction) ) - - - ! Accumulation of INTEGER attribute data: - - if( associated(aC%iAction) ) then ! if summing or avergaging ints... - - ! Accumulate only if fields are present - - - data_flag = 'INTEGER' - call aVaCSharedAttrIndexList_(aV, aC, data_flag, num_indices, & - aVindices, aCindices) - - if(num_indices > 0) then - - do n=1,num_indices - aVindex = aVindices(n) - aCindex = aCindices(n) - - ! Accumulate if the action is MCT_SUM or MCT_AVG - if( (aC%iAction(aCindex) == MCT_SUM) .or. & - (aC%iAction(aCindex) == MCT_AVG) ) then - do l=1,AttrVect_lsize(aV) - aC%data%iAttr(aCindex,l) = aC%data%iAttr(aCindex,l) + & - aV%iAttr(aVindex,l) - end do - endif - end do - - deallocate(aVindices, aCindices, stat=ierr) - if(ierr /= 0) then - write(stderr,'(2a,i8)') myname_, & - ':: Error in second deallocate(aVindices...), ierr = ',ierr - call die(myname_) - endif - - endif ! if(num_indices > 0) - - endif ! if( associated(aC%iAction) ) - - ! Increment aC%steps_done: - - aC%steps_done = aC%steps_done + 1 - - ! If we are at the end of an averaging period, compute the - ! average (if desired). - - if(aC%steps_done == num_steps) then - - step_weight = 1.0_FP / REAL(num_steps,FP) - do n=1,nRAttr_(aC) - if( aC%rAction(n) == MCT_AVG ) then - do l=1,lsize_(aC) - aC%data%rAttr(n,l) = step_weight * aC%data%rAttr(n,l) - enddo - endif - enddo - - do n=1,nIAttr_(aC) - if( aC%iAction(n) == MCT_AVG ) then - do l=1,lsize_(aC) - aC%data%iAttr(n,l) = aC%data%iAttr(n,l) / num_steps - enddo - endif - enddo - - endif - - end subroutine accumulate_ - -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: average_ -- Force an average to be taken on an Accumulator -! -! !DESCRIPTION: -! This routine will compute the average of the current values in an -! {\tt Accumulator} using the current value of {\tt steps\_done} -! in the {\tt Accumulator} -! -! !INTERFACE: - - subroutine average_(aC) - -! -! !USES: -! - use m_stdio, only : stdout,stderr - use m_die, only : die - - use m_AttrVect, only : AttrVect - use m_AttrVect, only : AttrVect_lsize => lsize - use m_AttrVect, only : AttrVect_nIAttr => nIAttr - use m_AttrVect, only : AttrVect_nRAttr => nRAttr - use m_AttrVect, only : AttrVect_indexRA => indexRA - use m_AttrVect, only : AttrVect_indexIA => indexIA - - implicit none - -! !INPUT/OUTPUT PARAMETERS: -! - type(Accumulator), intent(inout) :: aC ! Output Accumulator - -! !REVISION HISTORY: -! 11Jan08 - R.Jacob -- initial version based on accumulate_ -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::average_' - -! Overlapping attribute index number - integer :: num_indices - -! Overlapping attribute index storage arrays: - integer, dimension(:), pointer :: aCindices, aVindices - integer :: aCindex, aVindex - -! Error flag and loop indices - integer :: ierr, l, n - -! Averaging time-weighting factor: - real(FP) :: step_weight - integer :: steps_done - - - if(aC%num_steps == 0) then - write(stderr,'(2a)') myname_,':: FATAL--Zero steps in accumulation cycle.' - call die(myname_) - endif - - if(aC%steps_done == 0) then - write(stderr,'(2a)') myname_,':: FATAL--Zero steps completed in accumulation cycle.' - call die(myname_) - endif - - ! Set num_steps from aC: - - steps_done = aC%steps_done - - - step_weight = 1.0_FP / REAL(steps_done,FP) - do n=1,nRAttr_(aC) - do l=1,lsize_(aC) - aC%data%rAttr(n,l) = step_weight * aC%data%rAttr(n,l) - enddo - enddo - - do n=1,nIAttr_(aC) - do l=1,lsize_(aC) - aC%data%iAttr(n,l) = aC%data%iAttr(n,l) / steps_done - enddo - enddo - - - end subroutine average_ - - end module m_Accumulator diff --git a/cesm/models/utils/mct/mct/m_AccumulatorComms.F90 b/cesm/models/utils/mct/mct/m_AccumulatorComms.F90 deleted file mode 100644 index bf95b01..0000000 --- a/cesm/models/utils/mct/mct/m_AccumulatorComms.F90 +++ /dev/null @@ -1,803 +0,0 @@ -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!----------------------------------------------------------------------- -! CVS $Id$ -! CVS $Name$ -!BOP ------------------------------------------------------------------- -! -! !MODULE: m_AccumulatorComms - MPI Communication Methods for the Accumulator -! -! -! !DESCRIPTION: -! -! This module contains communications methods for the {\tt Accumulator} -! datatype (see {\tt m\_Accumulator} for details). MCT's communications -! are implemented in terms of the Message Passing Interface (MPI) standard, -! and we have as best as possible, made the interfaces to these routines -! appear as similar as possible to the corresponding MPI routines. For the -! { \tt Accumulator}, we currently support only the following collective -! operations: broadcast, gather, and scatter. The gather and scatter -! operations rely on domain decomposition descriptors that are defined -! elsewhere in MCT: the {\tt GlobalMap}, which is a one-dimensional -! decomposition (see the MCT module {\tt m\_GlobalMap} for more details); -! and the {\tt GlobalSegMap}, which is a segmented decomposition capable -! of supporting multidimensional domain decompositions (see the MCT module -! {\tt m\_GlobalSegMap} for more details). -! -! !INTERFACE: - - module m_AccumulatorComms -! -! !USES: -! -! No external modules are used in the declaration section of this module. - - implicit none - - private ! except - -! !PUBLIC MEMBER FUNCTIONS: -! -! List of communications Methods for the Accumulator class - - public :: gather ! gather all local vectors to the root - public :: scatter ! scatter from the root to all PEs - public :: bcast ! bcast from root to all PEs - -! Definition of interfaces for the communication methods for -! the Accumulator: - - interface gather ; module procedure & - GM_gather_, & - GSM_gather_ - end interface - interface scatter ; module procedure & - GM_scatter_, & - GSM_scatter_ - end interface - interface bcast ; module procedure bcast_ ; end interface - -! !REVISION HISTORY: -! 31Oct00 - Jay Larson - initial prototype-- -! These routines were separated from the module m_Accumulator -! 15Jan01 - Jay Larson - Specification of -! APIs for the routines GSM_gather_() and GSM_scatter_(). -! 10May01 - Jay Larson - Changes in the -! comms routine to match the MPI model for collective -! communications, and general clean-up of prologues. -! 9Aug01 - E.T. Ong - Added private routine -! bcastp_. Used new Accumulator routines initp_ and -! initialized_ to simplify the routines. -! 26Aug02 - E.T. Ong - thourough code revision; -! no added routines -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname='MCT::m_AccumulatorComms' - - contains - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: GM_gather_ - Gather Accumulator Distributed by a GlobalMap -! -! !DESCRIPTION: {\tt GM\_gather()} takes a distributed (across the -! communicator associated with the handle {\tt comm}) input -! {\tt Accumulator} argument {\tt iC} and gathers its data to the -! {\tt Accumulator} {\tt oC} on the {\tt root}. The decomposition of -! {\tt iC} is described by the input {\tt GlobalMap} argument {\tt Gmap}. -! The success (failure) of this operation is signified by the zero (nonzero) -! value of the optional output argument {\tt stat}. -! -! !INTERFACE: - - subroutine GM_gather_(iC, oC, GMap, root, comm, stat) -! -! !USES: -! - use m_stdio - use m_die - use m_mpif90 - - use m_GlobalMap, only : GlobalMap - use m_AttrVect, only : AttrVect_clean => clean - use m_Accumulator, only : Accumulator - use m_Accumulator, only : Accumulator_initialized => initialized - use m_Accumulator, only : Accumulator_initv => init - use m_AttrVectComms, only : AttrVect_gather => gather - - implicit none - -! !INPUT PARAMETERS: -! - type(Accumulator), intent(in) :: iC - type(GlobalMap) , intent(in) :: GMap - integer, intent(in) :: root - integer, intent(in) :: comm - -! !OUTPUT PARAMETERS: -! - type(Accumulator), intent(out) :: oC - integer, optional,intent(out) :: stat - -! !REVISION HISTORY: -! 13Sep00 - Jay Larson - initial prototype -! 31Oct00 - Jay Larson - relocated to the -! module m_AccumulatorComms -! 15Jan01 - Jay Larson - renamed GM_gather_ -! 10May01 - Jay Larson - revamped comms -! model to match MPI comms model, and cleaned up prologue -! 9Aug01 - E.T. Ong - 2nd prototype. Used the -! intiialized_ and accumulator init routines. -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::GM_gather_' - integer :: myID, ier, i - logical :: status - - ! Initialize status flag (if present) - - if(present(stat)) stat=0 - - call MP_comm_rank(comm, myID, ier) - if(ier /= 0) call MP_perr_die(myname_,'MP_comm_rank()',ier) - - ! Argument check of iC: kill if iC is not initialized - ! on all processes - - status = Accumulator_initialized(iC,die_flag=.true.,source_name=myname_) - - ! NOTE: removed argument check for oC on the root. - ! Is there any good way to check if an accumulator is NOT initialized? - - ! Initialize oC from iC. Clean oC%data - we don't want this av. - - if(myID == root) then - - call Accumulator_initv(oC,iC,lsize=1, & - num_steps=iC%num_steps,steps_done=iC%steps_done) - call AttrVect_clean(oC%data) - - endif - - ! Initialize oC%data. Gather distributed iC%data to oC%data on the root - - call AttrVect_gather(iC%data, oC%data, GMap, root, comm, ier) - - if(ier /= 0) then - call perr(myname_,'AttrVect_gather(iC%data, oC%data...',ier) - if(.not.present(stat)) call die(myname_) - stat=ier - return - endif - - ! Check oC to see if its valid - - if(myID == root) then - status = Accumulator_initialized(oC,die_flag=.true.,source_name=myname_) - endif - - end subroutine GM_gather_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: GSM_gather_ - Gather Accumulator Distributed by a GlobalSegMap -! -! !DESCRIPTION: This routine takes the distrubuted (on the communcator -! associated with the handle {\tt comm}) input {\tt Accumulator} -! argument {\tt iC} gathers it to the the {\tt Accumulator} argument -! {\tt oC} (valid only on the {\tt root}). The decompositon of {\tt iC} -! is contained in the input {\tt GlobalSegMap} argument {\tt GSMap}. -! The success (failure) of this operation is signified by the zero -! (nonzero) returned value of the {\tt INTEGER} flag {\tt stat}. -! -! !INTERFACE: - - subroutine GSM_gather_(iC, oC, GSMap, root, comm, stat) -! -! !USES: -! - use m_stdio - use m_die - use m_mpif90 - - use m_GlobalSegMap, only : GlobalSegMap - use m_AttrVect, only : AttrVect_clean => clean - use m_Accumulator, only : Accumulator - use m_Accumulator, only : Accumulator_initv => init - use m_Accumulator, only : Accumulator_initialized => initialized - use m_AttrVectComms, only : AttrVect_gather => gather - - implicit none - -! !INPUT PARAMETERS: -! - type(Accumulator), intent(in) :: iC - type(GlobalSegMap), intent(in) :: GSMap - integer, intent(in) :: root - integer, intent(in) :: comm - -! !OUTPUT PARAMETERS: -! - type(Accumulator), intent(out) :: oC - integer, optional, intent(out) :: stat - -! !REVISION HISTORY: -! 15Jan01 - Jay Larson - API specification. -! 10May01 - Jay Larson - Initial code and -! cleaned up prologue. -! 09Aug01 - E.T. Ong - 2nd prototype. Used the -! intiialized_ and accumulator init routines. -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::GSM_gather_' - integer :: myID, ier, i - logical :: status - - ! Initialize status flag (if present) - - if(present(stat)) stat=0 - - call MP_comm_rank(comm, myID, ier) - if(ier /= 0) call MP_perr_die(myname_,'MP_comm_rank()',ier) - - ! Argument check of iC - - status = Accumulator_initialized(iC,die_flag=.true.,source_name=myname_) - - ! NOTE: removed argument check for oC on the root. - ! Is there any good way to check if an accumulator is NOT initialized? - - ! Initialize oC from iC. Clean oC%data - we don't want this av. - - if(myID == root) then - call Accumulator_initv(oC,iC,lsize=1, & - num_steps=iC%num_steps,steps_done=iC%steps_done) - call AttrVect_clean(oC%data) - endif - - ! Gather distributed iC%data to oC%data on the root - - call AttrVect_gather(iC%data, oC%data, GSMap, root, comm, ier) - - if(ier /= 0) then - call perr(myname_,'AttrVect_gather(iC%data, oC%data...',ier) - if(.not.present(stat)) call die(myname_) - stat=ier - return - endif - - ! Check oC to see if its valid - - if(myID == root) then - status = Accumulator_initialized(oC,die_flag=.true.,source_name=myname_) - endif - - - end subroutine GSM_gather_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: GM_scatter_ - Scatter an Accumulator using a GlobalMap -! -! !DESCRIPTION: This routine takes the input {\tt Accumulator} argument -! {\tt iC} (valid only on the {\tt root}), and scatters it to the -! distributed {\tt Accumulator} argument {\tt oC} on the processes -! associated with the communicator handle {\tt comm}. The decompositon -! used to scatter the data is contained in the input {\tt GlobalMap} -! argument {\tt GMap}. The success (failure) of this operation is -! signified by the zero (nonzero) returned value of the {\tt INTEGER} -! flag {\tt stat}. -! -! !INTERFACE: - - subroutine GM_scatter_(iC, oC, GMap, root, comm, stat) -! -! !USES: -! - use m_stdio - use m_die - use m_mpif90 - - use m_GlobalMap, only : GlobalMap - use m_Accumulator, only : Accumulator - use m_Accumulator, only : Accumulator_initv => init - use m_Accumulator, only : Accumulator_initialized => initialized - use m_AttrVect, only : AttrVect_clean => clean - use m_AttrVectComms, only : AttrVect_scatter => scatter - - implicit none - -! !INPUT PARAMETERS: -! - type(Accumulator), intent(in) :: iC - type(GlobalMap), intent(in) :: GMap - integer, intent(in) :: root - integer, intent(in) :: comm - -! !OUTPUT PARAMETERS: -! - type(Accumulator), intent(out) :: oC - integer, optional, intent(out) :: stat - -! !REVISION HISTORY: -! 14Sep00 - Jay Larson - initial prototype -! 31Oct00 - Jay Larson - moved from the module -! m_Accumulator to m_AccumulatorComms -! 15Jan01 - Jay Larson - renamed GM_scatter_. -! 10May01 - Jay Larson - revamped code to fit -! MPI-like comms model, and cleaned up prologue. -! 09Aug01 - E.T. Ong - 2nd prototype. Used the -! initialized_, Accumulator init_, and bcastp_ routines. -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::GM_scatter_' - - integer :: myID, ier - logical :: status - - ! Initialize status flag (if present) - - if(present(stat)) stat=0 - - call MP_comm_rank(comm, myID, ier) - if(ier /= 0) call MP_perr_die(myname_,'MP_comm_rank()',ier) - - ! Argument check of iC - - if(myID==root) then - status = Accumulator_initialized(iC,die_flag=.true.,source_name=myname_) - endif - - ! NOTE: removed argument check for oC on all processes. - ! Is there any good way to check if an accumulator is NOT initialized? - - ! Copy accumulator from iC to oC - ! Clean up oC%data on root. - - if(myID == root) then - call Accumulator_initv(oC,iC,lsize=1,num_steps=iC%num_steps, & - steps_done=iC%steps_done) - call AttrVect_clean(oC%data) - endif - - ! Broadcast oC (except for oC%data) - - call bcastp_(oC, root, comm, stat) - - ! Scatter the AttrVect component of iC - - call AttrVect_scatter(iC%data, oC%data, GMap, root, comm, ier) - - if(ier /= 0) then - call perr(myname_,'AttrVect_scatter(iC%data, oC%data...',ier) - if(.not.present(stat)) call die(myname_) - stat=ier - return - endif - - ! Check oC to see if its valid - - status = Accumulator_initialized(oC,die_flag=.true.,source_name=myname_) - - end subroutine GM_scatter_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: GSM_scatter_ - Scatter an Accumulator using a GlobalSegMap -! -! !DESCRIPTION: This routine takes the input {\tt Accumulator} argument -! {\tt iC} (valid only on the {\tt root}), and scatters it to the -! distributed {\tt Accumulator} argument {\tt oC} on the processes -! associated with the communicator handle {\tt comm}. The decompositon -! used to scatter the data is contained in the input {\tt GlobalSegMap} -! argument {\tt GSMap}. The success (failure) of this operation is -! signified by the zero (nonzero) returned value of the {\tt INTEGER} -! flag {\tt stat}. -! -! !INTERFACE: - - subroutine GSM_scatter_(iC, oC, GSMap, root, comm, stat) -! -! !USES: -! - use m_stdio - use m_die - use m_mpif90 - - use m_GlobalSegMap, only : GlobalSegMap - use m_Accumulator, only : Accumulator - use m_Accumulator, only : Accumulator_initv => init - use m_Accumulator, only : Accumulator_initialized => initialized - use m_AttrVect, only : AttrVect_clean => clean - use m_AttrVectComms, only : AttrVect_scatter => scatter - - implicit none - -! !INPUT PARAMETERS: -! - type(Accumulator), intent(in) :: iC - type(GlobalSegMap), intent(in) :: GSMap - integer, intent(in) :: root - integer, intent(in) :: comm - -! !OUTPUT PARAMETERS: -! - type(Accumulator), intent(out) :: oC - integer, optional, intent(out) :: stat - -! !REVISION HISTORY: -! 15Jan01 - Jay Larson - API specification. -! 10May01 - Jay Larson - Initial code/prologue -! 09Aug01 - E.T. Ong 2nd prototype. Used the -! initialized and accumulator init routines. -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::GSM_scatter_' - - integer :: myID, ier - logical :: status - - ! Initialize status flag (if present) - - if(present(stat)) stat=0 - - call MP_comm_rank(comm, myID, ier) - if(ier /= 0) call MP_perr_die(myname_,'MP_comm_rank()',ier) - - ! Argument check of iC - - if(myID == root) then - status = Accumulator_initialized(iC,die_flag=.true.,source_name=myname_) - endif - - ! NOTE: removed argument check for oC on all processes. - ! Is there any good way to check if an accumulator is NOT initialized? - - ! Copy accumulator from iC to oC - ! Clean up oC%data on root. - - if(myID == root) then - call Accumulator_initv(oC,iC,lsize=1,num_steps=iC%num_steps, & - steps_done=iC%steps_done) - call AttrVect_clean(oC%data) - endif - - ! Broadcast oC (except for oC%data) - - call bcastp_(oC, root, comm, stat) - - ! Scatter the AttrVect component of aC - - call AttrVect_scatter(iC%data, oC%data, GSMap, root, comm, ier) - - if(ier /= 0) then - call perr(myname_,'AttrVect_scatter(iC%data, oC%data...',ier) - if(.not.present(stat)) call die(myname_) - stat=ier - return - endif - - ! Check oC if its valid - - status = Accumulator_initialized(oC,die_flag=.true.,source_name=myname_) - - - end subroutine GSM_scatter_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: bcast_ - Broadcast an Accumulator -! -! !DESCRIPTION: This routine takes the input {\tt Accumulator} argument -! {\tt aC} (on input valid only on the {\tt root}), and broadcasts it -! to all the processes associated with the communicator handle -! {\tt comm}. The success (failure) of this operation is signified by -! the zero (nonzero) returned value of the {\tt INTEGER} flag {\tt stat}. -! -! !INTERFACE: -! - subroutine bcast_(aC, root, comm, stat) - -! -! !USES: -! - use m_die - use m_mpif90 - use m_AttrVectComms, only : AttrVect_bcast => bcast - - use m_Accumulator, only : Accumulator - use m_Accumulator, only : Accumulator_initialized => initialized - - implicit none - -! !INPUT PARAMETERS: -! - integer,intent(in) :: root - integer,intent(in) :: comm - -! !INPUT/OUTPUT PARAMETERS: -! - type(Accumulator), intent(inout) :: aC ! (IN) on root, (OUT) elsewhere - -! !OUTPUT PARAMETERS: -! - integer, optional, intent(out) :: stat - -! !REVISION HISTORY: -! 14Sep00 - Jay Larson - initial prototype -! 31Oct00 - Jay Larson - moved from the module -! m_Accumulator to m_AccumulatorComms -! 09May01 - Jay Larson - cleaned up prologue -! 09Aug01 - E.T. Ong - 2nd prototype. Made use of -! bcastp_ routine. Also more argument checks. -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::bcast_' - - integer :: myID - integer :: ier - logical :: status - - if(present(stat)) stat=0 - - call MP_comm_rank(comm,myID,ier) - if(ier /= 0) call MP_perr_die(myname_,'MP_comm_rank()',ier) - - ! Argument check : Kill if the root aC is not initialized, - ! or if the non-root aC is initialized - - if(myID == root) then - status = Accumulator_initialized(aC,die_flag=.true.,source_name=myname_) - endif - - ! NOTE: removed argument check for aC on all non-root processes. - ! Is there any good way to check if an accumulator is NOT initialized? - - call bcastp_(aC, root, comm, stat) - - - ! Broadcast the root value of aC%data - - call AttrVect_bcast(aC%data, root, comm, ier) - - if(ier /= 0) then - call perr(myname_,'AttrVect_bcast(aC%data)',ier) - if(.not.present(stat)) call die(myname_) - stat=ier - return - endif - - ! Check that aC on all processes are initialized - - status = Accumulator_initialized(aC,die_flag=.true.,source_name=myname_) - - - end subroutine bcast_ - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: bcastp_ - Broadcast an Accumulator (but Not its Registers) -! -! !DESCRIPTION: This routine broadcasts all components of the accumulator -! aC except for aC%data. This is a private routine, only meant -! to be used by accumulator scatter and gather routines. -! -! -! !INTERFACE: -! - subroutine bcastp_(aC, root, comm, stat) - -! -! !USES: -! - use m_die - use m_mpif90 - use m_AttrVectComms, only : AttrVect_bcast => bcast - use m_Accumulator, only : Accumulator - use m_Accumulator, only : Accumulator_initp => initp - use m_Accumulator, only : Accumulator_nIAttr => nIAttr - use m_Accumulator, only : Accumulator_nRAttr => nRAttr - - implicit none - -! !INPUT PARAMETERS: -! - integer,intent(in) :: root - integer,intent(in) :: comm - -! !INPUT/OUTPUT PARAMETERS: -! - type(Accumulator), intent(inout) :: aC ! (IN) on root, (OUT) elsewhere - -! !OUTPUT PARAMETERS: -! - integer, optional, intent(out) :: stat - -! !REVISION HISTORY: -! 09Aug01 - E.T. Ong - initial prototype -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::bcastp_' - - integer :: myID - integer :: ier, i - integer :: aC_num_steps, aC_steps_done, aC_nIAttr, aC_nRAttr - integer :: FirstiActionIndex, LastiActionIndex - integer :: FirstrActionIndex, LastrActionIndex - integer :: AccBuffSize - integer :: nIAttr, nRAttr - integer, dimension(:), allocatable :: AccBuff, aC_iAction, aC_rAction - logical :: status - - if(present(stat)) stat=0 - - call MP_comm_rank(comm,myID,ier) - if(ier /= 0) call MP_perr_die(myname_,'MP_comm_rank()',ier) - - ! STEP 1: Pack broadcast buffer. - - ! On the root, load up the Accumulator Buffer: Buffer Size = - ! num_steps {1} + steps_done {1} + nIAttr {1} + nRAttr {1} + - ! iAction {nIAttr} + rAction {nRAttr} - - - if(myID == root) then - - if(associated(aC%iAction)) then - nIAttr = size(aC%iAction) - else - nIAttr = 0 - endif - - if(associated(aC%rAction)) then - nRAttr = size(aC%rAction) - else - nRAttr = 0 - endif - - AccBuffSize = 4+nIAttr+nRAttr - - endif - - ! Use AccBuffSize to initialize AccBuff on all processes - - call MPI_BCAST(AccBuffSize, 1, MP_INTEGER, root, comm, ier) - - if(ier /= 0) call MP_perr_die(myname_,'AttrVect_bcast(AccBuffSize)',ier) - - allocate(AccBuff(AccBuffSize),stat=ier) - if(ier /= 0) call MP_perr_die(myname_,"AccBuff allocate",ier) - - if(myID == root) then - - ! load up iC%num_steps and iC%steps_done - - AccBuff(1) = aC%num_steps - AccBuff(2) = aC%steps_done - - ! Load up nIAttr and nRAttr - - AccBuff(3) = nIAttr - AccBuff(4) = nRAttr - - ! Load up aC%iAction (pointer copy) - - do i=1,nIAttr - AccBuff(4+i) = aC%iAction(i) - enddo - - ! Load up aC%rAction (pointer copy) - - do i=1,nRAttr - AccBuff(4+nIAttr+i) = aC%rAction(i) - enddo - endif - - ! STEP 2: Broadcast - - ! Broadcast the root value of AccBuff - - call MPI_BCAST(AccBuff, AccBuffSize, MP_INTEGER, root, comm, ier) - - if(ier /= 0) call MP_perr_die(myname_,'MPI_bcast(AccBuff...',ier) - - - ! STEP 3: Unpack broadcast buffer. - - ! On all processes unload aC_num_steps, aC_steps_done - ! aC_nIAttr, and aC_nRAttr from StepBuff - - aC_num_steps = AccBuff(1) - aC_steps_done = AccBuff(2) - aC_nIAttr = AccBuff(3) - aC_nRAttr = AccBuff(4) - - ! Unload iC%iAction and iC%rAction - - if(aC_nIAttr > 0) then - allocate(aC_iAction(aC_nIAttr),stat=ier) - if(ier /= 0) call die(myname_,"allocate aC_iAction",ier) - - FirstiActionIndex = 5 - LastiActionIndex = 4+aC_nIAttr - aC_iAction(1:aC_nIAttr) = AccBuff(FirstiActionIndex:LastiActionIndex) - - endif - - if(aC_nRAttr > 0) then - allocate(aC_rAction(aC_nRAttr),stat=ier) - if(ier /= 0) call die(myname_,"allocate aC_rAction",ier) - - FirstrActionIndex = 5+aC_nIAttr - LastrActionIndex = 4+aC_nIAttr+aC_nRAttr - aC_rAction(1:aC_nRAttr) = AccBuff(FirstrActionIndex:LastrActionIndex) - - endif - - ! Initialize aC on non-root processes - - if( (aC_nIAttr > 0).and.(aC_nRAttr > 0) ) then - - if(myID /= root) then - call Accumulator_initp(aC,iAction=aC_iAction,rAction=aC_rAction, & - num_steps=aC_num_steps, & - steps_done=aC_steps_done) - endif - - deallocate(aC_iAction,aC_rAction,stat=ier) - if(ier /= 0) call die(myname_,"deallocate aC_iAction...",ier) - - else - - if (aC_nIAttr > 0) then - if(myID /= root) then - call Accumulator_initp(aC,iAction=aC_iAction, & - num_steps=aC_num_steps, & - steps_done=aC_steps_done) - endif - deallocate(aC_iAction,stat=ier) - if(ier /= 0) call die(myname_,"deallocate aC_iAction...",ier) - endif - - if (aC_nRAttr > 0) then - if(myID /= root) then - call Accumulator_initp(aC,rAction=aC_rAction, & - num_steps=aC_num_steps, & - steps_done=aC_steps_done) - endif - deallocate(aC_rAction,stat=ier) - if(ier /= 0) call die(myname_,"deallocate aC_iAction...",ier) - endif - - endif - - ! Clean up allocated arrays - - deallocate(AccBuff,stat=ier) - if(ier /= 0) call die(myname_,"deallocate(AccBuff)",ier) - - - end subroutine bcastp_ - - - end module m_AccumulatorComms - - - - - - - diff --git a/cesm/models/utils/mct/mct/m_AttrVect.F90 b/cesm/models/utils/mct/mct/m_AttrVect.F90 deleted file mode 100644 index 0ffb800..0000000 --- a/cesm/models/utils/mct/mct/m_AttrVect.F90 +++ /dev/null @@ -1,4161 +0,0 @@ -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!----------------------------------------------------------------------- -! CVS $Id$ -! CVS $Name$ -!BOP ------------------------------------------------------------------- -! -! !MODULE: m_AttrVect - Multi-field Storage -! -! !DESCRIPTION: -! -! An {\em attribute vector} is a scheme for storing bundles of integer -! and real data vectors, indexed by the names of the fields stored in -! {\tt List} format (see the mpeu module {\tt m\_List} for more -! information about the {\tt List} datatype). The ordering of the -! fieldnames in the integer and real attribute {\tt List} components -! ({\tt AttrVect\%iList} and {\tt AttrVect\%rList}, respectively) -! corresponds to the storage order of the attributes in their respective -! data buffers (the components {\tt AttrVect\%iAttr(:,:)} and -! {\tt AttrVect\%rAttr(:,:)}, respectively). The organization of -! the fieldnames in {\tt List} format, along with the direct mapping -! between {\tt List} items and locations in the data buffer, allows -! the user to have {\em random access} to the field data. This -! approach also allows the user to set the number and the names of fields -! stored in an {\tt AttrVect} at run-time. -! -! The {\tt AttrVect} stores field data in a {\em pointwise} fashion -! (that is, the data are grouped so that all the integer or real data -! associated with an individual point are adjacent to each other in memory. -! This amounts to the having the integer and real field data arrays in -! the {\tt AttrVect} (the components {\tt AttrVect\%iAttr(:,:)} and -! {\tt AttrVect\%rAttr(:,:)}, respectively) having the attribute index -! as the major (or fastest-varying) index. A prime example of this is -! observational data input to a data assimilation system. In the Model -! Coupling Toolkit, this datatype is the fundamental type for storing -! field data exchanged by component models, and forms a basis for other -! MCT datatypes that encapsulate time accumulation/averaging buffers (the -! {\tt Accumulator} datatype defined in the module {\tt m\_Accumulator}), -! coordinate grid information (the {\tt GeneralGrid} datatype defined in -! the module {\tt m\_GeneralGrid}), and sparse interpolation matrices -! (the {\tt SparseMatrix} datatype defined in the module -! {\tt m\_SparseMatrix}). -! -! The attribute vector is implemented in Fortran 90 using the -! {\tt AttrVect} derived type. This module contains the definition -! of the {\tt AttrVect}, and the numerous methods that service it. There -! are a number of initialization (creation) schemes, and a routine for -! zeroing out the elements of an {\tt AttrVect}. There is a method -! to {\em clean} up allocated memory used by an {\tt AttrVect} -! (destruction). There are numerous query methods that return: the -! number of datapoints (or {\em length}; the numbers of integer and -! real attributes; the data buffer index of a given real or integer -! attribute; and return the lists of real and integer attributes. There -! also exist methods for exporting a given attribute as a one-dimensional -! array and importing a given attribute from a one-dimensional array. -! There is a method for copying attributes from one {\tt AttrVect} to -! another. There is also a method for cross-indexing the attributes in -! two {\tt AttrVect} variables. In addition, there are methods that -! return those cross-indexed attributes along with some auxiliary data -! in a {\tt AVSharedIndicesOneType} or {\tt AVSharedIndices} structure. -! Finally, there are methods for sorting and permuting {\tt AttrVect} -! entries using a MergeSort scheme keyed by the attributes of the {\tt -! AttrVect}. -! -! !INTERFACE: - - module m_AttrVect -! -! !USES: -! - use m_realkinds,only : SP,DP,FP ! Real types definitions - - use m_List, only : List ! Support for rList and iList components. - - implicit none - - private ! except - -! !PUBLIC TYPES: - - public :: AttrVect ! The class data structure - public :: AVSharedIndicesOneType ! Data structure recording shared indices between - ! two attribute vectors, for a single data type - ! (e.g., shared real attributes) - public :: AVSharedIndices ! Data structure recording shared indices between two - ! attribute vectors, for all data types - - type AttrVect -#ifdef SEQUENCE - sequence -#endif - type(List) :: iList - type(List) :: rList - integer,dimension(:,:),pointer :: iAttr - real(FP) ,dimension(:,:),pointer :: rAttr - end type AttrVect - - type AVSharedIndicesOneType - integer :: num_indices ! number of shared items - logical :: contiguous ! true if index segments are contiguous in memory - character*7 :: data_flag ! data type flag (e.g., 'REAL' or 'INTEGER') - - ! arrays of indices to storage locations of shared attributes between the two - ! attribute vectors: - integer, dimension(:), pointer :: aVindices1 - integer, dimension(:), pointer :: aVindices2 - end type AVSharedIndicesOneType - - type AVSharedIndices - type(AVSharedIndicesOneType) :: shared_real ! shared indices of type REAL - type(AVSharedIndicesOneType) :: shared_integer ! shared indices of type INTEGER - end type AVSharedIndices - - -! !PUBLIC MEMBER FUNCTIONS: - - public :: init ! create a local vector - public :: clean ! clean the local vector - public :: zero ! zero the local vector - public :: lsize ! size of the local vector - public :: nIAttr ! number of integer attributes on local - public :: nRAttr ! number of real attributes on local - public :: indexIA ! index the integer attributes - public :: indexRA ! index the real attributes - public :: getIList ! return list of integer attributes - public :: getRList ! return list of real attributes - public :: getIListtoChar ! return list of integer attributes as Char - public :: getRListtoChar ! return list of real attributes as Char - public :: exportIList ! export INTEGER attibute List - public :: exportRList ! export REAL attibute List - public :: exportIListToChar ! export INTEGER attibute List as Char - public :: exportRListToChar ! export REAL attibute List as Char - public :: appendIAttr ! append INTEGER attribute List - public :: appendRAttr ! append REAL attribute List - public :: exportIAttr ! export INTEGER attribute to vector - public :: exportRAttr ! export REAL attribute to vector - public :: importIAttr ! import INTEGER attribute from vector - public :: importRAttr ! import REAL attribute from vector - public :: Copy ! copy attributes from one Av to another - public :: RCopy ! copy real attributes from one Av to another - public :: ICopy ! copy integer attributes from one Av to another - public :: Sort ! sort entries, and return permutation - public :: Permute ! permute entries - public :: Unpermute ! Unpermute entries - public :: SortPermute ! sort and permute entries - public :: SharedAttrIndexList ! Cross-indices of shared - ! attributes of two AttrVects - public :: SharedIndices ! Given two AttrVects, create an AVSharedIndices structure - public :: SharedIndicesOneType ! Given two AttrVects, create an - ! AVSharedIndicesOneType structure for a single type - public :: cleanSharedIndices ! clean a AVSharedIndices structure - public :: cleanSharedIndicesOneType ! clean a AVSharedIndicesOneType structure - - - interface init ; module procedure & - init_, & - initv_, & - initl_ - end interface - interface clean ; module procedure clean_ ; end interface - interface zero ; module procedure zero_ ; end interface - interface lsize ; module procedure lsize_ ; end interface - interface nIAttr ; module procedure nIAttr_ ; end interface - interface nRAttr ; module procedure nRAttr_ ; end interface - interface indexIA; module procedure indexIA_; end interface - interface indexRA; module procedure indexRA_; end interface - interface getIList; module procedure getIList_; end interface - interface getRList; module procedure getRList_; end interface - interface getIListToChar; module procedure getIListToChar_; end interface - interface getRListToChar; module procedure getRListToChar_; end interface - interface exportIList; module procedure exportIList_; end interface - interface exportRList; module procedure exportRList_; end interface - interface exportIListToChar - module procedure exportIListToChar_ - end interface - interface exportRListToChar - module procedure exportRListToChar_ - end interface - interface appendIAttr ; module procedure appendIAttr_ ; end interface - interface appendRAttr ; module procedure appendRAttr_ ; end interface - interface exportIAttr; module procedure exportIAttr_; end interface - interface exportRAttr; module procedure & - exportRAttrSP_, & - exportRAttrDP_ - end interface - interface importIAttr; module procedure importIAttr_; end interface - interface importRAttr; module procedure & - importRAttrSP_, & - importRAttrDP_ - end interface - interface Copy ; module procedure Copy_ ; end interface - interface RCopy ; module procedure & - RCopy_, & - RCopyL_ - end interface - interface ICopy ; module procedure & - ICopy_, & - ICopyL_ - end interface - interface Sort ; module procedure Sort_ ; end interface - interface Permute ; module procedure Permute_ ; end interface - interface Unpermute ; module procedure Unpermute_ ; end interface - interface SortPermute ; module procedure SortPermute_ ; end interface - interface SharedAttrIndexList ; module procedure & - aVaVSharedAttrIndexList_ - end interface - interface SharedIndices ; module procedure SharedIndices_ ; end interface - interface SharedIndicesOneType ; module procedure SharedIndicesOneType_ ; end interface - interface cleanSharedIndices ; module procedure cleanSharedIndices_ ; end interface - interface cleanSharedIndicesOneType ; module procedure cleanSharedIndicesOneType_ ; end interface - -! !REVISION HISTORY: -! 10Apr98 - Jing Guo - initial prototype/prolog/code -! 10Oct00 - J.W. Larson - made getIList -! and getRList functions public and added appropriate -! interface definitions -! 20Oct00 - J.W. Larson - added Sort, -! Permute, and SortPermute functions. -! 09May01 - J.W. Larson - added initl_(). -! 19Oct01 - J.W. Larson - added routines -! exportIattr(), exportRAttr(), importIAttr(), -! and importRAttr(). Also cleaned up module and -! routine prologues. -! 13Dec01 - J.W. Larson - made importIAttr() -! and importRAttr() public (bug fix). -! 14Dec01 - J.W. Larson - added exportIList() -! and exportRList(). -! 14Feb02 - J.W. Larson - added CHARCTER -! functions exportIListToChar() and exportRListToChar() -! 26Feb02 - J.W. Larson - corrected of usage -! of m_die routines throughout this module. -! 16Apr02 - J.W. Larson - added the method -! LocalReduce(), and the public data members AttrVectSUM, -! AttrVectMIN, and AttrVectMAX. -! 7May02 - J.W. Larson - Refactoring. Moved -! LocalReduce() and the public data members AttrVectSUM, -! AttrVectMIN, and AttrVectMAX to a new module named -! m_AttrVectReduce. -! 12Jun02 - R.L. Jacob - add Copy function -! 13Jun02 - R.L. Jacob - move aVavSharedAttrIndexList -! to this module from old m_SharedAttrIndicies -! 28Apr11 - W.J. Sacks - added AVSharedIndices and -! AVSharedIndicesOneType derived types, and associated -! subroutines -! 10Apr12 - W.J. Sacks - modified AVSharedIndices code -! to be Fortran-90 compliant -! 10Jan13 - T.Craig - add getRListToChar and getIListToChar -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname='MCT::m_AttrVect' - - contains - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: init_ - Initialize an AttrVect Given Attribute Lists and Length -! -! !DESCRIPTION: -! This routine creates an {\tt AttrVect} (the output argument {\tt aV}) -! using the optional input {\tt CHARACTER} arguments {\tt iList}, and -! {\tt rList} to define its integer and real attributes, respectively. -! The optional input {\tt INTEGER} argument {\tt lsize} defines the -! number of points for which we are storing attributes, or the -! {\em length} of {\tt aV}. The expected form for the arguments -! {\tt iList} and {\tt rList} are colon-delimited strings where each -! substring defines an attribute. Suppose we wish to store {\tt N} -! observations that have the real attributes {\tt 'latitude'}, -! {\tt 'longitude'}, {\tt pressure}, {\tt 'u-wind'}, and -! {\tt 'v-wind'}. Suppose we also wish to store the integer -! attributes {\tt 'hour'}, {\tt 'day'}, {\tt 'month'}, {\tt 'year'}, -! and {\tt 'data source'}. This can be accomplished by invoking -! {\tt init\_()} as follows: -! \begin{verbatim} -! call init_(aV, 'hour:day:month:year:data source', & -! 'latitude:longitude:pressure:u-wind:v-wind', N) -! \end{verbatim} -! The resulting {\tt AttrVect} {\tt aV} will have five integer -! attributes, five real attributes, and length {\tt N}. -! -! !INTERFACE: - - subroutine init_(aV, iList, rList, lsize) -! -! !USES: -! - use m_List, only : List - use m_List, only : init,nitem - use m_List, only : List_nullify => nullify - use m_mall - use m_die - - implicit none - -! !INPUT PARAMETERS: -! - character(len=*), optional, intent(in) :: iList - character(len=*), optional, intent(in) :: rList - integer, optional, intent(in) :: lsize - -! !OUTPUT PARAMETERS: -! - type(AttrVect), intent(out) :: aV - -! !REVISION HISTORY: -! 09Apr98 - Jing Guo - initial prototype/prolog/code -! 09Oct01 - J.W. Larson - added feature to -! nullify all pointers before usage. This was done to -! accomodate behavior of the f90 ASSOCIATED intrinsic -! function on the AIX platform. -! 07Dec01 - E.T. Ong - added support for -! intialization with blank character strings for iList -! and rList -!EOP ___________________________________________________________________ -! - character(len=*),parameter :: myname_=myname//'::init_' - integer :: nIA,nRA,n,ier - - ! Initially, nullify all pointers in the AttrVect aV: - - nullify(aV%iAttr) - nullify(aV%rAttr) - call List_nullify(aV%iList) - call List_nullify(aV%rList) - - if(present(rList)) then - if(len_trim(rList) > 0) then - call init(aV%rList,rList) ! init.List() - endif - endif - - if(present(iList)) then - if(len_trim(iList) > 0) then - call init(aV%iList,iList) ! init.List() - endif - endif - - nIA=nitem(aV%iList) ! nitem.List() - nRA=nitem(aV%rList) ! nitem.List() - - n=0 - if(present(lsize)) n=lsize - - allocate( aV%iAttr(nIA,n),aV%rAttr(nRA,n), stat=ier) - if(ier /= 0) call die(myname_,'allocate()',ier) - -#ifdef MALL_ON - call mall_ci(size(transfer(aV%iAttr,(/1/)),myname_) - call mall_ci(size(transfer(aV%rAttr,(/1/)),myname_) -#endif - - end subroutine init_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: initv_ - Initialize One AttrVect from Another -! -! !DESCRIPTION: This routine takes an input {\tt AttrVect} argument -! {\tt bV}, and uses its attribute list information to create an output -! {\tt AttrVect} variable {\tt aV}. The length of {\tt aV} is defined -! by the input {\tt INTEGER} argument {\tt lsize}. -! -! !INTERFACE: - - subroutine initv_(aV, bV, lsize) -! -! !USES: -! - use m_String, only : String,char - use m_String, only : String_clean => clean - use m_List, only : get - use m_List, only : List_nullify => nullify - use m_die - use m_stdio - - implicit none - -! !INPUT PARAMETERS: -! - type(AttrVect),intent(in) :: bV - integer, intent(in) :: lsize - -! !OUTPUT PARAMETERS: -! - type(AttrVect),intent(out) :: aV - -! !REVISION HISTORY: -! 22Apr98 - Jing Guo - initial prototype/prolog/code -! 17May01 - R. Jacob - add a check to see if -! input argument has been defined. SGI will dump -! core if its not. -! 10Oct01 - J. Larson - Nullify all pointers -! in ouput AttrVect aV before initializing aV. -! 19Sep08 - J. Wolfe - plug memory leak from not deallocating -! strings. -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::initv_' - type(String) :: iLStr,rLStr - - ! Step One: Nullify all pointers in aV. We will set - ! only the pointers we really need for aV based on those - ! currently ASSOCIATED in bV. - - call List_nullify(aV%iList) - call List_nullify(aV%rList) - nullify(aV%iAttr) - nullify(aV%rAttr) - - ! Convert the two Lists to two Strings - - if(.not.associated(bv%iList%bf) .and. & - .not.associated(bv%rList%bf)) then - write(stderr,'(2a)')myname_, & - 'MCTERROR: Trying to initialize a new AttrVect off an undefined AttrVect' - call die(myname_,'undefined input argument',0) - endif - - if(associated(bv%iList%bf)) then - call get(iLStr,bv%iList) - endif - - if(associated(bv%rList%bf)) then - call get(rLStr,bv%rList) - endif - - ! Initialize the AttrVect aV depending on which parts of - ! the input bV are valid: - - if(associated(bv%iList%bf) .and. associated(bv%rList%bf)) then - call init_(aV,iList=char(iLStr),rList=char(rLStr),lsize=lsize) - endif - if(.not.associated(bv%iList%bf) .and. associated(bv%rList%bf)) then - call init_(aV,rList=char(rLStr),lsize=lsize) - endif - if(associated(bv%iList%bf) .and. .not.associated(bv%rList%bf)) then - call init_(aV,iList=char(iLStr),lsize=lsize) - endif - - if(associated(bv%iList%bf)) then - call String_clean(iLStr) - endif - if(associated(bv%rList%bf)) then - call String_clean(rLStr) - endif - - end subroutine initv_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: initl_ - Initialize an AttrVect Using the List Type -! -! !DESCRIPTION: This routine initializes an {\tt AttrVect} directly -! from input {\tt List} data type arguments {\tt iList} and {\tt rList} -! (see the module {\tt m\_List} in mpeu for further details), and an -! input length {\tt lsize}. The resulting {\tt AttrVect} is returned in -! the argument {\tt aV}. -! -! {\bf N.B.}: If the user supplies an empty list for the arguments -! {\tt iList} ({\tt rList}), then {\tt aV} will be created only with -! {\tt REAL} ({\tt INTEGER}) attributes. If both arguments {\tt iList} -! and {\tt rList} are empty, the routine will terminate execution and -! report an error. -! -! {\bf N.B.}: The outcome of this routine, {\tt aV} represents -! allocated memory. When this {\tt AttrVect} is no longer needed, -! it must be deallocated by invoking the routine {\tt AttrVect\_clean()}. -! Failure to do so will spawn a memory leak. -! -! !INTERFACE: - - subroutine initl_(aV, iList, rList, lsize) - -! -! !USES: -! - use m_die - use m_stdio - - use m_String, only : String - use m_String, only : String_clean => clean - use m_String, only : String_toChar => toChar - - use m_List, only : List - use m_List, only : List_nitem => nitem - use m_List, only : List_exportToChar => exportToChar - - implicit none - -! !INPUT PARAMETERS: -! - type(List), intent(in) :: iList - type(List), intent(in) :: rList - integer, intent(in) :: lsize - -! !OUTPUT PARAMETERS: -! - type(AttrVect), intent(out) :: aV - -! !REVISION HISTORY: -! 09May98 - J.W. Larson - initial version. -! 08Aug01 - E.T. Ong - change list assignment(=) -! to list copy to avoid compiler errors with pgf90. -! 10Oct01 - J. Larson - Nullify all pointers -! in ouput AttrVect aV before initializing aV. Also, -! greater caution taken regarding validity of input -! arguments iList and rList. -! 15May08 - J. Larson - Simplify to use -! the init_ routine. Better argument checking. -!EOP ___________________________________________________________________ -! - character(len=*),parameter :: myname_=myname//'::initl_' - - ! Basic argument sanity checks: - - if (List_nitem(iList) < 0) then - write(stderr,'(2a,i8,a)') myname_, & - ':: FATAL: List argument iList has a negative number ( ',List_nitem(iList), & - ' ) of attributes!' - call die(myname_) - endif - - if (List_nitem(rList) < 0) then - write(stderr,'(2a,i8,a)') myname_, & - ':: FATAL: List argument rList has a negative number ( ',List_nitem(rList), & - ' ) of attributes!' - call die(myname_) - endif - - if ((List_nitem(iList) > 0) .and. (List_nitem(rList) > 0)) then - - call init_(aV, List_exportToChar(iList), List_exportToChar(rList), lsize) - - else ! Then solely REAL or solely INTEGER attributes: - - if (List_nitem(iList) > 0) then ! solely INTEGER attributes - - call init_(aV, iList=List_exportToChar(iList), lsize=lsize) - - endif ! if (List_nitem(iList) > 0) then... - - if (List_nitem(rList) > 0) then ! solely REAL attributes - - call init_(aV, rList=List_exportToChar(rList), lsize=lsize) - - endif ! if (List_nitem(rList) > 0) then... - - endif ! if ((List_nitem(iList) > 0) .and. (List_nitem(rList) > 0)) then... - - end subroutine initl_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: clean_ - Deallocate Allocated Memory Structures of an AttrVect -! -! !DESCRIPTION: -! This routine deallocates the allocated memory structures of the -! input/output {\tt AttrVect} argument {\tt aV}. This amounts to -! cleaning the {\tt List} structures {\tt aV\%iList} and {\tt av\%rList}, -! and deallocating the arrays {\tt aV\%iAttr(:,:)} and -! {\tt aV\%rAttr(:,:)}. The success (failure) of this operation is -! signified by a zero (non-zero) value of the optional {\tt INTEGER} -! output argument {\tt stat}. If {\tt clean\_()} is invoked without -! supplying {\tt stat}, and any of the deallocation operations fail, -! the routine will terminate with an error message. -! -! !INTERFACE: - - subroutine clean_(aV, stat) -! -! !USES: -! - use m_mall - use m_stdio - use m_die - use m_List, only : List_clean => clean - - implicit none - -! !INPUT/OUTPUT PARAMETERS: -! - type(AttrVect), intent(inout) :: aV - -! !OUTPUT PARAMETERS: -! - integer, optional, intent(out) :: stat - -! !REVISION HISTORY: -! 09Apr98 - Jing Guo - initial prototype/prolog/code -! 10Oct01 - J. Larson - various fixes to -! prevent deallocation of UNASSOCIATED pointers. -! 01Mar01 - E.T. Ong - removed dies to prevent -! crashes when cleaning uninitialized attrvects. Added -! optional stat argument. -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::clean_' - integer :: ier - - ! Note that an undefined pointer may either crash the process - ! or return either .true. or .false. to the associated() test. - ! One should therefore avoid using the function on an - ! undefined pointer. - - ! Clean up INTEGER attribute list: - - if(present(stat)) stat=0 - - if(associated(aV%iList%bf)) then - - if(present(stat)) then - call List_clean(aV%iList,ier) - if(ier/=0) stat=ier - else - call List_clean(aV%iList) - endif - - endif - - ! Clean up REAL attribute list: - - if(associated(aV%rList%bf)) then - - if(present(stat)) then - call List_clean(aV%rList,ier) - if(ier/=0) stat=ier - else - call List_clean(aV%rList) - endif - - endif - - ! Clean up INTEGER attributes: - - if(associated(aV%iAttr)) then - -#ifdef MALL_ON - call mall_co(size(transfer(aV%iAttr,(/1/)),myname_) -#endif - - deallocate(aV%iAttr,stat=ier) - - if(ier /= 0) then - if(present(stat)) then - stat=ier - else - call warn(myname_,'deallocate(aV%iAttr)',ier) - endif - endif - - endif ! if(associated(aV%iAttr))... - - ! Clean up REAL attributes: - - if(associated(aV%rAttr)) then - -#ifdef MALL_ON - call mall_co(size(transfer(aV%rAttr,(/1/)),myname_) -#endif - - deallocate(aV%rAttr,stat=ier) - - if(ier /= 0) then - if(present(stat)) then - stat=ier - else - call warn(myname_,'deallocate(aV%rAttr)',ier) - endif - endif - - endif ! if(associated(aV%rAttr))... - - - end subroutine clean_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: lsize_ - Length of an AttrVect -! -! !DESCRIPTION: -! This function returns the number of elements, or {\em length} of the -! input {\tt AttrVect} argument {\tt aV}. This function examines the -! length of the second dimension of the arrays {\tt aV\%iAttr(:,:)} -! and {\tt aV\%rAttr(:,:)}. If neither {\tt aV\%iAttr(:,:)} nor -! {\tt aV\%rAttr(:,:)} are associated, then ${\tt lsize\_(aV)} = 0$. -! If {\tt aV\%iAttr(:,:)} is associated, but {\tt aV\%rAttr(:,:)} is -! not, then ${\tt lsize\_(aV)} = {\tt size(aV\%iAttr,2)}$. If -! {\tt aV\%iAttr(:,:)} is not associated, but {\tt aV\%rAttr(:,:)} is, -! then ${\tt lsize\_(aV)} = {\tt size(aV\%rAttr,2)}$. If both -! {\tt aV\%iAttr(:,:)} and {\tt aV\%rAttr(:,:)} are associated, the -! function {\tt lsize\_()} will do one of two things: If -! ${\tt size(aV\%iAttr,2)} = {\tt size(aV\%rAttr,2)}$, this equal value -! will be returned. If ${\tt size(aV\%iAttr,2)} \neq -! {\tt size(aV\%rAttr,2)}$, termination with an error message will occur. -! -! !INTERFACE: - - integer function lsize_(aV) - -! !USES: - - use m_List, only : List - use m_List, only : List_allocated => allocated - - use m_stdio, only : stderr - use m_die - - implicit none - -! !INPUT PARAMETERS: -! - type(AttrVect), intent(in) :: aV - -! !REVISION HISTORY: -! 09Apr98 - Jing Guo - initial prototype/prolog/code -! 10Oct01 - J. Larson - made code more robust -! to handle cases where the length of either aV%iAttr or -! aV%rAttr is zero, but the other is positive. -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::lsize_' - integer :: iLength, rLength - - ! One should try to avoid using this function on an undefined - ! or disassocated pointer. However, it is understandable - ! that an undefined or disassocated pointer has a size 0, if - ! the associated() test sucesses. - - lsize_=0 - - if(List_allocated(aV%iList) .and. associated(aV%iAttr)) then - iLength = size(aV%iAttr,2) - else - iLength = 0 - endif - - if(List_allocated(aV%rList) .and. associated(aV%rAttr)) then - rLength = size(aV%rAttr,2) - else - rLength = 0 - endif - - if(iLength /= rLength) then - - if((rLength > 0) .and. (iLength > 0)) then - call die(myname_,'attribute array length mismatch', & - iLength-rLength) - endif - - if((rLength > 0) .and. (iLength == 0)) then - lsize_ = rLength - endif - - if((iLength > 0) .and. (rLength == 0)) then - lsize_ = iLength - endif - - endif - - if(iLength == rLength) lsize_ = iLength - - end function lsize_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: zero_ - Set AttrVect Field Data to Zero -! -! !DESCRIPTION: -! This routine sets all of the point values of the integer and real -! attributes of an the input/output {\tt AttrVect} argument {\tt aV} -! to zero. The default action is to set the values of all the real and -! integer attributes to zero. The user may prevent the zeroing of the -! real (integer) attributes invoking {\tt zero\_()} with the optional -! {\tt LOGICAL} argument {\tt zeroReals} ({\tt zeroInts}) set with value -! {\tt .FALSE.} -! -! !INTERFACE: - - subroutine zero_(aV, zeroReals, zeroInts) - -! !USES: - - - use m_die,only : die - use m_stdio,only : stderr - - use m_List, only : List - use m_List, only : List_allocated => allocated - - implicit none - -! !INPUT PARAMETERS: - - logical, optional, intent(IN) :: zeroReals - logical, optional, intent(IN) :: zeroInts - -! !INPUT/OUTPUT PARAMETERS: -! - type(AttrVect), intent(INOUT) :: aV - -! !REVISION HISTORY: -! 17May01 - R. Jacob - initial prototype/code -! 15Oct01 - J. Larson - switched loop order -! for cache optimization. -! 03Dec01 - E.T. Ong - eliminated looping method of -! of zeroing. "Compiler assignment" of attrvect performs faster -! on the IBM SP with mpxlf90 compiler. -! 05Jan10 - R. Jacob - zeroing an uninitialized aV is no -! longer a fatal error. -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::zero_' - - logical myZeroReals, myZeroInts - - if(present(zeroReals)) then - myZeroReals = zeroReals - else - myZeroReals = .TRUE. - endif - - if(present(zeroInts)) then - myZeroInts = zeroInts - else - myZeroInts = .TRUE. - endif - -! if((.not. List_allocated(aV%iList)) .and. (.not. List_allocated(aV%rList))) then -! write(stderr,'(2a)')myname_, & -! 'MCTERROR: Trying to zero an uninitialized AttrVect' -! call die(myname_) -! endif - - if(myZeroInts) then ! zero out INTEGER attributes - if(List_allocated(aV%iList)) then -!CDIR COLLAPSE - if(associated(aV%iAttr) .and. (nIAttr_(aV)>0)) aV%iAttr=0 - endif - endif - - if(myZeroReals) then ! zero out REAL attributes - if(List_allocated(aV%rList)) then -!CDIR COLLAPSE - if(associated(aV%rAttr) .and. (nRAttr_(aV)>0)) aV%rAttr=0._FP - endif - endif - - end subroutine zero_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: nIAttr_ - Return the Number of Integer Attributes -! -! !DESCRIPTION: -! This integer function returns the number of integer attributes -! present in the input {\tt AttrVect} argument {\tt aV}. -! -! !INTERFACE: - - integer function nIAttr_(aV) -! -! !USES: -! - use m_List, only : nitem - - implicit none - -! !INPUT PARAMETERS: -! - type(AttrVect),intent(in) :: aV - -! !REVISION HISTORY: -! 22Apr98 - Jing Guo - initial prototype/prolog/code -! 10Oct01 - J. Larson - made code more robust -! by checking status of pointers in aV%iList -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::nIAttr_' - - if(associated(aV%iList%bf)) then - nIAttr_ = nitem(aV%iList) - else - nIAttr_ = 0 - endif - - end function nIAttr_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: nRAttr_ - Return the Number of Real Attributes -! -! !DESCRIPTION: -! This integer function returns the number of real attributes -! present in the input {\tt AttrVect} argument {\tt aV}. - -! !INTERFACE: - - integer function nRAttr_(aV) -! -! !USES: -! - use m_List, only : nitem - - implicit none - -! !INPUT PARAMETERS: -! - type(AttrVect),intent(in) :: aV - -! !REVISION HISTORY: -! 22Apr98 - Jing Guo - initial prototype/prolog/code -! 10Oct01 - J. Larson - made code more robust -! by checking status of pointers in aV%iList -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::nRAttr_' - - if(associated(aV%rList%bf)) then - nRAttr_ = nitem(aV%rList) - else - nRAttr_ = 0 - endif - - end function nRAttr_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: getIList_ - Retrieve the Name of a Numbered Integer Attribute -! -! !DESCRIPTION: -! This routine returns the name of the {\tt ith} integer attribute of -! the input {\tt AttrVect} argument {\tt aVect}. The name is returned -! in the output {\tt String} argument {\tt item} (see the mpeu module -! {\tt m\_String} for more information regarding the {\tt String} type). -! -! !INTERFACE: - - subroutine getIList_(item, ith, aVect) -! -! !USES: -! - use m_String, only : String - use m_List, only : get - - implicit none - -! !INPUT PARAMETERS: -! - integer, intent(in) :: ith - type(AttrVect),intent(in) :: aVect - -! !OUTPUT PARAMETERS: -! - type(String),intent(out) :: item - -! !REVISION HISTORY: -! 24Apr98 - Jing Guo - initial prototype/prolog/code -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::getIList_' - - call get(item, ith, aVect%iList) - - end subroutine getIList_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: getRList_ - Retrieve the Name of a Numbered Real Attribute -! -! !DESCRIPTION: -! This routine returns the name of the {\tt ith} real attribute of -! the input {\tt AttrVect} argument {\tt aVect}. The name is returned -! in the output {\tt String} argument {\tt item} (see the mpeu module -! {\tt m\_String} for more information regarding the {\tt String} type). -! -! !INTERFACE: - - subroutine getRList_(item, ith, aVect) -! -! !USES: -! - use m_String, only : String - use m_List, only : get - - implicit none - -! !INPUT PARAMETERS: -! - integer, intent(in) :: ith - type(AttrVect), intent(in) :: aVect - -! !OUTPUT PARAMETERS: -! - type(String), intent(out) :: item - -! !REVISION HISTORY: -! 24Apr98 - Jing Guo - initial prototype/prolog/code -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::getRList_' - - call get(item,ith,aVect%rList) - - end subroutine getRList_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: getIListToChar_ - Retrieve the Name of a Numbered Integer Attribute -! -! !DESCRIPTION: -! This routine returns the name of the {\tt ith} integer attribute of -! the input {\tt AttrVect} argument {\tt aVect}. The name is returned -! in the function {\tt char} argument. -! -! !INTERFACE: - - function getIListToChar_(ith, aVect) -! -! !USES: -! - use m_String, only : String - use m_String, only : String_ToChar => ToChar - use m_String, only : String_clean => clean - use m_List, only : get - - implicit none - -! !INPUT PARAMETERS: -! - integer, intent(in) :: ith - type(AttrVect),intent(in) :: aVect - -! !OUTPUT PARAMETERS: -! - character(len=size(aVect%iList%bf,1)) :: getIListToChar_ - -! !REVISION HISTORY: -! 10Jan13 - T. Craig - initial prototype/prolog/code -!EOP ___________________________________________________________________ - - type(String) :: item - character(len=*),parameter :: myname_=myname//'::getIListToChar_' - - call get(item, ith, aVect%iList) - getIListToChar_ = String_toChar(item) - call String_clean(item) - - end function getIListToChar_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: getRListToChar_ - Retrieve the Name of a Numbered Integer Attribute -! -! !DESCRIPTION: -! This routine returns the name of the {\tt ith} integer attribute of -! the input {\tt AttrVect} argument {\tt aVect}. The name is returned -! in the function {\tt char} argument. -! -! !INTERFACE: - - function getRListToChar_(ith, aVect) -! -! !USES: -! - use m_String, only : String - use m_String, only : String_ToChar => ToChar - use m_String, only : String_clean => clean - use m_List, only : get - - implicit none - -! !INPUT PARAMETERS: -! - integer, intent(in) :: ith - type(AttrVect),intent(in) :: aVect - -! !OUTPUT PARAMETERS: -! - character(len=size(aVect%rList%bf,1)) :: getRListToChar_ - -! !REVISION HISTORY: -! 10Jan13 - T. Craig - initial prototype/prolog/code -!EOP ___________________________________________________________________ - - type(String) :: item - character(len=*),parameter :: myname_=myname//'::getRListToChar_' - - call get(item, ith, aVect%rList) - getRListToChar_ = String_toChar(item) - call String_clean(item) - - end function getRListToChar_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: indexIA_ - Index an Integer Attribute -! -! !DESCRIPTION: -! This function returns an {\tt INTEGER}, corresponding to the location -! of an integer attribute within the input {\tt AttrVect} argument -! {\tt aV}. For example, suppose {\tt aV} has the following attributes -! {\tt 'month'}, {\tt 'day'}, and {\tt 'year'}. The array of integer -! values for the attribute {\tt 'day'} is stored in -!% \begin{verbatim} -! {\tt aV\%iAttr(indexIA\_(aV,'day'),:)}. -!% \end{verbatim} -! If {\tt indexIA\_()} is unable to match {\tt item} to any of the integer -! attributes in {\tt aV}, the resulting value is zero which is equivalent -! to an error. The optional input {\tt CHARACTER} arguments {\tt perrWith} -! and {\tt dieWith} control how such errors are handled. -! \begin{enumerate} -! \item if neither {\tt perrWith} nor {\tt dieWith} are present, -! {\tt indexIA\_()} terminates execution with an internally generated -! error message; -! \item if {\tt perrWith} is present, but {\tt dieWith} is not, an error -! message is written to {\tt stderr} incorporating user-supplied traceback -! information stored in the argument {\tt perrWith}; -! \item if {\tt perrWith} is present, but {\tt dieWith} is not, and -! {\tt perrWith} is equal to ``quiet'', no error message is written. -! \item if {\tt dieWith} is present, execution terminates with an error -! message written to {\tt stderr} that incorporates user-supplied traceback -! information stored in the argument {\tt dieWith}; and -! \item if both {\tt perrWith} and {\tt dieWith} are present, execution -! terminates with an error message using {\tt dieWith}, and the argument -! {\tt perrWith} is ignored. -! \end{enumerate} -! -! !INTERFACE: - - integer function indexIA_(aV, item, perrWith, dieWith) -! -! !USES: -! - use m_die, only : die - use m_stdio,only : stderr - - use m_String, only : String - use m_String, only : String_init => init - use m_String, only : String_clean => clean - use m_String, only : String_ToChar => ToChar - - use m_List, only : index - - use m_TraceBack, only : GenTraceBackString - - implicit none - -! !INPUT PARAMETERS: -! - type(AttrVect), intent(in) :: aV - character(len=*), intent(in) :: item - character(len=*), optional, intent(in) :: perrWith - character(len=*), optional, intent(in) :: dieWith - -! !REVISION HISTORY: -! 27Apr98 - Jing Guo - initial prototype/prolog/code -! 2Aug02 - J. Larson - Solidified error handling using perrWith/dieWith -! 1Jan05 - R. Jacob - add quiet option for error handling -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::indexIA_' - - type(String) :: myTrace - - if(present(dieWith)) then - call GenTraceBackString(myTrace, dieWith, myname_) - else - if(present(perrWith)) then - call GenTraceBackString(myTrace, perrWith, myname_) - else - call GenTraceBackString(myTrace, myname_) - endif - endif - - indexIA_=index(aV%iList,item) - - if(indexIA_==0) then ! The attribute was not found! - ! As per the prologue, decide how to handle this error - if(present(perrWith) .and. (.not. present(dieWith))) then - if (trim(perrWith).eq.'quiet') then - ! do nothing - else - write(stderr,'(5a)') myname_, & - ':: ERROR--attribute not found: "',trim(item),'" ', & - 'Traceback: ',String_ToChar(myTrace) - endif - else ! Shutdown - write(stderr,'(5a)') myname_, & - ':: FATAL--attribute not found: "',trim(item),'" ', & - 'Traceback: ',String_ToChar(myTrace) - call die(myname_) - endif - endif - - call String_clean(myTrace) - - end function indexIA_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: indexRA_ - Index a Real Attribute -! -! !DESCRIPTION: -! This function returns an {\tt INTEGER}, corresponding to the location -! of a real attribute within the input {\tt AttrVect} argument -! {\tt aV}. For example, suppose {\tt aV} has the following attributes -! {\tt 'latitude'}, {\tt 'longitude'}, and {\tt 'pressure'}. The array -! of real values for the attribute {\tt 'longitude'} is stored in -!% \begin{verbatim} -! {\tt aV\%iAttr(indexRA\_(aV,'longitude'),:)}. -!% \end{verbatim} -! If {\tt indexRA\_()} is unable to match {\tt item} to any of the real -! attributes in {\tt aV}, the resulting value is zero which is equivalent -! to an error. The optional input {\tt CHARACTER} arguments {\tt perrWith} -! and {\tt dieWith} control how such errors are handled. -! \begin{enumerate} -! \item if neither {\tt perrWith} nor {\tt dieWith} are present, -! {\tt indexRA\_()} terminates execution with an internally generated -! error message; -! \item if {\tt perrWith} is present, but {\tt dieWith} is not, an error -! message is written to {\tt stderr} incorporating user-supplied traceback -! information stored in the argument {\tt perrWith}; -! \item if {\tt perrWith} is present, but {\tt dieWith} is not, and -! {\tt perrWith} is equal to ``quiet'', no error message is written. -! \item if {\tt dieWith} is present, execution terminates with an error -! message written to {\tt stderr} that incorporates user-supplied traceback -! information stored in the argument {\tt dieWith}; and -! \item if both {\tt perrWith} and {\tt dieWith} are present, execution -! terminates with an error message using {\tt dieWith}, and the argument -! {\tt perrWith} is ignored. -! \end{enumerate} -! -! !INTERFACE: - - integer function indexRA_(aV, item, perrWith, dieWith) -! -! !USES: -! - use m_die, only : die - use m_stdio,only : stderr - - use m_List, only : index - - use m_String, only : String - use m_String, only : String_init => init - use m_String, only : String_clean => clean - use m_String, only : String_ToChar => ToChar - - use m_TraceBack, only : GenTraceBackString - - implicit none - -! !INPUT PARAMETERS: -! - type(AttrVect), intent(in) :: aV - character(len=*), intent(in) :: item - character(len=*), optional, intent(in) :: perrWith - character(len=*), optional, intent(in) :: dieWith - -! !REVISION HISTORY: -! 27Apr98 - Jing Guo - initial prototype/prolog/code -! 2Aug02 - J. Larson - Solidified error handling using perrWith/dieWith -! 18Jan05 - R. Jacob - add quiet option for error handling -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::indexRA_' - - type(String) :: myTrace - - if(present(dieWith)) then ! Append onto TraceBack - call GenTraceBackString(myTrace, dieWith, myname_) - else - if(present(perrWith)) then ! Append onto TraceBack - call GenTraceBackString(myTrace, perrWith, myname_) - else ! Start a TraceBackString - call GenTraceBackString(myTrace, myname_) - endif - endif - - indexRA_=index(aV%rList,item) - - if(indexRA_==0) then ! The attribute was not found! - ! As per the prologue, decide how to handle this error - if(present(perrWith) .and. (.not. present(dieWith))) then - if (trim(perrWith).eq.'quiet') then - ! do nothing - else - write(stderr,'(5a)') myname_, & - ':: ERROR--attribute not found: "',trim(item),'" ', & - 'Traceback: ',String_ToChar(myTrace) - endif - else ! Shutdown if dieWith or no arguments present - write(stderr,'(5a)') myname_, & - ':: FATAL--attribute not found: "',trim(item),'" ', & - 'Traceback: ',String_ToChar(myTrace) - call die(myname_) - endif - endif - - call String_clean(myTrace) - - end function indexRA_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! DOE/ANL Mathematics and Computer Science Division ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: appendIAttr_ - Append one or more attributes onto the INTEGER part of an AttrVect. -! -! !DESCRIPTION: This routine takes an input {\tt AttrVect} argument -! {\tt aV}, and an input character string {\tt rList} and Appends {\tt rList} -! to the INTEGER part of {\tt aV}. The success (failure) of this operation is -! signified by a zero (nonzero) value for the optional {\tt INTEGER} -! output argument {\tt status}. -! -! !INTERFACE: - - subroutine appendIAttr_(aV, iList, status) -! -! !USES: -! - use m_List, only : List_init => init - use m_List, only : List_append => append - use m_List, only : List_clean => clean - use m_List, only : List_nullify => nullify - use m_List, only : List_allocated => allocated - use m_List, only : List_copy => copy - use m_List, only : List - use m_die - use m_stdio - - implicit none - -! !INPUT/OUTPUT PARAMETERS: -! - type(AttrVect),intent(inout) :: aV - -! !INPUT PARAMETERS: -! - character(len=*), intent(in) :: iList - -! !OUTPUT PARAMETERS: -! - integer,optional,intent(out) :: status - -! !REVISION HISTORY: -! 08Jul03 - R. Jacob - initial version -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::appendIAttr_' - - type(List) :: avRList,avIList ! placeholders for the aV attributes - type(List) :: addIlist ! for the input string - type(AttrVect) :: tempaV ! placeholder for aV data. - integer :: locsize ! size of aV - integer :: rlstatus,cstatus ! status flags - integer :: ilstatus - - if(present(status)) status = 0 - - call List_nullify(avIList) - call List_nullify(avRList) - -! save the local size and current int and real attributes - locsize = lsize_(aV) - call exportRList_(aV,avRList,rlstatus) - call exportIList_(aV,avIList,ilstatus) - -! create and fill a temporary AttrVect to hold any data currently in the aV - call initv_(tempaV,aV,lsize=locsize) - call Copy_(aV,tempaV) - -! create a List with the new attributes - call List_init(addIlist,iList) - -! append addIlist to current avIList if it has attributes. - if(List_allocated(avIList)) then - call List_append(avIList,addIlist) -! copy addIlist to avIList - else - call List_copy(avIList,addIlist) - endif - -! now delete the input aV and recreate it - call clean_(aV,cstatus) - call initl_(aV,avIList,avRList,locsize) - -! copy back the data - call Copy_(tempaV,aV) - -! clean up. - call List_clean(avRList,cstatus) - - call clean_(tempaV,cstatus) - call List_clean(addIlist,cstatus) - call List_clean(avIList,cstatus) - - if(present(status)) status = cstatus - - end subroutine appendIAttr_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! DOE/ANL Mathematics and Computer Science Division ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: appendRAttr_ - Append one or more attributes onto the REAL part of an AttrVect. -! -! !DESCRIPTION: This routine takes an input {\tt AttrVect} argument -! {\tt aV}, and an input character string {\tt rList} and Appends {\tt rList} -! to the REAL part of {\tt aV}. The success (failure) of this operation is -! signified by a zero (nonzero) value for the optional {\tt INTEGER} -! output argument {\tt status}. -! -! !INTERFACE: - - subroutine appendRAttr_(aV, rList, status) -! -! !USES: -! - use m_List, only : List_init => init - use m_List, only : List_append => append - use m_List, only : List_clean => clean - use m_List, only : List_nullify => nullify - use m_List, only : List_allocated => allocated - use m_List, only : List_copy => copy - use m_List, only : List - use m_die - use m_stdio - - implicit none - -! !INPUT/OUTPUT PARAMETERS: -! - type(AttrVect),intent(inout) :: aV - -! !INPUT PARAMETERS: -! - character(len=*), intent(in) :: rList - -! !OUTPUT PARAMETERS: -! - integer,optional,intent(out) :: status - -! !REVISION HISTORY: -! 04Jun03 - R. Jacob - initial version -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::appendRAttr_' - - type(List) :: avRList,avIList ! placeholders for the aV attributes - type(List) :: addRlist ! for the input string - type(AttrVect) :: tempaV ! placeholder for aV data. - integer :: locsize ! size of aV - integer :: rlstatus,cstatus ! status flags - integer :: ilstatus - - if(present(status)) status = 0 - - call List_nullify(avIList) - call List_nullify(avRList) - -! save the local size and current int and real attributes - locsize = lsize_(aV) - call exportRList_(aV,avRList,rlstatus) - call exportIList_(aV,avIList,ilstatus) - -! create and fill a temporary AttrVect to hold any data currently in the aV - call initv_(tempaV,aV,lsize=locsize) - call Copy_(aV,tempaV) - -! create a List with the new attributes - call List_init(addRlist,rList) - -! append addRlist to current avRList if it has attributes. - if(List_allocated(avRList)) then - call List_append(avRList,addRlist) -! copy addRlist to avRList - else - call List_copy(avRList,addRlist) - endif - -! now delete the input aV and recreate it - call clean_(aV,cstatus) - call initl_(aV,avIList,avRList,locsize) - -! copy back the data - call Copy_(tempaV,aV) - -! clean up. - call List_clean(avIList,cstatus) - - call clean_(tempaV,cstatus) - call List_clean(addRlist,cstatus) - call List_clean(avRList,cstatus) - - if(present(status)) status = cstatus - - end subroutine appendRAttr_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: exportIList_ - Return INTEGER Attribute List -! -! !DESCRIPTION: -! This routine extracts from the input {\tt AttrVect} argument {\tt aV} -! the integer attribute list, and returns it as the {\tt List} output -! argument {\tt outIList}. The success (failure) of this operation is -! signified by a zero (nonzero) value for the optional {\tt INTEGER} -! output argument {\tt status}. -! -! {\bf N.B.:} This routine returns an allocated {\tt List} data -! structure ({\tt outIList}). The user is responsible for deallocating -! this structure by invoking {\tt List\_clean()} (see the module -! {\tt m\_List} for details) once it is no longer needed. Failure to -! do so will result in a memory leak. -! -! !INTERFACE: - - subroutine exportIList_(aV, outIList, status) - -! -! !USES: -! - use m_die , only : die - use m_stdio, only : stderr - - use m_List, only : List - use m_List, only : List_allocated => allocated - use m_List, only : List_copy => copy - use m_List, only : List_nullify => nullify - - implicit none - -! !INPUT PARAMETERS: - - type(AttrVect), intent(in) :: aV - -! !OUTPUT PARAMETERS: - - type(List), intent(out) :: outIList - integer, optional, intent(out) :: status - -! !REVISION HISTORY: -! 14Dec01 - J.W. Larson - initial prototype. -! -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::exportIList_' - - ! Initialize status flag (if present) to success value of zero. - - if(present(status)) status = 0 - - if(List_allocated(aV%iList)) then - call List_copy(outIList, aV%iList) - else - call List_nullify(outIList) - if(present(status)) then - status = 1 - else - call die(myname_) - endif - endif - - end subroutine exportIList_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: exportRList_ - Return REAL attribute List -! -! !DESCRIPTION: -! This routine extracts from the input {\tt AttrVect} argument {\tt aV} -! the real attribute list, and returns it as the {\tt List} output -! argument {\tt outRList}. The success (failure) of this operation is -! signified by a zero (nonzero) value for the optional {\tt INTEGER} -! output argument {\tt status}. -! -! {\bf N.B.:} This routine returns an allocated {\tt List} data -! structure ({\tt outRList}). The user is responsible for deallocating -! this structure by invoking {\tt List\_clean()} (see the module -! {\tt m\_List} for details) once it is no longer needed. Failure to -! do so will result in a memory leak. -! -! !INTERFACE: - - subroutine exportRList_(aV, outRList, status) - -! -! !USES: -! - use m_die , only : die - use m_stdio, only : stderr - - use m_List, only : List - use m_List, only : List_allocated => allocated - use m_List, only : List_copy => copy - use m_List, only : List_nullify => nullify - - implicit none - -! !INPUT PARAMETERS: - - type(AttrVect), intent(in) :: aV - -! !OUTPUT PARAMETERS: - - type(List), intent(out) :: outRList - integer, optional, intent(out) :: status - -! !REVISION HISTORY: -! 14Dec01 - J.W. Larson - initial prototype. -! -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::exportRList_' - - ! Initialize status flag (if present) to success value of zero. - - if(present(status)) status = 0 - - if(List_allocated(aV%rList)) then - call List_copy(outRList, aV%rList) - else - call List_nullify(outRList) - if(present(status)) then - status = 1 - else - call die(myname_) - endif - endif - - end subroutine exportRList_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: exportIListToChar_ - Return AttrVect\%iList as CHARACTER -! -! !DESCRIPTION: -! This routine extracts from the input {\tt AttrVect} argument {\tt aV} -! the integer attribute list (see the mpeu module {\tt m\_List} for more -! information regarding the {\tt List} type), and returns it as a -! {\tt CHARACTER} suitable for printing. An example of its usage is -! \begin{verbatim} -! write(stdout,'(1a)') exportIListToChar_(aV) -! \end{verbatim} -! which writes the contents of {\tt aV\%iList\%bf} to the Fortran device -! {\tt stdout}. -! -! !INTERFACE: - - function exportIListToChar_(aV) - -! -! !USES: -! - use m_die , only : die - use m_stdio, only : stderr - - use m_List, only : List - use m_List, only : List_allocated => allocated - use m_List, only : List_copy => copy - use m_List, only : List_exportToChar => exportToChar - use m_List, only : List_clean => clean - - implicit none - -! !INPUT PARAMETERS: - - type(AttrVect), intent(in) :: aV - -! !OUTPUT PARAMETERS: - - character(len=size(aV%iList%bf,1)) :: exportIListToChar_ - -! !REVISION HISTORY: -! 13Feb02 - J.W. Larson - initial prototype. -! 05Jun03 - R. Jacob - return a blank instead of dying -! to avoid I/O errors when this function is used in a write statement. -! -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::exportIListToChar_' - - ! The following extraneous list copy avoids a bug in the - ! SGI MIPSpro Fortran 90 compiler version 7.30. and the - ! Sun Fortran 90 Workshop compiler 5.0. If this line is removed, - ! the following error will occur during compile time: - - ! Signal: Segmentation fault in IR->WHIRL Conversion phase. - ! "m_AttrVect.F90": Error: Signal Segmentation fault in phase IR->WHIRL - ! Conversion -- processing aborted - ! f90 ERROR: /opt/MIPSpro/73/usr/lib32/cmplrs/mfef90 died due to signal 4 - ! f90 ERROR: core dumped - ! *** Error code 32 (bu21) - - type(List) :: iListCopy - - ! Extract the INTEGER attribute list to a character: - - if(List_allocated(aV%iList)) then - call List_copy(iListCopy,aV%iList) - exportIListToChar_ = List_exportToChar(iListCopy) - call List_clean(iListCopy) - else - exportIListToChar_ = '' - endif - - end function exportIListToChar_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: exportRListToChar_ - Return AttrVect\%rList as CHARACTER -! -! !DESCRIPTION: -! This routine extracts from the input {\tt AttrVect} argument {\tt aV} -! the real attribute list (see the mpeu module {\tt m\_List} for more -! information regarding the {\tt List} type), and returns it as a -! {\tt CHARACTER} suitable for printing. An example of its usage is -! \begin{verbatim} -! write(stdout,'(1a)') exportRListToChar_(aV) -! \end{verbatim} -! which writes the contents of {\tt aV\%rList\%bf} to the Fortran device -! {\tt stdout}. -! -! !INTERFACE: - - function exportRListToChar_(aV) - -! -! !USES: -! - use m_die , only : die - use m_stdio, only : stderr - - use m_List, only : List - use m_List, only : List_allocated => allocated - use m_List, only : List_copy => copy - use m_List, only : List_exportToChar => exportToChar - use m_List, only : List_clean => clean - - implicit none - -! !INPUT PARAMETERS: - - type(AttrVect), intent(in) :: aV - -! !OUTPUT PARAMETERS: - - character(len=size(aV%rList%bf,1)) :: exportRListToChar_ - -! !REVISION HISTORY: -! 13Feb02 - J.W. Larson - initial prototype. -! 05Jun03 - R. Jacob - return a blank instead of dying -! to avoid I/O errors when this function is used in a write statement. -! -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::exportRListToChar_' - - ! The following extraneous list copy avoids a bug in the - ! SGI MIPSpro Fortran 90 compiler version 7.30. and the - ! Sun Fortran 90 Workshop compiler 5.0. If this line is removed, - ! the following error will occur during compile time: - - ! Signal: Segmentation fault in IR->WHIRL Conversion phase. - ! "m_AttrVect.F90": Error: Signal Segmentation fault in phase IR->WHIRL - ! Conversion -- processing aborted - ! f90 ERROR: /opt/MIPSpro/73/usr/lib32/cmplrs/mfef90 died due to signal 4 - ! f90 ERROR: core dumped - ! *** Error code 32 (bu21) - - type(List) :: rListCopy - - ! Extract the REAL attribute list to a character: - - if(List_allocated(aV%rList)) then - call List_copy(rListCopy,aV%rList) - exportRListToChar_ = List_exportToChar(rListCopy) - call List_clean(rListCopy) - else - exportRListToChar_ = '' - endif - - end function exportRListToChar_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: exportIAttr_ - Return INTEGER Attribute as a Vector -! -! !DESCRIPTION: -! This routine extracts from the input {\tt AttrVect} argument {\tt aV} -! the integer attribute corresponding to the tag defined in the input -! {\tt CHARACTER} argument {\tt AttrTag}, and returns it in the -! {\tt INTEGER} output array {\tt outVect}, and its length in the output -! {\tt INTEGER} argument {\tt lsize}. The optional input {\tt CHARACTER} -! arguments {\tt perrWith} and {\tt dieWith} control how errors are -! handled. -! \begin{enumerate} -! \item if neither {\tt perrWith} nor {\tt dieWith} are present, -! {\tt exportIAttr\_()} terminates execution with an internally generated -! error message; -! \item if {\tt perrWith} is present, but {\tt dieWith} is not, an error -! message is written to {\tt stderr} incorporating user-supplied traceback -! information stored in the argument {\tt perrWith}; -! \item if {\tt dieWith} is present, execution terminates with an error -! message written to {\tt stderr} that incorporates user-supplied traceback -! information stored in the argument {\tt dieWith}; and -! \item if both {\tt perrWith} and {\tt dieWith} are present, execution -! terminates with an error message using {\tt dieWith}, and the argument -! {\tt perrWith} is ignored. -! \end{enumerate} -! -! {\bf N.B.:} This routine will fail if the {\tt AttrTag} is not in -! the {\tt AttrVect} {\tt List} component {\tt aV\%iList}. -! -! {\bf N.B.:} The flexibility of this routine regarding the pointer -! association status of the output argument {\tt outVect} means the -! user must invoke this routine with care. If the user wishes this -! routine to fill a pre-allocated array, then obviously this array -! must be allocated prior to calling this routine. If the user wishes -! that the routine {\em create} the output argument array {\tt outVect}, -! then the user must ensure this pointer is not allocated (i.e. the user -! must nullify this pointer) before this routine is invoked. -! -! {\bf N.B.:} If the user has relied on this routine to allocate memory -! associated with the pointer {\tt outVect}, then the user is responsible -! for deallocating this array once it is no longer needed. Failure to -! do so will result in a memory leak. -! -! !INTERFACE: - - subroutine exportIAttr_(aV, AttrTag, outVect, lsize, perrWith, dieWith) - -! -! !USES: -! - use m_die , only : die - use m_stdio , only : stderr - - use m_String, only : String - use m_String, only : String_init => init - use m_String, only : String_clean => clean - use m_String, only : String_ToChar => ToChar - - use m_TraceBack, only : GenTraceBackString - - implicit none - -! !INPUT PARAMETERS: - - type(AttrVect), intent(in) :: aV - character(len=*), intent(in) :: AttrTag - character(len=*), optional, intent(in) :: perrWith - character(len=*), optional, intent(in) :: dieWith - -! !OUTPUT PARAMETERS: - - integer, dimension(:), pointer :: outVect - integer, optional, intent(out) :: lsize - -! !REVISION HISTORY: -! 19Oct01 - J.W. Larson - initial (slow) -! prototype. -! 6May02 - J.W. Larson - added capability -! to work with pre-allocated outVect. -! -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::exportIAttr_' - - integer :: index, ierr, n, myLsize - type(String) :: myTrace - - if(present(dieWith)) then ! Append onto TraceBack - call GenTraceBackString(myTrace, dieWith, myname_) - else - if(present(perrWith)) then ! Append onto TraceBack - call GenTraceBackString(myTrace, perrWith, myname_) - else ! Start a TraceBackString - call GenTraceBackString(myTrace, myname_) - endif - endif - - ! Index the attribute we wish to extract: - - index = indexIA_(aV, attrTag, dieWith=String_ToChar(myTrace)) - - ! Determine the number of data points: - - myLsize = lsize_(aV) - - ! Allocate space for outVect (if it is not already dimensioned) - - if(associated(outVect)) then ! check the size of outVect - if(size(outVect) < myLsize) then - write(stderr,'(3a,i8,a,i8)') myname_, & - ':: ERROR length of output array outVect ', & - ' less than length of aV. size(outVect)=',size(outVect), & - ', length of aV=',myLsize - write(stderr,'(2a)') 'Traceback: ',String_ToChar(myTrace) - call die(myname_) - endif - else ! allocate space for outVect - allocate(outVect(myLsize), stat=ierr) - if(ierr /= 0) then - write(stderr,'(2a,i8)') myname_, & - ':: Error - allocate(outVect(...) failed. ierr = ',ierr - write(stderr,'(2a)') 'Traceback: ',String_ToChar(myTrace) - call die(myname_) - endif - endif - - ! Copy the attribute data into outVect - -!$OMP PARALLEL DO PRIVATE(n) - do n=1,myLsize - outVect(n) = aV%iAttr(index,n) - end do - - ! return optional output argument lsize: - if(present(lsize)) lsize = myLsize - - call String_clean(myTrace) - - end subroutine exportIAttr_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: exportRAttrSP_ - Return REAL Attribute as a Pointer to Array -! -! !DESCRIPTION: -! This routine extracts from the input {\tt AttrVect} argument {\tt aV} -! the real attribute corresponding to the tag defined in the input -! {\tt CHARACTER} argument {\tt AttrTag}, and returns it in the -! {\tt REAL} output array {\tt outVect}, and its length in the output -! {\tt INTEGER} argument {\tt lsize}. The optional input {\tt CHARACTER} -! arguments {\tt perrWith} and {\tt dieWith} control how errors are -! handled. -! \begin{enumerate} -! \item if neither {\tt perrWith} nor {\tt dieWith} are present, -! {\tt exportRAttr\_()} terminates execution with an internally generated -! error message; -! \item if {\tt perrWith} is present, but {\tt dieWith} is not, an error -! message is written to {\tt stderr} incorporating user-supplied traceback -! information stored in the argument {\tt perrWith}; -! \item if {\tt dieWith} is present, execution terminates with an error -! message written to {\tt stderr} that incorporates user-supplied traceback -! information stored in the argument {\tt dieWith}; and -! \item if both {\tt perrWith} and {\tt dieWith} are present, execution -! terminates with an error message using {\tt dieWith}, and the argument -! {\tt perrWith} is ignored. -! \end{enumerate} -! -! {\bf N.B.:} This routine will fail if the {\tt AttrTag} is not in -! the {\tt AttrVect} {\tt List} component {\tt aV\%iList}. -! -! {\bf N.B.:} The flexibility of this routine regarding the pointer -! association status of the output argument {\tt outVect} means the -! user must invoke this routine with care. If the user wishes this -! routine to fill a pre-allocated array, then obviously this array -! must be allocated prior to calling this routine. If the user wishes -! that the routine {\em create} the output argument array {\tt outVect}, -! then the user must ensure this pointer is not allocated (i.e. the user -! must nullify this pointer) before this routine is invoked. -! -! {\bf N.B.:} If the user has relied on this routine to allocate memory -! associated with the pointer {\tt outVect}, then the user is responsible -! for deallocating this array once it is no longer needed. Failure to -! do so will result in a memory leak. -! -! !INTERFACE: - - subroutine exportRAttrSP_(aV, AttrTag, outVect, lsize, perrWith, dieWith) - -! -! !USES: -! - use m_die , only : die - use m_stdio , only : stderr - - - use m_String, only : String - use m_String, only : String_init => init - use m_String, only : String_clean => clean - use m_String, only : String_ToChar => ToChar - - use m_TraceBack, only : GenTraceBackString - - implicit none - -! !INPUT PARAMETERS: - - type(AttrVect), intent(in) :: aV - character(len=*), intent(in) :: AttrTag - character(len=*), optional, intent(in) :: perrWith - character(len=*), optional, intent(in) :: dieWith - -! !OUTPUT PARAMETERS: - - real(SP), dimension(:), pointer :: outVect - integer, optional, intent(out) :: lsize - -! !REVISION HISTORY: -! 19Oct01 - J.W. Larson - initial (slow) -! prototype. -! 6May02 - J.W. Larson - added capability -! to work with pre-allocated outVect. -! -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::exportRAttrSP_' - - integer :: index, ierr, n, myLsize - type(String) :: myTrace - - if(present(dieWith)) then ! Append onto TraceBack - call GenTraceBackString(myTrace, dieWith, myname_) - else - if(present(perrWith)) then ! Append onto TraceBack - call GenTraceBackString(myTrace, perrWith, myname_) - else ! Start a TraceBackString - call GenTraceBackString(myTrace, myname_) - endif - endif - - ! Index the attribute we wish to extract: - - index = indexRA_(aV, attrTag, dieWith=String_ToChar(myTrace)) - - ! Determine the number of data points: - - myLsize = lsize_(aV) - - ! Allocate space for outVect (if it is not already dimensioned) - - if(associated(outVect)) then ! check the size of outVect - if(size(outVect) < myLsize) then - write(stderr,'(3a,i8,a,i8)') myname_, & - ':: ERROR length of output array outVect ', & - ' less than length of aV. size(outVect)=',size(outVect), & - ', length of aV=',myLsize - write(stderr,'(2a)') 'Traceback: ',String_ToChar(myTrace) - call die(myname_) - endif - else ! allocate space for outVect - allocate(outVect(myLsize), stat=ierr) - if(ierr /= 0) then - write(stderr,'(2a,i8)') myname_, & - ':: Error - allocate(outVect(...) failed. ierr = ',ierr - write(stderr,'(2a)') 'Traceback: ',String_ToChar(myTrace) - call die(myname_) - endif - endif - - ! Copy the attribute data into outVect - -!$OMP PARALLEL DO PRIVATE(n) - do n=1,myLsize - outVect(n) = aV%rAttr(index,n) - end do - - call String_clean(myTrace) - - ! return optional argument lsize - if(present(lsize)) lsize = myLsize - - end subroutine exportRAttrSP_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -! ---------------------------------------------------------------------- -! -! !IROUTINE: exportRAttrDP_ - Return REAL Attribute as a Pointer to Array -! -! !DESCRIPTION: -! Double precision version of exportRAttrSP_ -! -! !INTERFACE: - - subroutine exportRAttrDP_(aV, AttrTag, outVect, lsize, perrWith, dieWith) - -! -! !USES: -! - use m_die , only : die - use m_stdio , only : stderr - - - use m_String, only : String - use m_String, only : String_init => init - use m_String, only : String_clean => clean - use m_String, only : String_ToChar => ToChar - - use m_TraceBack, only : GenTraceBackString - - implicit none - -! !INPUT PARAMETERS: - - type(AttrVect), intent(in) :: aV - character(len=*), intent(in) :: AttrTag - character(len=*), optional, intent(in) :: perrWith - character(len=*), optional, intent(in) :: dieWith - -! !OUTPUT PARAMETERS: - - real(DP), dimension(:), pointer :: outVect - integer, optional, intent(out) :: lsize - -! !REVISION HISTORY: -! 19Oct01 - J.W. Larson - initial (slow) -! prototype. -! 6May02 - J.W. Larson - added capability -! to work with pre-allocated outVect. -! -! ______________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::exportRAttrDP_' - - integer :: index, ierr, n, myLsize - type(String) :: myTrace - - if(present(dieWith)) then ! Append onto TraceBack - call GenTraceBackString(myTrace, dieWith, myname_) - else - if(present(perrWith)) then ! Append onto TraceBack - call GenTraceBackString(myTrace, perrWith, myname_) - else ! Start a TraceBackString - call GenTraceBackString(myTrace, myname_) - endif - endif - - ! Index the attribute we wish to extract: - - index = indexRA_(aV, attrTag, dieWith=String_ToChar(myTrace)) - - ! Determine the number of data points: - - myLsize = lsize_(aV) - - ! Allocate space for outVect (if it is not already dimensioned) - - if(associated(outVect)) then ! check the size of outVect - if(size(outVect) < myLsize) then - write(stderr,'(3a,i8,a,i8)') myname_, & - ':: ERROR length of output array outVect ', & - ' less than length of aV. size(outVect)=',size(outVect), & - ', length of aV=',myLsize - write(stderr,'(2a)') 'Traceback: ',String_ToChar(myTrace) - call die(myname_) - endif - else ! allocate space for outVect - allocate(outVect(myLsize), stat=ierr) - if(ierr /= 0) then - write(stderr,'(2a,i8)') myname_, & - ':: Error - allocate(outVect(...) failed. ierr = ',ierr - write(stderr,'(2a)') 'Traceback: ',String_ToChar(myTrace) - call die(myname_) - endif - endif - - ! Copy the attribute data into outVect - -!$OMP PARALLEL DO PRIVATE(n) - do n=1,myLsize - outVect(n) = aV%rAttr(index,n) - end do - - call String_clean(myTrace) - - ! return optional argument lsize - if(present(lsize)) lsize = myLsize - - end subroutine exportRAttrDP_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: importIAttr_ - Import INTEGER Vector as an Attribute -! -! !DESCRIPTION: -! This routine imports into the input/output {\tt AttrVect} argument -! {\tt aV} the integer attribute corresponding to the tag defined in the -! input {\tt CHARACTER} argument {\tt AttrTag}. The data to be imported -! is provided in the {\tt INTEGER} input array {\tt inVect}, and the -! number of entries to be imported in the optional input {\tt INTEGER} -! argument {\tt lsize}. -! -! {\bf N.B.:} This routine will fail if the {\tt AttrTag} is not in -! the {\tt AttrVect} {\tt List} component {\tt aV\%iList}. -! -! !INTERFACE: - - subroutine importIAttr_(aV, AttrTag, inVect, lsize) -! -! !USES: -! - use m_die , only : die - use m_stdio , only : stderr - - implicit none - -! !INPUT PARAMETERS: - - character(len=*), intent(in) :: AttrTag - integer, dimension(:), pointer :: inVect - integer, optional, intent(in) :: lsize - -! !INPUT/OUTPUT PARAMETERS: - - type(AttrVect), intent(inout) :: aV - -! !REVISION HISTORY: -! 19Oct01 - J.W. Larson - initial (slow) -! prototype. -! -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::importIAttr_' - - integer :: index, aVsize, ierr, n, mysize - - ! Index the attribute we wish to extract: - - index = indexIA_(aV, attrTag) - - ! Determine the number of data points: - - aVsize = lsize_(aV) - - ! Check input array size vs. lsize_(aV): - - if(present(lsize)) then - if(aVsize < lsize) then - write(stderr,'(3a,i8,a,i8)') myname_, & - ':: ERROR--attempt to import too many entries ', & - 'into AttrVect aV. AttrVect_lsize(aV)=',aVsize, & - ', number of entries to be imported=',lsize - call die(myname_) - endif - mysize=lsize - else - if(aVsize < size(inVect)) then - write(stderr,'(3a,i8,a,i8)') myname_, & - ':: ERROR--attempt to import too many entries ', & - 'into AttrVect aV. AttrVect_lsize(aV)=',aVsize, & - ' , number of entries to be imported=',size(inVect) - call die(myname_) - endif - mysize = aVsize - endif - - ! Copy the data from inVect to its attribute slot: - -!$OMP PARALLEL DO PRIVATE(n) - do n=1,mysize - aV%iAttr(index,n) = inVect(n) - end do - - end subroutine importIAttr_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: importRAttrSP_ - Import REAL Vector as an Attribute -! -! !DESCRIPTION: -! This routine imports into the input/output {\tt AttrVect} argument -! {\tt aV} the real attribute corresponding to the tag defined in the -! input {\tt CHARACTER} argument {\tt AttrTag}. The data to be imported -! is provided in the {\tt REAL} input array {\tt inVect}, and its -! length in the optional input {\tt INTEGER} argument {\tt lsize}. -! -! {\bf N.B.:} This routine will fail if the {\tt AttrTag} is not in -! the {\tt AttrVect} {\tt List} component {\tt aV\%rList}. -! -! !INTERFACE: - - subroutine importRAttrSP_(aV, AttrTag, inVect, lsize) -! -! !USES: -! - use m_die , only : die - use m_stdio , only : stderr - - implicit none - -! !INPUT PARAMETERS: - - character(len=*), intent(in) :: AttrTag - real(SP), dimension(:), pointer :: inVect - integer, optional, intent(in) :: lsize - -! !INPUT/OUTPUT PARAMETERS: - - type(AttrVect), intent(inout) :: aV - - - -! !REVISION HISTORY: -! 19Oct01 - J.W. Larson - initial (slow) -! prototype. -! -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::importRAttrSP_' - - integer :: index, aVsize, ierr, n, mysize - - ! Index the attribute we wish to extract: - - index = indexRA_(aV, attrTag) - - ! Determine the number of data points: - - aVsize = lsize_(aV) - - ! Check input array size vs. lsize_(aV): - - if(present(lsize)) then - if(aVsize < lsize) then - write(stderr,'(3a,i8,a,i8)') myname_, & - ':: ERROR--attempt to import too many entries ', & - 'into AttrVect aV. AttrVect_lsize(aV)=',aVsize, & - ', number of entries to be imported=',lsize - call die(myname_) - endif - mysize=lsize - else - if(aVsize < size(inVect)) then - write(stderr,'(3a,i8,a,i8)') myname_, & - ':: ERROR--attempt to import too many entries ', & - 'into AttrVect aV. AttrVect_lsize(aV)=',aVsize, & - ' , number of entries to be imported=',size(inVect) - call die(myname_) - endif - mysize=aVsize - endif - - ! Copy the attribute data into outVect - -!$OMP PARALLEL DO PRIVATE(n) - do n=1,mysize - aV%rAttr(index,n) = inVect(n) - end do - - end subroutine importRAttrSP_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -! ---------------------------------------------------------------------- -! -! !IROUTINE: importRAttrDP_ - Import REAL Vector as an Attribute -! -! !DESCRIPTION: -! Double precision version of importRAttrSP_ -! -! !INTERFACE: - - subroutine importRAttrDP_(aV, AttrTag, inVect, lsize) -! -! !USES: -! - use m_die , only : die - use m_stdio , only : stderr - - implicit none - -! !INPUT PARAMETERS: - - character(len=*), intent(in) :: AttrTag - real(DP), dimension(:), pointer :: inVect - integer, optional, intent(in) :: lsize - -! !INPUT/OUTPUT PARAMETERS: - - type(AttrVect), intent(inout) :: aV - - - -! !REVISION HISTORY: -! 19Oct01 - J.W. Larson - initial (slow) -! prototype. -! -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::importRAttrDP_' - - integer :: index, aVsize, ierr, n, mysize - - ! Index the attribute we wish to extract: - - index = indexRA_(aV, attrTag) - - ! Determine the number of data points: - - aVsize = lsize_(aV) - - ! Check input array size vs. lsize_(aV): - - if(present(lsize)) then - if(aVsize < lsize) then - write(stderr,'(3a,i8,a,i8)') myname_, & - ':: ERROR--attempt to import too many entries ', & - 'into AttrVect aV. AttrVect_lsize(aV)=',aVsize, & - ', number of entries to be imported=',lsize - call die(myname_) - endif - mysize=lsize - else - if(aVsize < size(inVect)) then - write(stderr,'(3a,i8,a,i8)') myname_, & - ':: ERROR--attempt to import too many entries ', & - 'into AttrVect aV. AttrVect_lsize(aV)=',aVsize, & - ' , number of entries to be imported=',size(inVect) - call die(myname_) - endif - mysize=aVsize - endif - - ! Copy the attribute data into outVect - -!$OMP PARALLEL DO PRIVATE(n) - do n=1,mysize - aV%rAttr(index,n) = inVect(n) - end do - - end subroutine importRAttrDP_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: RCopy_ - Copy Real Attributes from One AttrVect to Another -! -! !DESCRIPTION: -! This routine copies from input argment {\tt aVin} into the output -! {\tt AttrVect} argument {\tt aVout} the shared real attributes. -! -! If the optional argument {\tt Vector} is present and true, the vector -! architecture-friendly portions of this routine will be invoked. -! -! If the optional argument {\tt sharedIndices} is present, it should be -! the result of the call {\tt SharedIndicesOneType\_(aVin, aVout, 'REAL', -! sharedIndices)}. Providing this argument speeds up this routine -! substantially. For example, you can compute a {\tt sharedIndices} -! structure once for a given pair of {\tt AttrVect}s, then use that same -! structure for all copies between those two {\tt AttrVect}s (although -! note that a different {\tt sharedIndices} variable would be needed if -! {\tt aVin} and {\tt aVout} were reversed). -! -! {\bf N.B.:} This routine will fail if the {\tt aVout} is not initialized. -! -! !INTERFACE: - - subroutine RCopy_(aVin, aVout, vector, sharedIndices) - -! -! !USES: -! - use m_die , only : die - use m_stdio , only : stderr - - use m_List, only : GetSharedListIndices - use m_List, only : GetIndices => get_indices - - implicit none - -! !INPUT PARAMETERS: - - type(AttrVect), intent(in) :: aVin - logical, optional, intent(in) :: vector - type(AVSharedIndicesOneType), optional, intent(in) :: sharedIndices - -! !OUTPUT PARAMETERS: - - type(AttrVect), intent(inout) :: aVout - - -! !REVISION HISTORY: -! 18Aug06 - R. Jacob - initial version. -! 28Apr11 - W.J. Sacks - added sharedIndices argument -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::RCopy_' - - integer :: i,j,ier ! dummy variables - integer :: aVsize ! The lsize of aVin and aVout - integer :: num_inindices, num_outindices ! Number of matching indices in aV - integer :: inxmin, outxmin, inx, outx ! Index variables - logical :: usevector ! true if vector flag is present and true. - character*7 :: data_flag ! character variable used as data type flag - type(AVSharedIndicesOneType) :: mySharedIndices ! copied from sharedIndices, or - ! computed if sharedIndices is not - ! present - logical :: clean_mySharedIndices ! true if we need to clean mySharedIndices before - ! returning (will be true if we did allocation in this - ! subroutine) - - - ! Check the arguments - aVsize = lsize_(aVin) - if(lsize_(aVin) /= lsize_(aVout)) then - write(stderr,'(2a)') myname_, & - 'MCTERROR: Input aV and output aV do not have the same size' - call die(myname_,'MCTERROR: Input aV and output aV & - &do not have the same size',2) - endif - - data_flag = 'REAL' - - if (present(sharedIndices)) then - ! do some error checking on sharedIndices - if (.not. (associated(sharedIndices%aVindices1) .and. associated(sharedIndices%aVindices2))) then - call die(myname_,'MCTERROR: provided sharedIndices structure is uninitialized',3) - endif - if (trim(sharedIndices%data_flag) /= data_flag) then - call die(myname_,'MCTERROR: provided sharedIndices structure has incorrect data_flag',4) - endif - - ! copy into local variable - mySharedIndices = sharedIndices - clean_mySharedIndices = .false. - else - ! Check REAL attributes for matching indices - call SharedIndicesOneType_(aVin, aVout, data_flag, mySharedIndices) - clean_mySharedIndices = .true. - endif - - if(mySharedIndices%num_indices <= 0) then - if (clean_mySharedIndices) then - call cleanSharedIndicesOneType_(mySharedIndices,stat=ier) - if(ier /= 0) call die(myname_,'MCTERROR: in cleanSharedIndicesOneType_',ier) - endif - return - endif - - ! check vector flag. - usevector = .false. - if (present(vector)) then - if(vector) usevector = .true. - endif - - ! Start copying - - if(mySharedIndices%contiguous) then - - if(usevector) then - outxmin=mySharedIndices%aVindices2(1)-1 - inxmin=mySharedIndices%aVindices1(1)-1 -!$OMP PARALLEL DO PRIVATE(i,j) - do i=1,mySharedIndices%num_indices -!CDIR SELECT(VECTOR) -!DIR$ CONCURRENT - do j=1,aVsize - aVout%rAttr(outxmin+i,j) = aVin%rAttr(inxmin+i,j) - enddo - enddo - else - outxmin=mySharedIndices%aVindices2(1)-1 - inxmin=mySharedIndices%aVindices1(1)-1 -!$OMP PARALLEL DO PRIVAtE(j,i) - do j=1,aVsize -!DIR$ CONCURRENT - do i=1,mySharedIndices%num_indices - aVout%rAttr(outxmin+i,j) = aVin%rAttr(inxmin+i,j) - enddo - enddo - endif - - else - -!$OMP PARALLEL DO PRIVATE(j,i,outx,inx) - do j=1,aVsize -!DIR$ CONCURRENT - do i=1,mySharedIndices%num_indices - outx=mySharedIndices%aVindices2(i) - inx=mySharedIndices%aVindices1(i) - aVout%rAttr(outx,j) = aVin%rAttr(inx,j) - enddo - enddo - - endif - - - if (clean_mySharedIndices) then - call cleanSharedIndicesOneType_(mySharedIndices,stat=ier) - if(ier /= 0) call die(myname_,'MCTERROR: in cleanSharedIndicesOneType_',ier) - endif - - end subroutine RCopy_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: RCopyL_ - Copy Specific Real Attributes from One AttrVect to Another -! -! !DESCRIPTION: -! This routine copies from input argment {\tt aVin} into the output -! {\tt AttrVect} argument {\tt aVout} the real attributes specified in -! input {\tt CHARACTER} argument {\tt rList}. The attributes can -! be listed in any order. -! -! If any attributes in {\tt aVout} have different names but represent the -! the same quantity and should still be copied, you must provide a translation -! argument {\tt TrList}. The translation arguments should -! be identical in length to the {\tt rList} but with the correct {\tt aVout} -! name subsititued at the appropriate place. -! -! If the optional argument {\tt Vector} is present and true, the vector -! architecture-friendly portions of this routine will be invoked. -! -! {\bf N.B.:} This routine will fail if the {\tt aVout} is not initialized or -! if any of the specified attributes are not present in either {\tt aVout} or {\tt aVin}. -! -! !INTERFACE: - - subroutine RCopyL_(aVin, aVout, rList, TrList, vector) - -! -! !USES: -! - use m_die , only : die - use m_stdio , only : stderr - - use m_List, only : GetSharedListIndices - use m_List, only : GetIndices => get_indices - - implicit none - -! !INPUT PARAMETERS: - - type(AttrVect), intent(in) :: aVin - character(len=*), intent(in) :: rList - character(len=*), optional, intent(in) :: TrList - logical, optional, intent(in) :: vector - -! !OUTPUT PARAMETERS: - - type(AttrVect), intent(inout) :: aVout - - -! !REVISION HISTORY: -! 16Aug06 - R. Jacob - initial version from breakup -! of Copy_. -! -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::RCopyL_' - - integer :: i,j,ier ! dummy variables - integer :: num_indices ! Overlapping attribute index number - integer :: aVsize ! The lsize of aVin and aVout - integer :: num_inindices, num_outindices ! Number of matching indices in aV - integer :: inxmin, outxmin, inx, outx ! Index variables - logical :: TrListIsPresent ! true if list argument is present - logical :: contiguous ! true if index segments are contiguous in memory - logical :: usevector ! true if vector flag is present and true. - character*7 :: data_flag ! character variable used as data type flag - - ! Overlapping attribute index storage arrays: - integer, dimension(:), pointer :: aVinindices, aVoutindices - - - ! Check the arguments - aVsize = lsize_(aVin) - if(lsize_(aVin) /= lsize_(aVout)) then - write(stderr,'(2a)') myname_, & - 'MCTERROR: Input aV and output aV do not have the same size' - call die(myname_,'MCTERROR: Input aV and output aV & - &do not have the same size',2) - endif - - if(len_trim(rList) <= 0) return - ! Copy the listed real attributes - - ! Index rList with the AttrVects - call GetIndices(aVinindices,aVin%rList,trim(rList)) - -! TrList is present if it is provided and its length>0 - TrListIsPresent = .false. - if(present(TrList)) then - if(len_trim(TrList) > 0) then - TrListIsPresent = .true. - endif - endif - - if(TrListIsPresent) then - call GetIndices(aVoutindices,aVout%rList,trim(TrList)) - - if(size(aVinindices) /= size(aVoutindices)) then - call die(myname_,"Arguments rList and TrList do not& - &contain the same number of items") - endif - else - call GetIndices(aVoutindices,aVout%rList,trim(rList)) - endif - - num_indices=size(aVoutindices) - - ! nothing to do if num_indices <=0 - if (num_indices <= 0) then - deallocate(aVinindices, aVoutindices, stat=ier) - if(ier/=0) call die(myname_,"deallocate(aVinindices...)",ier) - return - endif - - ! check vector flag. - usevector = .false. - if (present(vector)) then - if(vector) usevector = .true. - endif - -! Check if the indices are contiguous in memory for faster copy - contiguous=.true. - do i=2,num_indices - if(aVinindices(i) /= aVinindices(i-1)+1) contiguous = .false. - enddo - if(contiguous) then - do i=2,num_indices - if(aVoutindices(i) /= aVoutindices(i-1)+1) contiguous=.false. - enddo - endif - -! Start copying (arranged loop order optimized for xlf90) - if(contiguous) then - - if(usevector) then - outxmin=aVoutindices(1)-1 - inxmin=aVinindices(1)-1 -!$OMP PARALLEL DO PRIVATE(i,j) - do i=1,num_indices -!DIR$ CONCURRENT - do j=1,aVsize - aVout%rAttr(outxmin+i,j) = aVin%rAttr(inxmin+i,j) - enddo - enddo - else - outxmin=aVoutindices(1)-1 - inxmin=aVinindices(1)-1 -!$OMP PARALLEL DO PRIVATE(j,i) - do j=1,aVsize -!DIR$ CONCURRENT - do i=1,num_indices - aVout%rAttr(outxmin+i,j) = aVin%rAttr(inxmin+i,j) - enddo - enddo - endif - - else - -!$OMP PARALLEL DO PRIVATE(j,i,outx,inx) - do j=1,aVsize -!DIR$ CONCURRENT - do i=1,num_indices - outx=aVoutindices(i) - inx=aVinindices(i) - aVout%rAttr(outx,j) = aVin%rAttr(inx,j) - enddo - enddo - - endif - - deallocate(aVinindices, aVoutindices, stat=ier) - if(ier/=0) call die(myname_,"deallocate(aVinindices...)",ier) - - end subroutine RCopyL_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: ICopy_ - Copy Integer Attributes from One AttrVect to Another -! -! !DESCRIPTION: -! This routine copies from input argment {\tt aVin} into the output -! {\tt AttrVect} argument {\tt aVout} the shared integer attributes. -! -! If the optional argument {\tt Vector} is present and true, the vector -! architecture-friendly portions of this routine will be invoked. -! -! If the optional argument {\tt sharedIndices} is present, it should be -! the result of the call {\tt SharedIndicesOneType\_(aVin, aVout, 'INTEGER', -! sharedIndices)}. Providing this argument speeds up this routine -! substantially. For example, you can compute a {\tt sharedIndices} -! structure once for a given pair of {\tt AttrVect}s, then use that same -! structure for all copies between those two {\tt AttrVect}s (although -! note that a different {\tt sharedIndices} variable would be needed if -! {\tt aVin} and {\tt aVout} were reversed). -! -! {\bf N.B.:} This routine will fail if the {\tt aVout} is not initialized. -! -! !INTERFACE: - - subroutine ICopy_(aVin, aVout, vector, sharedIndices) - -! -! !USES: -! - use m_die , only : die - use m_stdio , only : stderr - - use m_List, only : GetSharedListIndices - use m_List, only : GetIndices => get_indices - - implicit none - -! !INPUT PARAMETERS: - - type(AttrVect), intent(in) :: aVin - logical, optional, intent(in) :: vector - type(AVSharedIndicesOneType), optional, intent(in) :: sharedIndices - -! !OUTPUT PARAMETERS: - - type(AttrVect), intent(inout) :: aVout - - -! !REVISION HISTORY: -! 16Aug06 - R. Jacob - initial version. -! 28Apr11 - W.J. Sacks - added sharedIndices argument -! -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::ICopy_' - - integer :: i,j,ier ! dummy variables - integer :: aVsize ! The lsize of aVin and aVout - integer :: num_inindices, num_outindices ! Number of matching indices in aV - integer :: inxmin, outxmin, inx, outx ! Index variables - logical :: usevector ! true if vector flag is present and true. - character*7 :: data_flag ! character variable used as data type flag - type(AVSharedIndicesOneType) :: mySharedIndices ! copied from sharedIndices, or - ! computed if sharedIndices is not - ! present - logical :: clean_mySharedIndices ! true if we need to clean mySharedIndices before - ! returning (will be true if we did allocation in this - ! subroutine) - - - ! Check the arguments - aVsize = lsize_(aVin) - if(lsize_(aVin) /= lsize_(aVout)) then - write(stderr,'(2a)') myname_, & - 'MCTERROR: Input aV and output aV do not have the same size' - call die(myname_,'MCTERROR: Input aV and output aV & - &do not have the same size',2) - endif - - data_flag = 'INTEGER' - - if (present(sharedIndices)) then - ! do some error checking on sharedIndices - if (.not. (associated(sharedIndices%aVindices1) .and. associated(sharedIndices%aVindices2))) then - call die(myname_,'MCTERROR: provided sharedIndices structure is uninitialized',3) - endif - if (trim(sharedIndices%data_flag) /= data_flag) then - call die(myname_,'MCTERROR: provided sharedIndices structure has incorrect data_flag',4) - endif - - ! copy into local variable - mySharedIndices = sharedIndices - clean_mySharedIndices = .false. - else - ! Check INTEGER attributes for matching indices - call SharedIndicesOneType_(aVin, aVout, data_flag, mySharedIndices) - clean_mySharedIndices = .true. - endif - - if(mySharedIndices%num_indices <= 0) then - if (clean_mySharedIndices) then - call cleanSharedIndicesOneType_(mySharedIndices,stat=ier) - if(ier /= 0) call die(myname_,'MCTERROR: in cleanSharedIndicesOneType_',ier) - endif - return - endif - - ! check vector flag. - usevector = .false. - if (present(vector)) then - if(vector) usevector = .true. - endif - - - if(mySharedIndices%contiguous) then - - if(usevector) then - outxmin=mySharedIndices%aVindices2(1)-1 - inxmin=mySharedIndices%aVindices1(1)-1 -!$OMP PARALLEL DO PRIVATE(i,j) - do i=1,mySharedIndices%num_indices -!CDIR SELECT(VECTOR) -!DIR$ CONCURRENT - do j=1,aVsize - aVout%iAttr(outxmin+i,j) = aVin%iAttr(inxmin+i,j) - enddo - enddo - else - outxmin=mySharedIndices%aVindices2(1)-1 - inxmin=mySharedIndices%aVindices1(1)-1 -!$OMP PARALLEL DO PRIVATE(j,i) - do j=1,aVsize -!DIR$ CONCURRENT - do i=1,mySharedIndices%num_indices - aVout%iAttr(outxmin+i,j) = aVin%iAttr(inxmin+i,j) - enddo - enddo - endif - - else - -!$OMP PARALLEL DO PRIVATE(j,i,outx,inx) - do j=1,aVsize -!DIR$ CONCURRENT - do i=1,mySharedIndices%num_indices - outx=mySharedIndices%aVindices2(i) - inx=mySharedIndices%aVindices1(i) - aVout%iAttr(outx,j) = aVin%iAttr(inx,j) - enddo - enddo - - endif - - if (clean_mySharedIndices) then - call cleanSharedIndicesOneType_(mySharedIndices,stat=ier) - if(ier /= 0) call die(myname_,'MCTERROR: in cleanSharedIndicesOneType_',ier) - endif - - end subroutine ICopy_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: ICopyL_ - Copy Specific Integer Attributes from One AttrVect to Another -! -! !DESCRIPTION: -! This routine copies from input argment {\tt aVin} into the output -! {\tt AttrVect} argument {\tt aVout} the integer attributes specified in -! input {\tt CHARACTER} argument {\tt iList}. The attributes can -! be listed in any order. -! -! If any attributes in {\tt aVout} have different names but represent the -! the same quantity and should still be copied, you must provide a translation -! argument {\tt TiList}. The translation arguments should -! be identical in length to the {\tt iList} but with the correct {\tt aVout} -! name subsititued at the appropriate place. -! -! If the optional argument {\tt Vector} is present and true, the vector -! architecture-friendly portions of this routine will be invoked. -! -! {\bf N.B.:} This routine will fail if the {\tt aVout} is not initialized or -! if any of the specified attributes are not present in either {\tt aVout} or {\tt aVin}. -! -! !INTERFACE: - - subroutine ICopyL_(aVin, aVout, iList, TiList, vector) - -! -! !USES: -! - use m_die , only : die - use m_stdio , only : stderr - - use m_List, only : GetIndices => get_indices - - implicit none - -! !INPUT PARAMETERS: - - type(AttrVect), intent(in) :: aVin - character(len=*) , intent(in) :: iList - character(len=*), optional, intent(in) :: TiList - logical, optional, intent(in) :: vector - -! !OUTPUT PARAMETERS: - - type(AttrVect), intent(inout) :: aVout - - -! !REVISION HISTORY: -! 16Aug06 - R. Jacob - initial version from breakup -! of Copy_. -! -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::ICopyL_' - - integer :: i,j,ier ! dummy variables - integer :: num_indices ! Overlapping attribute index number - integer :: aVsize ! The lsize of aVin and aVout - integer :: num_inindices, num_outindices ! Number of matching indices in aV - integer :: inxmin, outxmin, inx, outx ! Index variables - logical :: TiListIsPresent ! true if list argument is present - logical :: contiguous ! true if index segments are contiguous in memory - logical :: usevector ! true if vector flag is present and true. - character*7 :: data_flag ! character variable used as data type flag - - ! Overlapping attribute index storage arrays: - integer, dimension(:), pointer :: aVinindices, aVoutindices - - - ! Check the arguments - aVsize = lsize_(aVin) - if(lsize_(aVin) /= lsize_(aVout)) then - write(stderr,'(2a)') myname_, & - 'MCTERROR: Input aV and output aV do not have the same size' - call die(myname_,'MCTERROR: Input aV and output aV & - &do not have the same size',2) - endif - - if(len_trim(iList) <= 0) return - ! Copy the listed real attributes - - -! Index rList with the AttrVects - call GetIndices(aVinindices,aVin%iList,trim(iList)) - -! TiList is present if its provided and its length>0 - TiListIsPresent = .false. - if(present(TiList)) then - if(len_trim(TiList) > 0) then - TiListIsPresent = .true. - endif - endif - - if(TiListIsPresent) then - call GetIndices(aVoutindices,aVout%iList,trim(TiList)) - if(size(aVinindices) /= size(aVoutindices)) then - call die(myname_,"Arguments iList and TiList do not& - &contain the same number of items") - endif - else - call GetIndices(aVoutindices,aVout%iList,trim(iList)) - endif - - num_indices=size(aVoutindices) - - ! nothing to do if num_indices <=0 - if (num_indices <= 0) then - deallocate(aVinindices, aVoutindices, stat=ier) - if(ier/=0) call die(myname_,"deallocate(aVinindices...)",ier) - return - endif - - ! check vector flag. - usevector = .false. - if (present(vector)) then - if(vector) usevector = .true. - endif - -! Check if the indices are contiguous in memory for faster copy - contiguous=.true. - do i=2,num_indices - if(aVinindices(i) /= aVinindices(i-1)+1) contiguous = .false. - enddo - if(contiguous) then - do i=2,num_indices - if(aVoutindices(i) /= aVoutindices(i-1)+1) contiguous=.false. - enddo - endif - -! Start copying (arranged loop order optimized for xlf90) - if(contiguous) then - - if(usevector) then - outxmin=aVoutindices(1)-1 - inxmin=aVinindices(1)-1 -!$OMP PARALLEL DO PRIVAtE(i,j) - do i=1,num_indices -!CDIR SELECT(VECTOR) -!DIR$ CONCURRENT - do j=1,aVsize - aVout%iAttr(outxmin+i,j) = aVin%iAttr(inxmin+i,j) - enddo - enddo - else - outxmin=aVoutindices(1)-1 - inxmin=aVinindices(1)-1 -!$OMP PARALLEL DO PRIVATE(j,i) - do j=1,aVsize -!DIR$ CONCURRENT - do i=1,num_indices - aVout%iAttr(outxmin+i,j) = aVin%iAttr(inxmin+i,j) - enddo - enddo - endif - - else - -!$OMP PARALLEL DO PRIVATE(j,i,outx,inx) - do j=1,aVsize -!DIR$ CONCURRENT - do i=1,num_indices - outx=aVoutindices(i) - inx=aVinindices(i) - aVout%iAttr(outx,j) = aVin%iAttr(inx,j) - enddo - enddo - - endif - - deallocate(aVinindices, aVoutindices, stat=ier) - if(ier/=0) call die(myname_,"deallocate(aVinindices...)",ier) - - end subroutine ICopyL_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: Copy_ - Copy Real and Integer Attributes from One AttrVect to Another -! -! !DESCRIPTION: -! This routine copies from input argment {\tt aVin} into the output -! {\tt AttrVect} argument {\tt aVout} the real and integer attributes specified in -! input {\tt CHARACTER} argument {\tt iList} and {\tt rList}. The attributes can -! be listed in any order. If neither {\tt iList} nor {\tt rList} are provided, -! all attributes shared between {\tt aVin} and {\tt aVout} will be copied. -! -! If any attributes in {\tt aVout} have different names but represent the -! the same quantity and should still be copied, you must provide a translation -! argument {\tt TrList} and/or {\tt TiList}. The translation arguments should -! be identical to the {\tt rList} or {\tt iList} but with the correct {\tt aVout} -! name subsititued at the appropriate place. -! -! This routines combines the functions of {\tt RCopy\_}, {\tt RCopyL\_}, -! {\tt ICopy\_} and {\tt ICopyL\_}. If you know you only want to copy real -! attributes, use the {\tt RCopy} functions. If you know you only want to -! copy integer attributes, use the {\tt ICopy} functions. -! -! If the optional argument {\tt Vector} is present and true, the vector -! architecture-friendly portions of this routine will be invoked. -! -! If the optional argument {\tt sharedIndices} is present, it should be -! the result of the call {\tt SharedIndices\_(aVin, aVout, -! sharedIndices)}. Providing this argument speeds up this routine -! substantially. For example, you can compute a {\tt sharedIndices} -! structure once for a given pair of {\tt AttrVect}s, then use that same -! structure for all copies between those two {\tt AttrVect}s (although -! note that a different {\tt sharedIndices} variable would be needed if -! {\tt aVin} and {\tt aVout} were reversed). Note, however, that {\tt -! sharedIndices} is ignored if either {\tt rList} or {\tt iList} are -! given. -! -! {\bf N.B.:} This routine will fail if the {\tt aVout} is not initialized or -! if any of the specified attributes are not present in either {\tt aVout} or {\tt aVin}. -! -! !INTERFACE: - - subroutine Copy_(aVin, aVout, rList, TrList, iList, TiList, vector, sharedIndices) - -! -! !USES: -! - use m_die , only : die, warn - use m_stdio , only : stderr - - use m_List, only : GetSharedListIndices - use m_List, only : GetIndices => get_indices - - implicit none - -! !INPUT PARAMETERS: - - type(AttrVect), intent(in) :: aVin - character(len=*), optional, intent(in) :: iList - character(len=*), optional, intent(in) :: rList - character(len=*), optional, intent(in) :: TiList - character(len=*), optional, intent(in) :: TrList - logical, optional, intent(in) :: vector - type(AVSharedIndices), optional, intent(in) :: sharedIndices - -! !OUTPUT PARAMETERS: - - type(AttrVect), intent(inout) :: aVout - - -! !REVISION HISTORY: -! 12Jun02 - R. Jacob - initial version. -! 13Jun02 - R. Jacob - copy shared attributes -! if no attribute lists are specified. -! 30Sep02 - R. Jacob - new argument order with all -! optional arguments last -! 19Feb02 - E. Ong - new implementation using -! new list function get_indices and faster memory copy -! 28Oct03 - R. Jacob - add optional vector -! argument to use vector-friendly code provided by Fujitsu -! 16Aug06 - R. Jacob - split into 4 routines: -! RCopy_,RCopyL_,ICopy_,ICopyL_ -! 28Apr11 - W.J. Sacks - added sharedIndices argument -! -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::Copy_' - - integer :: i,j,ier ! dummy variables - integer :: num_indices ! Overlapping attribute index number - integer :: aVsize ! The lsize of aVin and aVout - integer :: num_inindices, num_outindices ! Number of matching indices in aV - integer :: inxmin, outxmin, inx, outx ! Index variables - logical :: TiListIsPresent, TrListIsPresent! true if list argument is present - logical :: contiguous ! true if index segments are contiguous in memory - logical :: usevector ! true if vector flag is present and true. - character*7 :: data_flag ! character variable used as data type flag - - ! Overlapping attribute index storage arrays: - integer, dimension(:), pointer :: aVinindices, aVoutindices - - - ! Check the arguments - aVsize = lsize_(aVin) - if(lsize_(aVin) /= lsize_(aVout)) then - write(stderr,'(2a)') myname_, & - 'MCTERROR: Input aV and output aV do not have the same size' - call die(myname_,'MCTERROR: Input aV and output aV & - &do not have the same size',2) - endif - - ! check vector flag. - usevector = .false. - if (present(vector)) then - if(vector) usevector = .true. - endif - - ! Copy the listed real attributes - if(present(rList)) then - ! TrList is present if it is provided and its length>0 - TrListIsPresent = .false. - if(present(TrList)) then - if(len_trim(TrList) > 0) then - TrListIsPresent = .true. - endif - endif - - if(present(sharedIndices)) then - call warn(myname_,'Use of sharedIndices not implemented in RCopyL; & - &ignoring sharedIndices',1) - end if - - if(TrListIsPresent) then - call RCopyL_(aVin,aVout,rList,TrList,vector=usevector) - else - call RCopyL_(aVin,aVout,rList,vector=usevector) - endif - - endif ! if(present(rList) - - ! Copy the listed integer attributes - if(present(iList)) then - - ! TiList is present if its provided and its length>0 - TiListIsPresent = .false. - if(present(TiList)) then - if(len_trim(TiList) > 0) then - TiListIsPresent = .true. - endif - endif - - if(present(sharedIndices)) then - call warn(myname_,'Use of sharedIndices not implemented in ICopyL; & - &ignoring sharedIndices',1) - end if - - if(TiListIsPresent) then - call ICopyL_(aVin,aVout,iList,TiList,vector=usevector) - else - call ICopyL_(aVin,aVout,iList,vector=usevector) - endif - - endif ! if(present(iList)) - - ! If neither rList nor iList is present, copy shared attibutes - ! from in to out. - if( .not.present(rList) .and. .not.present(iList)) then - - if (present(sharedIndices)) then - call RCopy_(aVin, Avout, vector=usevector, sharedIndices=sharedIndices%shared_real) - call ICopy_(aVin, Avout, vector=usevector, sharedIndices=sharedIndices%shared_integer) - else - call RCopy_(aVin, Avout, vector=usevector) - call ICopy_(aVin, Avout, vector=usevector) - endif - - endif - - end subroutine Copy_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: Sort_ - Use Attributes as Keys to Generate an Index Permutation -! -! !DESCRIPTION: -! The subroutine {\tt Sort\_()} uses a list of keys defined by the {\tt List} -! {\tt key\_list}, searches for the appropriate integer or real attributes -! referenced by the items in {\tt key\_list} ( that is, it identifies the -! appropriate entries in {aV\%iList} and {\tt aV\%rList}), and then -! uses these keys to generate a permutation {\tt perm} that will put -! the entries of the attribute vector {\tt aV} in lexicographic order -! as defined by {\tt key\_list} (the ordering in {\tt key\_list} being from -! left to right. -! -! {\bf N.B.:} This routine will fail if {\tt aV\%iList} and -! {\tt aV\%rList} share one or more common entries. -! -! {\bf N.B.:} This routine will fail if one of the sorting keys presented is -! not present in {\tt aV\%iList} nor {\tt aV\%rList}. -! -! !INTERFACE: - - subroutine Sort_(aV, key_list, perm, descend, perrWith, dieWith) -! -! !USES: -! - use m_String, only : String - use m_String, only : String_tochar => tochar - use m_String, only : String_clean => clean - use m_List , only : List_allocated => allocated - use m_List , only : List_index => index - use m_List , only : List_nitem => nitem - use m_List , only : List_get => get - use m_die , only : die - use m_stdio , only : stderr - use m_SortingTools , only : IndexSet - use m_SortingTools , only : IndexSort - - implicit none - -! !INPUT PARAMETERS: -! - type(AttrVect), intent(in) :: aV - type(List), intent(in) :: key_list - logical, dimension(:), optional, intent(in) :: descend - character(len=*), optional, intent(in) :: perrWith - character(len=*), optional, intent(in) :: dieWith - -! !OUTPUT PARAMETERS: -! - integer, dimension(:), pointer :: perm - - -! !REVISION HISTORY: -! 20Oct00 - J.W. Larson - initial prototype -! 25Apr01 - R.L. Jacob - add -1 to make a -! backwards loop go backwards -! 14Jun01 - J. Larson / E. Ong -- Fixed logic bug in REAL attribute -! sort (discovered by E. Ong), and cleaned up error / -! shutdown logic. -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::Sort_' - -! local variables - - ! storage for key extracted from key_list: - - type(String) :: key - - ! number of keys, loop index, error flag, and length: - - integer :: nkeys, n, ierr, length - - ! key indices for av%rAttr and av%iAttr, respectively: - - integer, dimension(:), allocatable :: rIndex, iIndex - - ! copy of descend argument - - logical, dimension(:), allocatable :: descend_copy - - ! count the sorting keys: - - nkeys = List_nitem(key_list) - - ! Check the descend argument. Note: the unnecessary copy - ! circumvents an optimization bug in the compaq compiler - - if(present(descend)) then - if(size(descend)/=nkeys) then - call die(myname_,"Size of descend argument is not equal & - &to the number of keys") - endif - allocate(descend_copy(nkeys),stat=ierr) - if(ierr/=0) call die(myname_,"allocate(descend_copy)",ierr) - descend_copy=descend - endif - - - ! allocate and initialize rIndex and iIndex to - ! zero (the null return values from the functions - ! indexRA_() and indexIA_() ). - - allocate(rIndex(nkeys), iIndex(nkeys), stat=ierr) - if(ierr/=0) call die(myname_,"allocate(rindex,iIndex)",ierr) - - rIndex = 0 - iIndex = 0 - - ! Loop over the keys in the list, and identify the - ! appropriate integer or real attribute, storing the - ! attribute index in iIndex(:) or rIndex(:), respectively. - - do n = 1, nkeys - - ! grab the next key - - call List_get(key, n, key_list) - - ! determine wheter this key refers to an - ! integer or real attribute: -! jwl commented out in favor of below code block unitl an error -! handling strategy is settled upon for indexIA_() and indexRA_(). -! rIndex(n) = indexRA_(aV, String_tochar(key), dieWith=myname_) -! iIndex(n) = indexIA_(aV, String_tochar(key), dieWith=myname_) - - if(List_allocated(aV%rList)) then - rIndex(n) = List_index(aV%rList, String_tochar(key)) - else - rIndex(n) = 0 - endif - if(List_allocated(aV%iList)) then - iIndex(n) = List_index(aV%iList, String_tochar(key)) - else - iIndex(n) = 0 - endif - - ! If both rIndex(n) and iIndex(n) are greater than - ! zero, then we have an integer attribute sharing - ! the same name as a real attribute, and there is - ! no clear path as to which one is the sort key. - ! This is a fatal error that triggers shutdown. - - if ((rIndex(n) > 0) .and. (iIndex(n) > 0)) then - if(.not.present(dieWith)) then - if(present(perrWith)) write(stderr,'(4a)') myname, & - ":: ambiguous key, ", perrWith, & - " both iIndex(n) and rIndex(n) positive." - call die(myname_,":: both iIndex(n) and rIndex(n) > 0.") - else - if(present(perrWith)) then - write(stderr,'(4a)') myname_,":: ", perrWith, & - " both iIndex(n) and rIndex(n) positive." - endif - call die(myname_,dieWith) - endif - endif - - ! If both rIndex(n) and iIndex(n) are nonpositive, - ! then the requested sort key is not present in either - ! aV%rList or aV%iList, and we cannot perform the sort. - ! This is a fatal error that triggers shutdown. - - if ((rIndex(n) <= 0) .and. (iIndex(n) <= 0)) then - if(.not.present(dieWith)) then - if(present(perrWith)) write(stderr,'(4a)') myname,":: ", & - perrWith, & - " both iIndex(n) and rIndex(n) nonpositive" - call die(myname_,":: both iIndex(n) and rIndex(n) <= 0.") - else - if(present(perrWith)) then - write(stderr,'(4a)') myname_,":: ", perrWith, & - " both iIndex(n) and rIndex(n) nonpositive" - endif - call die(myname_,dieWith) - endif - endif - - ! If only one of rIndex(n) or iIndex(n) is positive, - ! set the other value to zero. - - if (iIndex(n) > 0) rIndex(n) = 0 - if (rIndex(n) > 0) iIndex(n) = 0 - - ! Clean up temporary string -key- - - call String_clean(key) - - enddo ! do n=1,nkeys - - ! Now we have the locations of the keys in the integer and - ! real attribute storage areas aV%iAttr and aV%rAttr, respectively. - ! our next step is to construct and initialize the permutation - ! array perm. First step--determine the length of aV using - ! lsize_(): - - length = lsize_(aV) - - allocate(perm(length), stat=ierr) - if(ierr/=0) call die(myname_,"allocate(perm)",ierr) - - ! Initialize perm(i)=i, for i=1,length - - call IndexSet(perm) - - ! Now we can perform the stable successive keyed sorts to - ! transform perm into the permutation that will place the - ! entries of the attribute arrays in the lexicographic order - ! defined by key_list. This is achieved by successive calls to - ! IndexSort(), but in reverse order to the order of the keys - ! as they appear in key_list. - - do n=nkeys, 1, -1 - if(iIndex(n) > 0) then - if(present(descend)) then - call IndexSort(length, perm, aV%iAttr(iIndex(n),:), & - descend_copy(n)) - else - call IndexSort(length, perm, aV%iAttr(iIndex(n),:), & - descend=.false.) - endif ! if(present(descend)... - else - if(rIndex(n) > 0) then - if(present(descend)) then - call IndexSort(length, perm, aV%rAttr(rIndex(n),:), & - descend_copy(n)) - else - call IndexSort(length, perm, aV%rAttr(rIndex(n),:), & - descend=.false.) - endif ! if(present(descend)... - endif ! if (rIndex(n) > 0)... - endif ! if (iIndex(n) > 0)... - enddo - - ! Now perm(1:length) is the transformation we seek--we are - ! finished. - - deallocate(iIndex, rIndex, stat=ierr) ! clean up allocated arrays. - if(ierr/=0) call die(myname_,"deallocate(iIndex,rIndex)",ierr) - - if(present(descend)) deallocate(descend_copy,stat=ierr) - if(ierr/=0) call die(myname_,"deallocate(descend_copy)",ierr) - - end subroutine Sort_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: Permute_ - Permute AttrVect Elements -! -! !DESCRIPTION: -! The subroutine {\tt Permute\_()} uses a a permutation {\tt perm} (which can -! be generated by the routine {\tt Sort\_()} in this module) to rearrange -! the entries in the attribute integer and real storage areas of the -! input attribute vector {\tt aV}--{\tt aV\%iAttr} and {\tt aV\%rAttr}, -! respectively. -! -! !INTERFACE: - - subroutine Permute_(aV, perm, perrWith, dieWith) -! -! !USES: -! - use m_die , only : die - use m_stdio , only : stderr - use m_SortingTools , only : Permute - - implicit none - -! !INPUT PARAMETERS: -! - integer, dimension(:), intent(in) :: perm - character(len=*), optional, intent(in) :: perrWith - character(len=*), optional, intent(in) :: dieWith - -! !INPUT/OUTPUT PARAMETERS: -! - type(AttrVect), intent(inout) :: aV - -! !REVISION HISTORY: -! 23Oct00 - J.W. Larson - initial prototype -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::Permute_' - -! local variables - - integer :: i - - ! Check input arguments for compatibility--assure - ! lsize_(aV) = size(perm); that is, make sure the - ! index permutation is the same length as the vectors - ! it will re-arrange. - - if (size(perm) /= lsize_(aV)) then - if(.not.present(dieWith)) then - if(present(perrWith)) write(stderr,'(4a,i8,a,i8)') myname, & - ":: size mismatch, ", perrWith, & - "size(perm)=",size(perm)," lsize_(aV)=",lsize_(aV) - else - write(stderr,'(4a,i8,a,i8)') myname, & - ":: size mismatch, ", dieWith, & - "size(perm)=",size(perm)," lsize_(aV)=",lsize_(aV) - call die(dieWith) - endif - endif - - if(size(perm) == lsize_(aV)) then - - ! Permute integer attributes: - if(nIAttr_(aV) /= 0) then - do i=1,nIAttr_(aV) - call Permute(aV%iAttr(i,:),perm,lsize_(aV)) - end do - endif - - ! Permute real attributes: - if(nRAttr_(aV) /= 0) then - do i=1,nRAttr_(aV) - call Permute(aV%rAttr(i,:),perm,lsize_(aV)) - end do - endif - - endif - - end subroutine Permute_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: Unpermute_ - Unpermute AttrVect Elements -! -! !DESCRIPTION: -! The subroutine {\tt Unpermute\_()} uses a a permutation {\tt perm} (which can -! be generated by the routine {\tt Sort\_()} in this module) to rearrange -! the entries in the attribute integer and real storage areas of the -! input attribute vector {\tt aV}--{\tt aV\%iAttr} and {\tt aV\%rAttr}, -! respectively. This is meant to be called on an {\tt aV} that has already -! been permuted but it could also be used to perform the inverse operation -! implied by {\tt perm} on an unpermuted {\tt aV}. -! -! !INTERFACE: - - subroutine Unpermute_(aV, perm, perrWith, dieWith) -! -! !USES: -! - use m_die , only : die - use m_stdio , only : stderr - use m_SortingTools , only : Unpermute - - implicit none - -! !INPUT PARAMETERS: -! - integer, dimension(:), intent(in) :: perm - character(len=*), optional, intent(in) :: perrWith - character(len=*), optional, intent(in) :: dieWith - -! !INPUT/OUTPUT PARAMETERS: -! - type(AttrVect), intent(inout) :: aV - -! !REVISION HISTORY: -! 23Nov05 - R. Jacob - based on Permute -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::Unpermute_' - -! local variables - - integer :: i - - ! Check input arguments for compatibility--assure - ! lsize_(aV) = size(perm); that is, make sure the - ! index permutation is the same length as the vectors - ! it will re-arrange. - - if (size(perm) /= lsize_(aV)) then - if(.not.present(dieWith)) then - if(present(perrWith)) write(stderr,'(4a,i8,a,i8)') myname, & - ":: size mismatch, ", perrWith, & - "size(perm)=",size(perm)," lsize_(aV)=",lsize_(aV) - else - write(stderr,'(4a,i8,a,i8)') myname, & - ":: size mismatch, ", dieWith, & - "size(perm)=",size(perm)," lsize_(aV)=",lsize_(aV) - call die(dieWith) - endif - endif - - if(size(perm) == lsize_(aV)) then - - ! Unpermute integer attributes: - if(nIAttr_(aV) /= 0) then - do i=1,nIAttr_(aV) - call Unpermute(aV%iAttr(i,:),perm,lsize_(aV)) - end do - endif - - ! Permute real attributes: - if(nRAttr_(aV) /= 0) then - do i=1,nRAttr_(aV) - call Unpermute(aV%rAttr(i,:),perm,lsize_(aV)) - end do - endif - - endif - - end subroutine Unpermute_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: SortPermute_ - In-place Lexicographic Sort of an AttrVect -! -! !DESCRIPTION: -! -! The subroutine {\tt SortPermute\_()} uses the routine {\tt Sort\_()} -! to create an index permutation {\tt perm} that will place the AttrVect -! entries in the lexicographic order defined by the keys in the List -! variable {\tt key\_list}. This permutation is then used by the routine -! {\tt Permute\_()} to place the AttreVect entries in lexicographic order. -! -! !INTERFACE: - - subroutine SortPermute_(aV, key_list, descend, perrWith, dieWith) -! -! !USES: -! - use m_die , only : die - use m_stdio , only : stderr - - implicit none - -! !INPUT PARAMETERS: -! - type(List), intent(in) :: key_list - logical , dimension(:), optional, intent(in) :: descend - character(len=*), optional, intent(in) :: perrWith - character(len=*), optional, intent(in) :: dieWith - -! !INPUT/OUTPUT PARAMETERS: -! - type(AttrVect), intent(inout) :: aV - -! !REVISION HISTORY: -! 24Oct00 - J.W. Larson - initial prototype -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::Permute_' - -! local variables - - ! Permutation array pointer perm(:) - integer, dimension(:), pointer :: perm - ! Error flag ierr - integer :: ierr - - ! Step One: Generate the index permutation perm(:) - - if(present(descend)) then - call Sort_(aV, key_list, perm, descend, perrWith, dieWith) - else - call Sort_(aV, key_list, perm, perrWith=perrWith, & - dieWith=dieWith) - endif - - ! Step Two: Apply the index permutation perm(:) - - call Permute_(aV, perm, perrWith, dieWith) - - ! Step Three: deallocate temporary array used to - ! store the index permutation (this was allocated - ! in the routine Sort_() - - deallocate(perm, stat=ierr) - - end subroutine SortPermute_ - -! Sorting: -! -! aV%iVect(:,:) = & -! aV%iVect((/(indx(i),i=1,lsize(aV))/),:) -! -! aV%iVect((/(indx(i),i=1,lsize(aV))/),:) = & -! aV%iVect(:,:) -! -! aV%iVect(:,ikx),aV%iVect(:,iks) -! -! - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: aVaVSharedAttrIndexList_ - AttrVect shared attributes. -! -! !DESCRIPTION: {\tt aVaVSharedAttrIndexList\_()} takes a pair of -! user-supplied {\tt AttrVect} variables {\tt aV1} and {\tt aV2}, -! and for choice of either {\tt REAL} or {\tt INTEGER} attributes (as -! specified literally in the input {\tt CHARACTER} argument {\tt attrib}) -! returns the number of shared attributes {\tt NumShared}, and arrays of -! indices {\tt Indices1} and {\tt Indices2} to their storage locations -! in {\tt aV1} and {\tt aV2}, respectively. -! -! {\bf N.B.:} This routine returns two allocated arrays---{\tt Indices1(:)} -! and {\tt Indices2(:)}---which must be deallocated once the user no longer -! needs them. Failure to do this will create a memory leak. -! -! !INTERFACE: - - subroutine aVaVSharedAttrIndexList_(aV1, aV2, attrib, NumShared, & - Indices1, Indices2) - -! -! !USES: -! - use m_stdio - use m_die, only : MP_perr_die, die, warn - - use m_List, only : GetSharedListIndices - - implicit none - -! !INPUT PARAMETERS: -! - type(AttrVect), intent(in) :: aV1 - type(AttrVect), intent(in) :: aV2 - character(len=*), intent(in) :: attrib - -! !OUTPUT PARAMETERS: -! - integer, intent(out) :: NumShared - integer, dimension(:), pointer :: Indices1 - integer, dimension(:), pointer :: Indices2 - -! !REVISION HISTORY: -! 07Feb01 - J.W. Larson - initial version -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::aVaVSharedAttrIndexList_' - - integer :: ierr - - ! Based on the value of the argument attrib, pass the - ! appropriate pair of Lists for comparison... - - select case(trim(attrib)) - case('REAL','real') - call GetSharedListIndices(aV1%rList, aV2%rList, NumShared, & - Indices1, Indices2) - case('INTEGER','integer') - call GetSharedListIndices(aV1%iList, aV2%iList, NumShared, & - Indices1, Indices2) - case default - write(stderr,'(4a)') myname_,":: value of argument attrib=",attrib, & - " not recognized. Allowed values: REAL, real, INTEGER, integer" - ierr = 1 - call die(myname_, 'invalid value for attrib', ierr) - end select - - end subroutine aVaVSharedAttrIndexList_ - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Climate and Global Dynamics Division, National Center for Atmospheric Research ! -!BOP ----------------------------------------------------------------------------- -! -! !IROUTINE: SharedIndices_ - AttrVect shared attributes and auxiliary information -! -! !DESCRIPTION: {\tt SharedIndices\_()} takes a pair of user-supplied -! {\tt AttrVect} variables {\tt aV1} and {\tt aV2}, and returns a -! structure of type {\tt AVSharedIndices} ({\tt sharedIndices}). This -! structure contains arrays of indices to the locations of the shared -! attributes, as well as auxiliary information. The structure contains -! information on both the {\tt REAL} and {\tt INTEGER} attributes. See -! documentation for the {\tt SharedIndicesOneType\_} subroutine for some -! additional details, as much of the work is done there. -! -! {\bf N.B.:} The returned structure, {\tt sharedIndices}, contains -! allocated arrays that must be deallocated once the user no longer -! needs them. This should be done through a call to {\tt -! cleanSharedIndices\_}. -! -! !INTERFACE: - - subroutine SharedIndices_(aV1, aV2, sharedIndices) - - implicit none - -! !INPUT PARAMETERS: -! - type(AttrVect), intent(in) :: aV1 - type(AttrVect), intent(in) :: aV2 - -! !INPUT/OUTPUT PARAMETERS: -! - type(AVSharedIndices), intent(inout) :: sharedIndices - -! !REVISION HISTORY: -! 28Apr11 - W.J. Sacks - initial version -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::SharedIndices_' - - call SharedIndicesOneType_(aV1, aV2, 'REAL', sharedIndices%shared_real) - call SharedIndicesOneType_(aV1, aV2, 'INTEGER', sharedIndices%shared_integer) - - end subroutine SharedIndices_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Climate and Global Dynamics Division, National Center for Atmospheric Research ! -!BOP ----------------------------------------------------------------------------- -! -! !IROUTINE: SharedIndicesOneType_ - AttrVect shared attributes and auxiliary information, for one data type -! -! !DESCRIPTION: {\tt SharedIndicesOneType\_()} takes a pair of -! user-supplied {\tt AttrVect} variables {\tt aV1} and {\tt aV2}, and -! for choice of either {\tt REAL} or {\tt INTEGER} attributes (as -! specified literally in the input {\tt CHARACTER} argument {\tt -! attrib}) returns a structure of type {\tt AVSharedIndicesOneType} ({\tt -! sharedIndices}). This structure contains arrays of indices to the -! locations of the shared attributes of the given type, as well as -! auxiliary information. -! -! The {\tt aVindices1} and {\tt aVindices2} components of {\tt -! sharedIndices} will be indices into {\tt aV1} and {\tt aV2}, -! respectively. -! -! {\bf N.B.:} The returned structure, {\tt sharedIndices}, contains -! allocated arrays that must be deallocated once the user no longer -! needs them. This should be done through a call to {\tt -! cleanSharedIndicesOneType\_}. Even if there are no attributes in -! common between {\tt aV1} and {\tt aV2}, {\tt sharedIndices} will still -! be initialized, and memory will still be allocated. Furthermore, if an -! already-initialized {\tt sharedIndices} variable is to be given new -! values, {\tt cleanSharedIndicesOneType\_} must be called before {\tt -! SharedIndicesOneType\_} is called a second time, in order to prevent a -! memory leak. -! -! !INTERFACE: - - subroutine SharedIndicesOneType_(aV1, aV2, attrib, sharedIndices) - - implicit none - -! !INPUT PARAMETERS: -! - type(AttrVect), intent(in) :: aV1 - type(AttrVect), intent(in) :: aV2 - character(len=*), intent(in) :: attrib - -! !INPUT/OUTPUT PARAMETERS: -! - type(AVSharedIndicesOneType), intent(inout) :: sharedIndices - -! !REVISION HISTORY: -! 28Apr11 - W.J. Sacks - initial version -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::SharedIndicesOneType_' - integer :: i - - ! Check appropriate attributes (real or integer) for matching indices - call aVaVSharedAttrIndexList_(aV1, aV2, attrib, sharedIndices%num_indices, & - sharedIndices%aVindices1, sharedIndices%aVindices2) - - sharedIndices%data_flag = attrib - - ! Check indices for contiguous segments in memory - sharedIndices%contiguous=.true. - do i=2,sharedIndices%num_indices - if(sharedIndices%aVindices1(i) /= sharedIndices%aVindices1(i-1)+1) then - sharedIndices%contiguous = .false. - endif - enddo - if(sharedIndices%contiguous) then - do i=2,sharedIndices%num_indices - if(sharedIndices%aVindices2(i) /= sharedIndices%aVindices2(i-1)+1) then - sharedIndices%contiguous=.false. - endif - enddo - endif - - end subroutine SharedIndicesOneType_ - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Climate and Global Dynamics Division, National Center for Atmospheric Research ! -!BOP ----------------------------------------------------------------------------- -! -! !IROUTINE: cleanSharedIndices_ - Deallocate allocated memory structures of an AVSharedIndices structure -! -! !DESCRIPTION: This routine deallocates the allocated memory structures -! of the input/output {\tt AVSharedIndicesOneType} argument {\tt -! sharedIndices}, if they are currently associated. It also resets -! other components of this structure to a default state. The success -! (failure) of this operation is signified by a zero (non-zero) value of -! the optional {\tt INTEGER} output argument {\tt stat}. If {\tt -! clean\_()} is invoked without supplying {\tt stat}, and any of the -! deallocation operations fail, the routine will terminate with an error -! message. If multiple errors occur, {\tt stat} will give the error -! condition for the last error. -! -! !INTERFACE: - - subroutine cleanSharedIndices_(sharedIndices, stat) - - implicit none - -! !INPUT/OUTPUT PARAMETERS: -! - type(AVSharedIndices), intent(inout) :: sharedIndices - -! !OUTPUT PARAMETERS: -! - integer, optional, intent(out) :: stat - -! !REVISION HISTORY: -! 28Apr11 - W.J. Sacks - initial version -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::cleanSharedIndices_' - integer :: ier - - if(present(stat)) stat=0 - - call cleanSharedIndicesOneType_(sharedIndices%shared_real, stat=ier) - if(present(stat) .and. ier /= 0) then - stat = ier - end if - - call cleanSharedIndicesOneType_(sharedIndices%shared_integer, stat=ier) - if(present(stat) .and. ier /= 0) then - stat = ier - end if - - end subroutine cleanSharedIndices_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Climate and Global Dynamics Division, National Center for Atmospheric Research ! -!BOP ----------------------------------------------------------------------------- -! -! !IROUTINE: cleanSharedIndicesOneType_ - Deallocate allocated memory structures of an AVSharedIndicesOneType structure -! -! !DESCRIPTION: This routine deallocates the allocated memory structures -! of the input/output {\tt AVSharedIndices} argument {\tt -! sharedIndices}, if they are currently associated. It also resets -! other components of this structure to a default state. The success -! (failure) of this operation is signified by a zero (non-zero) value of -! the optional {\tt INTEGER} output argument {\tt stat}. If {\tt -! clean\_()} is invoked without supplying {\tt stat}, and any of the -! deallocation operations fail, the routine will terminate with an error -! message. If multiple errors occur, {\tt stat} will give the error -! condition for the last error. -! -! !INTERFACE: - - subroutine cleanSharedIndicesOneType_(sharedIndices, stat) -! -! !USES: -! - use m_die, only : die - - implicit none - -! !INPUT/OUTPUT PARAMETERS: -! - type(AVSharedIndicesOneType), intent(inout) :: sharedIndices - -! !OUTPUT PARAMETERS: -! - integer, optional, intent(out) :: stat - -! !REVISION HISTORY: -! 28Apr11 - W.J. Sacks - initial version -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::cleanSharedIndicesOneType_' - integer :: ier - - if(present(stat)) stat=0 - - if(associated(sharedIndices%aVindices1)) then - - deallocate(sharedIndices%aVindices1,stat=ier) - - if (ier /= 0) then - if(present(stat)) then - stat=ier - else - call die(myname_,'deallocate(sharedIndices%aVindices1)',ier) - endif - endif - - endif - - if(associated(sharedIndices%aVindices2)) then - - deallocate(sharedIndices%aVindices2,stat=ier) - - if (ier /= 0) then - if(present(stat)) then - stat=ier - else - call die(myname_,'deallocate(sharedIndices%aVindices2)',ier) - endif - endif - - endif - - ! Reset other components to default values - sharedIndices%num_indices = 0 - sharedIndices%contiguous = .false. - sharedIndices%data_flag = ' ' - - end subroutine cleanSharedIndicesOneType_ - - end module m_AttrVect -!. - - - - diff --git a/cesm/models/utils/mct/mct/m_AttrVectComms.F90 b/cesm/models/utils/mct/mct/m_AttrVectComms.F90 deleted file mode 100644 index e110a0c..0000000 --- a/cesm/models/utils/mct/mct/m_AttrVectComms.F90 +++ /dev/null @@ -1,1683 +0,0 @@ -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!----------------------------------------------------------------------- -! CVS $Id$ -! CVS $Name$ -!BOP ------------------------------------------------------------------- -! -! !MODULE: m_AttrVectComms - MPI Communications Methods for the AttrVect -! -! !DESCRIPTION: -! -! This module defines the communications methods for the {\tt AttrVect} -! datatype (see the module {\tt m\_AttrVect} for more information about -! this class and its methods). MCT's communications are implemented -! in terms of the Message Passing Interface (MPI) standard, and we have -! as best as possible, made the interfaces to these routines appear as -! similar as possible to the corresponding MPI routines. For the -! { \tt AttrVect}, we supply {\em blocking} point-to-point send and -! receive operations. We also supply the following collective -! operations: broadcast, gather, and scatter. The gather and scatter -! operations rely on domain decomposition descriptors that are defined -! elsewhere in MCT: the {\tt GlobalMap}, which is a one-dimensional -! decomposition (see the MCT module {\tt m\_GlobalMap} for more details); -! and the {\tt GlobalSegMap}, which is a segmented decomposition capable -! of supporting multidimensional domain decompositions (see the MCT module -! {\tt m\_GlobalSegMap} for more details). -! -! !INTERFACE: - module m_AttrVectComms -! -! !USES: -! - use m_AttrVect ! AttrVect class and its methods - - implicit none - - private ! except - - public :: gather ! gather all local vectors to the root - public :: scatter ! scatter from the root to all PEs - public :: bcast ! bcast from root to all PEs - public :: send ! send an AttrVect - public :: recv ! receive an AttrVect - - interface gather ; module procedure & - GM_gather_, & - GSM_gather_ - end interface - interface scatter ; module procedure & - GM_scatter_, & - GSM_scatter_ - end interface - interface bcast ; module procedure bcast_ ; end interface - interface send ; module procedure send_ ; end interface - interface recv ; module procedure recv_ ; end interface - -! !REVISION HISTORY: -! 27Oct00 - J.W. Larson - relocated routines -! from m_AttrVect to create this module. -! 15Jan01 - J.W. Larson - Added APIs for -! GSM_gather_() and GSM_scatter_(). -! 9May01 - J.W. Larson - Modified GM_scatter_ -! so its communication model agrees with MPI_scatter(). -! Also tidied up prologues in all module routines. -! 7Jun01 - J.W. Larson - Added send() -! and recv(). -! 3Aug01 - E.T. Ong - in GSM_scatter, call -! GlobalMap_init with actual shaped array to satisfy -! Fortran 90 standard. See comment in subroutine. -! 23Aug01 - E.T. Ong - replaced assignment(=) -! with copy for list type to avoid compiler bugs in pgf90. -! Added more error checking in gsm scatter. Fixed minor bugs -! in gsm and gm gather. -! 13Dec01 - E.T. Ong - GSM_scatter, allow users -! to scatter with a haloed GSMap. Fixed some bugs in -! GM_scatter. -! 19Dec01 - E.T. Ong - allow bcast of an AttrVect -! with only an integer or real attribute. -! 27Mar02 - J.W. Larson - Corrected usage of -! m_die routines throughout this module. -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname='MCT::m_AttrVectComms' - - contains - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: send_ - Point-to-point Send of an AttrVect -! -! !DESCRIPTION: This routine takes an input {\tt AttrVect} argument -! {\tt inAV} and sends it to processor {\tt dest} on the communicator -! associated with the Fortran {\tt INTEGER} MPI communicator handle -! {\tt comm}. The overalll message is tagged by the input {\tt INTEGER} -! argument {\tt TagBase}. The success (failure) of this operation is -! reported in the zero (nonzero) optional output argument {\tt status}. -! -! {\bf N.B.}: One must avoid assigning elsewhere the MPI tag values -! between {\tt TagBase} and {\tt TagBase+7}, inclusive. This is -! because {\tt send\_()} performs the send of the {\tt AttrVect} as -! a series of eight send operations. -! -! !INTERFACE: - - subroutine send_(inAV, dest, TagBase, comm, status) -! -! !USES: -! - use m_stdio - use m_mpif90 - use m_die - - use m_List, only : List - use m_List, only : List_allocated => allocated - use m_List, only : List_nitem => nitem - use m_List, only : List_send => send - - use m_AttrVect, only : AttrVect - use m_AttrVect, only : AttrVect_lsize => lsize - - implicit none - -! !INPUT PARAMETERS: -! - type(AttrVect), intent(in) :: inAV - integer, intent(in) :: dest - integer, intent(in) :: TagBase - integer, intent(in) :: comm - -! !OUTPUT PARAMETERS: -! - integer, optional, intent(out) :: status - -! !REVISION HISTORY: -! 7Jun01 - J.W. Larson - initial version. -! 13Jun01 - J.W. Larson - Initialize status -! (if present). -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::send_' - - logical :: ListAssoc(2) - integer :: ierr - integer :: AVlength - - ! Initialize status (if present) - - if(present(status)) status = 0 - - - ! Step 1. Are inAV%iList and inAV%rList filled? Store - ! the answers in the LOGICAL array ListAssoc and send. - - ListAssoc(1) = List_allocated(inAV%iList) - ListAssoc(2) = List_allocated(inAV%rList) - - if(.NOT. (ListAssoc(1).or.ListAssoc(2)) ) then - call die(myname_,"inAV has not been initialized") - endif - - call MPI_SEND(ListAssoc, 2, MP_LOGICAL, dest, TagBase, comm, ierr) - if(ierr /= 0) then - call MP_perr_die(myname_,':: MPI_SEND(ListAssoc...',ierr) - endif - - - ! Step 2. Send non-blank inAV%iList and inAV%rList. - - if(ListAssoc(1)) then - call List_send(inAV%iList, dest, TagBase+1, comm, ierr) - if(ierr /= 0) then - if(present(status)) then - write(stderr,*) myname_,':: call List_send(inAV%iList...' - status = ierr - return - else - call die(myname_,':: call List_send(inAV%iList...',ierr) - endif - endif - endif - - if(ListAssoc(2)) then - call List_send(inAV%rList, dest, TagBase+3, comm, ierr) - if(ierr /= 0) then - if(present(status)) then - write(stderr,*) myname_,':: call List_send(inAV%rList...' - status = ierr - return - else - call die(myname_,':: call List_send(inAV%rList...',ierr) - endif - endif - endif - - ! Step 3. Determine and send the lengths of inAV%iAttr(:,:) - ! and inAV%rAttr(:,:). - - AVlength = AttrVect_lsize(inAV) - - if(AVlength<=0) then - call die(myname_,"Size of inAV <= 0",AVLength) - endif - - call MPI_SEND(AVlength, 1, MP_type(AVlength), dest, TagBase+5, & - comm, ierr) - if(ierr /= 0) then - call MP_perr_die(myname_,':: call MPI_SEND(AVlength...',ierr) - endif - - ! Step 4. If AVlength > 0, we may have INTEGER and REAL - ! data to send. Send as needed. - - if(AVlength > 0) then - - if(ListAssoc(1)) then - - ! Send the INTEGER data stored in inAV%iAttr(:,:) - - call MPI_SEND(inAV%iAttr(1,1), AVlength*List_nitem(inAV%iList), & - MP_type(inAV%iAttr(1,1)), dest, TagBase+6, & - comm, ierr) - if(ierr /= 0) then - call MP_perr_die(myname_,':: call MPI_SEND(inAV%iAttr...',ierr) - endif - - endif ! if(associated(inAV%rList)) - - if(ListAssoc(2)) then - - ! Send the REAL data stored in inAV%rAttr(:,:) - - call MPI_SEND(inAV%rAttr(1,1), AVlength*List_nitem(inAV%rList), & - MP_type(inAV%rAttr(1,1)), dest, TagBase+7, & - comm, ierr) - if(ierr /= 0) then - call MP_perr_die(myname_,':: call MPI_SEND(inAV%rAttr...',ierr) - endif - - endif ! if(associated(inAV%rList)) - - endif ! if (AVlength > 0) - - end subroutine send_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: recv_ - Point-to-point Receive of an AttrVect -! -! !DESCRIPTION: This routine receives the output {\tt AttrVect} argument -! {\tt outAV} from processor {\tt source} on the communicator associated -! with the Fortran {\tt INTEGER} MPI communicator handle {\tt comm}. The -! overall message is tagged by the input {\tt INTEGER} argument -! {\tt TagBase}. The success (failure) of this operation is reported in -! the zero (nonzero) optional output argument {\tt status}. -! -! {\bf N.B.}: One must avoid assigning elsewhere the MPI tag values -! between {\tt TagBase} and {\tt TagBase+7}, inclusive. This is -! because {\tt recv\_()} performs the receive of the {\tt AttrVect} as -! a series of eight receive operations. -! -! !INTERFACE: - - subroutine recv_(outAV, dest, TagBase, comm, status) -! -! !USES: -! - use m_stdio - use m_mpif90 - use m_die - - use m_List, only : List - use m_List, only : List_nitem => nitem - use m_List, only : List_recv => recv - - use m_AttrVect, only : AttrVect - - implicit none - -! !INPUT PARAMETERS: -! - integer, intent(in) :: dest - integer, intent(in) :: TagBase - integer, intent(in) :: comm - -! !OUTPUT PARAMETERS: -! - type(AttrVect), intent(out) :: outAV - integer, optional, intent(out) :: status - -! !REVISION HISTORY: -! 7Jun01 - J.W. Larson - initial working version. -! 13Jun01 - J.W. Larson - Initialize status -! (if present). -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::recv_' - - logical :: ListAssoc(2) - integer :: ierr - integer :: AVlength - integer :: MPstatus(MP_STATUS_SIZE) - - ! Initialize status (if present) - - if(present(status)) status = 0 - - - ! Step 1. Are outAV%iList and outAV%rList filled? TRUE - ! entries in the LOGICAL array ListAssoc(:) correspond - ! to Non-blank Lists...that is: - ! - ! ListAssoc(1) = .TRUE. <==> associated(outAV%iList%bf) - ! ListAssoc(2) = .TRUE. <==> associated(outAV%rList%bf) - - call MPI_RECV(ListAssoc, 2, MP_LOGICAL, dest, TagBase, comm, & - MPstatus, ierr) - if(ierr /= 0) then - call MP_perr_die(myname_,':: MPI_RECV(ListAssoc...',ierr) - endif - - - ! Step 2. Receive non-blank outAV%iList and outAV%rList. - - if(ListAssoc(1)) then - call List_recv(outAV%iList, dest, TagBase+1, comm, ierr) - if(ierr /= 0) then - if(present(status)) then - write(stderr,*) myname_,':: call List_recv(outAV%iList...' - status = ierr - return - else - call die(myname_,':: call List_recv(outAV%iList...',ierr) - endif - endif - endif - - if(ListAssoc(2)) then - call List_recv(outAV%rList, dest, TagBase+3, comm, ierr) - if(ierr /= 0) then - if(present(status)) then - write(stderr,*) myname_,':: call List_recv(outAV%rList...' - status = ierr - return - else - call die(myname_,':: call List_recv(outAV%rList...',ierr) - endif - endif - endif - - ! Step 3. Receive the lengths of outAV%iAttr(:,:) and outAV%rAttr(:,:). - - call MPI_RECV(AVlength, 1, MP_type(AVlength), dest, TagBase+5, & - comm, MPstatus, ierr) - if(ierr /= 0) then - call MP_perr_die(myname_,':: call MPI_RECV(AVlength...',ierr) - endif - - ! Step 4. If AVlength > 0, we may have to receive INTEGER - ! and/or REAL data. Receive as needed. - - if(AVlength > 0) then - - if(ListAssoc(1)) then - - ! Allocate outAV%iAttr(:,:) - - allocate(outAV%iAttr(List_nitem(outAV%iList),AVlength), stat=ierr) - if(ierr/=0) call die(myname_,"allocate(outAV%iAttr)",ierr) - - ! Receive the INTEGER data to outAV%iAttr(:,:) - - call MPI_RECV(outAV%iAttr(1,1), AVlength*List_nitem(outAV%iList), & - MP_type(outAV%iAttr(1,1)), dest, TagBase+6, & - comm, MPstatus, ierr) - if(ierr /= 0) then - call MP_perr_die(myname_,':: call MPI_RECV(outAV%iAttr...',ierr) - endif - - endif ! if(associated(outAV%rList)) - - if(ListAssoc(2)) then - - ! Allocate outAV%rAttr(:,:) - - allocate(outAV%rAttr(List_nitem(outAV%rList),AVlength), stat=ierr) - if(ierr/=0) call die(myname_,"allocate(outAV%rAttr)",ierr) - - ! Receive the REAL data to outAV%rAttr(:,:) - - call MPI_RECV(outAV%rAttr(1,1), AVlength*List_nitem(outAV%rList), & - MP_type(outAV%rAttr(1,1)), dest, TagBase+7, & - comm, MPstatus, ierr) - if(ierr /= 0) then - call MP_perr_die(myname_,':: call MPI_RECV(outAV%rAttr...',ierr) - endif - - endif ! if(associated(outAV%rList)) - - endif ! if (AVlength > 0) - - end subroutine recv_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: GM_gather_ - Gather an AttrVect Distributed by a GlobalMap -! -! !DESCRIPTION: -! This routine gathers a {\em distributed} {\tt AttrVect} {\tt iV} to -! the {\tt root} process, and returns it in the output {\tt AttrVect} -! argument {\tt oV}. The decomposition of {\tt iV} is described by -! the input {\tt GlobalMap} argument {\tt GMap}. The input {\tt INTEGER} -! argument {\tt comm} is the Fortran integer MPI communicator handle. -! The success (failure) of this operation corresponds to a zero (nonzero) -! value of the optional output {\tt INTEGER} argument {\tt stat}. -! -! !INTERFACE: - - subroutine GM_gather_(iV, oV, GMap, root, comm, stat) -! -! !USES: -! - use m_stdio - use m_die - use m_mpif90 - use m_realkinds, only : FP - use m_GlobalMap, only : GlobalMap - use m_GlobalMap, only : GlobalMap_lsize => lsize - use m_GlobalMap, only : GlobalMap_gsize => gsize - use m_AttrVect, only : AttrVect - use m_AttrVect, only : AttrVect_init => init - use m_AttrVect, only : AttrVect_zero => zero - use m_AttrVect, only : AttrVect_lsize => lsize - use m_AttrVect, only : AttrVect_nIAttr => nIAttr - use m_AttrVect, only : AttrVect_nRAttr => nRAttr - use m_AttrVect, only : AttrVect_clean => clean - use m_FcComms, only : fc_gatherv_int, fc_gatherv_fp - - implicit none - -! !INPUT PARAMETERS: -! - type(AttrVect), intent(in) :: iV - type(GlobalMap), intent(in) :: GMap - integer, intent(in) :: root - integer, intent(in) :: comm - -! !OUTPUT PARAMETERS: -! - type(AttrVect), intent(out) :: oV - integer, optional, intent(out) :: stat - -! !REVISION HISTORY: -! 15Apr98 - Jing Guo - initial prototype/prolog/code -! 27Oct00 - J.W. Larson - relocated from -! m_AttrVect -! 15Jan01 - J.W. Larson - renamed GM_gather_ -! 9May01 - J.W. Larson - tidied up prologue -! 18May01 - R.L. Jacob - use MP_Type function -! to determine type for mpi_gatherv -! 31Jan09 - P.H. Worley - replaced call to -! MPI_gatherv with call to flow controlled gather routines -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::GM_gather_' - integer :: nIA,nRA,niV,noV,ier - integer :: myID - integer :: mp_type_Av - type(AttrVect) :: nonRootAV - - if(present(stat)) stat=0 - - call MP_comm_rank(comm, myID, ier) - if(ier /= 0) then - call MP_perr_die(myname_,':: call MP_COMM_RANK()',ier) - endif - - ! Verify the input: a _scatterd_ vector - - niV=GlobalMap_lsize(GMap) - noV=AttrVect_lsize(iV) - - if(niV /= noV) then - write(stderr,'(2a,i4,a,i4,a,i4)') myname_, & - ': invalid input, lsize(GMap) =',niV, & - ', lsize(iV) =',noV, 'myID =', myID - if(.not.present(stat)) call die(myname_) - stat=-1 - return - endif - - noV=GlobalMap_gsize(GMap) ! the gathered local size, as for the output - - if(myID == root) then - call AttrVect_init(oV,iV,noV) - call AttrVect_zero(oV) - else - call AttrVect_init(nonRootAV,iV,1) - call AttrVect_zero(nonRootAV) - endif - - niV=GlobalMap_lsize(GMap) ! the scattered local size, as for the input - - nIA=AttrVect_nIAttr(iV) ! number of INTEGER attributes - nRA=AttrVect_nRAttr(iV) ! number of REAL attributes - - mp_type_Av = MP_Type(1._FP) ! set mpi type to same as AV%rAttr - - if(nIA > 0) then - - if(myID == root) then - - call fc_gatherv_int(iV%iAttr,niV*nIA,MP_INTEGER, & - oV%iAttr,GMap%counts*nIA,GMap%displs*nIA, & - MP_INTEGER,root,comm) - - else - - call fc_gatherv_int(iV%iAttr,niV*nIA,MP_INTEGER, & - nonRootAV%iAttr,GMap%counts*nIA,GMap%displs*nIA, & - MP_INTEGER,root,comm) - - endif ! if(myID == root) - - endif ! if(nIA > 0) - - if(nRA > 0) then - - if(myID == root) then - - call fc_gatherv_fp(iV%rAttr,niV*nRA,mp_type_Av, & - oV%rAttr,GMap%counts*nRA,GMap%displs*nRA, & - mp_type_Av,root,comm) - - else - - call fc_gatherv_fp(iV%rAttr,niV*nRA,mp_type_Av, & - nonRootAV%rAttr,GMap%counts*nRA,GMap%displs*nRA, & - mp_type_Av,root,comm) - - endif ! if(myID == root) - - endif ! if(nRA > 0) - - - - if(myID /= root) then - call AttrVect_clean(nonRootAV,ier) - if(ier /= 0) then - write(stderr,'(2a,i4)') myname_, & - ':: AttrVect_clean(nonRootAV) failed for non-root & - &process: myID = ', myID - call die(myname_,':: AttrVect_clean failed & - &for nonRootAV off of root',ier) - endif - endif - - end subroutine GM_gather_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: GSM_gather_ - Gather an AttrVect Distributed by a GlobalSegMap -! -! !DESCRIPTION: -! The routine {\tt GSM\_gather\_()} takes a distributed input -! {\tt AttrVect} argument {\tt iV}, whose decomposition is described -! by the input {\tt GlobalSegMap} argument {\tt GSMap}, and gathers -! it to the output {\tt AttrVect} argument {\tt oV}. The gathered -! {\tt AttrVect} {\tt oV} is valid only on the root process specified -! by the input argument {\tt root}. The communicator used to gather -! the data is specified by the argument {\tt comm}. The success (failure) -! is reported in the zero (non-zero) value of the output argument -! {\tt stat}. -! -! {\tt GSM\_gather\_()} converts the problem of gathering data -! according to a {\tt GlobalSegMap} into the simpler problem of -! gathering data as specified by a {\tt GlobalMap}. The {\tt GlobalMap} -! variable {\tt GMap} is created based on the local storage requirements -! for each distributed piece of {\tt iV}. On the root, a complete -! (including halo points) gathered copy of {\tt iV} is collected into -! the temporary {\tt AttrVect} variable {\tt workV} (the length of -! {\tt workV} is the larger of {\tt GlobalSegMap\_GlobalStorage(GSMap)} or -! {\tt GlobalSegMap\_GlobalSize(GSMap)}). The -! variable {\tt workV} is segmented by process, and segments are -! copied into it by process, but ordered in the same order the segments -! appear in {\tt GSMap}. Once {\tt workV} is loaded, the data are -! copied segment-by-segment to their appropriate locations in the output -! {\tt AttrVect} {\tt oV}. -! -! !INTERFACE: - - subroutine GSM_gather_(iV, oV, GSMap, root, comm, stat, rdefault, idefault) -! -! !USES: -! -! Message-passing environment utilities (mpeu) modules: - use m_stdio - use m_die - use m_mpif90 - use m_realkinds, only: FP -! GlobalSegMap and associated services: - use m_GlobalSegMap, only : GlobalSegMap - use m_GlobalSegMap, only : GlobalSegMap_comp_id => comp_id - use m_GlobalSegMap, only : GlobalSegMap_ngseg => ngseg - use m_GlobalSegMap, only : GlobalSegMap_lsize => lsize - use m_GlobalSegMap, only : GlobalSegMap_gsize => gsize - use m_GlobalSegMap, only : GlobalSegMap_haloed => haloed - use m_GlobalSegMap, only : GlobalSegMap_GlobalStorage => GlobalStorage -! AttrVect and associated services: - use m_AttrVect, only : AttrVect - use m_AttrVect, only : AttrVect_init => init - use m_AttrVect, only : AttrVect_zero => zero - use m_AttrVect, only : AttrVect_lsize => lsize - use m_AttrVect, only : AttrVect_nIAttr => nIAttr - use m_AttrVect, only : AttrVect_nRAttr => nRAttr - use m_AttrVect, only : AttrVect_clean => clean -! GlobalMap and associated services: - use m_GlobalMap, only : GlobalMap - use m_GlobalMap, only : GlobalMap_init => init - use m_GlobalMap, only : GlobalMap_clean => clean - - implicit none - -! !INPUT PARAMETERS: -! - type(AttrVect), intent(in) :: iV - type(GlobalSegMap), intent(in) :: GSMap - integer, intent(in) :: root - integer, intent(in) :: comm - real(FP), optional, intent(in) :: rdefault - integer, optional, intent(in) :: idefault - -! !OUTPUT PARAMETERS: -! - type(AttrVect), intent(out) :: oV - integer, optional, intent(out) :: stat - -! !REVISION HISTORY: -! 15Jan01 - J.W. Larson - API specification. -! 25Feb01 - J.W. Larson - Prototype code. -! 26Apr01 - R.L. Jacob - add use statement for -! AttVect_clean -! 9May01 - J.W. Larson - tidied up prologue -! 13Jun01 - J.W. Larson - Initialize stat -! (if present). -! 20Aug01 - E.T. Ong - Added error checking for -! matching processors in gsmap and comm. Corrected -! current_pos assignment. -! 23Nov01 - R. Jacob - zero the oV before copying in -! gathered data. -! 27Jul07 - R. Loy - add Tony's suggested improvement -! for a default value in the output AV -! 11Aug08 - R. Jacob - add Pat Worley's faster way -! to initialize lns -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::GSM_gather_' - -! Temporary workspace AttrVect: - type(AttrVect) :: workV -! Component ID and number of segments for GSMap: - integer :: comp_id, ngseg, iseg -! Total length of GSMap segments laid end-to-end: - integer :: global_storage -! Error Flag - integer :: ierr -! Number of processes on communicator, and local rank: - integer :: NumProcs, myID -! Total local storage on each pe according to GSMap: - integer, dimension(:), allocatable :: lns -! Temporary GlobalMap used to scatter the segmented (by pe) data - type(GlobalMap) :: workGMap -! Loop counters and temporary indices: - integer :: m, n, ilb, iub, olb, oub, pe -! workV segment tracking index array: - integer, dimension(:), allocatable :: current_pos -! workV sizes - integer :: gssize, gstorage - - ! Initialize stat (if present) - - if(present(stat)) stat = 0 - - ! Initial Check: If GSMap contains halo points, die - - if(GlobalSegMap_haloed(GSMap)) then - ierr = 1 - call die(myname_,"Input GlobalSegMap haloed--not allowed",ierr) - endif - - ! Which process am I? - - call MPI_COMM_RANK(comm, myID, ierr) - - if(ierr /= 0) then - call MP_perr_die(myname_,':: call MPI_COMM_RANK()',ierr) - endif - ! How many processes are there on this communicator? - - call MPI_COMM_SIZE(comm, NumProcs, ierr) - - if(ierr /= 0) then - call MP_perr_die(myname_,':: call MPI_COMM_SIZE()',ierr) - endif - - ! Processor Check: Do the processors on GSMap match those in comm? - - if(MAXVAL(GSMap%pe_loc) > (NumProcs-1)) then - stat=2 - write(stderr,*) myname_, & - ":: Procs in GSMap%pe_loc do not match procs in communicator ", & - NumProcs-1, MAXVAL(GSMap%pe_loc) - call die(myname_, & - "Procs in GSMap%pe_loc do not match procs in communicator",stat) - endif - - if(myID == root) then - - ! Allocate a precursor to a GlobalMap accordingly... - - allocate(lns(0:NumProcs-1), stat=ierr) - - ! And Load it... - - lns(:)=0 - do iseg=1,GSMap%ngseg - n = GSMap%pe_loc(iseg) - lns(n) = lns(n) + GSMap%length(iseg) - end do - - else - - allocate(lns(0)) ! This conforms to F90 standard for shaped arguments. - - endif ! if(myID == root) - - ! Determine the component id of GSMap: - - comp_id = GlobalSegMap_comp_id(GSMap) - - ! Create working GlobalMap workGMap (used for the gather): - - call GlobalMap_init(workGMap, comp_id, lns, root, comm) - - ! Gather the Data process-by-process to workV... - ! do not include stat argument; bypass an argument check in gm_gather. - - call GM_gather_(iV, workV, workGMap, root, comm, stat) - - ! On the root, initialize oV, and load the contents of - !workV into it... - - if(myID == root) then - -! bug fix: gstorage will be bigger than gssize if GSmap is -! haloed. But gstorage may be smaller than gsize if GSmap -! is masked. So take the maximum. RLJ - gstorage = GlobalSegMap_GlobalStorage(GSMap) - gssize = GlobalSegMap_gsize(GSMap) - global_storage = MAX(gstorage,gssize) - - call AttrVect_init(oV,iV,global_storage) - call AttrVect_zero(oV) - - if (present(rdefault)) then - if (AttrVect_nRAttr(oV) > 0) oV%rAttr=rdefault - endif - if (present(idefault)) then - if (AttrVect_nIAttr(oV) > 0) oV%iAttr=idefault - endif - - ! On the root, allocate current position index for - ! each process chunk: - - allocate(current_pos(0:NumProcs-1), stat=ierr) - - if(ierr /= 0) then - write(stderr,*) myname_,':: allocate(current_pos(..) failed,', & - 'stat = ',ierr - if(present(stat)) then - stat=ierr - else - call die(myname_,'allocate(current_pos(..) failed.' ) - endif - endif - - ! Initialize current_pos(:) using GMap%displs(:) - - do n=0,NumProcs-1 - current_pos(n) = workGMap%displs(n) + 1 - end do - - ! Load each segment of iV into its appropriate segment - ! of workV: - - ngseg = GlobalSegMap_ngseg(GSMap) - - do n=1,ngseg - - ! Determine which process owns segment n: - - pe = GSMap%pe_loc(n) - - ! Input map (lower/upper indicess) of segment of iV: - - ilb = current_pos(pe) - iub = current_pos(pe) + GSMap%length(n) - 1 - - ! Output map of (lower/upper indicess) segment of workV: - - olb = GSMap%start(n) - oub = GSMap%start(n) + GSMap%length(n) - 1 - - ! Increment current_pos(n) for next time: - - current_pos(pe) = current_pos(pe) + GSMap%length(n) - - ! Now we are equipped to do the copy: - - do m=1,AttrVect_nIAttr(iV) - oV%iAttr(m,olb:oub) = workV%iAttr(m,ilb:iub) - end do - - do m=1,AttrVect_nRAttr(iV) - oV%rAttr(m,olb:oub) = workV%rAttr(m,ilb:iub) - end do - - end do ! do n=1,ngseg - - ! Clean up current_pos, which was only allocated on the root - - deallocate(current_pos, stat=ierr) - if(ierr /= 0) then - write(stderr,*) myname_,'error in deallocate(current_pos), stat=',ierr - if(present(stat)) then - stat=ierr - else - call die(myname_) - endif - endif - endif ! if(myID == root) - - ! At this point, we are finished. The data have been gathered - ! to oV - - ! Finally, clean up allocated structures: - - if(myID == root) call AttrVect_clean(workV) - call GlobalMap_clean(workGMap) - - deallocate(lns, stat=ierr) - - if(ierr /= 0) then - write(stderr,*) myname_,'error in deallocate(lns), stat=',ierr - if(present(stat)) then - stat=ierr - else - call die(myname_) - endif - endif - - end subroutine GSM_gather_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: GM_scatter_ - Scatter an AttrVect Using a GlobalMap -! -! !DESCRIPTION: -! The routine {\tt GM\_scatter\_} takes an input {\tt AttrVect} type -! {\tt iV} (valid only on the root), and scatters it to a distributed -! {\tt AttrVect} {\tt oV}. The input {\tt GlobalMap} argument -! {\tt GMap} dictates how {\tt iV} is scattered to {\tt oV}. The -! success (failure) of this routine is reported in the zero (non-zero) -! value of the output argument {\tt stat}. -! -! {\bf N.B.}: The output {\tt AttrVect} argument {\tt oV} represents -! dynamically allocated memory. When it is no longer needed, it should -! be deallocated by invoking {\tt AttrVect\_clean()} (see the module -! {\tt m\_AttrVect} for more details). -! -! !INTERFACE: - - subroutine GM_scatter_(iV, oV, GMap, root, comm, stat) -! -! !USES: -! - use m_stdio - use m_die - use m_mpif90 - use m_realkinds, only : FP - - use m_List, only : List - use m_List, only : List_copy => copy - use m_List, only : List_bcast => bcast - use m_List, only : List_clean => clean - use m_List, only : List_nullify => nullify - use m_List, only : List_nitem => nitem - - use m_GlobalMap, only : GlobalMap - use m_GlobalMap, only : GlobalMap_lsize => lsize - use m_GlobalMap, only : GlobalMap_gsize => gsize - - use m_AttrVect, only : AttrVect - use m_AttrVect, only : AttrVect_init => init - use m_AttrVect, only : AttrVect_zero => zero - use m_AttrVect, only : AttrVect_lsize => lsize - use m_AttrVect, only : AttrVect_nIAttr => nIAttr - use m_AttrVect, only : AttrVect_nRAttr => nRAttr - use m_AttrVect, only : AttrVect_clean => clean - - implicit none - -! !INPUT PARAMETERS: -! - type(AttrVect), intent(in) :: iV - type(GlobalMap), intent(in) :: GMap - integer, intent(in) :: root - integer, intent(in) :: comm - -! !OUTPUT PARAMETERS: -! - type(AttrVect), intent(out) :: oV - integer, optional, intent(out) :: stat - -! !REVISION HISTORY: -! 21Apr98 - Jing Guo - initial prototype/prolog/code -! 27Oct00 - J.W. Larson - relocated from -! m_AttrVect -! 15Jan01 - J.W. Larson - renamed GM_scatter_ -! 8Feb01 - J.W. Larson - add logic to prevent -! empty calls (i.e. no data in buffer) to MPI_SCATTERV() -! 27Apr01 - R.L. Jacob - small bug fix to -! integer attribute scatter -! 9May01 - J.W. Larson - Re-vamped comms model -! to reflect MPI comms model for the scatter. Tidied up -! the prologue, too. -! 18May01 - R.L. Jacob - use MP_Type function -! to determine type for mpi_scatterv -! 8Aug01 - E.T. Ong - replace list assignment(=) -! with list copy to avoid compiler errors in pgf90. -! 13Dec01 - E.T. Ong - allow scatter with an -! AttrVect containing only an iList or rList. -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::GM_scatter_' - integer :: nIA,nRA,niV,noV,ier - integer :: myID - integer :: mp_type_Av - type(List) :: iList, rList - type(AttrVect) :: nonRootAV - - if(present(stat)) stat=0 - - call MP_comm_rank(comm,myID,ier) - if(ier /= 0) then - call MP_perr_die(myname_,'MP_comm_rank()',ier) - endif - - ! Verify the input: a _gathered_ vector - - if(myID == root) then - - niV = GlobalMap_gsize(GMap) ! the _gathered_ local size - noV = AttrVect_lsize(iV) ! the length of the input AttrVect iV - - if(niV /= noV) then - write(stderr,'(2a,i5,a,i8,a,i8)') myname_, & - ': myID = ',myID,'. Invalid input on root, gsize(GMap) =',& - niV,', lsize(iV) =',noV - if(present(stat)) then - stat=-1 - else - call die(myname_) - endif - endif - - endif - - ! On the root, read the integer and real attribute - ! lists off of iV. - - call List_nullify(iList) - call List_nullify(rList) - - if(myID == root) then - - ! Count the number of real and integer attributes - - nIA = AttrVect_nIAttr(iV) ! number of INTEGER attributes - nRA = AttrVect_nRAttr(iV) ! number of REAL attributes - - if(nIA > 0) then - call List_copy(iList,iV%iList) - endif - - if(nRA > 0) then - call List_copy(rList,iV%rList) - endif - - endif - - ! From the root, broadcast iList and rList - - call MPI_BCAST(nIA,1,MP_INTEGER,root,comm,ier) - if(ier /= 0) call MP_perr(myname_,'MPI_BCAST(nIA)',ier) - - call MPI_BCAST(nRA,1,MP_INTEGER,root,comm,ier) - if(ier /= 0) call MP_perr(myname_,'MPI_BCAST(nRA)',ier) - - if(nIA>0) call List_bcast(iList, root, comm) - if(nRA>0) call List_bcast(rList, root, comm) - - noV = GlobalMap_lsize(GMap) ! the _scatterd_ local size - - ! On all processes, use List data and noV to initialize oV - - call AttrVect_init(oV, iList, rList, noV) - call AttrVect_zero(oV) - - ! Initialize a dummy AttrVect for non-root MPI calls - - if(myID/=root) then - call AttrVect_init(nonRootAV,oV,1) - call AttrVect_zero(nonRootAV) - endif - - - if(nIA > 0) then - - if(myID == root) then - - call MPI_scatterv(iV%iAttr,GMap%counts*nIA, & - GMap%displs*nIA,MP_INTEGER,oV%iAttr, & - noV*nIA,MP_INTEGER,root,comm,ier ) - if(ier /= 0) then - call MP_perr_die(myname_,'MPI_scatterv(iAttr) on root',ier) - endif - - else - - call MPI_scatterv(nonRootAV%iAttr,GMap%counts*nIA, & - GMap%displs*nIA,MP_INTEGER,oV%iAttr, & - noV*nIA,MP_INTEGER,root,comm,ier ) - if(ier /= 0) then - call MP_perr_die(myname_,'MPI_scatterv(iAttr) off root',ier) - endif - - endif ! if(myID == root) - - call List_clean(iList) - - endif ! if(nIA > 0) - - mp_type_Av = MP_Type(1._FP) ! set mpi type to same as AV%rAttr - - if(nRA > 0) then - - if(myID == root) then - - - call MPI_scatterv(iV%rAttr,GMap%counts*nRA, & - GMap%displs*nRA,mp_type_Av,oV%rAttr, & - noV*nRA,mp_type_Av,root,comm,ier ) - if(ier /= 0) then - call MP_perr_die(myname_,'MPI_scatterv(rAttr) on root',ier) - endif - - else - - - call MPI_scatterv(nonRootAV%rAttr,GMap%counts*nRA, & - GMap%displs*nRA,mp_type_Av,oV%rAttr, & - noV*nRA,mp_type_Av,root,comm,ier ) - if(ier /= 0) then - call MP_perr_die(myname_,'MPI_scatterv(rAttr) off root',ier) - endif - - endif - - call List_clean(rList) - - endif - - if(myID /= root) then - call AttrVect_clean(nonRootAV,ier) - if(ier /= 0) then - write(stderr,'(2a,i4)') myname_, & - ':: AttrVect_clean(nonRootAV) failed for non-root & - &process: myID = ', myID - call die(myname_,':: AttrVect_clean failed & - &for nonRootAV off of root',ier) - endif - endif - - end subroutine GM_scatter_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: GSM_scatter_ - Scatter an AttrVect using a GlobalSegMap -! -! !DESCRIPTION: -! The routine {\tt GSM\_scatter\_} takes an input {\tt AttrVect} type -! {\tt iV} (valid only on the root), and scatters it to a distributed -! {\tt AttrVect} {\tt oV}. The input {\tt GlobalSegMap} argument -! {\tt GSMap} dictates how {\tt iV} is scattered to {\tt oV}. The -! success (failure) of this routine is reported in the zero (non-zero) -! value of the output argument {\tt stat}. -! -! {\tt GSM\_scatter\_()} converts the problem of scattering data -! according to a {\tt GlobalSegMap} into the simpler problem of -! scattering data as specified by a {\tt GlobalMap}. The {\tt GlobalMap} -! variable {\tt GMap} is created based on the local storage requirements -! for each distributed piece of {\tt iV}. On the root, a complete -! (including halo points) copy of {\tt iV} is stored in -! the temporary {\tt AttrVect} variable {\tt workV} (the length of -! {\tt workV} is {\tt GlobalSegMap\_GlobalStorage(GSMap)}). The -! variable {\tt workV} is segmented by process, and segments are -! copied into it by process, but ordered in the same order the segments -! appear in {\tt GSMap}. Once {\tt workV} is loaded, the data are -! scattered to the output {\tt AttrVect} {\tt oV} by a call to the -! routine {\tt GM\_scatter\_()} defined in this module, with {\tt workV} -! and {\tt GMap} as the input arguments. -! -! {\bf N.B.:} This algorithm assumes that memory access times are much -! shorter than message-passing transmission times. -! -! {\bf N.B.}: The output {\tt AttrVect} argument {\tt oV} represents -! dynamically allocated memory. When it is no longer needed, it should -! be deallocated by invoking {\tt AttrVect\_clean()} (see the module -! {\tt m\_AttrVect} for more details). -! -! !INTERFACE: - - subroutine GSM_scatter_(iV, oV, GSMap, root, comm, stat) -! -! !USES: -! -! Environment utilities from mpeu: - - use m_stdio - use m_die - use m_mpif90 - - use m_List, only : List_nullify => nullify - -! GlobalSegMap and associated services: - use m_GlobalSegMap, only : GlobalSegMap - use m_GlobalSegMap, only : GlobalSegMap_comp_id => comp_id - use m_GlobalSegMap, only : GlobalSegMap_ngseg => ngseg - use m_GlobalSegMap, only : GlobalSegMap_lsize => lsize - use m_GlobalSegMap, only : GlobalSegMap_gsize => gsize - use m_GlobalSegMap, only : GlobalSegMap_GlobalStorage => GlobalStorage -! AttrVect and associated services: - use m_AttrVect, only : AttrVect - use m_AttrVect, only : AttrVect_init => init - use m_AttrVect, only : AttrVect_zero => zero - use m_AttrVect, only : AttrVect_lsize => lsize - use m_AttrVect, only : AttrVect_nIAttr => nIAttr - use m_AttrVect, only : AttrVect_nRAttr => nRAttr - use m_AttrVect, only : AttrVect_clean => clean -! GlobalMap and associated services: - use m_GlobalMap, only : GlobalMap - use m_GlobalMap, only : GlobalMap_init => init - use m_GlobalMap, only : GlobalMap_clean => clean - - implicit none - -! !INPUT PARAMETERS: -! - type(AttrVect), intent(in) :: iV - type(GlobalSegMap), intent(in) :: GSMap - integer, intent(in) :: root - integer, intent(in) :: comm - -! !OUTPUT PARAMETERS: -! - type(AttrVect), intent(out) :: oV - integer, optional, intent(out) :: stat - -! !REVISION HISTORY: -! 15Jan01 - J.W. Larson - API specification. -! 8Feb01 - J.W. Larson - Initial code. -! 25Feb01 - J.W. Larson - Bug fix--replaced -! call to GlobalSegMap_lsize with call to the new fcn. -! GlobalSegMap_ProcessStorage(). -! 26Apr01 - R.L. Jacob - add use statement for -! AttVect_clean -! 26Apr01 - J.W. Larson - bug fixes--data -! misalignment in use of the GlobalMap to compute the -! memory map into workV, and initialization of workV -! on all processes. -! 9May01 - J.W. Larson - tidied up prologue -! 15May01 - Larson / Jacob - stopped initializing -! workV on off-root processes (no longer necessary). -! 13Jun01 - J.W. Larson - Initialize stat -! (if present). -! 20Jun01 - J.W. Larson - Fixed a subtle bug -! appearing on AIX regarding the fact workV is uninitial- -! ized on non-root processes. This is fixed by nullifying -! all the pointers in workV for non-root processes. -! 20Aug01 - E.T. Ong - Added argument check -! for matching processors in gsmap and comm. -! 13Dec01 - E.T. Ong - got rid of restriction -! GlobalStorage(GSMap)==AttrVect_lsize(AV) to allow for -! GSMap to be haloed. -! 11Aug08 - R. Jacob - remove call to ProcessStorage -! and replace with faster algorithm provided by Pat Worley -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::GSM_scatter_' - -! Temporary workspace AttrVect: - type(AttrVect) :: workV -! Component ID and number of segments for GSMap: - integer :: comp_id, ngseg, iseg -! Total length of GSMap segments laid end-to-end: - integer :: global_storage -! Error Flag - integer :: ierr -! Number of processes on communicator, and local rank: - integer :: NumProcs, myID -! Total local storage on each pe according to GSMap: - integer, dimension(:), allocatable :: lns -! Temporary GlobalMap used to scatter the segmented (by pe) data - type(GlobalMap) :: GMap -! Loop counters and temporary indices: - integer :: m, n, ilb, iub, olb, oub, pe -! workV segment tracking index array: - integer, dimension(:), allocatable :: current_pos - - ! Initialize stat (if present) - - if(present(stat)) stat = 0 - - ! Which process am I? - - call MPI_COMM_RANK(comm, myID, ierr) - - if(ierr /= 0) then - call MP_perr_die(myname_,'MPI_COMM_RANK',ierr) - endif - - if(myID == root) then - - if(GSMap%gsize > AttrVect_lsize(iV)) then - write(stderr,'(2a,i5,a,i8,a,i8)') myname_, & - ': myID = ',myID,'. Invalid input, GSMap%gsize =',& - GSMap%gsize, ', lsize(iV) =',AttrVect_lsize(iV) - if(present(stat)) then - stat=-1 - else - call die(myname_) - endif - endif - - endif - - ! On the root, initialize a work AttrVect type of the - ! above length, and with the same attribute lists as iV. - ! on other processes, initialize workV only with the - ! attribute information, but no storage. - - if(myID == root) then - - global_storage = GlobalSegMap_GlobalStorage(GSMap) - call AttrVect_init(workV, iV, global_storage) - call AttrVect_zero(workV) - - else - ! nullify workV just to be safe - - call List_nullify(workV%iList) - call List_nullify(workV%rList) - nullify(workV%iAttr) - nullify(workV%rAttr) - - endif - - ! Return to processing on the root to load workV: - - ! How many processes are there on this communicator? - - call MPI_COMM_SIZE(comm, NumProcs, ierr) - - if(ierr /= 0) then - call MP_perr_die(myname_,'MPI_COMM_SIZE',ierr) - endif - - ! Processor Check: Do the processors on GSMap match those in comm? - - if(MAXVAL(GSMap%pe_loc) > (NumProcs-1)) then - write(stderr,*) myname_, & - ":: Procs in GSMap%pe_loc do not match procs in communicator ", & - NumProcs-1, MAXVAL(GSMap%pe_loc) - if(present(stat)) then - stat=1 - return - else - call die(myname_) - endif - endif - - if(myID == root) then - - ! Allocate a precursor to a GlobalMap accordingly... - - allocate(lns(0:NumProcs-1), stat=ierr) - if(ierr /= 0) then - write(stderr,*) myname_,':: allocate(lns...) failed, stat=',ierr - if(present(stat)) then - stat=ierr - else - call die(myname_,'allocate(lns)',ierr) - endif - endif - - ! And Load it... - - lns(:)=0 - do iseg=1,GSMap%ngseg - n = GSMap%pe_loc(iseg) - lns(n) = lns(n) + GSMap%length(iseg) - end do - - endif ! if(myID == root) - - ! Non-root processes call GlobalMap_init with lns, - ! although this argument is not used in the - ! subroutine. Since it correspond to a dummy shaped array arguments - ! in GlobslMap_init, the Fortran 90 standard dictates that the actual - ! argument must contain complete shape information. Therefore, - ! the array argument must be allocated on all processes. - - if(myID /= root) then - - allocate(lns(1),stat=ierr) - if(ierr /= 0) then - write(stderr,*) myname_,':: allocate(lns...) failed, stat=',ierr - if(present(stat)) then - stat=ierr - return - else - call die(myname_,'allocate(lns(1))',ierr) - endif - endif - - endif ! if(myID /= root)... - - ! Create a GlobalMap describing the 1-D decomposition - ! of workV: - - comp_id = GlobalSegMap_comp_id(GSMap) - - call GlobalMap_init(GMap, comp_id, lns, root, comm) - - ! On the root, load workV: - - if(myID == root) then - - ! On the root, allocate current position index for - ! each process chunk: - - allocate(current_pos(0:NumProcs-1), stat=ierr) - if(ierr /= 0) then - write(stderr,*) myname_,':: allocate(current_pos..) failed, stat=', & - ierr - if(present(stat)) then - stat=ierr - return - else - call die(myname_,'allocate(current_pos)',ierr) - endif - endif - - ! Initialize current_pos(:) using GMap%displs(:) - - do n=0,NumProcs-1 - current_pos(n) = GMap%displs(n) + 1 - end do - - ! Load each segment of iV into its appropriate segment - ! of workV: - - ngseg = GlobalSegMap_ngseg(GSMap) - - do n=1,ngseg - - ! Determine which process owns segment n: - - pe = GSMap%pe_loc(n) - - ! Input map (lower/upper indicess) of segment of iV: - - ilb = GSMap%start(n) - iub = GSMap%start(n) + GSMap%length(n) - 1 - - ! Output map of (lower/upper indicess) segment of workV: - - olb = current_pos(pe) - oub = current_pos(pe) + GSMap%length(n) - 1 - - ! Increment current_pos(n) for next time: - - current_pos(pe) = current_pos(pe) + GSMap%length(n) - - ! Now we are equipped to do the copy: - - do m=1,AttrVect_nIAttr(iV) - workV%iAttr(m,olb:oub) = iV%iAttr(m,ilb:iub) - end do - - do m=1,AttrVect_nRAttr(iV) - workV%rAttr(m,olb:oub) = iV%rAttr(m,ilb:iub) - end do - - end do ! do n=1,ngseg - - ! Clean up current_pos, which was only allocated on the root - - deallocate(current_pos, stat=ierr) - if(ierr /= 0) then - write(stderr,*) myname_,':: deallocate(current_pos) failed. ', & - 'stat = ',ierr - if(present(stat)) then - stat=ierr - return - else - call die(myname_,'deallocate(current_pos)',ierr) - endif - endif - - endif ! if(myID == root) - - ! Now we are in business...we have: 1) an AttrVect laid out - ! in contiguous segments, each segment corresponding to a - ! process, and in the same order dictated by GSMap; - ! 2) a GlobalMap telling us which segment of workV goes to - ! which process. Thus, we can us GM_scatter_() to achieve - ! our goal. - - call GM_scatter_(workV, oV, GMap, root, comm, ierr) - if(ierr /= 0) then - write(stderr,*) myname,':: ERROR in return from GM_scatter_(), ierr=',& - ierr - if(present(stat)) then - stat = ierr - return - else - call die(myname_,'ERROR returning from GM_scatter_()',ierr) - endif - endif - - ! Finally, clean up allocated structures: - - if(myID == root) then - call AttrVect_clean(workV) - endif - - call GlobalMap_clean(GMap) - - deallocate(lns, stat=ierr) - if(ierr /= 0) then - write(stderr,*) myname_,':: ERROR in deallocate(lns), ierr=',ierr - if(present(stat)) then - stat=ierr - return - else - call die(myname_,'deallocate(lns)',ierr) - endif - endif - - end subroutine GSM_scatter_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: bcast_ - Broadcast an AttrVect -! -! !DESCRIPTION: This routine takes an {\tt AttrVect} argument {\tt aV} -! (at input, valid on the root only), and broadcasts it to all the -! processes associated with the communicator handle {\tt comm}. The -! success (failure) of this routine is reported in the zero (non-zero) -! value of the output argument {\tt stat}. -! -! {\bf N.B.}: The output (on non-root processes) {\tt AttrVect} argument -! {\tt aV} represents dynamically allocated memory. When it is no longer -! needed, it should be deallocated by invoking {\tt AttrVect\_clean()} -! (see the module {\tt m\_AttrVect} for details). -! -! !INTERFACE: - - subroutine bcast_(aV, root, comm, stat) -! -! !USES: -! - use m_stdio - use m_die - use m_mpif90 - use m_String, only : String,bcast,char,String_clean - use m_String, only : String_bcast => bcast - use m_List, only : List_get => get - use m_AttrVect, only : AttrVect - use m_AttrVect, only : AttrVect_init => init - use m_AttrVect, only : AttrVect_zero => zero - use m_AttrVect, only : AttrVect_lsize => lsize - use m_AttrVect, only : AttrVect_nIAttr => nIAttr - use m_AttrVect, only : AttrVect_nRAttr => nRAttr - - implicit none - -! !INPUT PARAMETERS: -! - integer, intent(in) :: root - integer, intent(in) :: comm - -! !INPUT/OUTPUT PARAMETERS: -! - type(AttrVect), intent(inout) :: aV ! (IN) on the root, - ! (OUT) elsewhere - -! !OUTPUT PARAMETERS: -! - integer, optional, intent(out) :: stat - -! !REVISION HISTORY: -! 27Apr98 - Jing Guo - initial prototype/prologue/code -! 27Oct00 - J.W. Larson - relocated from -! m_AttrVect -! 9May01 - J.W. Larson - tidied up prologue -! 18May01 - R.L. Jacob - use MP_Type function -! to determine type for bcast -! 19Dec01 - E.T. Ong - adjusted for case of AV with -! only integer or real attribute -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::bcast_' - type(String) :: iLStr,rLStr - integer :: nIA, nRA, lsize - integer :: myID - integer :: ier - integer :: mp_Type_aV - - if(present(stat)) stat=0 - - call MP_comm_rank(comm,myID,ier) - if(ier /= 0) then - call MP_perr_die(myname_,'MP_comm_rank()',ier) - endif - - ! Broadcaast to all PEs - - if(myID == root) then - nIA = AttrVect_nIAttr(aV) - nRA = AttrVect_nRAttr(aV) - lsize = AttrVect_lsize(aV) - endif - - call MPI_bcast(nIA,1,MP_INTEGER,root,comm,ier) - if(ier /= 0) then - call MP_perr_die(myname_,'MPI_bcast(nIA)',ier) - endif - - call MPI_bcast(nRA,1,MP_INTEGER,root,comm,ier) - if(ier /= 0) then - call MP_perr_die(myname_,'MPI_bcast(nRA)',ier) - endif - - call MPI_bcast(lsize,1,MP_INTEGER,root,comm,ier) - if(ier /= 0) then - call MP_perr_die(myname_,'MPI_bcast(lsize)',ier) - endif - - ! Convert the two Lists to two Strings - - if(nIA>0) then - - if(myID == root) call List_get(iLStr,aV%iList) - - call String_bcast(iLStr,root,comm,stat=ier) ! bcast.String() - - if(ier /= 0) then - write(stderr,*) myname_,'bcast.String(iLstr), ier=',ier - if(present(stat)) then - stat=ier - return - else - call die(myname_,'String_bcast(iLStr) failed',ier) - endif - endif ! if(ier /= 0)... - - endif ! if(nIA > 0)... - - - if(nRA>0) then - - if(myID == root) call List_get(rLStr,aV%rList) - - call String_bcast(rLStr,root,comm,stat=ier) ! bcast.String() - if(ier /= 0) then - write(stderr,*) myname_,'bcast.String(iLstr), ier=',ier - if(present(stat)) then - stat=ier - return - else - call die(myname_,'String_bcast(iLStr) failed',ier) - endif - endif ! if(ier /= 0)... - - endif ! if(nRA > 0)... - - if(myID /= root) then - - if( (nIA>0) .and. (nRA>0) ) then - call AttrVect_init(aV,iList=char(iLStr),rList=char(rLStr), & - lsize=lsize) - endif - - if( (nIA>0) .and. (nRA<=0) ) then - call AttrVect_init(aV,iList=char(iLStr),lsize=lsize) - endif - - if( (nIA<=0) .and. (nRA>0) ) then - call AttrVect_init(aV,rList=char(rLStr),lsize=lsize) - endif - - if( (nIA<=0) .and. (nRA<=0) ) then - write(stderr,*) myname_,':: Nonpositive numbers of both ',& - 'real AND integer attributes. nIA =',nIA,' nRA=',nRA - if(present(stat)) then - stat = -1 - return - else - call die(myname_,'AV has not been initialized',-1) - endif - endif ! if((nIA<= 0) .and. (nRA<=0))... - - call AttrVect_zero(aV) - - - endif ! if(myID /= root)... - - if(nIA > 0) then - - mp_Type_aV=MP_Type(av%iAttr) - call MPI_bcast(aV%iAttr,nIA*lsize,mp_Type_aV,root,comm,ier) - if(ier /= 0) then - call MP_perr_die(myname_,'MPI_bcast(iAttr) failed.',ier) - endif - - call String_clean(iLStr) - - endif - - if(nRA > 0) then - - mp_Type_aV=MP_Type(av%rAttr) - call MPI_bcast(aV%rAttr,nRA*lsize,mp_Type_aV,root,comm,ier) - if(ier /= 0) then - call MP_perr_die(myname_,'MPI_bcast(rAttr) failed.',ier) - endif - - call String_clean(rLStr) - - endif - - end subroutine bcast_ - - end module m_AttrVectComms - - - diff --git a/cesm/models/utils/mct/mct/m_AttrVectReduce.F90 b/cesm/models/utils/mct/mct/m_AttrVectReduce.F90 deleted file mode 100644 index 3df2cc8..0000000 --- a/cesm/models/utils/mct/mct/m_AttrVectReduce.F90 +++ /dev/null @@ -1,1108 +0,0 @@ -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!----------------------------------------------------------------------- -! CVS $Id$ -! CVS $Name$ -!BOP ------------------------------------------------------------------- -! -! !MODULE: m_AttrVectReduce - Local/Distributed AttrVect Reduction Ops. -! -! !DESCRIPTION: This module provides routines to perform reductions on -! the {\tt AttrVect} datatype. These reductions can either be the types -! of operations supported by MPI (currently, summation, minimum and -! maximum are available) that are applied either to all the attributes -! (both integer and real), or specific reductions applicable only to the -! real attributes of an {\tt AttrVect}. This module provides services -! for both local (i.e., one address space) and global (distributed) -! reductions. The type of reduction is defined through use of one of -! the public data members of this module: -!\begin{table}[htbp] -!\begin{center} -!\begin{tabular}{|c|c|} -!\hline -!{\bf Value} & {\bf Action} \\ -!\hline -!{\tt AttrVectSUM} & Sum \\ -!\hline -!{\tt AttrVectMIN} & Minimum \\ -!\hline -!{\tt AttrVectMAX} & Maximum \\ -!\hline -!\end{tabular} -!\end{center} -!\end{table} -! -! !INTERFACE: - - module m_AttrVectReduce -! -! !USES: -! -! No modules are used in the declaration section of this module. - - implicit none - - private ! except - -! !PUBLIC MEMBER FUNCTIONS: - - public :: LocalReduce ! Local reduction of all attributes - public :: LocalReduceRAttr ! Local reduction of REAL attributes - public :: AllReduce ! AllReduce for distributed AttrVect - public :: GlobalReduce ! Local Reduce followed by AllReduce - public :: LocalWeightedSumRAttr ! Local weighted sum of - ! REAL attributes - public :: GlobalWeightedSumRAttr ! Global weighted sum of REAL - ! attributes for a distrubuted - ! AttrVect - - interface LocalReduce ; module procedure LocalReduce_ ; end interface - interface LocalReduceRAttr - module procedure LocalReduceRAttr_ - end interface - interface AllReduce - module procedure AllReduce_ - end interface - interface GlobalReduce - module procedure GlobalReduce_ - end interface - interface LocalWeightedSumRAttr; module procedure & - LocalWeightedSumRAttrSP_, & - LocalWeightedSumRAttrDP_ - end interface - interface GlobalWeightedSumRAttr; module procedure & - GlobalWeightedSumRAttrSP_, & - GlobalWeightedSumRAttrDP_ - end interface - -! !PUBLIC DATA MEMBERS: - - public :: AttrVectSUM - public :: AttrVectMIN - public :: AttrVectMAX - - integer, parameter :: AttrVectSUM = 1 - integer, parameter :: AttrVectMIN = 2 - integer, parameter :: AttrVectMAX = 3 - -! !REVISION HISTORY: -! -! 7May02 - J.W. Larson - Created module -! using routines originally prototyped in m_AttrVect. -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname='MCT::m_AttrVectReduce' - - contains - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: LocalReduce_ - Local Reduction of INTEGER and REAL Attributes -! -! !DESCRIPTION: -! -! The subroutine {\tt LocalReduce\_()} takes the input {\tt AttrVect} -! argument {\tt inAV}, and reduces each of its integer and real -! attributes, returning them in the output {\tt AttrVect} argument -! {\tt outAV} (which is created by this routine). The type of -! reduction is defined by the input {\tt INTEGER} argument {\tt action}. -! Allowed values for action are defined as public data members to this -! module, and are summarized below: -! -!\begin{table}[htbp] -!\begin{center} -!\begin{tabular}{|c|c|} -!\hline -!{\bf Value} & {\bf Action} \\ -!\hline -!{\tt AttrVectSUM} & Sum \\ -!\hline -!{\tt AttrVectMIN} & Minimum \\ -!\hline -!{\tt AttrVectMAX} & Maximum \\ -!\hline -!\end{tabular} -!\end{center} -!\end{table} -! -! {\bf N.B.}: The output {\tt AttrVect} argument {\tt outAV} is -! allocated memory, and must be destroyed by invoking the routine -! {\tt AttrVect\_clean()} when it is no longer needed. Failure to -! do so will result in a memory leak. -! -! !INTERFACE: - - subroutine LocalReduce_(inAV, outAV, action) -! -! !USES: -! - use m_realkinds, only : FP - use m_die , only : die - use m_stdio , only : stderr - use m_AttrVect, only : AttrVect - use m_AttrVect, only : AttrVect_init => init - use m_AttrVect, only : AttrVect_zero => zero - use m_AttrVect, only : AttrVect_nIAttr => nIAttr - use m_AttrVect, only : AttrVect_nRAttr => nRAttr - use m_AttrVect, only : AttrVect_lsize => lsize - - implicit none - -! !INPUT PARAMETERS: -! - type(AttrVect), intent(IN) :: inAV - integer, intent(IN) :: action - -! !OUTPUT PARAMETERS: -! - type(AttrVect), intent(OUT) :: outAV - -! !REVISION HISTORY: -! 16Apr02 - J.W. Larson - initial prototype -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::LocalReduce_' - - integer :: i,j - - ! First Step: create outAV from inAV (but with one element) - - call AttrVect_init(outAV, inAV, lsize=1) - - call AttrVect_zero(outAV) - - select case(action) - case(AttrVectSUM) ! sum up each attribute... - - ! Compute INTEGER and REAL attribute sums: - - do j=1,AttrVect_lsize(inAV) - do i=1,AttrVect_nIAttr(outAV) - outAV%iAttr(i,1) = outAV%iAttr(i,1) + inAV%iAttr(i,j) - end do - end do - - do j=1,AttrVect_lsize(inAV) - do i=1,AttrVect_nRAttr(outAV) - outAV%rAttr(i,1) = outAV%rAttr(i,1) + inAV%rAttr(i,j) - end do - end do - - case(AttrVectMIN) ! find the minimum of each attribute... - - ! Initialize INTEGER and REAL attribute minima: - - do i=1,AttrVect_nIAttr(outAV) - outAV%iAttr(i,1) = inAV%iAttr(i,1) - end do - - do i=1,AttrVect_nRAttr(outAV) - outAV%rAttr(i,1) = inAV%rAttr(i,1) - end do - - ! Compute INTEGER and REAL attribute minima: - - do j=1,AttrVect_lsize(inAV) - do i=1,AttrVect_nIAttr(outAV) - if(inAV%iAttr(i,j) < outAV%iAttr(i,1)) then - outAV%iAttr(i,1) = inAV%iAttr(i,j) - endif - end do - end do - - do j=1,AttrVect_lsize(inAV) - do i=1,AttrVect_nRAttr(outAV) - if(inAV%rAttr(i,j) < outAV%rAttr(i,1)) then - outAV%rAttr(i,1) = inAV%rAttr(i,j) - endif - end do - end do - - case(AttrVectMAX) ! find the maximum of each attribute... - - ! Initialize INTEGER and REAL attribute maxima: - - do i=1,AttrVect_nIAttr(outAV) - outAV%iAttr(i,1) = inAV%iAttr(i,1) - end do - - do i=1,AttrVect_nRAttr(outAV) - outAV%rAttr(i,1) = inAV%rAttr(i,1) - end do - - ! Compute INTEGER and REAL attribute maxima: - - do j=1,AttrVect_lsize(inAV) - do i=1,AttrVect_nIAttr(outAV) - if(inAV%iAttr(i,j) > outAV%iAttr(i,1)) then - outAV%iAttr(i,1) = inAV%iAttr(i,j) - endif - end do - end do - - do j=1,AttrVect_lsize(inAV) - do i=1,AttrVect_nRAttr(outAV) - if(inAV%rAttr(i,j) > outAV%rAttr(i,1)) then - outAV%rAttr(i,1) = inAV%rAttr(i,j) - endif - end do - end do - - case default - - write(stderr,'(2a,i8)') myname_,':: unrecognized action = ',action - call die(myname_) - - end select - - end subroutine LocalReduce_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: LocalReduceRAttr_ - Local Reduction of REAL Attributes -! -! !DESCRIPTION: -! -! The subroutine {\tt LocalReduceRAttr\_()} takes the input -! {\tt AttrVect} argument {\tt inAV}, and reduces each of its {\tt REAL} -! attributes, returning them in the output {\tt AttrVect} argument -! {\tt outAV} (which is created by this routine). The type of reduction -! is defined by the input {\tt INTEGER} argument {\tt action}. Allowed -! values for action are defined as public data members to this module -! (see the declaration section of {\tt m\_AttrVect}, and are summarized below: -! -!\begin{table}[htbp] -!\begin{center} -!\begin{tabular}{|c|c|} -!\hline -!{\bf Value} & {\bf Action} \\ -!\hline -!{\tt AttrVectSUM} & Sum \\ -!\hline -!{\tt AttrVectMIN} & Minimum \\ -!\hline -!{\tt AttrVectMAX} & Maximum \\ -!\hline -!\end{tabular} -!\end{center} -!\end{table} -! -! {\bf N.B.}: The output {\tt AttrVect} argument {\tt outAV} is -! allocated memory, and must be destroyed by invoking the routine -! {\tt AttrVect\_clean()} when it is no longer needed. Failure to -! do so will result in a memory leak. -! -! !INTERFACE: -! - subroutine LocalReduceRAttr_(inAV, outAV, action) - -! -! !USES: -! - use m_realkinds, only : FP - - use m_die , only : die - use m_stdio , only : stderr - - use m_List, only : List - use m_List, only : List_copy => copy - use m_List, only : List_exportToChar => exportToChar - use m_List, only : List_clean => clean - - use m_AttrVect, only : AttrVect - use m_AttrVect, only : AttrVect_init => init - use m_AttrVect, only : AttrVect_zero => zero - use m_AttrVect, only : AttrVect_nIAttr => nIAttr - use m_AttrVect, only : AttrVect_nRAttr => nRAttr - use m_AttrVect, only : AttrVect_lsize => lsize - - implicit none - -! !INPUT PARAMETERS: -! - type(AttrVect), intent(IN) :: inAV - integer, intent(IN) :: action - -! !OUTPUT PARAMETERS: -! - type(AttrVect), intent(OUT) :: outAV - -! !REVISION HISTORY: -! 16Apr02 - J.W. Larson - initial prototype -! 6May02 - J.W. Larson - added optional -! argument weights(:) -! 8May02 - J.W. Larson - modified interface -! to return it to being a pure reduction operation. -! 9May02 - J.W. Larson - renamed from -! LocalReduceReals_() to LocalReduceRAttr_() to make -! the name more consistent with other module procedure -! names in this module. -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::LocalReduceRAttr_' - - integer :: i,j - type(List) :: rList_copy - - - ! First Step: create outAV from inAV (but with one element) - - ! Superflous list copy circumvents SGI compiler bug - call List_copy(rList_copy,inAV%rList) - call AttrVect_init(outAV, rList=List_exportToChar(rList_copy), lsize=1) - call AttrVect_zero(outAV) - call List_clean(rList_copy) - - select case(action) - case(AttrVectSUM) ! sum up each attribute... - - ! Compute REAL attribute sums: - - do j=1,AttrVect_lsize(inAV) - do i=1,AttrVect_nRAttr(outAV) - outAV%rAttr(i,1) = outAV%rAttr(i,1) + inAV%rAttr(i,j) - end do - end do - - case(AttrVectMIN) ! find the minimum of each attribute... - - ! Initialize REAL attribute minima: - - do i=1,AttrVect_nRAttr(outAV) - outAV%rAttr(i,1) = inAV%rAttr(i,1) - end do - - ! Compute REAL attribute minima: - - do j=1,AttrVect_lsize(inAV) - do i=1,AttrVect_nRAttr(outAV) - if(inAV%rAttr(i,j) < outAV%rAttr(i,1)) then - outAV%rAttr(i,1) = inAV%rAttr(i,j) - endif - end do - end do - - case(AttrVectMAX) ! find the maximum of each attribute... - - ! Initialize REAL attribute maxima: - - do i=1,AttrVect_nRAttr(outAV) - outAV%rAttr(i,1) = inAV%rAttr(i,1) - end do - - ! Compute REAL attribute maxima: - - do j=1,AttrVect_lsize(inAV) - do i=1,AttrVect_nRAttr(outAV) - if(inAV%rAttr(i,j) > outAV%rAttr(i,1)) then - outAV%rAttr(i,1) = inAV%rAttr(i,j) - endif - end do - end do - - case default - - write(stderr,'(2a,i8)') myname_,':: unrecognized action = ',action - call die(myname_) - - end select - - end subroutine LocalReduceRAttr_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: AllReduce_ - Reduction of INTEGER and REAL Attributes -! -! !DESCRIPTION: -! -! The subroutine {\tt AllReduce\_()} takes the distributed input -! {\tt AttrVect} argument {\tt inAV}, and performs a global reduction -! of all its attributes across the MPI communicator associated with -! the Fortran90 {\tt INTEGER} handle {\tt comm}, and returns these -! reduced values to all processes in the {\tt AttrVect} argument -! {\tt outAV} (which is created by this routine). The reduction -! operation is specified by the user, and must have one of the values -! listed in the table below: -!\begin{table}[htbp] -!\begin{center} -!\begin{tabular}{|c|c|} -!\hline -!{\bf Value} & {\bf Action} \\ -!\hline -!{\tt AttrVectSUM} & Sum \\ -!\hline -!{\tt AttrVectMIN} & Minimum \\ -!\hline -!{\tt AttrVectMAX} & Maximum \\ -!\hline -!\end{tabular} -!\end{center} -!\end{table} -! -! {\bf N.B.}: The output {\tt AttrVect} argument {\tt outAV} is -! allocated memory, and must be destroyed by invoking the routine -! {\tt AttrVect\_clean()} when it is no longer needed. Failure to -! do so will result in a memory leak. -! -! !INTERFACE: -! - - subroutine AllReduce_(inAV, outAV, ReductionOp, comm, ierr) - -! -! !USES: -! - use m_die - use m_stdio , only : stderr - use m_mpif90 - - use m_List, only : List - use m_List, only : List_exportToChar => exportToChar - use m_List, only : List_allocated => allocated - - use m_AttrVect, only : AttrVect - use m_AttrVect, only : AttrVect_init => init - use m_AttrVect, only : AttrVect_zero => zero - use m_AttrVect, only : AttrVect_lsize => lsize - use m_AttrVect, only : AttrVect_nIAttr => nIAttr - use m_AttrVect, only : AttrVect_nRAttr => nRAttr - - implicit none - -! !INPUT PARAMETERS: -! - type(AttrVect), intent(IN) :: inAV - integer, intent(IN) :: ReductionOp - integer, intent(IN) :: comm - -! !OUTPUT PARAMETERS: -! - type(AttrVect), intent(OUT) :: outAV - integer, optional, intent(OUT) :: ierr - -! !REVISION HISTORY: -! 8May02 - J.W. Larson - initial version. -! 9Jul02 - J.W. Larson - slight modification; -! use List_allocated() to determine if there is attribute -! data to be reduced (this patch is to support the Sun -! F90 compiler). -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::AllReduce_' - - integer :: BufferSize, myID, ier - - ! Initialize ierr (if present) to "success" value - if(present(ierr)) ierr = 0 - - call MPI_COMM_RANK(comm, myID, ier) - if(ier /= 0) then - write(stderr,'(2a)') myname_,':: MPI_COMM_RANK() failed.' - call MP_perr_die(myname_, 'MPI_COMM_RANK() failed.', ier) - endif - - call AttrVect_init(outAV, inAV, lsize=AttrVect_lsize(inAV)) - call AttrVect_zero(outAV) - - if(List_allocated(inAV%rList)) then ! invoke MPI_AllReduce() for the real - ! attribute data. - BufferSize = AttrVect_lsize(inAV) * AttrVect_nRAttr(inAV) - - select case(ReductionOp) - case(AttrVectSUM) - call MPI_AllReduce(inAV%rAttr, outAV%rAttr, BufferSize, & - MP_Type(inAV%rAttr(1,1)), MP_SUM, & - comm, ier) - case(AttrVectMIN) - call MPI_AllReduce(inAV%rAttr, outAV%rAttr, BufferSize, & - MP_Type(inAV%rAttr(1,1)), MP_MIN, & - comm, ier) - case(AttrVectMAX) - call MPI_AllReduce(inAV%rAttr, outAV%rAttr, BufferSize, & - MP_Type(inAV%rAttr(1,1)), MP_MAX, & - comm, ier) - case default - write(stderr,'(2a,i8,a)') myname_, & - '::FATAL ERROR--value of RedctionOp=', & - ReductionOp,' not supported.' - end select - - if(ier /= 0) then - write(stderr,*) myname_, & - ':: Fatal Error in MPI_AllReduce(), myID = ',myID - call MP_perr_die(myname_, 'MPI_AllReduce() failed.', ier) - endif - - endif ! if(List_allocated(inAV%rList))... - - if(List_allocated(inAV%iList)) then ! invoke MPI_AllReduce() for the - ! integer attribute data. - - BufferSize = AttrVect_lsize(inAV) * AttrVect_nIAttr(inAV) - - select case(ReductionOp) - case(AttrVectSUM) - call MPI_AllReduce(inAV%iAttr, outAV%iAttr, BufferSize, & - MP_Type(inAV%iAttr(1,1)), MP_SUM, & - comm, ier) - case(AttrVectMIN) - call MPI_AllReduce(inAV%iAttr, outAV%iAttr, BufferSize, & - MP_Type(inAV%iAttr(1,1)), MP_MIN, & - comm, ier) - case(AttrVectMAX) - call MPI_AllReduce(inAV%iAttr, outAV%iAttr, BufferSize, & - MP_Type(inAV%iAttr(1,1)), MP_MAX, & - comm, ier) - case default - write(stderr,'(2a,i8,a)') myname_, & - '::FATAL ERROR--value of RedctionOp=', & - ReductionOp,' not supported.' - end select - - if(ierr /= 0) then - write(stderr,*) myname_, & - ':: Fatal Error in MPI_AllReduce(), myID = ',myID - call MP_perr_die(myname_, 'MPI_AllReduce() failed.', ier) - endif - endif ! if(List_allocated(inAV%iList))... - - if(present(ierr)) ierr = ier - - end subroutine AllReduce_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: GlobalReduce_ - Reduction of INTEGER and REAL Attributes -! -! !DESCRIPTION: -! -! The subroutine {\tt GlobalReduce\_()} takes the distributed input -! {\tt AttrVect} argument {\tt inAV}, and performs a local reduction of -! all its integer and real attributes, followed by a an {\tt AllReduce} -! of all the result of the local reduction across the MPI communicator -! associated with the Fortran90 {\tt INTEGER} handle {\tt comm}, and -! returns these reduced values to all processes in the {\tt AttrVect} -! argument {\tt outAV} (which is created by this routine). The reduction -! operation is specified by the user, and must have one of the values -! listed in the table below: -!\begin{table}[htbp] -!\begin{center} -!\begin{tabular}{|c|c|} -!\hline -!{\bf Value} & {\bf Action} \\ -!\hline -!{\tt AttrVectSUM} & Sum \\ -!\hline -!{\tt AttrVectMIN} & Minimum \\ -!\hline -!{\tt AttrVectMAX} & Maximum \\ -!\hline -!\end{tabular} -!\end{center} -!\end{table} -! -! {\bf N.B.}: The output {\tt AttrVect} argument {\tt outAV} is -! allocated memory, and must be destroyed by invoking the routine -! {\tt AttrVect\_clean()} when it is no longer needed. Failure to -! do so will result in a memory leak. -! -! !INTERFACE: -! - - subroutine GlobalReduce_(inAV, outAV, ReductionOp, comm, ierr) - -! -! !USES: -! - use m_die - use m_stdio , only : stderr - use m_mpif90 - - use m_AttrVect, only : AttrVect - use m_AttrVect, only : AttrVect_clean => clean - - implicit none - -! !INPUT PARAMETERS: -! - type(AttrVect), intent(IN) :: inAV - integer, intent(IN) :: ReductionOp - integer, intent(IN) :: comm - -! !OUTPUT PARAMETERS: -! - type(AttrVect), intent(OUT) :: outAV - integer, optional, intent(OUT) :: ierr - -! !REVISION HISTORY: -! 6May03 - J.W. Larson - initial version. -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::GlobalReduce_' - type(AttrVect) :: LocalResult - - ! Step One: On-PE reduction - - call LocalReduce_(inAV, LocalResult, ReductionOp) - - ! Step Two: An AllReduce on the distributed local reduction results - - if(present(ierr)) then - call AllReduce_(LocalResult, outAV, ReductionOp, comm, ierr) - else - call AllReduce_(LocalResult, outAV, ReductionOp, comm) - endif - - ! Step Three: Clean up and return. - - call AttrVect_clean(LocalResult) - - end subroutine GlobalReduce_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: LocalWeightedSumRAttrSP_ - Local Weighted Sum of REAL Attributes -! -! !DESCRIPTION: -! -! The subroutine {\tt LocalWeightedSumRAttr\_()} takes the input -! {\tt AttrVect} argument {\tt inAV}, and performs a weighted sum -! of each of its {\tt REAL} attributes, returning them in the output -! {\tt AttrVect} argument {\tt outAV} (which is created by this routine -! and will contain {\em no} integer attributes). The weights used -! for the summation are provided by the user in the input argument -! {\tt Weights(:)}. If the sum of the weights is desired, this can be -! returned as an attribute in {\tt outAV} if the optional {\tt CHARACTER} -! argument {\tt WeightSumAttr} is provided (which will be concatenated -! onto the list of real attributes in {\tt inAV}). -! -! {\bf N.B.}: The argument {\tt WeightSumAttr} must not be identical -! to any of the real attribute names in {\tt inAV}. -! -! {\bf N.B.}: The output {\tt AttrVect} argument {\tt outAV} is -! allocated memory, and must be destroyed by invoking the routine -! {\tt AttrVect\_clean()} when it is no longer needed. Failure to -! do so will result in a memory leak. -! -! !INTERFACE: -! - subroutine LocalWeightedSumRAttrSP_(inAV, outAV, Weights, WeightSumAttr) - -! -! !USES: -! - use m_die , only : die - use m_stdio , only : stderr - use m_realkinds, only : SP, FP - - use m_List, only : List - use m_List, only : List_init => init - use m_List, only : List_clean => clean - use m_List, only : List_exportToChar => exportToChar - use m_List, only : List_concatenate => concatenate - - use m_AttrVect, only : AttrVect - use m_AttrVect, only : AttrVect_init => init - use m_AttrVect, only : AttrVect_zero => zero - use m_AttrVect, only : AttrVect_nIAttr => nIAttr - use m_AttrVect, only : AttrVect_nRAttr => nRAttr - use m_AttrVect, only : AttrVect_lsize => lsize - - implicit none - -! !INPUT PARAMETERS: -! - type(AttrVect), intent(IN) :: inAV - real(SP), dimension(:), pointer :: Weights - character(len=*), optional, intent(IN) :: WeightSumAttr - -! !OUTPUT PARAMETERS: -! - type(AttrVect), intent(OUT) :: outAV - -! !REVISION HISTORY: -! 8May02 - J.W. Larson - initial version. -! 14Jun02 - J.W. Larson - bug fix regarding -! accumulation of weights when invoked with argument -! weightSumAttr. Now works in MCT unit tester. -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::LocalWeightedSumRAttrSP_' - - integer :: i,j - type(List) dummyList1, dummyList2 - - ! Check for consistencey between inAV and the weights array - - if(size(weights) /= AttrVect_lsize(inAV)) then - write(stderr,'(4a)') myname_,':: ERROR--mismatch in lengths of ', & - 'input array array argument weights(:) and input AttrVect ',& - 'inAV.' - write(stderr,'(2a,i8)') myname_,':: size(weights)=',size(weights) - write(stderr,'(2a,i8)') myname_,':: length of inAV=', & - AttrVect_lsize(inAV) - call die(myname_) - endif - - ! First Step: create outAV from inAV (but with one element) - - if(present(WeightSumAttr)) then - call List_init(dummyList1,WeightSumAttr) - call List_concatenate(inAV%rList, dummyList1, dummyList2) - call AttrVect_init(outAV, rList=List_exportToChar(dummyList2), & - lsize=1) - call List_clean(dummyList1) - call List_clean(dummyList2) - else - call AttrVect_init(outAV, rList=List_exportToChar(inAV%rList), lsize=1) - endif - - ! Initialize REAL attribute sums: - call AttrVect_zero(outAV) - - ! Compute REAL attribute sums: - - if(present(WeightSumAttr)) then ! perform weighted sum AND sum weights - - do j=1,AttrVect_lsize(inAV) - - do i=1,AttrVect_nRAttr(inAV) - outAV%rAttr(i,1) = outAV%rAttr(i,1) + inAV%rAttr(i,j) * weights(j) - end do - ! The final attribute is the sum of the weights - outAV%rAttr(AttrVect_nRAttr(outAV),1) = & - outAV%rAttr(AttrVect_nRAttr(outAV),1) + weights(j) - end do - - else ! only perform weighted sum - - do j=1,AttrVect_lsize(inAV) - do i=1,AttrVect_nRAttr(inAV) - outAV%rAttr(i,1) = outAV%rAttr(i,1) + inAV%rAttr(i,j) * weights(j) - end do - end do - - endif ! if(present(WeightSumAttr))... - - end subroutine LocalWeightedSumRAttrSP_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -! ---------------------------------------------------------------------- -! -! !IROUTINE: LocalWeightedSumRAttrDP_ - Local Weighted Sum of REAL Attributes -! -! !DESCRIPTION: -! Double precision version of LocalWeightedSumRAttrSP_ -! -! !INTERFACE: -! - subroutine LocalWeightedSumRAttrDP_(inAV, outAV, Weights, WeightSumAttr) - -! -! !USES: -! - use m_die , only : die - use m_stdio , only : stderr - use m_realkinds, only : DP, FP - - use m_List, only : List - use m_List, only : List_init => init - use m_List, only : List_clean => clean - use m_List, only : List_exportToChar => exportToChar - use m_List, only : List_concatenate => concatenate - - use m_AttrVect, only : AttrVect - use m_AttrVect, only : AttrVect_init => init - use m_AttrVect, only : AttrVect_zero => zero - use m_AttrVect, only : AttrVect_nIAttr => nIAttr - use m_AttrVect, only : AttrVect_nRAttr => nRAttr - use m_AttrVect, only : AttrVect_lsize => lsize - - implicit none - -! !INPUT PARAMETERS: -! - type(AttrVect), intent(IN) :: inAV - real(DP), dimension(:), pointer :: Weights - character(len=*), optional, intent(IN) :: WeightSumAttr - -! !OUTPUT PARAMETERS: -! - type(AttrVect), intent(OUT) :: outAV - -! !REVISION HISTORY: -! 8May02 - J.W. Larson - initial version. -! 14Jun02 - J.W. Larson - bug fix regarding -! accumulation of weights when invoked with argument -! weightSumAttr. Now works in MCT unit tester. -! ______________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::LocalWeightedSumRAttrDP_' - - integer :: i,j - type(List) dummyList1, dummyList2 - - ! Check for consistencey between inAV and the weights array - - if(size(weights) /= AttrVect_lsize(inAV)) then - write(stderr,'(4a)') myname_,':: ERROR--mismatch in lengths of ', & - 'input array array argument weights(:) and input AttrVect ',& - 'inAV.' - write(stderr,'(2a,i8)') myname_,':: size(weights)=',size(weights) - write(stderr,'(2a,i8)') myname_,':: length of inAV=', & - AttrVect_lsize(inAV) - call die(myname_) - endif - - ! First Step: create outAV from inAV (but with one element) - - if(present(WeightSumAttr)) then - call List_init(dummyList1,WeightSumAttr) - call List_concatenate(inAV%rList, dummyList1, dummyList2) - call AttrVect_init(outAV, rList=List_exportToChar(dummyList2), & - lsize=1) - call List_clean(dummyList1) - call List_clean(dummyList2) - else - call AttrVect_init(outAV, rList=List_exportToChar(inAV%rList), lsize=1) - endif - - ! Initialize REAL attribute sums: - call AttrVect_zero(outAV) - - ! Compute REAL attribute sums: - - if(present(WeightSumAttr)) then ! perform weighted sum AND sum weights - - do j=1,AttrVect_lsize(inAV) - - do i=1,AttrVect_nRAttr(inAV) - outAV%rAttr(i,1) = outAV%rAttr(i,1) + inAV%rAttr(i,j) * weights(j) - end do - ! The final attribute is the sum of the weights - outAV%rAttr(AttrVect_nRAttr(outAV),1) = & - outAV%rAttr(AttrVect_nRAttr(outAV),1) + weights(j) - end do - - else ! only perform weighted sum - - do j=1,AttrVect_lsize(inAV) - do i=1,AttrVect_nRAttr(inAV) - outAV%rAttr(i,1) = outAV%rAttr(i,1) + inAV%rAttr(i,j) * weights(j) - end do - end do - - endif ! if(present(WeightSumAttr))... - - end subroutine LocalWeightedSumRAttrDP_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: GlobalWeightedSumRAttrSP_ - Global Weighted Sum of REAL Attributes -! -! !DESCRIPTION: -! -! The subroutine {\tt GlobalWeightedSumRAttr\_()} takes the -! distributed input {\tt AttrVect} argument {\tt inAV}, and performs -! a weighted global sum across the MPI communicator associated with -! the Fortran90 {\tt INTEGER} handle {\tt comm} of each of its -! {\tt REAL} attributes, returning the sums to each process in the -! {\tt AttrVect} argument {\tt outAV} (which is created by this routine -! and will contain {\em no} integer attributes). The weights used for -! the summation are provided by the user in the input argument -! {\tt weights(:)}. If the sum of the weights is desired, this can be -! returned as an attribute in {\tt outAV} if the optional {\tt CHARACTER} -! argument {\tt WeightSumAttr} is provided (which will be concatenated -! onto the list of real attributes in {\tt inAV} to form the list of -! real attributes for {\tt outAV}). -! -! {\bf N.B.}: The argument {\tt WeightSumAttr} must not be identical -! to any of the real attribute names in {\tt inAV}. -! -! {\bf N.B.}: The output {\tt AttrVect} argument {\tt outAV} is -! allocated memory, and must be destroyed by invoking the routine -! {\tt AttrVect\_clean()} when it is no longer needed. Failure to -! do so will result in a memory leak. -! -! !INTERFACE: -! - subroutine GlobalWeightedSumRAttrSP_(inAV, outAV, Weights, comm, & - WeightSumAttr) - -! -! !USES: -! - use m_die - use m_stdio , only : stderr - use m_mpif90 - use m_realkinds, only : SP - - use m_List, only : List - use m_List, only : List_exportToChar => exportToChar - - use m_AttrVect, only : AttrVect - use m_AttrVect, only : AttrVect_clean => clean - use m_AttrVect, only : AttrVect_lsize => lsize - - implicit none - -! !INPUT PARAMETERS: -! - type(AttrVect), intent(IN) :: inAV - real(SP), dimension(:), pointer :: Weights - integer, intent(IN) :: comm - character(len=*), optional, intent(IN) :: WeightSumAttr - -! !OUTPUT PARAMETERS: -! - type(AttrVect), intent(OUT) :: outAV - -! !REVISION HISTORY: -! 8May02 - J.W. Larson - initial version. -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::GlobalWeightedSumRAttrSP_' - - type(AttrVect) :: LocallySummedAV - integer :: myID, ierr - - ! Get local process rank (for potential error reporting purposes) - - call MPI_COMM_RANK(comm, myID, ierr) - if(ierr /= 0) then - call MP_perr_die(myname_,':: MPI_COMM_RANK() error.',ierr) - endif - - ! Check for consistencey between inAV and the weights array - - if(size(weights) /= AttrVect_lsize(inAV)) then - write(stderr,'(2a,i8,3a)') myname_,':: myID=',myID, & - 'ERROR--mismatch in lengths of ', & - 'input array array argument weights(:) and input AttrVect ',& - 'inAV.' - write(stderr,'(2a,i8)') myname_,':: size(weights)=',size(weights) - write(stderr,'(2a,i8)') myname_,':: length of inAV=', & - AttrVect_lsize(inAV) - call die(myname_) - endif - - if(present(WeightSumAttr)) then - call LocalWeightedSumRAttrSP_(inAV, LocallySummedAV, Weights, & - WeightSumAttr) - else - call LocalWeightedSumRAttrSP_(inAV, LocallySummedAV, Weights) - endif - - call AllReduce_(LocallySummedAV, outAV, AttrVectSUM, comm, ierr) - - ! Clean up intermediate local sums - - call AttrVect_clean(LocallySummedAV) - - end subroutine GlobalWeightedSumRAttrSP_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -! ---------------------------------------------------------------------- -! -! !IROUTINE: GlobalWeightedSumRAttrDP_ - Global Weighted Sum of REAL Attributes -! -! !DESCRIPTION: -! Double precision version of GlobalWeightedSumRAttrSP_ -! -! !INTERFACE: -! - subroutine GlobalWeightedSumRAttrDP_(inAV, outAV, Weights, comm, & - WeightSumAttr) - -! -! !USES: -! - use m_die - use m_stdio , only : stderr - use m_mpif90 - use m_realkinds, only : DP - - use m_List, only : List - use m_List, only : List_exportToChar => exportToChar - - use m_AttrVect, only : AttrVect - use m_AttrVect, only : AttrVect_clean => clean - use m_AttrVect, only : AttrVect_lsize => lsize - - implicit none - -! !INPUT PARAMETERS: -! - type(AttrVect), intent(IN) :: inAV - real(DP), dimension(:), pointer :: Weights - integer, intent(IN) :: comm - character(len=*), optional, intent(IN) :: WeightSumAttr - -! !OUTPUT PARAMETERS: -! - type(AttrVect), intent(OUT) :: outAV - -! !REVISION HISTORY: -! 8May02 - J.W. Larson - initial version. -! ______________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::GlobalWeightedSumRAttrDP_' - - type(AttrVect) :: LocallySummedAV - integer :: myID, ierr - - ! Get local process rank (for potential error reporting purposes) - - call MPI_COMM_RANK(comm, myID, ierr) - if(ierr /= 0) then - call MP_perr_die(myname_,':: MPI_COMM_RANK() error.',ierr) - endif - - ! Check for consistencey between inAV and the weights array - - if(size(weights) /= AttrVect_lsize(inAV)) then - write(stderr,'(2a,i8,3a)') myname_,':: myID=',myID, & - 'ERROR--mismatch in lengths of ', & - 'input array array argument weights(:) and input AttrVect ',& - 'inAV.' - write(stderr,'(2a,i8)') myname_,':: size(weights)=',size(weights) - write(stderr,'(2a,i8)') myname_,':: length of inAV=', & - AttrVect_lsize(inAV) - call die(myname_) - endif - - if(present(WeightSumAttr)) then - call LocalWeightedSumRAttrDP_(inAV, LocallySummedAV, Weights, & - WeightSumAttr) - else - call LocalWeightedSumRAttrDP_(inAV, LocallySummedAV, Weights) - endif - - call AllReduce_(LocallySummedAV, outAV, AttrVectSUM, comm, ierr) - - ! Clean up intermediate local sums - - call AttrVect_clean(LocallySummedAV) - - end subroutine GlobalWeightedSumRAttrDP_ - - end module m_AttrVectReduce -!. - - - - diff --git a/cesm/models/utils/mct/mct/m_ConvertMaps.F90 b/cesm/models/utils/mct/mct/m_ConvertMaps.F90 deleted file mode 100644 index adc6d30..0000000 --- a/cesm/models/utils/mct/mct/m_ConvertMaps.F90 +++ /dev/null @@ -1,438 +0,0 @@ -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!----------------------------------------------------------------------- -! CVS $Id$ -! CVS $Name$ -!BOP ------------------------------------------------------------------- -! -! !MODULE: m_ConvertMaps - Conversion Between MCT Domain Decomposition Descriptors -! -! !DESCRIPTION: -! -! This module contains routines to convert between the {\tt GlobalMap} -! and {\tt GlobalSegMap} types. Since the {\tt GlobalMap} is a 1-D -! decomposition with one contiguous segment per process, it is always -! possible to create a {\tt GlobalSegMap} containing the same decomposition -! information. In the unusual case that a {\tt GlobalSegMap} contains -! {\em at most} one segment per process, and no two segments overlap, it -! is possible to create a {\tt GlobalMap} describing the same decomposition. -! -! !INTERFACE: - - module m_ConvertMaps -! -! !USES: -! - use m_GlobalMap, only : GlobalMap - use m_GlobalSegMap, only : GlobalSegMap - - implicit none - - private ! except - -! !PUBLIC MEMBER FUNCTIONS: - - public :: GlobalMapToGlobalSegMap - public :: GlobalSegMapToGlobalMap - - - interface GlobalMapToGlobalSegMap ; module procedure & - GlobalMapToGlobalSegMap_ - end interface - interface GlobalSegMapToGlobalMap ; module procedure & - GlobalSegMapToGlobalMap_ - end interface - -! !REVISION HISTORY: -! 12Feb01 - J.W. Larson - initial module -! -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname='MCT::m_ConvertMap' - - contains - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: GlobalMapToGlobalSegMap_ - Convert GlobalMap to GlobalSegMap -! -! !DESCRIPTION: -! This routine takes an input {\tt GlobalMap} argument {\tt GMap}, and -! converts its decomposition information into the output {\tt GlobalSegMap} -! argument {\tt GSMap}. Since the {\tt GlobalMap} is a very special case -! of the more general {\tt GlobalSegMap} decomposition, this conversion is -! always possible. -! -! The motivation of this routine is the fact that the majority of the -! APIs for MCT services require the user to supply a {\tt GlobalSegMap} -! as a domain decomposition descriptor argument. This routine is the -! means by which the user can enjoy the convenience and simplicity of -! the {\tt GlobalMap} datatype (where it is appropriate), but still -! access all of the MCT's functionality. -! -! {\bf N.B.:} This routine creates an allocated structure {\tt GSMap}. -! The user is responsible for deleting this structure using the {\tt clean()} -! method for the {\tt GlobalSegMap} when {\tt GSMap} is no longer needed. -! Failure to do so will create a memory leak. -! -! !INTERFACE: - - subroutine GlobalMapToGlobalSegMap_(GMap, GSMap) - -! -! !USES: -! - use m_stdio, only : stderr - use m_die, only : MP_perr_die, die, warn - - use m_GlobalMap, only : GlobalMap - - use m_GlobalSegMap, only : GlobalSegMap - use m_GlobalSegMap, only : GlobalSegMap_init => init - - use m_MCTWorld, only : ThisMCTWorld - use m_MCTWorld, only : MCTWorld_ComponentNumProcs => ComponentNumProcs - - implicit none - -! !INPUT PARAMETERS: - - type(GlobalMap), intent(in) :: GMap - -! !OUTPUT PARAMETERS: - - type(GlobalSegMap), intent(out) :: GSMap - -! !REVISION HISTORY: -! 12Feb01 - J.W. Larson - Prototype code. -! 24Feb01 - J.W. Larson - Finished code. -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::GlobalMapToGlobalSegMap_' - - integer :: ierr, n, NumProcs - integer, dimension(:), allocatable :: start, length, pe_loc - - ! Sanity Check -- is GMap the right size? - - NumProcs = MCTWorld_ComponentNumProcs(ThisMCTWorld, GMap%comp_id) - if(NumProcs /= size(GMap%displs)) then - call warn(myname_,"component/GlobalMap size mismatch") - call die(myname_,":: Size mismatch-NumProcs = ", & - NumProcs,"size(GMap%displs) = ",size(GMap%displs)) - endif - - ! Allocate space for process location - - allocate(start(NumProcs), length(NumProcs), pe_loc(NumProcs), stat=ierr) - if(ierr /= 0) call die(myname_,"allocate(start(NumProcs...",ierr) - - ! Load the arrays: - - do n=1,NumProcs - start(n) = GMap%displs(n-1) + 1 - length(n) = GMap%counts(n-1) - pe_loc(n) = n-1 - end do - - call GlobalSegMap_init(GSMap, GMap%comp_id, NumProcs, GMap%gsize, & - start, length, pe_loc) - - ! Clean up... - - deallocate(start, length, pe_loc, stat=ierr) - if(ierr /= 0) call die(myname_,"deallocate(start,...",ierr) - - end subroutine GlobalMapToGlobalSegMap_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: GlobalSegMapToGlobalMap_ - Convert GlobalSegMap to GlobalMap -! -! !DESCRIPTION: -! This routine takes an input {\tt GlobalSegMap} argument {\tt GSMap}, -! and examines it to determine whether or not it may be expressed in -! {\tt GlobalMap} form. A {\tt GlobalSegMap} can be converted to a -! {\tt GlobalMap} if and only if: -! \begin{enumerate} -! \item Each process on the communicator covered by the -! {\tt GlobalSegMap} contains {\em at most one} segment; -! \item The {\tt GlobalSegMap} is {\em not} haloed (that is, none of -! the segments overlap); and -! \item The start indices of the segments are in the same order as their -! respective process ID numbers. -! \end{enumerate} -! If these conditions are satisfied, {\tt GlobalSegMapToGlobalMap\_()} -! creates an output {\tt GlobalMap} argument {\tt GMap} describing the -! same decomposition as {\tt GSMap}. If these conditions are not satisfied, -! map conversion can not occur, and {\tt GlobalSegMapToGlobalMap\_()} -! has one of two outcomes: -! \begin{enumerate} -! \item If the optional output {\tt INTEGER} argument {\tt status} is -! provided, {\tt GlobalSegMapToGlobalMap\_()} returns without creating -! {\tt GMap}, and returns a non-zero value for {\tt status}. -! \item If the optional output {\tt INTEGER} argument {\tt status} is -! not provided, execution will terminate with an error message. -! \end{enumerate} -! -! The optional output {\tt INTEGER} argument {\tt status}, if provided -! will be returned from {\tt GlobalSegMapToGlobalMap\_()} with a value -! explained by the table below: -!\begin{table}[htbp] -!\begin{center} -!\begin{tabular}{|c|c|} -!\hline -!{\bf Value of {\tt status}} & {\bf Significance} \\ -!\hline -!{\tt 0} & Map Conversion Successful \\ -!\hline -!{\tt 1} & Unsuccessful--more than one segment per process, \\ -! & or a negative numer of segments (ERROR) \\ -!\hline -!{\tt 2} & Unsuccessful--{\tt GSMap} haloed \\ -!\hline -!{\tt 3} & Unsuccessful--{\tt GSMap} segments out-of-order \\ -! & with respect to resident process ID ranks \\ -!\hline -!\end{tabular} -!\end{center} -!\end{table} -! -! {\bf N.B.:} This routine creates an allocated structure {\tt GMap}. -! The user is responsible for deleting this structure using the {\tt clean()} -! method for the {\tt GlobalMap} when {\tt GMap} is no longer needed. -! Failure to do so will create a memory leak. -! -! !INTERFACE: - - subroutine GlobalSegMapToGlobalMap_(GSMap, GMap, status) -! -! !USES: -! - use m_stdio, only : stderr - use m_die, only : MP_perr_die, die - - use m_SortingTools , only : IndexSet - use m_SortingTools , only : IndexSort - use m_SortingTools , only : Permute - - use m_MCTWorld, only : MCTWorld - use m_MCTWorld, only : ThisMCTWorld - use m_MCTWorld, only : ComponentNumProcs - - use m_GlobalSegMap, only : GlobalSegMap - use m_GlobalSegMap, only : GlobalSegMap_comp_id => comp_id - use m_GlobalSegMap, only : GlobalSegMap_gsize => gsize - use m_GlobalSegMap, only : GlobalSegMap_haloed => haloed - use m_GlobalSegMap, only : GlobalSegMap_ngseg => ngseg - use m_GlobalSegMap, only : GlobalSegMap_nlseg => nlseg - use m_GlobalSegMap, only : GlobalSegMap_active_pes => active_pes - - use m_GlobalMap, only : GlobalMap - - implicit none - -! !INPUT PARAMETERS: - - type(GlobalSegMap), intent(in) :: GSMap - -! !OUTPUT PARAMETERS: - - type(GlobalMap), intent(out) :: GMap - integer, optional, intent(out) :: status - -! !REVISION HISTORY: -! 12Feb01 - J.W. Larson - API / first prototype. -! 21Sep02 - J.W. Larson - Near-complete Implementation, -! still, do not call! -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::GlobalSegMapToGlobalMap_' - - integer :: i, ierr, n - integer :: nlseg, NumActive, NumProcs, NumPEs, NGSegs - integer, dimension(:), pointer :: NumSegs - integer, dimension(:), pointer :: GSMstarts, GSMlengths, GSMpe_locs, perm - logical :: convertible - - ! If the status flag is present, set it to the "success" value: - - if(present(status)) then - status = 0 - endif - - ! How many segments are there in GSMap? If the number of - ! segments is greater than the number of processes on the - ! GlobalSegMap's native communicator conversion to a - ! GlobalMap is not possible. If the number of segments is - ! fewer than the number of PEs, further checks are necessary - ! to determine whether map conversion is possible. - - NumPEs = ComponentNumProcs(ThisMCTWorld, GlobalSegMap_comp_id(GSMap)) - NGSegs = GlobalSegMap_ngseg(GSMap) - - if(NGSegs > NumPEs) then - write(stderr,'(3a,i8,a,i8,2a)') myname_, & - ':: Conversion of input GlobalSegMap to GlobalMap not possible.', & - ' Number of segments is greater than number of PEs. NumPEs = ', & - NumPEs,' NGSegs = ', NGSegs,'. See MCT API Document for more', & - ' information.' - if(present(status)) then - status = 1 - return - else - call die(myname_) - endif - endif - - ! Is GSMap haloed? If it is, map conversion is impossible - - if(GlobalSegMap_haloed(GSMap)) then - write(stderr,'(3a)') myname_, & - ':: input GlobalSegMap is haloed. Conversion to GlobalMap ', & - ' type not possible. See MCT API Document for details.' - if(present(status)) then - status = 2 - return - else - call die(myname_) - endif - endif - - ! At this point, we've done the easy tests. - - ! Return to the first condition: at most one segment per PE. - ! We've eliminated the obvious case of more segments than PEs. - ! Now, we examine the case of fewer segments than PEs, to see - ! if any single PE has more than one segment. - - allocate(NumSegs(0:NumPes-1), stat=ierr) - if(ierr /= 0) call die(myname_,'allocate(NumSegs(1:NumPes-1))=',ierr) - - do n=0,NumPes-1 - - ! Is there at most one segment per process? If not, then - ! map conversion is impossible. - - NumSegs(n) = GlobalSegMap_nlseg(GSMap, n) - - if((NumSegs(n) > 1) .or. (NumSegs(n) < 0)) then ! fails GMap - write(stderr,'(3a,i8,a,i8)') myname_, & - ':: ERROR: Map conversion not possible due to ', & - 'inappropriate number of segments on PE number ', & - n,'. Number of segments = ',NumSegs(n) - deallocate(NumSegs, stat=ierr) - if(ierr /= 0) then ! problem cleaning up - write(stderr,'(3a)') myname_, & - ':: Encountered error deallocating NumSegs ', & - 'while exiting.' - endif - if(present(status)) then ! return with error code - status = 1 - return - else - call die(myname_) - endif - endif - - end do ! do n=0,NumPes-1 - - deallocate(NumSegs, stat=ierr) - if(ierr /= 0) call die(myname_,'deallocate(NumSegs,...)',ierr) - - ! If execution has reached this point in the code, GSMap has - ! satisfied the first two criteria for conversion to a GlobalMap. - ! The final test is whether or not the global start indices for - ! the segments (which we know by now are at most one per PE) are - ! in the same order as their resident process ID ranks. - - ! Extract start, length, and PE location arrays from GSMap: - - allocate(GSMstarts(NGSegs), GSMlengths(NGSegs), GSMpe_locs(NGSegs), & - perm(NGSegs), stat=ierr) - if(ierr /= 0) call die(myname_,'allocate(GSMstarts,...)=',ierr) - - do i=1,NGSegs - GSMstarts(i) = GSMap%start(i) - GSMlengths(i) = GSMap%length(i) - GSMpe_locs(i) = GSMap%pe_loc(i) - end do - - ! Begin sorting process. First, set index permutation. - call IndexSet(perm) - ! Generate sort permutation keyed by PE location - call IndexSort(NGSegs, perm, GSMpe_locs, descend=.false.) - ! Permute segment info arrays using perm(:) - call Permute(GSMstarts, perm, NGSegs) - call Permute(GSMlengths, perm, NGSegs) - call Permute(GSMpe_locs, perm, NGSegs) - - ! Now that these arrays are ordered by PE location, we - ! can check the segment start ordering to see if it is - ! the same. Start with the assumption they are in order, - ! corrsponding to convertible=.TRUE. - - convertible = .TRUE. - ORDER_TEST: do i=1,NGSegs-1 - if(GSMstarts(i) <= GSMstarts(i+1)) then - CYCLE - else - convertible = .FALSE. - EXIT - endif - end do ORDER_TEST - - if(convertible) then ! build output GlobalMap GMAP - - ! Integer components: - - GMap%comp_id = GlobalSegMap_comp_id(GSMap) - GMap%gsize = GlobalSegMap_gsize(GSMap) - - ! lsize is not defined in this case!!! -ETO -! GMap%lsize = GlobalSegMap_lsize(GSMap) - GMap%lsize = -1 - - ! Indexing components: - - allocate(GMap%displs(0:NumPEs-1), GMap%counts(0:NumPEs-1), stat=ierr) - - ! Set the counts(:) values to zero, then copy in the non-zero - ! segment length values - - GMap%counts = 0 - do i=1,NGSegs - GMap%counts(GSMpe_locs(i)) = GSMlengths(i) - end do - - ! From counts(:), build displs(:) - GMap%displs(0) = 0 - do i=1,NumPEs-1 - GMap%displs(i) = GMap%displs(i-1) + GMap%counts(i-1) - end do - - else ! Nullify it - - GMap%comp_id = -1 - GMap%gsize = -1 - GMap%lsize = -1 - nullify(GMap%displs) - nullify(GMap%counts) - - endif - - deallocate(GSMstarts, GSMlengths, GSMpe_locs, perm, stat=ierr) - if(ierr /= 0) call die(myname_,'deallocate(GSMstarts,...)=',ierr) - - end subroutine GlobalSegMapToGlobalMap_ - - end module m_ConvertMaps - - - - - diff --git a/cesm/models/utils/mct/mct/m_ExchangeMaps.F90 b/cesm/models/utils/mct/mct/m_ExchangeMaps.F90 deleted file mode 100644 index c1a3256..0000000 --- a/cesm/models/utils/mct/mct/m_ExchangeMaps.F90 +++ /dev/null @@ -1,613 +0,0 @@ -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!----------------------------------------------------------------------- -! CVS $Id$ -! CVS $Name$ -!BOP ------------------------------------------------------------------- -! -! !MODULE: m_ExchangeMaps - Exchange of Global Mapping Objects. -! -! !DESCRIPTION: -! This module contains routines that support the exchange of domain -! decomposition descriptors (DDDs) between two MCT components. There is -! support for {\em handshaking} between the two components to determine -! the types of domain decomposition descriptors they employ, {\em loading} -! of data contained within domain decomposition descriptors, and {\em -! map exchange}, resulting in the creation of a remote component's domain -! decomposition descriptor for use by a local component. These routines -! are largely used by MCT's {\tt Router} to create intercomponent -! communications scheduler, and normally should not be used by an MCT -! user. -! -! Currently, the types of map exchange supported by the public routine -! {\tt ExchangeMap()} are summarized in the table below. The first column -! lists the type of DDD used locally on the component invoking -! {\tt ExchangeMap()} (i.e., the input DDD). The second comlumn lists -! the DDD type used on the remote component (i.e., the output DDD). -!\begin{table}[htbp] -!\begin{center} -!\begin{tabular}{|c|c|} -!\hline -!{\bf Local DDD Type} & {\bf Remote DDD Type} \\ -!\hline -!{\tt GlobalMap} & {\tt GlobalSegMap} \\ -!\hline -!{\tt GlobalSegMap} & {\tt GlobalSegMap} \\ -!\hline -!\end{tabular} -!\end{center} -!\end{table} -! -! Currently, we do not support intercomponent map exchange where a -! {\tt GlobalMap} is output. The rationale for this is that any {\tt GlobalMap} -! may always be expressed as a {\tt GlobalSegMap}. -! -! !INTERFACE: - - module m_ExchangeMaps - -! !USES: -! No external modules are used in the declaration section of this module. - - implicit none - - private ! except -! -! !PUBLIC MEMBER FUNCTIONS: -! - public :: ExchangeMap - - interface ExchangeMap ; module procedure & - ExGSMapGSMap_, & ! GlobalSegMap for GlobalSegMap - ExGMapGSMap_ - end interface - -! !SEE ALSO: -! The MCT module m_ConvertMaps for more information regarding the -! relationship between the GlobalMap and GlobalSegMap types. -! The MCT module m_Router to see where these services are used to -! create intercomponent communications schedulers. -! -! !REVISION HISTORY: -! 3Feb01 - J.W. Larson - initial module -! 3Aug01 - E.T. Ong - in ExGSMapGSMap, -! call GlobalSegMap_init with actual shaped arrays -! for non-root processes to satisfy Fortran 90 standard. -! See comments in subroutine. -! 15Feb02 - R. Jacob - use MCT_comm instead of -! MP_COMM_WORLD -!EOP ___________________________________________________________________ -! - character(len=*),parameter :: myname='MCT::m_ExchangeMaps' - -! Map Handshaking Parameters: Map handshaking occurs via -! exchange of an array of INTEGER flags. - - ! Number of Handshaking Parameters; i.e.size of exhcanged parameters array - - integer, parameter :: NumHandshakePars = 4 - - ! ComponentIDIndex defines the storage location of the flag - ! signifying the component number in MCTWorld - - integer, parameter :: ComponentIDIndex = 1 - - ! MapTypeIndex defines the storage location in the handshake array - ! of the type of map offered for exchange - - integer, parameter :: MapTypeIndex = 2 - - ! NumMapTypes is the number of legitimate MapTypeIndex Values: - - integer, parameter :: NumMapTypes = 2 - - ! Recognized MapTypeIndex Values: - - integer, parameter :: GlobalMapFlag = 1 - integer, parameter :: GlobalSegMapFlag = 2 - - ! GsizeIndex defines the location of the grid size (number of points) - ! for the map. This size is - - integer, parameter :: GsizeIndex = 3 - - ! NumSegIndex defines the location of the number of segments in the - ! map. For a GlobalMap, this is the number of processes in the map. - ! For a GlobalSegMap, this is the number of global segments (ngseg). - - integer, parameter :: NumSegIndex = 4 - - contains - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: MapHandshake_ - Exchange Map descriptors. -! -! !DESCRIPTION: -! This routine takes input Map descriptors stored in the {\tt INTEGER} -! array {\tt LocalMapPars}, the local communicator on which this map is -! defined ({\tt LocalComm}), and the remote component ID -! {\tt RemoteCompID}, and effects an exchange of map descriptors with -! the remote component, which are returned in the {\tt INTEGER} array -! {\tt RemoteMapPars}. -! -! {\bf N.B.: } The values present in {\tt LocalMapPars} need to be valid -! only on the root of {\tt LocalComm}. Likewise, the returned values in -! {\tt RemoteMapPars} will be valid on the root of {\tt LocalComm}. -! -! !INTERFACE: - - subroutine MapHandshake_(LocalMapPars, LocalComm, RemoteCompID, & - RemoteMapPars) - -! -! !USES: -! - use m_mpif90 - use m_die, only : MP_perr_die - use m_stdio - use m_MCTWorld, only : ThisMCTWorld - use m_MCTWorld, only : ComponentRootRank - - implicit none -! -! !INPUT PARAMETERS: -! - integer, intent(in) :: LocalMapPars(NumHandshakePars) - integer, intent(in) :: LocalComm - integer, intent(in) :: RemoteCompID -! -! !OUTPUT PARAMETERS: -! - integer, intent(out) :: RemoteMapPars(NumHandshakePars) - -! !REVISION HISTORY: -! 6Feb01 - J.W. Larson - API specification. -! 20Apr01 - R.L. Jacob - add status argument -! to MPI_RECV -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::MapHandshake_' - - integer :: ierr, myID, RemoteRootID, SendTag, RecvTag - integer,dimension(MP_STATUS_SIZE) :: status - - call MP_COMM_RANK(LocalComm, myID, ierr) - if(ierr /= 0) call MP_perr_die(myname_,'call MP_COMM_RANK()',ierr) - - RemoteRootID = ComponentRootRank(RemoteCompID, ThisMCTWorld) - - if(myID == 0) then ! I am the root on LocalComm - - ! Compute send/receive tags: - - SendTag = 10 * LocalMapPars(ComponentIDIndex) + RemoteCompID - RecvTag = LocalMapPars(ComponentIDIndex) + 10 * RemoteCompID - - ! Post send to RemoteRootID: - - call MPI_SEND(LocalMapPars, NumHandshakePars, MP_INTEGER, & - RemoteRootID, SendTag, ThisMCTWorld%MCT_comm, ierr) - if(ierr /= 0) call MP_perr_die(myname_,'call MPI_SEND()',ierr) - - ! Post receive from RemoteRootID: - - call MPI_RECV(RemoteMapPars, NumHandshakePars, MP_INTEGER, & - RemoteRootID, RecvTag, ThisMCTWorld%MCT_comm, status, ierr) - if(ierr /= 0) call MP_perr_die(myname_,'call MPI_RECV()',ierr) - - endif ! if(myID == 0) - - end subroutine MapHandshake_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: LoadGlobalMapPars_ - Load GlobalMap descriptors. -! -! !DESCRIPTION: -! This routine takes an input {\tt GlobalMap} variable {\tt Gmap}, and -! loads its descriptors the output {\tt INTEGER} array {\tt MapPars}. -! The dimensions of this array, and loading order are all defined in -! the declaration section of this module. -! -! !INTERFACE: - - subroutine LoadGlobalMapPars_(GMap, MapPars) - -! -! !USES: -! - use m_mpif90 - use m_die - use m_stdio - use m_GlobalMap, only : GlobalMap - use m_GlobalMap, only : GlobalMap_comp_id => comp_id - use m_GlobalMap, only : GlobalMap_gsize => gsize -! use m_GlobalMap, only : GlobalMap_nprocs => nprocs - - implicit none -! -! !INPUT PARAMETERS: -! - type(GlobalMap), intent(in) :: GMap -! -! !OUTPUT PARAMETERS: -! - integer, intent(out) :: MapPars(NumHandshakePars) - -! !REVISION HISTORY: -! 6Feb01 - J.W. Larson - Initial version. -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::LoadGlobalMapPars_' - - MapPars(ComponentIDIndex) = GlobalMap_comp_id(GMap) - MapPars(MapTypeIndex) = GlobalMapFlag - MapPars(GsizeIndex) = GlobalMap_gsize(GMap) -! MapPars(NumSegIndex) = GlobalMap_nprocs(GSMap) - - end subroutine LoadGlobalMapPars_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: LoadGlobalSegMapPars_ - Load GlobalSegMap descriptors. -! -! !DESCRIPTION: -! This routine takes an input {\tt GlobalSegMap} variable {\tt Gmap}, and -! loads its descriptors the output {\tt INTEGER} array {\tt MapPars}. -! The dimensions of this array, and loading order are all defined in -! the declaration section of this module. -! -! !INTERFACE: - - subroutine LoadGlobalSegMapPars_(GSMap, MapPars) - -! -! !USES: -! - use m_mpif90 - use m_die - use m_stdio - use m_GlobalSegMap, only : GlobalSegMap - use m_GlobalSegMap, only : GlobalSegMap_comp_id => comp_id - use m_GlobalSegMap, only : GlobalSegMap_gsize => gsize - use m_GlobalSegMap, only : GlobalSegMap_ngseg => ngseg - - - implicit none -! -! !INPUT PARAMETERS: -! - type(GlobalSegMap), intent(in) :: GSMap -! -! !OUTPUT PARAMETERS: -! - integer, intent(out) :: MapPars(NumHandshakePars) - -! !REVISION HISTORY: -! 6Feb01 - J.W. Larson - Initial version. -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::LoadGlobalSegMapPars_' - - MapPars(ComponentIDIndex) = GlobalSegMap_comp_id(GSMap) - MapPars(MapTypeIndex) = GlobalSegMapFlag - MapPars(GsizeIndex) = GlobalSegMap_gsize(GSMap) - MapPars(NumSegIndex) = GlobalSegMap_ngseg(GSMap) - - end subroutine LoadGlobalSegMapPars_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: ExGSMapGSMap_ - Trade of GlobalSegMap structures. -! -! !DESCRIPTION: -! This routine effects the exchange between two components of their -! data decomposition descriptors, each of which is a {\tt GlobalSegMap}. -! The component invoking this routine provides its domain decomposition -! in the form of the input {\tt GlobalSegMap} argument {\tt LocalGSMap}. -! The component with which map exchange takes place is specified by the -! MCT integer component identification number defined by the input -! {\tt INTEGER} argument {\tt RemoteCompID}. The -! !INTERFACE: - - subroutine ExGSMapGSMap_(LocalGSMap, LocalComm, RemoteGSMap, & - RemoteCompID, ierr) - -! -! !USES: -! - use m_mpif90 - use m_die - use m_stdio - use m_GlobalSegMap, only : GlobalSegMap - use m_GlobalSegMap, only : GlobalSegMap_init => init - - use m_MCTWorld, only : ThisMCTWorld - use m_MCTWorld, only : ComponentRootRank - - implicit none - -! !INPUT PARAMETERS: - - type(GlobalSegMap), intent(in) :: LocalGSMap ! Local GlobalSegMap - integer, intent(in) :: LocalComm ! Local Communicator - integer , intent(in) :: RemoteCompID ! Remote component id - -! !OUTPUT PARAMETERS: - - type(GlobalSegMap), intent(out) :: RemoteGSMap ! Remote GlobalSegMap - integer, intent(out) :: ierr ! Error Flag - -! !REVISION HISTORY: -! 3Feb01 - J.W. Larson - API specification. -! 7Feb01 - J.W. Larson - First full version. -! 20Apr01 - R.L. Jacob - add status argument -! to MPI_RECV -! 25Apr01 - R.L. Jacob - set SendTag and -! RecvTag values -! 3May01 - R.L. Jacob - change MPI_SEND to -! MPI_ISEND to avoid possible buffering problems seen -! on IBM SP. -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::ExGSMapGSMap_' - -! root ID on local communicator: - integer, parameter :: root = 0 -! Storage for local and remote map descriptors: - integer :: LocalMapPars(NumHandshakePars) - integer :: RemoteMapPars(NumHandshakePars) -! Send and Receive Buffers - integer, dimension(:), allocatable :: SendBuf - integer, dimension(:), allocatable :: RecvBuf -! Send and Receive Tags - integer :: SendTag, RecvTag -! Storage arrays for Remote GlobalSegMap data: - integer, dimension(:), allocatable :: start, length, pe_loc - - integer :: myID, ngseg, remote_root,req - integer :: local_ngseg, remote_ngseg - integer,dimension(MP_STATUS_SIZE) :: status,wstatus - - ! Determine rank on local communicator: - - call MP_COMM_RANK(LocalComm, myID, ierr) - if(ierr /= 0) call MP_perr_die(myname_,'call MP_COMM_RANK()',ierr) - - ! If the root, exchange map handshake descriptors, - ! and information needed to initialize the remote map - ! on the local communicator. - - if(myID == root) then - - call LoadGlobalSegMapPars_(LocalGSMap, LocalMapPars) - - call MapHandshake_(LocalMapPars, LocalComm, RemoteCompID, & - RemoteMapPars) - - ! Consistency Checks between LocalMapPars and RemoteMapPars: - - if(LocalMapPars(MapTypeIndex) /= RemoteMapPars(MapTypeIndex)) then - ierr = 2 - write(stderr,*) myname_,":: MCTERROR, Map Type mismatch ", & - "LocalMap Type = ",LocalMapPars(MapTypeIndex)," RemoteMap Type = ", & - RemoteMapPars(MapTypeIndex) - call die(myname_,'Map Type mismatch',ierr) - endif - - if(LocalMapPars(GsizeIndex) /= RemoteMapPars(GsizeIndex)) then - ierr = 3 - write(stderr,*) myname_,":: MCTERROR, Grid Size mismatch ", & - "LocalMap Gsize = ",LocalMapPars(GsizeIndex)," RemoteMap Gsize = ", & - RemoteMapPars(GsizeIndex) - call die(myname_,'Map Grid Size mismatch',ierr) - endif - - if(RemoteCompID /= RemoteMapPars(ComponentIDIndex)) then - ierr = 4 - write(stderr,*) myname_,":: MCTERROR, Component ID mismatch ", & - "RemoteCompID = ",RemoteCompID," RemoteMap CompID = ", & - RemoteMapPars(ComponentIDIndex) - call die(myname_,'Component ID mismatch',ierr) - endif - - ! SendBuf will hold the arrays LocalGSMap%start, LocalGSMap%length, - ! and LocalGSMap%pe_loc in that order. - - allocate(SendBuf(3*LocalMapPars(NumSegIndex)), stat=ierr) - if(ierr /= 0) call die(myname_,'allocate(SendBuf...)',ierr) - - ! RecvBuf will hold the arrays RemoteGSMap%start, RemoteGSMap%length, - ! and RemoteGSMap%pe_loc in that order. - - allocate(RecvBuf(3*RemoteMapPars(NumSegIndex)), stat=ierr) - if(ierr /= 0) call die(myname_,'allocate(RecvBuf...)',ierr) - - ! Load SendBuf in the order described above: - local_ngseg = LocalMapPars(NumSegIndex) - SendBuf(1:local_ngseg) = & - LocalGSMap%start(1:local_ngseg) - SendBuf(local_ngseg+1:2*local_ngseg) = & - LocalGSMap%length(1:local_ngseg) - SendBuf(2*local_ngseg+1:3*local_ngseg) = & - LocalGSMap%pe_loc(1:local_ngseg) - - ! Determine the remote component root: - - remote_root = ComponentRootRank(RemoteMapPars(ComponentIDIndex), & - ThisMCTWorld) - - SendTag = 10 * LocalMapPars(ComponentIDIndex) + RemoteCompID - RecvTag = LocalMapPars(ComponentIDIndex) + 10 * RemoteCompID - - ! Send off SendBuf to the remote component root: - - call MPI_ISEND(SendBuf(1), 3*LocalMapPars(NumSegIndex), MP_INTEGER, & - remote_root, SendTag, ThisMCTWorld%MCT_comm, req, ierr) - if(ierr /= 0) call MP_perr_die(myname_,'MPI_SEND(SendBuf...',ierr) - - ! Receive RecvBuf from the remote component root: - - call MPI_RECV(RecvBuf, 3*RemoteMapPars(NumSegIndex), MP_INTEGER, & - remote_root, RecvTag, ThisMCTWorld%MCT_comm, status, ierr) - if(ierr /= 0) call MP_perr_die(myname_,'MPI_Recv(RecvBuf...',ierr) - - call MPI_WAIT(req,wstatus,ierr) - if(ierr /= 0) call MP_perr_die(myname_,'MPI_WAIT(SendBuf..',ierr) - - ! Allocate arrays start(:), length(:), and pe_loc(:) - - allocate(start(RemoteMapPars(NumSegIndex)), & - length(RemoteMapPars(NumSegIndex)), & - pe_loc(RemoteMapPars(NumSegIndex)), stat=ierr) - if(ierr /= 0) call die(myname_,'allocate(start...',ierr) - - ! Unpack RecvBuf into arrays start(:), length(:), and pe_loc(:) - remote_ngseg = RemoteMapPars(NumSegIndex) - start(1:remote_ngseg) = RecvBuf(1:remote_ngseg) - length(1:remote_ngseg) = & - RecvBuf(remote_ngseg+1:2*remote_ngseg) - pe_loc(1:remote_ngseg) = & - RecvBuf(2*remote_ngseg+1:3*remote_ngseg) - - endif ! if(myID == root) - - ! Non-root processes call GlobalSegMap_init with start, - ! length, and pe_loc, although these arguments are - ! not used in the subroutine. Since these correspond to dummy - ! shaped array arguments in GlobalSegMap_init, the Fortran 90 - ! standard dictates that the actual arguments must contain - ! complete shape information. Therefore, these array arguments - ! must be allocated on all processes. - - if(myID /= root) then - - allocate(start(1), length(1), pe_loc(1), stat=ierr) - if(ierr /= 0) call die(myname_,'non-root allocate(start...',ierr) - - endif - - - ! Initialize the Remote GlobalSegMap RemoteGSMap - - call GlobalSegMap_init(RemoteGSMap, RemoteMapPars(NumSegIndex), & - start, length, pe_loc, root, LocalComm, & - RemoteCompID, RemoteMapPars(GsizeIndex)) - - - ! Deallocate allocated arrays - - deallocate(start, length, pe_loc, stat=ierr) - if(ierr /= 0) then - call die(myname_,'deallocate(start...',ierr) - endif - - ! Deallocate allocated arrays on the root: - - if(myID == root) then - - deallocate(SendBuf, RecvBuf, stat=ierr) - if(ierr /= 0) then - call die(myname_,'deallocate(SendBuf...',ierr) - endif - - endif ! if(myID == root) - - end subroutine ExGSMapGSMap_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: ExGMapGSMap_ - Trade of GlobalMap for GlobalSegMap. -! -! !DESCRIPTION: -! This routine allows a component to report its domain decomposition -! using a {\tt GlobalMap} (the input argument {\tt LocalGMap}), and -! receive the domain decomposition of a remote component in the form -! of a {\tt GlobalSegMap} (the output argument {\tt RemoteGSMap}. The -! component with which map exchange occurs is defined by its component -! ID number (the input {\tt INTEGER} argument {\tt RemoteCompID}). -! Currently, this operation is implemented as an exchange of maps between -! the root nodes of each component's communicator, and then propagated -! across the local component's communicator. This requires the user to -! provide the local communicator (the input {\tt INTEGER} argument -! {\tt LocalComm}). The success (failure) of this operation is reported -! in the zero (nonzero) value of the output {\tt INTEGER} argument -! {\tt ierr}. -! -! !INTERFACE: - - subroutine ExGMapGSMap_(LocalGMap, LocalComm, RemoteGSMap, & - RemoteCompID, ierr) - -! -! !USES: -! - use m_mpif90 - use m_die - use m_stdio - - use m_GlobalMap, only : GlobalMap - - use m_GlobalSegMap, only : GlobalSegMap - use m_GlobalSegMap, only : GlobalSegMap_init => init - use m_GlobalSegMap, only : GlobalSegMap_clean => clean - - use m_ConvertMaps, only : GlobalMapToGlobalSegMap - - implicit none - -! !INPUT PARAMETERS: - - type(GlobalMap), intent(in) :: LocalGMap ! Local GlobalMap - integer, intent(in) :: LocalComm ! Local Communicator - integer, intent(in) :: RemoteCompID ! Remote component id - - -! !OUTPUT PARAMETERS: - - type(GlobalSegMap), intent(out) :: RemoteGSMap ! Remote GlobalSegMap - integer, intent(out) :: ierr ! Error Flag - -! !REVISION HISTORY: -! 3Feb01 - J.W. Larson - API specification. -! 26Sep02 - J.W. Larson - Implementation. -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::ExGMapGSMap_' - type(GlobalSegMap) :: LocalGSMap - - ! Convert LocalGMap to a GlobalSegMap - - call GlobalMapToGlobalSegMap(LocalGMap, LocalGSMap) - - ! Exchange local decomposition in GlobalSegMap form with - ! the remote component: - - call ExGSMapGSMap_(LocalGSMap, LocalComm, RemoteGSMap, & - RemoteCompID, ierr) - - ! Destroy LocalGSMap - - call GlobalSegMap_clean(LocalGSMap) - - end subroutine ExGMapGSMap_ - - end module m_ExchangeMaps - - - - - - - diff --git a/cesm/models/utils/mct/mct/m_GeneralGrid.F90 b/cesm/models/utils/mct/mct/m_GeneralGrid.F90 deleted file mode 100644 index 4aa5a85..0000000 --- a/cesm/models/utils/mct/mct/m_GeneralGrid.F90 +++ /dev/null @@ -1,3315 +0,0 @@ -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!----------------------------------------------------------------------- -! CVS $Id$ -! CVS $Name$ -!BOP ------------------------------------------------------------------- -! -! !MODULE: m_GeneralGrid -- Physical Coordinate Grid Information Storage -! -! !DESCRIPTION: -! The {\tt GeneralGrid} data type is a flexible, generic structure for -! storing physical coordinate grid information. The {\tt GeneralGrid} -! may be employed to store coordinate grids of arbitrary dimension, and -! is also capable of supporting unstructured grids such as meteorological -! observation data streams. The grid is representated by a literal -! listing of the gridpoint coordinates, along with other integer and real -! {\em attributes} associated with each location. Examples of real -! non-coordinate attributes are grid cell length, cross-sectional area, and -! volume elements, projections of local directional unit vectors onto -! {\em et cetera} A {\tt GeneralGrid} as at minimum one integer -! attribute---{\em the global grid point number}, or {\tt GlobGridNum}, -! which serves as a unique identifier for each physical grid location. -! -! The real attributes of of the {\tt GeneralGrid} are grouped as {\tt List} -! components: -! \begin{itemize} -! \item {\tt GGrid\%coordinate\_list} contains the list of the physical -! dimension names of the grid. The user initializes a {\tt List} by -! supplying the items in it as a string with the items delimitted by -! colons. For example, setting the coordinates for Euclidean 3-space -! is accomplished by a choice of {\tt 'x:y:z'}, cylindrical coordinates -! by {\tt 'rho:theta:z'}, spherical coordinates by {\tt 'r:theta:phi'}, -! {\em et cetera}. -! \item {\tt GGrid\%weight\_list} contains the names of the spatial -! cell length, area, and volume weights associated with the grid. These -! are also stored in {\tt List} form, and are set by the user in the same -! fashion as described above for coordinates. For example, one might -! wish create cell weight attributes for a cylindrical grid by defining -! a weight list of {\tt 'drho:dphi:rhodphi:dz}. -! \item {\tt GGrid\%other\_list} is space for the user to define other -! real attributes. For example, one might wish to do vector calculus -! operatons in spherical coordinates. Since the spherical coordinate -! unit vectors ${\hat r}$, ${\hat \theta}$, and ${\hat \phi}$ -! vary in space, it is sometimes useful to store their projections on -! the fixed Euclidean unit vectors ${\bf \hat x}$, ${\bf \hat y}$, and -! ${\bf \hat z}$. To do this one might set up a list of attributes -! using the string -! \begin{verbatim} -! 'rx:ry:rz:thetax:thetay:thetaz:phix:phiy:phyz' -! \end{verbatim} -! \item {\tt GGrid\%index\_list} provides space for the user to define -! integer attributes such as alternative indexing schemes, indices for -! defining spatial regions, {\em et cetera}. This attribute list contains -! all the integer attributes for the {\tt GeneralGrid} save one: the -! with the ever-present {\em global gridpoint number attribute} -! {\tt GlobGridNum}, which is set automatically by MCT. -! \end{itemize} -! -! This module contains the definition of the {\tt GeneralGrid} datatype, -! various methods for creating and destroying it, query methods, and tools -! for multiple-key sorting of gridpoints. -! -! !INTERFACE: - - module m_GeneralGrid - -! -! !USES: -! - use m_List, only : List ! Support for List components. - - use m_AttrVect, only : AttrVect ! Support for AttrVect component. - - implicit none - - private ! except - -! !PUBLIC TYPES: - - public :: GeneralGrid ! The class data structure - - Type GeneralGrid -#ifdef SEQUENCE - sequence -#endif - type(List) :: coordinate_list - type(List) :: coordinate_sort_order - logical, dimension(:), pointer :: descend - type(List) :: weight_list - type(List) :: other_list - type(List) :: index_list - type(AttrVect) :: data - End Type GeneralGrid - -! !PUBLIC MEMBER FUNCTIONS: - - public :: init ! Create a GeneralGrid - public :: initCartesian ! - public :: initUnstructured ! - public :: clean ! Destroy a GeneralGrid - public :: zero ! Zero data in a GeneralGrid - - ! Query functions----------------- - public :: dims ! Return dimensionality of the GeneralGrid - public :: indexIA ! Index integer attribute (indices) - public :: indexRA ! Index integer attribute (coords/weights) - public :: lsize ! Return local number of points - public :: exportIAttr ! Return INTEGER attribute as a vector - public :: exportRAttr ! Return REAL attribute as a vector - - ! Manipulation-------------------- - public :: importIAttr ! Insert INTEGER vector as attribute - public :: importRAttr ! Insert REAL vector as attribute - public :: Sort ! Sort point data by coordinates -> permutation - public :: Permute ! Rearrange point data using input permutation - public :: SortPermute ! Sort and Permute point data - - interface init ; module procedure & - init_, & - initl_, & - initgg_ - end interface - interface initCartesian ; module procedure & - initCartesianSP_, & - initCartesianDP_ - end interface - interface initUnstructured ; module procedure & - initUnstructuredSP_, & - initUnstructuredDP_ - end interface - interface clean ; module procedure clean_ ; end interface - interface zero ; module procedure zero_ ; end interface - - interface dims ; module procedure dims_ ; end interface - interface indexIA ; module procedure indexIA_ ; end interface - interface indexRA ; module procedure indexRA_ ; end interface - interface lsize ; module procedure lsize_ ; end interface - - interface exportIAttr ; module procedure exportIAttr_ ; end interface - interface exportRAttr ; module procedure & - exportRAttrSP_, & - exportRAttrDP_ - end interface - interface importIAttr ; module procedure importIAttr_ ; end interface - interface importRAttr ; module procedure & - importRAttrSP_, & - importRAttrDP_ - end interface - - interface Sort ; module procedure Sort_ ; end interface - interface Permute ; module procedure Permute_ ; end interface - interface SortPermute ; module procedure SortPermute_ ; end interface - -! !PUBLIC DATA MEMBERS: - -! CHARACTER Tag for GeneralGrid Global Grid Point Identification Number - - character(len=*), parameter :: GlobGridNum='GlobGridNum' - -! !SEE ALSO: -! The MCT module m_AttrVect and the mpeu module m_List. - -! !REVISION HISTORY: -! 25Sep00 - J.W. Larson - initial prototype -! 31Oct00 - J.W. Larson - modified the -! GeneralGrid type to allow inclusion of grid cell -! dimensions (lengths) and area/volume weights. -! 15Jan01 - J.W. Larson implemented new GeneralGrid type -! definition and added numerous APIs. -! 17Jan01 - J.W. Larson fixed minor bug in module header use -! statement. -! 19Jan01 - J.W. Larson added other_list and coordinate_sort_order -! components to the GeneralGrid type. -! 21Mar01 - J.W. Larson - deleted the initv_ API (more study -! needed before implementation. -! 2May01 - J.W. Larson - added initgg_ API (replaces old initv_). -! 13Dec01 - J.W. Larson - added import and export methods. -! 27Mar02 - J.W. Larson - Corrected usage of -! m_die routines throughout this module. -! 5Aug02 - E. Ong - Modified GeneralGrid usage -! to allow user-defined grid numbering schemes. -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname='MCT::m_GeneralGrid' - - contains - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: init_ - Create an Empty GeneralGrid -! -! !DESCRIPTION: -! The routine {\tt init\_()} creates the storage space for grid point -! coordinates, area/volume weights, and other coordinate data ({\em e.g.}, -! local cell dimensions). These data are referenced by {\tt List} -! components that are also created by this routine (see the documentation -! of the declaration section of this module for more details about setting -! list information). Each of the input {\tt CHARACTER} arguments is a -! colon-delimited string of attribute names, each corrsponding to a -! {\tt List} element of the output {\tt GeneralGrid} argument {\tt GGrid}, -! and are summarized in the table below: -! -!\begin{table}[htbp] -!\begin{center} -!\begin{tabular}{|l|l|l|l|} -!\hline -!{\bf Argument} & {\bf Component of {\tt GGrid}} & {\bf Significance} & {\bf Required?} \\ -!\hline -!{\tt CoordChars} & {\tt GGrid\%coordinate\_list} & Dimension Names & Yes \\ -!\hline -!{\tt CoordSortOrder} & {\tt GGrid\%coordinate\_sort\_order} & Grid Point & No \\ -! & & Sorting Keys & \\ -!\hline -!{\tt WeightChars} & {\tt GGrid\%weight\_list} & Grid Cell & No \\ -! & & Length, Area, and & \\ -! & & Volume Weights & \\ -!\hline -!{\tt OtherChars} & {\tt GGrid\%other\_list} & All Other & No \\ -! & & Real Attributes & \\ -!\hline -!{\tt IndexChars} & {\tt GGrid\%index\_list} & All Other & No \\ -! & & Integer Attributes & \\ -!\hline -!\end{tabular} -!\end{center} -!\end{table} -! -! The input {\tt INTEGER} argument {\tt lsize} defines the number of grid points -! to be stored in {\tt GGrid}. -! -! If a set of sorting keys is supplied in the argument {\tt CoordSortOrder}, -! the user can control whether the sorting by each key is in descending or -! ascending order by supplying the input {\tt LOGICAL} array {\tt descend(:)}. -! By default, all sorting is in {\em ascending} order for each key if the -! argument {\tt descend} is not provided. -! -! {\bf N.B.}: The output {\tt GeneralGrid} {\tt GGrid} is dynamically -! allocated memory. When one no longer needs {\tt GGrid}, one should -! release this space by invoking {\tt clean()} for the {\tt GeneralGrid}. -! -! !INTERFACE: - - subroutine init_(GGrid, CoordChars, CoordSortOrder, descend, WeightChars, & - OtherChars, IndexChars, lsize ) -! -! !USES: -! - use m_stdio - use m_die - - use m_List, only : List - use m_List, only : List_init => init - use m_List, only : List_nitem => nitem - use m_List, only : List_shared => GetSharedListIndices - use m_List, only : List_append => append - use m_List, only : List_copy => copy - use m_List, only : List_nullify => nullify - use m_List, only : List_clean => clean - - use m_AttrVect, only : AttrVect - use m_AttrVect, only : AttrVect_init => init - - implicit none - -! !INPUT PARAMETERS: -! - character(len=*), intent(in) :: CoordChars - character(len=*), optional, intent(in) :: CoordSortOrder - character(len=*), optional, intent(in) :: WeightChars - logical, dimension(:), optional, pointer :: descend - character(len=*), optional, intent(in) :: OtherChars - character(len=*), optional, intent(in) :: IndexChars - integer, optional, intent(in) :: lsize - -! !OUTPUT PARAMETERS: -! - type(GeneralGrid), intent(out) :: GGrid - -! !REVISION HISTORY: -! 25Sep00 - Jay Larson - initial prototype -! 15Jan01 - Jay Larson - modified to fit -! new GeneralGrid definition. -! 19Mar01 - Jay Larson - added OtherChars -! 25Apr01 - Jay Larson - added GlobGridNum -! as a mandatory integer attribute. -! 13Jun01 - Jay Larson - No longer define -! blank List attributes of the GeneralGrid. Previous -! versions of this routine had this feature, and this -! caused problems with the GeneralGrid Send and Receive -! operations on the AIX platform. -! 13Jun01 - R. Jacob - nullify any pointers -! for lists not declared. -! 15Feb02 - Jay Larson - made the input -! argument CoordSortOrder mandatory (rather than -! optional). -! 18Jul02 - E. Ong - replaced this version of -! init with one that calls initl_. -! 5Aug02 - E. Ong - made the input argument -! CoordSortOrder optional to allow user-defined grid -! numbering schemes. -!EOP ___________________________________________________________________ -! - character(len=*),parameter :: myname_=myname//'::init_' - - ! List to store real and integer attributes - type(List) :: RAList, IAList - - ! Overlapping index storage arrays: - integer, dimension(:), pointer :: & - CoordListIndices, CoordSortOrderIndices - - ! Temporary vars - integer :: NumShared, nitems, i, l, ierr - - ! Let's begin by nullifying everything: - - call List_nullify(GGrid%coordinate_list) - call List_nullify(GGrid%coordinate_sort_order) - call List_nullify(GGrid%weight_list) - call List_nullify(GGrid%other_list) - call List_nullify(GGrid%index_list) - nullify(GGrid%descend) - - ! Convert the Character arguments to the appropriate - ! GeneralGrid components. - - ! Set up the integer and real attribute lists. - - call List_init(GGrid%coordinate_list,trim(CoordChars)) - call List_copy(RAList,GGrid%coordinate_list) - - if(present(CoordSortOrder)) then - call List_init(GGrid%coordinate_sort_order,trim(CoordSortOrder)) - endif - - if(present(WeightChars)) then - call List_init(GGrid%weight_list,trim(WeightChars)) - call List_append(RAList, GGrid%weight_list) - endif - - if(present(OtherChars)) then - call List_init(GGrid%other_list,trim(OtherChars)) - call List_append(RAList, GGrid%other_list) - endif - - call List_init(IAList,GlobGridNum) - - if(present(IndexChars)) then - call List_init(GGrid%index_list,trim(IndexChars)) - call List_append(IAList, GGrid%index_list) - endif - - ! Check the lists that we've initialized : - - nitems = List_nitem(GGrid%coordinate_list) - - ! Check the number of coordinates - - if(nitems <= 0) then - write(stderr,*) myname_, & - ':: ERROR CoordList is empty!' - call die(myname_,'List_nitem(CoordList) <= 0',nitems) - endif - - ! Check the items in the coordinate list and the - ! coordinate grid sort keys...they should contain - ! the same items. - - if(present(CoordSortOrder)) then - - call List_shared(GGrid%coordinate_list,GGrid%coordinate_sort_order, & - NumShared,CoordListIndices,CoordSortOrderIndices) - - deallocate(CoordListIndices,CoordSortOrderIndices,stat=ierr) - if(ierr/=0) call die(myname_,'deallocate(CoordListIndices..)',ierr) - - if(NumShared /= nitems) then - call die(myname_,'CoordSortOrder must have the same items & - & as CoordList',abs(nitems-NumShared)) - endif - - endif - - ! If the LOGICAL argument descend is present, check the - ! number of entries to ensure they match the grid dimensionality. - ! If descend is not present, assume all coordinate grid point - ! sortings will be in ascending order. - - if(present(descend)) then - - if( ( (.not.associated(descend)) .or. & - (.not.present(CoordSortOrder)) ) .or. & - (size(descend) /= nitems) ) then - - write(stderr,*) myname_, & - ':: ERROR using descend argument, & - &associated(descend) = ', associated(descend), & - ' present(CoordSortOrder) = ', present(CoordSortOrder), & - ' size(descend) = ', size(descend), & - ' List_nitem(CoordSortOrder) = ', & - List_nitem(GGrid%coordinate_sort_order) - call die(myname_, 'ERROR using -descend- argument; & - & see stderr file for details') - endif - - endif - - ! Finally, Initialize GGrid%descend from descend(:). - ! If descend argument is not present, set it to the default .false. - - if(present(CoordSortOrder)) then - - allocate(GGrid%descend(nitems), stat=ierr) - if(ierr /= 0) call die(myname_,"allocate GGrid%descend...",ierr) - - if(present(descend)) then - - do i=1,nitems - GGrid%descend(i) = descend(i) - enddo - - else - - do i=1,nitems - GGrid%descend(i) = .FALSE. - enddo - - endif - - endif - - ! Initialize GGrid%data using IAList, RAList, and lsize (if - ! present). - - l = 0 - if(present(lsize)) l=lsize - - call AttrVect_init(GGrid%data, IAList, RAList, l) - - - ! Deallocate the temporary variables - - call List_clean(IAList) - call List_clean(RAList) - - end subroutine init_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: initl_ - Create an Empty GeneralGrid from Lists -! -! !DESCRIPTION: -! The routine {\tt initl\_()} creates the storage space for grid point -! coordinates, area/volume weights, and other coordinate data ({\em e.g.}, -! local cell dimensions). These data are referenced by {\tt List} -! components that are also created by this routine (see the documentation -! of the declaration section of this module for more details about setting -! list information). Each of the input {\tt List} arguments is used -! directly to create the corresponding -! {\tt List} element of the output {\tt GeneralGrid} argument {\tt GGrid}, -! and are summarized in the table below: -! -!\begin{table}[htbp] -!\begin{center} -!\begin{tabular}{|l|l|l|l|} -!\hline -!{\bf Argument} & {\bf Component of {\tt GGrid}} & {\bf Significance} & {\bf Required?} \\ -!\hline -!{\tt CoordList} & {\tt GGrid\%coordinate\_list} & Dimension Names & Yes \\ -!\hline -!{\tt CoordSortOrder} & {\tt GGrid\%coordinate\_sort\_order} & Grid Point & No \\ -! & & Sorting Keys & \\ -!\hline -!{\tt WeightList} & {\tt GGrid\%weight\_list} & Grid Cell & No \\ -! & & Length, Area, and & \\ -! & & Volume Weights & \\ -!\hline -!{\tt OtherList} & {\tt GGrid\%other\_list} & All Other & No \\ -! & & Real Attributes & \\ -!\hline -!{\tt IndexList} & {\tt GGrid\%index\_list} & All Other & No \\ -! & & Integer Attributes & \\ -!\hline -!\end{tabular} -!\end{center} -!\end{table} -! -! The input {\tt INTEGER} argument {\tt lsize} defines the number of grid points -! to be stored in {\tt GGrid}. -! -! If a set of sorting keys is supplied in the argument {\tt CoordSortOrder}, -! the user can control whether the sorting by each key is in descending or -! ascending order by supplying the input {\tt LOGICAL} array {\tt descend(:)}. -! By default, all sorting is in {\em ascending} order for each key if the -! argument {\tt descend} is not provided. -! -! {\bf N.B.}: The output {\tt GeneralGrid} {\tt GGrid} is dynamically -! allocated memory. When one no longer needs {\tt GGrid}, one should -! release this space by invoking {\tt clean()} for the {\tt GeneralGrid}. -! -! !INTERFACE: - - subroutine initl_(GGrid, CoordList, CoordSortOrder, descend, WeightList, & - OtherList, IndexList, lsize ) -! -! !USES: -! - - use m_stdio - use m_die - - use m_List, only : List - use m_List, only : List_init => init - use m_List, only : List_allocated => allocated - use m_List, only : List_nitem => nitem - use m_List, only : List_shared => GetSharedListIndices - use m_List, only : List_append => append - use m_List, only : List_copy => copy - use m_List, only : List_nullify => nullify - use m_List, only : List_clean => clean - - use m_AttrVect, only : AttrVect - use m_AttrVect, only : AttrVect_init => init - - implicit none - -! !INPUT PARAMETERS: -! - Type(List), intent(in) :: CoordList - Type(List), optional, intent(in) :: CoordSortOrder - Type(List), optional, intent(in) :: WeightList - logical, dimension(:), optional, pointer :: descend - Type(List), optional, intent(in) :: OtherList - Type(List), optional, intent(in) :: IndexList - integer, optional, intent(in) :: lsize - -! !OUTPUT PARAMETERS: -! - type(GeneralGrid), intent(out) :: GGrid - -! !REVISION HISTORY: -! 10May01 - Jay Larson - initial version -! 8Aug01 - E.T. Ong - changed list assignment(=) -! to list copy to avoid compiler bugs with pgf90 -! 17Jul02 - E. Ong - general revision; -! added error checks -! 5Aug02 - E. Ong - made input argument -! CoordSortOrder optional to allow for user-defined -! grid numbering schemes -!EOP ___________________________________________________________________ -! - character(len=*),parameter :: myname_=myname//'::initl_' - - ! List to store real and integer attributes - type(List) :: RAList, IAList - - ! Overlapping attribute index storage arrays: - integer, dimension(:), pointer :: & - CoordListIndices, CoordSortOrderIndices - - ! Temporary vars - integer :: NumShared, nitems, i, l, ierr - - ! Let's begin by nullifying everything: - - call List_nullify(GGrid%coordinate_list) - call List_nullify(GGrid%coordinate_sort_order) - call List_nullify(GGrid%weight_list) - call List_nullify(GGrid%other_list) - call List_nullify(GGrid%index_list) - nullify(GGrid%descend) - - ! Check the arguments: - - nitems = List_nitem(CoordList) - - ! Check the number of coordinates - - if(nitems <= 0) then - write(stderr,*) myname_, & - ':: ERROR CoordList is empty!' - call die(myname_,'List_nitem(CoordList) <= 0',nitems) - endif - - ! Check the items in the coordinate list and the - ! coordinate grid sort keys...they should contain - ! the same items. - - if(present(CoordSortOrder)) then - - call List_shared(CoordList,CoordSortOrder,NumShared, & - CoordListIndices,CoordSortOrderIndices) - - deallocate(CoordListIndices,CoordSortOrderIndices,stat=ierr) - if(ierr/=0) call die(myname_,'deallocate(CoordListIndices..)',ierr) - - if(NumShared /= nitems) then - call die(myname_,'CoordSortOrder must have the same items & - & as CoordList',abs(nitems-NumShared)) - endif - - endif - - ! If the LOGICAL argument descend is present, check the - ! number of entries to ensure they match the grid dimensionality. - ! If descend is not present, assume all coordinate grid point - ! sortings will be in ascending order. - - if(present(descend)) then - - if( ( (.not.associated(descend)) .or. & - (.not.present(CoordSortOrder)) ) .or. & - (size(descend) /= nitems) ) then - - write(stderr,*) myname_, & - ':: ERROR using descend argument, & - &associated(descend) = ', associated(descend), & - ' present(CoordSortOrder) = ', present(CoordSortOrder), & - ' size(descend) = ', size(descend), & - ' List_nitem(CoordSortOrder) = ', & - List_nitem(CoordSortOrder) - call die(myname_, 'ERROR using -descend- argument; & - &stderr file for details') - endif - - endif - - ! Initialize GGrid%descend from descend(:), if present. If - ! the argument descend(:) was not passed, set GGrid%descend - ! to the default .false. - - if(present(CoordSortOrder)) then - - allocate(GGrid%descend(nitems), stat=ierr) - if(ierr /= 0) call die(myname_,"allocate GGrid%descend...",ierr) - - if(present(descend)) then - - do i=1,nitems - GGrid%descend(i) = descend(i) - enddo - - else - - do i=1,nitems - GGrid%descend(i) = .FALSE. - enddo - - endif - - endif - - ! Process input lists and create the appropriate GeneralGrid - ! List components - - call List_copy(GGrid%coordinate_list,CoordList) - call List_copy(RAList,CoordList) - - if(present(CoordSortOrder)) then - if(List_allocated(CoordSortOrder)) then - call List_copy(GGrid%coordinate_sort_order,CoordSortOrder) - else - call die(myname_,"Argument CoortSortOrder not allocated") - endif - endif - - ! Concatenate present input Lists to create RAList, and - ! at the same time assign the List components of GGrid - - if(present(WeightList)) then - if(List_allocated(WeightList)) then - call List_copy(GGrid%weight_list,WeightList) - call List_append(RAList, WeightList) - else - call die(myname_,"Argument WeightList not allocated") - endif - endif - - if(present(OtherList)) then - if(List_allocated(OtherList)) then - call List_copy(GGrid%other_list,OtherList) - call List_append(RAList, OtherList) - else - call die(myname_,"Argument OtherList not allocated") - endif - endif - - ! Concatenate present input Lists to create IAList - - call List_init(IAList,GlobGridNum) - - if(present(IndexList)) then - call List_copy(GGrid%index_list,IndexList) - call List_append(IAList, IndexList) - endif - - ! Initialize GGrid%data using IAList, RAList, and lsize (if - ! present). - - l = 0 - if(present(lsize)) l = lsize - - call AttrVect_init(GGrid%data, IAList, RAList, l) - - ! Deallocate the temporary variables - - call List_clean(IAList) - call List_clean(RAList) - - end subroutine initl_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: initgg_ - Create a GeneralGrid from Another -! -! !DESCRIPTION: -! The routine {\tt initgg\_()} creates the storage space for grid point -! coordinates, area/volume weights, and other coordinate data ({\em e.g.}, -! nearest-neighbor coordinates). These data are all copied from the -! already initialized input {\tt GeneralGrid} argument {\tt iGGrid}. This -! routine initializes the output {\tt GeneralGrid} argument {\tt oGGrid} -! with the same {\tt List} data as {\tt iGGrid}, but with storage space -! for {\tt lsize} gridpoints. -! -! {\bf N.B.}: Though the attribute lists and gridpoint sorting strategy -! of {\tt iGGrid} is copied to {\tt oGGrid}, the actual values of the -! attributes are not. -! -! {\bf N.B.}: It is assumed that {\tt iGGrid} has been initialized. -! -! {\bf N.B.}: The output {\tt GeneralGrid} {\tt oGGrid} is dynamically -! allocated memory. When one no longer needs {\tt oGGrid}, one should -! release this space by invoking {\tt GeneralGrid\_clean()}. -! -! !INTERFACE: - - subroutine initgg_(oGGrid, iGGrid, lsize) -! -! !USES: -! - use m_stdio - use m_die - - use m_List, only : List - use m_List, only : List_allocated => allocated - use m_List, only : List_copy => copy - use m_List, only : List_nitems => nitem - use m_List, only : List_nullify => nullify - - use m_AttrVect, only: AttrVect - use m_AttrVect, only: AttrVect_init => init - - implicit none - -! !INPUT PARAMETERS: -! - type(GeneralGrid), intent(in) :: iGGrid - integer, optional, intent(in) :: lsize - -! !OUTPUT PARAMETERS: -! - type(GeneralGrid), intent(out) :: oGGrid - -! !REVISION HISTORY: -! 2May01 - Jay Larson - Initial version. -! 13Jun01 - Jay Larson - Now, undefined List -! components of the GeneralGrid iGGrid are no longer -! copied to oGGrid. -! 8Aug01 - E.T. Ong - changed list assignment(=) -! to list copy to avoid compiler bugs with pgf90 -! 24Jul02 - E.T. Ong - updated this init version -! to correspond with initl_ -! 5Aug02 - E. Ong - made input argument -! CoordSortOrder optional to allow for user-defined -! grid numbering schemes -!EOP ___________________________________________________________________ -! - character(len=*),parameter :: myname_=myname//'::initgg_' -! Number of grid points, number of grid dimensions - integer :: n, ncoord, norder -! Loop index and Error Flag - integer :: i, ierr - - ! Start by nullifying everything: - - call List_nullify(oGGrid%coordinate_list) - call List_nullify(oGGrid%coordinate_sort_order) - call List_nullify(oGGrid%weight_list) - call List_nullify(oGGrid%other_list) - call List_nullify(oGGrid%index_list) - nullify(oGGrid%descend) - - ! Brief argument check: - - ncoord = dims_(iGGrid) ! dimensionality of the GeneralGrid - - if(associated(iGGrid%descend)) then - - if(size(iGGrid%descend) /= ncoord) then ! size mismatch - call die(myname_,"size(iGGrid%descend) must equal ncoord, & - & size(iGGrid%descend) = ", size(iGGrid%descend), & - "ncoord = ", ncoord ) - endif - - endif - - ! If iGGrid%descend has been allocated, copy its contents; - ! allocate and fill oGGrid%descend - - if(associated(iGGrid%descend)) then - - allocate(oGGrid%descend(ncoord), stat=ierr) - if(ierr /= 0) then - call die(myname_,"allocate(oGGrid%descend...", ierr) - endif - - do i=1,ncoord - oGGrid%descend(i) = iGGrid%descend(i) - end do - - endif - - ! Copy list data from iGGrid to oGGrid. - - call List_copy(oGGrid%coordinate_list,iGGrid%coordinate_list) - if(List_allocated(iGGrid%coordinate_sort_order)) then - call List_copy(oGGrid%coordinate_sort_order,iGGrid%coordinate_sort_order) - endif - if(List_allocated(iGGrid%weight_list)) then - call List_copy(oGGrid%weight_list,iGGrid%weight_list) - endif - if(List_allocated(iGGrid%other_list)) then - call List_copy(oGGrid%other_list,iGGrid%other_list) - endif - if(List_allocated(iGGrid%index_list)) then - call List_copy(oGGrid%index_list,iGGrid%index_list) - endif - - ! if lsize is present, use it to set n; if not, set n=0 - - n = 0 - if(present(lsize)) n=lsize - - ! Now, initialize oGGrid%data from iGGrid%data, but - ! with length n. - - call AttrVect_init(oGGrid%data, iGGrid%data, n) - - end subroutine initgg_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: initCartesianSP_ - Initialize a Cartesian GeneralGrid -! -! !DESCRIPTION: -! The routine {\tt initCartesian\_()} creates the storage space for grid point -! coordinates, area and volume weights, and other coordinate data ({\em e.g.}, -! cell area and volume weights). The names of the Cartesian axes are supplied -! by the user as a colon-delimitted string in the input {\tt CHARACTER} -! argument {\tt CoordChars}. For example, a Cartesian grid for Euclidian -! 3-space would have ${\tt CoordChars} = {\tt 'x:y:z'}$. The user can -! define named real attributes for spatial weighting data in the input -! {\tt CHARACTER} argument {\tt WeightChars}. For example, one could -! define attributes for Euclidean 3-space length elements by setting -! ${\tt WeightChars} = {\tt 'dx:dy:dz'}$. The input {\tt CHARCTER} -! argument {\tt OtherChars} provides space for defining other real -! attributes (again as a colon-delimited string of attribute names). -! One can define integer attributes by supplying a colon-delimitted -! string of names in the input {\tt CHARACTER} argument -! {\tt IndexChars}. For example, on could set aside storage space -! for the {\tt x}-, {\tt y}-, and {\tt z}-indices by setting -! ${\tt IndexChars} = {\tt 'xIndex:yIndex:zIndex'}$. -! -! Once the storage space in {\tt GGrid} is initialized, The gridpoint -! coordinates are evaluated using the input arguments {\tt Dims} (the -! number of points on each coordinate axis) and {\tt AxisData} (the -! coordinate values on all of the points of all of the axes). The user -! presents the axes with each axis stored in a column of {\tt AxisData}, -! and the axes are laid out in the same order as the ordering of the -! axis names in {\tt CoordChars}. The number of points on each axis -! is defined by the entries of the input {\tt INTEGER} array -! {\tt Dims(:)}. Continuing with the Euclidean 3-space example given -! above, setting ${\tt Dims(1:3)} = {\tt (256, 256, 128)}$ will result -! in a Cartesian grid with 256 points in the {\tt x}- and {\tt y}-directions, -! and 128 points in the {\tt z}-direction. Thus the appropriate dimensions -! of {\tt AxisData} are 256 rows (the maximum number of axis points among -! all the axes) by 3 columns (the number of physical dimensions). The -! {\tt x}-axis points are stored in {\tt AxisData(1:256,1)}, the -! {\tt y}-axis points are stored in {\tt AxisData(1:256,2)}, and the -! {\tt z}-axis points are stored in {\tt AxisData(1:128,3)}. -! -! The sorting order of the gridpoints can be either user-defined, or -! set automatically by MCT. If the latter is desired, the user must -! supply the argument {\tt CoordSortOrder}, which defines the -! lexicographic ordering (by coordinate). The entries optional input -! {\tt LOGICAL} array {\tt descend(:)} stipulates whether the ordering -! with respect to the corresponding key in {\tt CoordChars} is to be -! {\em descending}. If {\tt CoordChars} is supplied, but {\tt descend(:)} -! is not, the gridpoint information is placed in {\em ascending} order -! for each key. Returning to our Euclidian 3-space example, a choice of -! ${\tt CoordSortOrder} = {\tt y:x:z}$ and ${\tt descend(1:3)} = -! ({\tt .TRUE.}, {\tt .FALSE.}, {\tt .FALSE.})$ will result in the entries of -! {\tt GGrid} being orderd lexicographically by {\tt y} (in descending -! order), {\tt x} (in ascending order), and {\tt z} (in ascending order). -! Regardless of the gridpoint sorting strategy, MCT will number each of -! the gridpoints in {\tt GGrid}, storing this information in the integer -! attribute named {\tt 'GlobGridNum'}. -! -! !INTERFACE: - - subroutine initCartesianSP_(GGrid, CoordChars, CoordSortOrder, descend, & - WeightChars, OtherChars, IndexChars, Dims, & - AxisData) -! -! !USES: -! - use m_stdio - use m_die - use m_realkinds, only : SP - - use m_String, only : String - use m_String, only : String_ToChar => ToChar - use m_String, only : String_clean => clean - - use m_List, only : List - use m_List, only : List_init => init - use m_List, only : List_clean => clean - use m_List, only : List_nullify => nullify - use m_List, only : List_append => append - use m_List, only : List_nitem => nitem - use m_List, only : List_get => get - use m_List, only : List_shared => GetSharedListIndices - - use m_AttrVect, only : AttrVect - use m_AttrVect, only : AttrVect_init => init - use m_AttrVect, only : AttrVect_zero => zero - - implicit none - -! !INPUT PARAMETERS: -! - character(len=*), intent(in) :: CoordChars - character(len=*), optional, intent(in) :: CoordSortOrder - character(len=*), optional, intent(in) :: WeightChars - logical, dimension(:), optional, pointer :: descend - character(len=*), optional, intent(in) :: OtherChars - character(len=*), optional, intent(in) :: IndexChars - integer, dimension(:), pointer :: Dims - real(SP), dimension(:,:), pointer :: AxisData - -! !OUTPUT PARAMETERS: -! - type(GeneralGrid), intent(out) :: GGrid - -! !REVISION HISTORY: -! 7Jun01 - Jay Larson - API Specification. -! 12Aug02 - Jay Larson - Implementation. -!EOP ___________________________________________________________________ -! - character(len=*),parameter :: myname_=myname//'::initCartesianSP_' - - type(List) :: IAList, RAList - type(String) :: AxisName - integer, dimension(:), pointer :: & - CoordListIndices, CoordSortOrderIndices - integer :: DimMax, NumDims, NumGridPoints, NumShared - integer :: ierr, iAxis, i, j, k, n, nCycles, nRepeat - integer :: index - - ! Nullify GeneralGrid components - - call List_nullify(GGrid%coordinate_list) - call List_nullify(GGrid%coordinate_sort_order) - call List_nullify(GGrid%weight_list) - call List_nullify(GGrid%other_list) - call List_nullify(GGrid%index_list) - nullify(GGrid%descend) - - ! Sanity check on axis definition arguments: - - ! Ensure each axis has a positive number of points, and - ! determine DimMax, the maximum entry in Dims(:). - - DimMax = 1 - do i=1,size(Dims) - if(Dims(i) > DimMax) DimMax = Dims(i) - if(Dims(i) <= 0) then - write(stderr,'(2a,i8,a,i8)') myname_, & - ':: FATAL--illegal number of axis points in Dims(',i,') = ', & - Dims(i) - call die(myname_) - endif - end do - - ! Are the definitions of Dims(:) and AxisData(:,:) compatible? - ! The number of elements in Dims(:) should match the number of - ! columns in AxisData(:,:), and the maximum value stored in Dims(:) - ! (DimMax determined above in this routine) must not exceed the - ! number of rows in AxisData(:,:). - - if(size(AxisData,2) /= size(Dims)) then - write(stderr,'(4a,i8,a,i8)') myname_, & - ':: FATAL-- The number of axes (elements) referenced in Dims(:) ', & - 'does not equal the number of columns in AxisData(:,:). ', & - 'size(Dims) = ',size(Dims),' size(AxisData,2) = ',size(AxisData,2) - call die(myname_) - endif - - if(size(AxisData,1) < DimMax) then - write(stderr,'(4a,i8,a,i8)') myname_, & - ':: FATAL-- Maximum number of axis points max(Dims) is ', & - 'greater than the number of rows in AxisData(:,:). ', & - 'max(Dims) = ',DimMax,' size(AxisData,1) = ',size(AxisData,1) - call die(myname_) - endif - - ! If the LOGICAL descend(:) flags for sorting are present, - ! make sure that (1) descend is associated, and - ! (2) CoordSortOrder is also present, and - ! (3) The size of descend(:) matches the size of Dims(:), - ! both of which correspond to the number of axes on the - ! Cartesian Grid. - - if(present(descend)) then - - if(.not.associated(descend)) then - call die(myname_,'descend argument must be associated') - endif - - if(.not. present(CoordSortOrder)) then - write(stderr,'(4a)') myname_, & - ':: FATAL -- Invocation with the argument descend(:) present ', & - 'requires the presence of the argument CoordSortOrder, ', & - 'which was not provided.' - call die(myname_, 'Argument CoordSortOrder was not provided') - endif - - if(size(descend) /= size(Dims)) then - write(stderr,'(4a,i8,a,i8)') myname_, & - ':: FATAL-- The sizes of the arrays descend(:) and Dims(:) ', & - 'must match (they both must equal the number of dimensions ', & - 'of the Cartesian Grid). size(Dims) = ',size(Dims), & - ' size(descend) = ',size(descend) - call die(myname_,'size of and arguments must match') - endif - - endif - - ! Initialize GGrid%coordinate_list and use the number of items - ! in it to set the number of dimensions of the Cartesian - ! Grid (NumDims): - - call List_init(GGrid%coordinate_list, CoordChars) - - NumDims = List_nitem(GGrid%coordinate_list) - - ! Check the number of arguments - - if(NumDims <= 0) then - write(stderr,*) myname_, & - ':: ERROR CoordList is empty!' - call die(myname_,'List_nitem(CoordList) <= 0',NumDims) - endif - - ! Do the number of coordinate names specified match the number - ! of coordinate axes (i.e., the number of columns in AxisData(:,:))? - - if(NumDims /= size(AxisData,2)) then - write(stderr,'(6a,i8,a,i8)') myname_, & - ':: FATAL-- Number of axes specified in argument CoordChars ', & - 'does not equal the number of axes stored in AxisData(:,:). ', & - 'CoordChars = ', CoordChars, & - 'Number of axes = ',NumDims, & - ' size(AxisData,2) = ',size(AxisData,2) - call die(myname_) - endif - - ! End of argument sanity checks. - - ! Create other List components of GGrid and build REAL - ! and INTEGER attribute lists for the AttrVect GGrid%data - - ! Start off with things *guaranteed* to be in IAList and RAList. - ! The variable GlobGridNum is a CHARACTER parameter inherited - ! from the declaration section of this module. - - call List_init(IAList, GlobGridNum) - call List_init(RAList, CoordChars) - - if(present(CoordSortOrder)) then - - call List_init(GGrid%coordinate_sort_order, CoordSortOrder) - - ! Check the items in the coordinate list and the - ! coordinate grid sort keys...they should contain - ! the same items. - - call List_shared(GGrid%coordinate_list,GGrid%coordinate_sort_order, & - NumShared,CoordListIndices,CoordSortOrderIndices) - - deallocate(CoordListIndices,CoordSortOrderIndices,stat=ierr) - if(ierr/=0) call die(myname_,'deallocate(CoordListIndices..)',ierr) - - if(NumShared /= NumDims) then - call die(myname_,'CoordSortOrder must have the same items & - & as CoordList',abs(NumDims-NumShared)) - endif - - endif - - if(present(WeightChars)) then - call List_init(GGrid%weight_list, WeightChars) - call List_append(RAList, GGrid%weight_list) - endif - - if(present(OtherChars)) then - call List_init(GGrid%other_list, OtherChars) - call List_append(RAList, GGrid%other_list) - endif - - if(present(IndexChars)) then - call List_init(GGrid%index_list, IndexChars) - call List_append(IAList, GGrid%index_list) - endif - - ! Finally, Initialize GGrid%descend from descend(:). - ! If descend argument is not present, set it to the default .false. - - if(present(CoordSortOrder)) then - - allocate(GGrid%descend(NumDims), stat=ierr) - if(ierr /= 0) call die(myname_,"allocate GGrid%descend...",ierr) - - if(present(descend)) then - do n=1,NumDims - GGrid%descend(n) = descend(n) - end do - else - do n=1,NumDims - GGrid%descend(n) = .FALSE. - end do - endif - - endif ! if(present(CoordSortOrder))... - - ! Compute the total number of grid points in the GeneralGrid. - ! This is merely the product of the elements of Dims(:) - - NumGridPoints = 1 - do i=1,NumDims - NumGridPoints = NumGridPoints * Dims(i) - end do - - ! Now we are prepared to create GGrid%data: - - call AttrVect_init(GGrid%data, IAList, RAList, NumGridPoints) - call AttrVect_zero(GGrid%data) - - ! Now, store Cartesian gridpoint data, in the order - ! defined by how the user laid out AxisData(:,:) - - do n=1,NumDims - - ! Retrieve first coordinate axis name from GGrid%coordinate_list - ! (as a String) - call List_get(AxisName, n, GGrid%coordinate_list) - - ! Index this real attribute of GGrid - iAxis = indexRA_(GGrid, String_ToChar(AxisName)) - - if(iAxis <= 0) then - write(stderr,'(4a)') myname_, & - ':: REAL Attribute "',String_ToChar(AxisName),'" not found.' - call die(myname_) - endif - - ! Now, clear the String AxisName for use in the next - ! cycle of this loop: - - call String_clean(AxisName) - - ! Compute the number of times we cycle through the axis - ! values (nCycles), and the number of times each axis - ! value is repeated in each cycle (nRepeat) - - nCycles = 1 - if(n > 1) then - do i=1,n-1 - nCycles = nCycles * Dims(i) - end do - endif - - nRepeat = 1 - if(n < NumDims) then - do i=n+1,NumDims - nRepeat = nRepeat * Dims(i) - end do - endif - - ! Loop over the number of cycles for which we run through - ! all the axis points. Within each cycle, loop over all - ! of the axis points, repeating each value nRepeat times. - ! This produces a set of grid entries that are in - ! lexicographic order with respect to how the axes are - ! presented to this routine. - - index = 1 - do i=1,nCycles - do j=1,Dims(n) - do k=1,nRepeat - GGrid%data%rAttr(iAxis,index) = AxisData(j,n) - index = index+1 - end do ! do k=1,nRepeat - end do ! do j=1,Dims(n) - end do ! do i=1,nCycles - - end do ! do n=1,NumDims... - - ! If the argument CoordSortOrder was supplied, the entries - ! of GGrid will be sorted/permuted with this lexicographic - ! ordering, and the values of the GGrid INTEGER attribute - ! GlobGridNum will be numbered to reflect this new ordering - ! scheme. - - index = indexIA_(GGrid, GlobGridNum) - - if(present(CoordSortOrder)) then ! Sort permute entries before - ! numbering them - - call SortPermute_(GGrid) ! Sort / permute - - endif ! if(present(CoordSortOrder))... - - ! Number the gridpoints based on the AttrVect point index - ! (i.e., the second index in GGrid%data%iAttr) - - do i=1, lsize_(GGrid) - GGrid%data%iAttr(index,i) = i - end do - - ! Finally, clean up intermediate Lists - - call List_clean(IAList) - call List_clean(RAList) - - end subroutine initCartesianSP_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -! ---------------------------------------------------------------------- -! -! !IROUTINE: initCartesianDP_ - Initialize a Cartesian GeneralGrid -! -! !DESCRIPTION: -! Double Precision version of initCartesianSP_ -! -! !INTERFACE: - - subroutine initCartesianDP_(GGrid, CoordChars, CoordSortOrder, descend, & - WeightChars, OtherChars, IndexChars, Dims, & - AxisData) -! -! !USES: -! - use m_stdio - use m_die - use m_realkinds, only : DP - - use m_String, only : String - use m_String, only : String_ToChar => ToChar - use m_String, only : String_clean => clean - - use m_List, only : List - use m_List, only : List_init => init - use m_List, only : List_clean => clean - use m_List, only : List_nullify => nullify - use m_List, only : List_append => append - use m_List, only : List_nitem => nitem - use m_List, only : List_get => get - use m_List, only : List_shared => GetSharedListIndices - - use m_AttrVect, only : AttrVect - use m_AttrVect, only : AttrVect_init => init - use m_AttrVect, only : AttrVect_zero => zero - - implicit none - -! !INPUT PARAMETERS: -! - character(len=*), intent(in) :: CoordChars - character(len=*), optional, intent(in) :: CoordSortOrder - character(len=*), optional, intent(in) :: WeightChars - logical, dimension(:), optional, pointer :: descend - character(len=*), optional, intent(in) :: OtherChars - character(len=*), optional, intent(in) :: IndexChars - integer, dimension(:), pointer :: Dims - real(DP), dimension(:,:), pointer :: AxisData - -! !OUTPUT PARAMETERS: -! - type(GeneralGrid), intent(out) :: GGrid - -! !REVISION HISTORY: -! 7Jun01 - Jay Larson - API Specification. -! 12Aug02 - Jay Larson - Implementation. -! ______________________________________________________________________ -! - character(len=*),parameter :: myname_=myname//'::initCartesianDP_' - - type(List) :: IAList, RAList - type(String) :: AxisName - integer, dimension(:), pointer :: & - CoordListIndices, CoordSortOrderIndices - integer :: DimMax, NumDims, NumGridPoints, NumShared - integer :: ierr, iAxis, i, j, k, n, nCycles, nRepeat - integer :: index - - ! Nullify GeneralGrid components - - call List_nullify(GGrid%coordinate_list) - call List_nullify(GGrid%coordinate_sort_order) - call List_nullify(GGrid%weight_list) - call List_nullify(GGrid%other_list) - call List_nullify(GGrid%index_list) - nullify(GGrid%descend) - - ! Sanity check on axis definition arguments: - - ! Ensure each axis has a positive number of points, and - ! determine DimMax, the maximum entry in Dims(:). - - DimMax = 1 - do i=1,size(Dims) - if(Dims(i) > DimMax) DimMax = Dims(i) - if(Dims(i) <= 0) then - write(stderr,'(2a,i8,a,i8)') myname_, & - ':: FATAL--illegal number of axis points in Dims(',i,') = ', & - Dims(i) - call die(myname_) - endif - end do - - ! Are the definitions of Dims(:) and AxisData(:,:) compatible? - ! The number of elements in Dims(:) should match the number of - ! columns in AxisData(:,:), and the maximum value stored in Dims(:) - ! (DimMax determined above in this routine) must not exceed the - ! number of rows in AxisData(:,:). - - if(size(AxisData,2) /= size(Dims)) then - write(stderr,'(4a,i8,a,i8)') myname_, & - ':: FATAL-- The number of axes (elements) referenced in Dims(:) ', & - 'does not equal the number of columns in AxisData(:,:). ', & - 'size(Dims) = ',size(Dims),' size(AxisData,2) = ',size(AxisData,2) - call die(myname_) - endif - - if(size(AxisData,1) < DimMax) then - write(stderr,'(4a,i8,a,i8)') myname_, & - ':: FATAL-- Maximum number of axis points max(Dims) is ', & - 'greater than the number of rows in AxisData(:,:). ', & - 'max(Dims) = ',DimMax,' size(AxisData,1) = ',size(AxisData,1) - call die(myname_) - endif - - ! If the LOGICAL descend(:) flags for sorting are present, - ! make sure that (1) descend is associated, and - ! (2) CoordSortOrder is also present, and - ! (3) The size of descend(:) matches the size of Dims(:), - ! both of which correspond to the number of axes on the - ! Cartesian Grid. - - if(present(descend)) then - - if(.not.associated(descend)) then - call die(myname_,'descend argument must be associated') - endif - - if(.not. present(CoordSortOrder)) then - write(stderr,'(4a)') myname_, & - ':: FATAL -- Invocation with the argument descend(:) present ', & - 'requires the presence of the argument CoordSortOrder, ', & - 'which was not provided.' - call die(myname_, 'Argument CoordSortOrder was not provided') - endif - - if(size(descend) /= size(Dims)) then - write(stderr,'(4a,i8,a,i8)') myname_, & - ':: FATAL-- The sizes of the arrays descend(:) and Dims(:) ', & - 'must match (they both must equal the number of dimensions ', & - 'of the Cartesian Grid). size(Dims) = ',size(Dims), & - ' size(descend) = ',size(descend) - call die(myname_,'size of and arguments must match') - endif - - endif - - ! Initialize GGrid%coordinate_list and use the number of items - ! in it to set the number of dimensions of the Cartesian - ! Grid (NumDims): - - call List_init(GGrid%coordinate_list, CoordChars) - - NumDims = List_nitem(GGrid%coordinate_list) - - ! Check the number of arguments - - if(NumDims <= 0) then - write(stderr,*) myname_, & - ':: ERROR CoordList is empty!' - call die(myname_,'List_nitem(CoordList) <= 0',NumDims) - endif - - ! Do the number of coordinate names specified match the number - ! of coordinate axes (i.e., the number of columns in AxisData(:,:))? - - if(NumDims /= size(AxisData,2)) then - write(stderr,'(6a,i8,a,i8)') myname_, & - ':: FATAL-- Number of axes specified in argument CoordChars ', & - 'does not equal the number of axes stored in AxisData(:,:). ', & - 'CoordChars = ', CoordChars, & - 'Number of axes = ',NumDims, & - ' size(AxisData,2) = ',size(AxisData,2) - call die(myname_) - endif - - ! End of argument sanity checks. - - ! Create other List components of GGrid and build REAL - ! and INTEGER attribute lists for the AttrVect GGrid%data - - ! Start off with things *guaranteed* to be in IAList and RAList. - ! The variable GlobGridNum is a CHARACTER parameter inherited - ! from the declaration section of this module. - - call List_init(IAList, GlobGridNum) - call List_init(RAList, CoordChars) - - if(present(CoordSortOrder)) then - - call List_init(GGrid%coordinate_sort_order, CoordSortOrder) - - ! Check the items in the coordinate list and the - ! coordinate grid sort keys...they should contain - ! the same items. - - call List_shared(GGrid%coordinate_list,GGrid%coordinate_sort_order, & - NumShared,CoordListIndices,CoordSortOrderIndices) - - deallocate(CoordListIndices,CoordSortOrderIndices,stat=ierr) - if(ierr/=0) call die(myname_,'deallocate(CoordListIndices..)',ierr) - - if(NumShared /= NumDims) then - call die(myname_,'CoordSortOrder must have the same items & - & as CoordList',abs(NumDims-NumShared)) - endif - - endif - - if(present(WeightChars)) then - call List_init(GGrid%weight_list, WeightChars) - call List_append(RAList, GGrid%weight_list) - endif - - if(present(OtherChars)) then - call List_init(GGrid%other_list, OtherChars) - call List_append(RAList, GGrid%other_list) - endif - - if(present(IndexChars)) then - call List_init(GGrid%index_list, IndexChars) - call List_append(IAList, GGrid%index_list) - endif - - ! Finally, Initialize GGrid%descend from descend(:). - ! If descend argument is not present, set it to the default .false. - - if(present(CoordSortOrder)) then - - allocate(GGrid%descend(NumDims), stat=ierr) - if(ierr /= 0) call die(myname_,"allocate GGrid%descend...",ierr) - - if(present(descend)) then - do n=1,NumDims - GGrid%descend(n) = descend(n) - end do - else - do n=1,NumDims - GGrid%descend(n) = .FALSE. - end do - endif - - endif ! if(present(CoordSortOrder))... - - ! Compute the total number of grid points in the GeneralGrid. - ! This is merely the product of the elements of Dims(:) - - NumGridPoints = 1 - do i=1,NumDims - NumGridPoints = NumGridPoints * Dims(i) - end do - - ! Now we are prepared to create GGrid%data: - - call AttrVect_init(GGrid%data, IAList, RAList, NumGridPoints) - call AttrVect_zero(GGrid%data) - - ! Now, store Cartesian gridpoint data, in the order - ! defined by how the user laid out AxisData(:,:) - - do n=1,NumDims - - ! Retrieve first coordinate axis name from GGrid%coordinate_list - ! (as a String) - call List_get(AxisName, n, GGrid%coordinate_list) - - ! Index this real attribute of GGrid - iAxis = indexRA_(GGrid, String_ToChar(AxisName)) - - if(iAxis <= 0) then - write(stderr,'(4a)') myname_, & - ':: REAL Attribute "',String_ToChar(AxisName),'" not found.' - call die(myname_) - endif - - ! Now, clear the String AxisName for use in the next - ! cycle of this loop: - - call String_clean(AxisName) - - ! Compute the number of times we cycle through the axis - ! values (nCycles), and the number of times each axis - ! value is repeated in each cycle (nRepeat) - - nCycles = 1 - if(n > 1) then - do i=1,n-1 - nCycles = nCycles * Dims(i) - end do - endif - - nRepeat = 1 - if(n < NumDims) then - do i=n+1,NumDims - nRepeat = nRepeat * Dims(i) - end do - endif - - ! Loop over the number of cycles for which we run through - ! all the axis points. Within each cycle, loop over all - ! of the axis points, repeating each value nRepeat times. - ! This produces a set of grid entries that are in - ! lexicographic order with respect to how the axes are - ! presented to this routine. - - index = 1 - do i=1,nCycles - do j=1,Dims(n) - do k=1,nRepeat - GGrid%data%rAttr(iAxis,index) = AxisData(j,n) - index = index+1 - end do ! do k=1,nRepeat - end do ! do j=1,Dims(n) - end do ! do i=1,nCycles - - end do ! do n=1,NumDims... - - ! If the argument CoordSortOrder was supplied, the entries - ! of GGrid will be sorted/permuted with this lexicographic - ! ordering, and the values of the GGrid INTEGER attribute - ! GlobGridNum will be numbered to reflect this new ordering - ! scheme. - - index = indexIA_(GGrid, GlobGridNum) - - if(present(CoordSortOrder)) then ! Sort permute entries before - ! numbering them - - call SortPermute_(GGrid) ! Sort / permute - - endif ! if(present(CoordSortOrder))... - - ! Number the gridpoints based on the AttrVect point index - ! (i.e., the second index in GGrid%data%iAttr) - - do i=1, lsize_(GGrid) - GGrid%data%iAttr(index,i) = i - end do - - ! Finally, clean up intermediate Lists - - call List_clean(IAList) - call List_clean(RAList) - - end subroutine initCartesianDP_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: initUnstructuredSP_ - Initialize an Unstructured GeneralGrid -! -! !DESCRIPTION: -! This routine creates the storage space for grid point -! coordinates, area/volume weights, and other coordinate data ({\em e.g.}, -! local cell dimensions), and fills in user-supplied values for the grid -! point coordinates. These data are referenced by {\tt List} -! components that are also created by this routine (see the documentation -! of the declaration section of this module for more details about setting -! list information). Each of the input {\tt CHARACTER} arguments is a -! colon-delimited string of attribute names, each corrsponding to a -! {\tt List} element of the output {\tt GeneralGrid} argument {\tt GGrid}, -! and are summarized in the table below: -! -!\begin{table}[htbp] -!\begin{center} -!\begin{tabular}{|l|l|l|l|} -!\hline -!{\bf Argument} & {\bf Component of {\tt GGrid}} & {\bf Significance} & {\bf Required?} \\ -!\hline -!{\tt CoordChars} & {\tt GGrid\%coordinate\_list} & Dimension Names & Yes \\ -!\hline -!{\tt CoordSortOrder} & {\tt GGrid\%coordinate\_sort\_order} & Grid Point & No \\ -! & & Sorting Keys & \\ -!\hline -!{\tt WeightChars} & {\tt GGrid\%weight\_list} & Grid Cell & No \\ -! & & Length, Area, and & \\ -! & & Volume Weights & \\ -!\hline -!{\tt OtherChars} & {\tt GGrid\%other\_list} & All Other & No \\ -! & & Real Attributes & \\ -!\hline -!{\tt IndexChars} & {\tt GGrid\%index\_list} & All Other & No \\ -! & & Integer Attributes & \\ -!\hline -!\end{tabular} -!\end{center} -!\end{table} -! -! The number of physical dimensions of the grid is set by the user in -! the input {\tt INTEGER} argument {\tt nDims}, and the number of grid -! points stored in {\tt GGrid} is set using the input {\tt INTEGER} -! argument {\tt nPoints}. The grid point coordinates are input via the -! {\tt REAL} array {\tt PointData(:)}. The number of entries in -! {\tt PointData} must equal the product of {\tt nDims} and {\tt nPoints}. -! The grid points are grouped in {\tt nPoints} consecutive groups of -! {\tt nDims} entries, with the coordinate values for each point set in -! the same order as the dimensions are named in the list {\tt CoordChars}. -! -! If a set of sorting keys is supplied in the argument {\tt CoordSortOrder}, -! the user can control whether the sorting by each key is in descending or -! ascending order by supplying the input {\tt LOGICAL} array {\tt descend(:)}. -! By default, all sorting is in {\em ascending} order for each key if the -! argument {\tt descend} is not provided. -! -! {\bf N.B.}: The output {\tt GeneralGrid} {\tt GGrid} is dynamically -! allocated memory. When one no longer needs {\tt GGrid}, one should -! release this space by invoking {\tt clean()} for the {\tt GeneralGrid}. -! -! !INTERFACE: - - subroutine initUnstructuredSP_(GGrid, CoordChars, CoordSortOrder, descend, & - WeightChars, OtherChars, IndexChars, nDims, & - nPoints, PointData) -! -! !USES: -! - use m_stdio - use m_die - use m_realkinds,only : SP - - use m_String, only : String, char - use m_List, only : List - use m_List, only : List_init => init - use m_List, only : List_clean => clean - use m_List, only : List_nitem => nitem - use m_List, only : List_nullify => nullify - use m_List, only : List_copy => copy - use m_List, only : List_append => append - use m_List, only : List_shared => GetSharedListIndices - use m_AttrVect, only : AttrVect - use m_AttrVect, only : AttrVect_init => init - use m_AttrVect, only : AttrVect_zero => zero - - implicit none - -! !INPUT PARAMETERS: -! - character(len=*), intent(in) :: CoordChars - character(len=*), optional, intent(in) :: CoordSortOrder - character(len=*), optional, intent(in) :: WeightChars - logical, dimension(:), optional, pointer :: descend - character(len=*), optional, intent(in) :: OtherChars - character(len=*), optional, intent(in) :: IndexChars - integer, intent(in) :: nDims - integer, intent(in) :: nPoints - real(SP), dimension(:), pointer :: PointData - -! !OUTPUT PARAMETERS: -! - type(GeneralGrid), intent(out) :: GGrid - -! !REVISION HISTORY: -! 7Jun01 - Jay Larson - API specification. -! 22Aug02 - J. Larson - Implementation. -!EOP ___________________________________________________________________ -! - character(len=*),parameter :: myname_=myname//'::initUnstructuredSP_' - - integer :: i, ierr, index, n, nOffSet, NumShared - integer, dimension(:), pointer :: & - CoordListIndices, CoordSortOrderIndices - type(List) :: IAList, RAList - - ! Nullify all GeneralGrid components - - call List_nullify(GGrid%coordinate_list) - call List_nullify(GGrid%coordinate_sort_order) - call List_nullify(GGrid%weight_list) - call List_nullify(GGrid%other_list) - call List_nullify(GGrid%index_list) - nullify(GGrid%descend) - - ! Sanity checks on input arguments: - - ! If the LOGICAL descend(:) flags for sorting are present, - ! make sure that (1) it is associated, - ! (2) CoordSortOrder is also present, and - ! (3) The size of descend(:) matches the size of Dims(:), - ! both of which correspond to the number of axes on the - ! Cartesian Grid. - - if(present(descend)) then - - if(.not.associated(descend)) then - call die(myname_,'descend argument must be associated') - endif - - if(.not. present(CoordSortOrder)) then - write(stderr,'(4a)') myname_, & - ':: FATAL -- Invocation with the argument descend(:) present ', & - 'requires the presence of the argument CoordSortOrder, ', & - 'which was not provided.' - call die(myname_,'Argument CoordSortOrder was not provided') - endif - - if(present(descend)) then - if(size(descend) /= nDims) then - write(stderr,'(4a,i8,a,i8)') myname_, & - ':: FATAL-- The size of the array descend(:) and nDims ', & - 'must be equal (they both must equal the number of dimensions ', & - 'of the unstructured Grid). nDims = ',nDims, & - ' size(descend) = ',size(descend) - call die(myname_,'size(descend)/=nDims') - endif - endif - - endif - - ! Initialize GGrid%coordinate_list and comparethe number of items - ! to the number of dimensions of the unstructured nDims: - - call List_init(GGrid%coordinate_list, CoordChars) - - ! Check the coordinate_list - - if(nDims /= List_nitem(GGrid%coordinate_list)) then - write(stderr,'(4a,i8,3a,i8)') myname_, & - ':: FATAL-- The number of coordinate names supplied in the ', & - 'argument CoordChars must equal the number of dimensions ', & - 'specified by the argument nDims. nDims = ',nDims, & - ' CoordChars = ',CoordChars, ' number of dimensions in CoordChars = ', & - List_nitem(GGrid%coordinate_list) - call die(myname_) - endif - - if(nDims <= 0) then - write(stderr,*) myname_, ':: ERROR nDims=0!' - call die(myname_,'nDims <= 0',nDims) - endif - - ! PointData is a one-dimensional array containing all the gridpoint - ! coordinates. As such, its size must equal nDims * nPoints. True? - - if(size(PointData) /= nDims * nPoints) then - write(stderr,'(3a,3(a,i8))') myname_, & - ':: FATAL-- The length of the array PointData(:) must match ', & - 'the product of the input arguments nDims and nPoints. ', & - 'nDims = ',nDims, ' nPoints = ',nPoints,& - ' size(PointData) = ',size(PointData) - call die(myname_) - endif - - ! End of input argument sanity checks. - - ! Create other List components of GGrid and build REAL - ! and INTEGER attribute lists for the AttrVect GGrid%data - - ! Start off with things *guaranteed* to be in IAList and RAList. - ! The variable GlobGridNum is a CHARACTER parameter inherited - ! from the declaration section of this module. - - call List_init(IAList, GlobGridNum) - call List_init(RAList, CoordChars) - - if(present(CoordSortOrder)) then - - call List_init(GGrid%coordinate_sort_order, CoordSortOrder) - - call List_shared(GGrid%coordinate_list,GGrid%coordinate_sort_order, & - NumShared,CoordListIndices,CoordSortOrderIndices) - - deallocate(CoordListIndices,CoordSortOrderIndices,stat=ierr) - if(ierr/=0) call die(myname_,'deallocate(CoordListIndices..)',ierr) - - if(NumShared /= nDims) then - call die(myname_,'CoordSortOrder must have the same items & - & as CoordList',abs(nDims-NumShared)) - endif - - endif - - if(present(WeightChars)) then - call List_init(GGrid%weight_list, WeightChars) - call List_append(RAList, GGrid%weight_list) - endif - - if(present(OtherChars)) then - call List_init(GGrid%other_list, OtherChars) - call List_append(RAList, GGrid%other_list) - endif - - if(present(IndexChars)) then - call List_init(GGrid%index_list, IndexChars) - call List_append(IAList, GGrid%index_list) - endif - - ! Initialize GGrid%descend from descend(:). - ! If descend argument is not present, set it to the default .false. - - if(present(CoordSortOrder)) then - - allocate(GGrid%descend(nDims), stat=ierr) - if(ierr /= 0) call die(myname_,"allocate GGrid%descend...",ierr) - - if(present(descend)) then - do n=1,nDims - GGrid%descend(n) = descend(n) - end do - else - do n=1,nDims - GGrid%descend(n) = .FALSE. - end do - endif - - endif ! if(present(CoordSortOrder))... - - ! Create Grid attribute data storage AttrVect GGrid%data: - - call AttrVect_init(GGrid%data, IAList, RAList, nPoints) - call AttrVect_zero(GGrid%data) - - ! Load up gridpoint coordinate data into GGrid%data. - ! Given how we've set up the real attributes of GGrid%data, - ! we have guaranteed the first nDims real attributes are - ! the gridpoint coordinates. - - do n=1,nPoints - nOffSet = (n-1) * nDims - do i=1,nDims - GGrid%data%rAttr(i,n) = PointData(nOffset + i) - end do - end do - - ! If the argument CoordSortOrder was supplied, the entries - ! of GGrid will be sorted/permuted with this lexicographic - ! ordering, and the values of the GGrid INTEGER attribute - ! GlobGridNum will be numbered to reflect this new ordering - ! scheme. - - index = indexIA_(GGrid, GlobGridNum) - - if(present(CoordSortOrder)) then ! Sort permute entries before - ! numbering them - - call SortPermute_(GGrid) ! Sort / permute - - endif ! if(present(CoordSortOrder))... - - ! Number the gridpoints based on the AttrVect point index - ! (i.e., the second index in GGrid%data%iAttr) - - do i=1, lsize_(GGrid) - GGrid%data%iAttr(index,i) = i - end do - - ! Clean up temporary allocated structures: - - call List_clean(IAList) - call List_clean(RAList) - - end subroutine initUnstructuredSP_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -! ---------------------------------------------------------------------- -! -! !IROUTINE: initUnstructuredDP_ - Initialize an Unstructured GeneralGrid -! -! !DESCRIPTION: -! Double precision version of initUnstructuredSP_ -! -! !INTERFACE: - - subroutine initUnstructuredDP_(GGrid, CoordChars, CoordSortOrder, descend, & - WeightChars, OtherChars, IndexChars, nDims, & - nPoints, PointData) -! -! !USES: -! - use m_stdio - use m_die - use m_realkinds,only : DP - - use m_String, only : String, char - use m_List, only : List - use m_List, only : List_init => init - use m_List, only : List_clean => clean - use m_List, only : List_nitem => nitem - use m_List, only : List_nullify => nullify - use m_List, only : List_copy => copy - use m_List, only : List_append => append - use m_List, only : List_shared => GetSharedListIndices - use m_AttrVect, only : AttrVect - use m_AttrVect, only : AttrVect_init => init - use m_AttrVect, only : AttrVect_zero => zero - - implicit none - -! !INPUT PARAMETERS: -! - character(len=*), intent(in) :: CoordChars - character(len=*), optional, intent(in) :: CoordSortOrder - character(len=*), optional, intent(in) :: WeightChars - logical, dimension(:), optional, pointer :: descend - character(len=*), optional, intent(in) :: OtherChars - character(len=*), optional, intent(in) :: IndexChars - integer, intent(in) :: nDims - integer, intent(in) :: nPoints - real(DP), dimension(:), pointer :: PointData - -! !OUTPUT PARAMETERS: -! - type(GeneralGrid), intent(out) :: GGrid - -! !REVISION HISTORY: -! 7Jun01 - Jay Larson - API specification. -! 22Aug02 - J. Larson - Implementation. -! ______________________________________________________________________ -! - character(len=*),parameter :: myname_=myname//'::initUnstructuredDP_' - - integer :: i, ierr, index, n, nOffSet, NumShared - integer, dimension(:), pointer :: & - CoordListIndices, CoordSortOrderIndices - type(List) :: IAList, RAList - - ! Nullify all GeneralGrid components - - call List_nullify(GGrid%coordinate_list) - call List_nullify(GGrid%coordinate_sort_order) - call List_nullify(GGrid%weight_list) - call List_nullify(GGrid%other_list) - call List_nullify(GGrid%index_list) - nullify(GGrid%descend) - - ! Sanity checks on input arguments: - - ! If the LOGICAL descend(:) flags for sorting are present, - ! make sure that (1) it is associated, - ! (2) CoordSortOrder is also present, and - ! (3) The size of descend(:) matches the size of Dims(:), - ! both of which correspond to the number of axes on the - ! Cartesian Grid. - - if(present(descend)) then - - if(.not.associated(descend)) then - call die(myname_,'descend argument must be associated') - endif - - if(.not. present(CoordSortOrder)) then - write(stderr,'(4a)') myname_, & - ':: FATAL -- Invocation with the argument descend(:) present ', & - 'requires the presence of the argument CoordSortOrder, ', & - 'which was not provided.' - call die(myname_,'Argument CoordSortOrder was not provided') - endif - - if(present(descend)) then - if(size(descend) /= nDims) then - write(stderr,'(4a,i8,a,i8)') myname_, & - ':: FATAL-- The size of the array descend(:) and nDims ', & - 'must be equal (they both must equal the number of dimensions ', & - 'of the unstructured Grid). nDims = ',nDims, & - ' size(descend) = ',size(descend) - call die(myname_,'size(descend)/=nDims') - endif - endif - - endif - - ! Initialize GGrid%coordinate_list and comparethe number of items - ! to the number of dimensions of the unstructured nDims: - - call List_init(GGrid%coordinate_list, CoordChars) - - ! Check the coordinate_list - - if(nDims /= List_nitem(GGrid%coordinate_list)) then - write(stderr,'(4a,i8,3a,i8)') myname_, & - ':: FATAL-- The number of coordinate names supplied in the ', & - 'argument CoordChars must equal the number of dimensions ', & - 'specified by the argument nDims. nDims = ',nDims, & - ' CoordChars = ',CoordChars, ' number of dimensions in CoordChars = ', & - List_nitem(GGrid%coordinate_list) - call die(myname_) - endif - - if(nDims <= 0) then - write(stderr,*) myname_, ':: ERROR nDims=0!' - call die(myname_,'nDims <= 0',nDims) - endif - - ! PointData is a one-dimensional array containing all the gridpoint - ! coordinates. As such, its size must equal nDims * nPoints. True? - - if(size(PointData) /= nDims * nPoints) then - write(stderr,'(3a,3(a,i8))') myname_, & - ':: FATAL-- The length of the array PointData(:) must match ', & - 'the product of the input arguments nDims and nPoints. ', & - 'nDims = ',nDims, ' nPoints = ',nPoints,& - ' size(PointData) = ',size(PointData) - call die(myname_) - endif - - ! End of input argument sanity checks. - - ! Create other List components of GGrid and build REAL - ! and INTEGER attribute lists for the AttrVect GGrid%data - - ! Start off with things *guaranteed* to be in IAList and RAList. - ! The variable GlobGridNum is a CHARACTER parameter inherited - ! from the declaration section of this module. - - call List_init(IAList, GlobGridNum) - call List_init(RAList, CoordChars) - - if(present(CoordSortOrder)) then - - call List_init(GGrid%coordinate_sort_order, CoordSortOrder) - - call List_shared(GGrid%coordinate_list,GGrid%coordinate_sort_order, & - NumShared,CoordListIndices,CoordSortOrderIndices) - - deallocate(CoordListIndices,CoordSortOrderIndices,stat=ierr) - if(ierr/=0) call die(myname_,'deallocate(CoordListIndices..)',ierr) - - if(NumShared /= nDims) then - call die(myname_,'CoordSortOrder must have the same items & - & as CoordList',abs(nDims-NumShared)) - endif - - endif - - if(present(WeightChars)) then - call List_init(GGrid%weight_list, WeightChars) - call List_append(RAList, GGrid%weight_list) - endif - - if(present(OtherChars)) then - call List_init(GGrid%other_list, OtherChars) - call List_append(RAList, GGrid%other_list) - endif - - if(present(IndexChars)) then - call List_init(GGrid%index_list, IndexChars) - call List_append(IAList, GGrid%index_list) - endif - - ! Initialize GGrid%descend from descend(:). - ! If descend argument is not present, set it to the default .false. - - if(present(CoordSortOrder)) then - - allocate(GGrid%descend(nDims), stat=ierr) - if(ierr /= 0) call die(myname_,"allocate GGrid%descend...",ierr) - - if(present(descend)) then - do n=1,nDims - GGrid%descend(n) = descend(n) - end do - else - do n=1,nDims - GGrid%descend(n) = .FALSE. - end do - endif - - endif ! if(present(CoordSortOrder))... - - ! Create Grid attribute data storage AttrVect GGrid%data: - - call AttrVect_init(GGrid%data, IAList, RAList, nPoints) - call AttrVect_zero(GGrid%data) - - ! Load up gridpoint coordinate data into GGrid%data. - ! Given how we've set up the real attributes of GGrid%data, - ! we have guaranteed the first nDims real attributes are - ! the gridpoint coordinates. - - do n=1,nPoints - nOffSet = (n-1) * nDims - do i=1,nDims - GGrid%data%rAttr(i,n) = PointData(nOffset + i) - end do - end do - - ! If the argument CoordSortOrder was supplied, the entries - ! of GGrid will be sorted/permuted with this lexicographic - ! ordering, and the values of the GGrid INTEGER attribute - ! GlobGridNum will be numbered to reflect this new ordering - ! scheme. - - index = indexIA_(GGrid, GlobGridNum) - - if(present(CoordSortOrder)) then ! Sort permute entries before - ! numbering them - - call SortPermute_(GGrid) ! Sort / permute - - endif ! if(present(CoordSortOrder))... - - ! Number the gridpoints based on the AttrVect point index - ! (i.e., the second index in GGrid%data%iAttr) - - do i=1, lsize_(GGrid) - GGrid%data%iAttr(index,i) = i - end do - - ! Clean up temporary allocated structures: - - call List_clean(IAList) - call List_clean(RAList) - - end subroutine initUnstructuredDP_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: clean_ - Destroy a GeneralGrid -! -! !DESCRIPTION: -! This routine deallocates all attribute storage space for the input/output -! {\tt GeneralGrid} argument {\tt GGrid}, and destroys all of its {\tt List} -! components and sorting flags. The success (failure) of this operation is -! signified by the zero (non-zero) value of the optional {\tt INTEGER} -! output argument {\tt stat}. -! -! !INTERFACE: - - subroutine clean_(GGrid, stat) -! -! !USES: -! - use m_stdio - use m_die - - use m_List, only : List_clean => clean - use m_List, only : List_allocated => allocated - use m_AttrVect, only : AttrVect_clean => clean - - implicit none - -! !INPUT/OUTPUT PARAMETERS: -! - type(GeneralGrid), intent(inout) :: GGrid - integer, optional, intent(out) :: stat - -! !REVISION HISTORY: -! 25Sep00 - J.W. Larson - initial prototype -! 20Mar01 - J.W. Larson - complete version. -! 1Mar01 - E.T. Ong - removed dies to prevent -! crashes when cleaning uninitialized attrvects. Added -! optional stat argument. -! 5Aug02 - E. Ong - a more rigorous revision -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::clean_' - integer :: ierr - - if(present(stat)) then - - stat=0 - call AttrVect_clean(GGrid%data,ierr) - if(ierr/=0) stat=ierr - - call List_clean(GGrid%coordinate_list,ierr) - if(ierr/=0) stat=ierr - - if(List_allocated(GGrid%coordinate_sort_order)) then - call List_clean(GGrid%coordinate_sort_order,ierr) - if(ierr/=0) stat=ierr - endif - - if(List_allocated(GGrid%weight_list)) then - call List_clean(GGrid%weight_list,ierr) - if(ierr/=0) stat=ierr - endif - - if(List_allocated(GGrid%other_list)) then - call List_clean(GGrid%other_list,ierr) - if(ierr/=0) stat=ierr - endif - - if(List_allocated(GGrid%index_list)) then - call List_clean(GGrid%index_list,ierr) - if(ierr/=0) stat=ierr - endif - - if(associated(GGrid%descend)) then - deallocate(GGrid%descend, stat=ierr) - if(ierr/=0) stat=ierr - endif - - else - - call AttrVect_clean(GGrid%data) - - call List_clean(GGrid%coordinate_list) - - if(List_allocated(GGrid%coordinate_sort_order)) then - call List_clean(GGrid%coordinate_sort_order) - endif - - if(List_allocated(GGrid%weight_list)) then - call List_clean(GGrid%weight_list) - endif - - if(List_allocated(GGrid%other_list)) then - call List_clean(GGrid%other_list) - endif - - if(List_allocated(GGrid%index_list)) then - call List_clean(GGrid%index_list) - endif - - if(associated(GGrid%descend)) then - deallocate(GGrid%descend, stat=ierr) - if(ierr/=0) call die(myname_,'deallocate(GGrid%descend)',ierr) - endif - - endif - - end subroutine clean_ - -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: zero_ - Set GeneralGrid Data to Zero -! -! !DESCRIPTION: -! This routine sets all of the point values of the integer and real -! attributes of an the input/output {\tt GeneralGrid} argument {\tt GGrid} -! to zero. The default action is to set the values of all the real and -! integer attributes to zero. -! -! !INTERFACE: - - subroutine zero_(GGrid, zeroReals, zeroInts) - -! !USES: - - - use m_die,only : die - use m_stdio,only : stderr - - use m_AttrVect, only : AttrVect_zero => zero - - implicit none -! !INPUT/OUTPUT PARAMETERS: -! - type(GeneralGrid), intent(INOUT) :: GGrid - -! !INPUT PARAMETERS: - - logical, optional, intent(IN) :: zeroReals - logical, optional, intent(IN) :: zeroInts - - -! !REVISION HISTORY: -! 11May08 - R. Jacob - initial prototype/code -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::zero_' - - logical myZeroReals, myZeroInts - - if(present(zeroReals)) then - myZeroReals = zeroReals - else - myZeroReals = .TRUE. - endif - - if(present(zeroInts)) then - myZeroInts = zeroInts - else - myZeroInts = .TRUE. - endif - - call AttrVect_zero(GGrid%data,myZeroReals,myZeroInts) - - end subroutine zero_ - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: dims_ - Return the Dimensionality of a GeneralGrid -! -! !DESCRIPTION: -! This {\tt INTEGER} function returns the number of physical dimensions -! of the input {\tt GeneralGrid} argument {\tt GGrid}. -! -! !INTERFACE: - - integer function dims_(GGrid) -! -! !USES: -! - use m_stdio - use m_die - - use m_List, only : List_nitem => nitem - - implicit none - -! !INPUT PARAMETERS: -! - type(GeneralGrid), intent(in) :: GGrid - -! !REVISION HISTORY: -! 15Jan01 - Jay Larson - initial version -!EOP ___________________________________________________________________ -! - character(len=*),parameter :: myname_=myname//'::dims_' - - - dims_ = List_nitem(GGrid%coordinate_list) - - if(dims_<=0) then - call die(myname_,"GGrid has zero dimensions",dims_) - endif - - end function dims_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: indexIA - Index an Integer Attribute -! -! !DESCRIPTION: -! This function returns an {\tt INTEGER}, corresponding to the location -! of an integer attribute within the input {\tt GeneralGrid} argument -! {\tt GGrid}. For example, every {\tt GGrid} has at least one integer -! attribute (namely the global gridpoint index {\tt 'GlobGridNum'}). -! The array of integer values for the attribute {\tt 'GlobGridNum'} is -! stored in -! \begin{verbatim} -! {\tt GGrid%data%iAttr(indexIA_(GGrid,'GlobGridNum'),:)}. -! \end{verbatim} -! If {\tt indexIA\_()} is unable to match {\tt item} to any of the integer -! attributes present in {\tt GGrid}, the resulting value is zero which is -! equivalent to an error. The optional input {\tt CHARACTER} arguments -! {\tt perrWith} and {\tt dieWith} control how such errors are handled. -! Below are the rules how error handling is controlled by using -! {\tt perrWith} and {\tt dieWith}: -! \begin{enumerate} -! \item if neither {\tt perrWith} nor {\tt dieWith} are present, -! {\tt indexIA\_()} terminates execution with an internally generated -! error message; -! \item if {\tt perrWith} is present, but {\tt dieWith} is not, an error -! message is written to {\tt stderr} incorporating user-supplied -! traceback information stored in the argument {\tt perrWith}; -! \item if {\tt dieWith} is present, execution terminates with an error -! message written to {\tt stderr} that incorporates user-supplied -! traceback information stored in the argument {\tt dieWith}; and -! \item if both {\tt perrWith} and {\tt dieWith} are present, execution -! terminates with an error message using {\tt dieWith}, and the argument -! {\tt perrWith} is ignored. -! \end{enumerate} -! -! !INTERFACE: - - integer function indexIA_(GGrid, item, perrWith, dieWith) - -! -! !USES: -! - use m_die - use m_stdio - - use m_String, only : String - use m_String, only : String_init => init - use m_String, only : String_clean => clean - use m_String, only : String_ToChar => ToChar - - use m_TraceBack, only : GenTraceBackString - - use m_AttrVect, only : AttrVect_indexIA => indexIA - - implicit none - -! !INPUT PARAMETERS: -! - type(GeneralGrid), intent(in) :: GGrid - character(len=*), intent(in) :: item - character(len=*), optional, intent(in) :: perrWith - character(len=*), optional, intent(in) :: dieWith - -! !REVISION HISTORY: -! 15Jan01 - Jay Larson - Initial version. -! 27Mar02 - Jay Larson - Cleaned up error -! handling logic. -! 2Aug02 - Jay Larson - Further refinement -! of error handling. -!EOP ___________________________________________________________________ -! - - character(len=*), parameter :: myname_=myname//'::indexIA_' - - type(String) :: myTrace - - ! Generate a traceback String - - if(present(dieWith)) then - call GenTraceBackString(myTrace, dieWith, myname_) - else - if(present(perrWith)) then - call GenTraceBackString(myTrace, perrWith, myname_) - else - call GenTraceBackString(myTrace, myname_) - endif - endif - - ! Call AttrVect_indexIA() accordingly: - - if( present(dieWith) .or. & - ((.not. present(dieWith)) .and. (.not. present(perrWith))) ) then - indexIA_ = AttrVect_indexIA(GGrid%data, item, & - dieWith=String_ToChar(myTrace)) - else ! perrWith but no dieWith case - indexIA_ = AttrVect_indexIA(GGrid%data, item, & - perrWith=String_ToChar(myTrace)) - endif - - call String_clean(myTrace) - - end function indexIA_ - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: indexRA - Index a Real Attribute -! -! !DESCRIPTION: - -! This function returns an {\tt INTEGER}, corresponding to the location -! of an integer attribute within the input {\tt GeneralGrid} argument -! {\tt GGrid}. For example, every {\tt GGrid} has at least one integer -! attribute (namely the global gridpoint index {\tt 'GlobGridNum'}). -! The array of integer values for the attribute {\tt 'GlobGridNum'} is -! stored in -! \begin{verbatim} -! {\tt GGrid%data%iAttr(indexRA_(GGrid,'GlobGridNum'),:)}. -! \end{verbatim} -! If {\tt indexRA\_()} is unable to match {\tt item} to any of the integer -! attributes present in {\tt GGrid}, the resulting value is zero which is -! equivalent to an error. The optional input {\tt CHARACTER} arguments -! {\tt perrWith} and {\tt dieWith} control how such errors are handled. -! Below are the rules how error handling is controlled by using -! {\tt perrWith} and {\tt dieWith}: -! \begin{enumerate} -! \item if neither {\tt perrWith} nor {\tt dieWith} are present, -! {\tt indexRA\_()} terminates execution with an internally generated -! error message; -! \item if {\tt perrWith} is present, but {\tt dieWith} is not, an error -! message is written to {\tt stderr} incorporating user-supplied -! traceback information stored in the argument {\tt perrWith}; -! \item if {\tt dieWith} is present, execution terminates with an error -! message written to {\tt stderr} that incorporates user-supplied -! traceback information stored in the argument {\tt dieWith}; and -! \item if both {\tt perrWith} and {\tt dieWith} are present, execution -! terminates with an error message using {\tt dieWith}, and the argument -! {\tt perrWith} is ignored. -! \end{enumerate} -! -! !INTERFACE: - - integer function indexRA_(GGrid, item, perrWith, dieWith) -! -! !USES: -! - use m_stdio - use m_die - - use m_String, only : String - use m_String, only : String_init => init - use m_String, only : String_clean => clean - use m_String, only : String_ToChar => ToChar - - use m_TraceBack, only : GenTraceBackString - - use m_AttrVect, only : AttrVect_indexRA => indexRA - - implicit none - -! !INPUT PARAMETERS: -! - type(GeneralGrid), intent(in) :: GGrid - character(len=*), intent(in) :: item - character(len=*), optional, intent(in) :: perrWith - character(len=*), optional, intent(in) :: dieWith - -! !REVISION HISTORY: -! 15Jan01 - Jay Larson - Initial version. -! 27Mar02 - Jay Larson - Cleaned up error -! handling logic. -!EOP ___________________________________________________________________ -! - character(len=*),parameter :: myname_=myname//'::indexRA_' - - - type(String) :: myTrace - - ! Generate a traceback String - - if(present(dieWith)) then ! append myname_ onto dieWith - call GenTraceBackString(myTrace, dieWith, myname_) - else - if(present(perrWith)) then ! append myname_ onto perrwith - call GenTraceBackString(myTrace, perrWith, myname_) - else ! Start a TraceBack String - call GenTraceBackString(myTrace, myname_) - endif - endif - - ! Call AttrVect_indexRA() accordingly: - - if( present(dieWith) .or. & - ((.not. present(dieWith)) .and. (.not. present(perrWith))) ) then - indexRA_ = AttrVect_indexRA(GGrid%data, item, & - dieWith=String_ToChar(myTrace)) - else ! perrWith but no dieWith case - indexRA_ = AttrVect_indexRA(GGrid%data, item, & - perrWith=String_ToChar(myTrace)) - endif - - call String_clean(myTrace) - - end function indexRA_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: lsize - Number of Grid Points -! -! !DESCRIPTION: -! This {\tt INTEGER} function returns the number of grid points stored -! in the input {\tt GeneralGrid} argument {\tt GGrid}. Note that the -! value returned will be the number of points stored on a local process -! in the case of a distributed {\tt GeneralGrid}. -! -! !INTERFACE: - - integer function lsize_(GGrid) -! -! !USES: -! - use m_List, only : List - use m_List, only : List_allocated => allocated - use m_AttrVect, only : AttrVect_lsize => lsize - use m_die, only : die - - - implicit none - -! !INPUT PARAMETERS: -! - type(GeneralGrid), intent(in) :: GGrid - -! !REVISION HISTORY: -! 15Jan01 - Jay Larson - Initial version. -! 27Mar02 - Jay Larson - slight logic change. -! 27Mar02 - Jay Larson - Bug fix and use of -! List_allocated() function to check for existence of -! attributes. -! 5Aug02 - E. Ong - more rigorous revision -!EOP ___________________________________________________________________ -! - character(len=*),parameter :: myname_=myname//'::lsize_' - - if(List_allocated(GGrid%data%rList) .and. & - List_allocated(GGrid%data%iList)) then - - lsize_ = AttrVect_lsize( GGrid%data ) - - else - - call die(myname_,"Argument GGrid%data is not associated!") - - endif - - end function lsize_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: exportIAttr_ - Return GeneralGrid INTEGER Attribute as a Vector -! -! !DESCRIPTION: -! This routine extracts from the input {\tt GeneralGrid} argument -! {\tt GGrid} the integer attribute corresponding to the tag defined in -! the input {\tt CHARACTER} argument {\tt AttrTag}, and returns it in -! the {\tt INTEGER} output array {\tt outVect}, and its length in the -! output {\tt INTEGER} argument {\tt lsize}. -! -! {\bf N.B.:} This routine will fail if the {\tt AttrTag} is not in -! the {\tt GeneralGrid} {\tt List} component {\tt GGrid\%data\%iList}. -! -! {\bf N.B.:} The flexibility of this routine regarding the pointer -! association status of the output argument {\tt outVect} means the -! user must invoke this routine with care. If the user wishes this -! routine to fill a pre-allocated array, then obviously this array -! must be allocated prior to calling this routine. If the user wishes -! that the routine {\em create} the output argument array {\tt outVect}, -! then the user must ensure this pointer is not allocated (i.e. the user -! must nullify this pointer) before this routine is invoked. -! -! {\bf N.B.:} If the user has relied on this routine to allocate memory -! associated with the pointer {\tt outVect}, then the user is responsible -! for deallocating this array once it is no longer needed. Failure to -! do so will result in a memory leak. -! -! !INTERFACE: - - subroutine exportIAttr_(GGrid, AttrTag, outVect, lsize) -! -! !USES: -! - use m_die - use m_stdio - - use m_AttrVect, only : AttrVect_exportIAttr => exportIAttr - - implicit none - -! !INPUT PARAMETERS: - - type(GeneralGrid), intent(in) :: GGrid - character(len=*), intent(in) :: AttrTag - -! !OUTPUT PARAMETERS: - - integer, dimension(:), pointer :: outVect - integer, optional, intent(out) :: lsize - -! !REVISION HISTORY: -! 13Dec01 - J.W. Larson - initial prototype. -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::exportIAttr_' - - ! Export the data (inheritance from AttrVect) - if(present(lsize)) then - call AttrVect_exportIAttr(GGrid%data, AttrTag, outVect, lsize) - else - call AttrVect_exportIAttr(GGrid%data, AttrTag, outVect) - endif - - end subroutine exportIAttr_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: exportRAttrSP_ - Return GeneralGrid REAL Attribute as a Vector -! -! !DESCRIPTION: -! This routine extracts from the input {\tt GeneralGrid} argument -! {\tt GGrid} the real attribute corresponding to the tag defined in -! the input {\tt CHARACTER} argument {\tt AttrTag}, and returns it in -! the {\tt REAL} output array {\tt outVect}, and its length in the -! output {\tt INTEGER} argument {\tt lsize}. -! -! {\bf N.B.:} This routine will fail if the {\tt AttrTag} is not in -! the {\tt GeneralGrid} {\tt List} component {\tt GGrid\%data\%rList}. -! -! {\bf N.B.:} The flexibility of this routine regarding the pointer -! association status of the output argument {\tt outVect} means the -! user must invoke this routine with care. If the user wishes this -! routine to fill a pre-allocated array, then obviously this array -! must be allocated prior to calling this routine. If the user wishes -! that the routine {\em create} the output argument array {\tt outVect}, -! then the user must ensure this pointer is not allocated (i.e. the user -! must nullify this pointer) before this routine is invoked. -! -! {\bf N.B.:} If the user has relied on this routine to allocate memory -! associated with the pointer {\tt outVect}, then the user is responsible -! for deallocating this array once it is no longer needed. Failure to -! do so will result in a memory leak. -! -! !INTERFACE: - - subroutine exportRAttrSP_(GGrid, AttrTag, outVect, lsize) -! -! !USES: -! - use m_die - use m_stdio - - use m_realkinds, only : SP - - use m_AttrVect, only : AttrVect_exportRAttr => exportRAttr - - implicit none - -! !INPUT PARAMETERS: - - type(GeneralGrid), intent(in) :: GGrid - character(len=*), intent(in) :: AttrTag - -! !OUTPUT PARAMETERS: - - real(SP), dimension(:), pointer :: outVect - integer, optional, intent(out) :: lsize - -! !REVISION HISTORY: -! 13Dec01 - J.W. Larson - initial prototype. -! -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::exportRAttrSP_' - - ! Export the data (inheritance from AttrVect) - - if(present(lsize)) then - call AttrVect_exportRAttr(GGrid%data, AttrTag, outVect, lsize) - else - call AttrVect_exportRAttr(GGrid%data, AttrTag, outVect) - endif - - end subroutine exportRAttrSP_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -! --------------------------------------------------------------------- -! -! !IROUTINE: exportRAttrDP_ - Return GeneralGrid REAL Attribute as a Vector -! -! !DESCRIPTION: -! double precision version of exportRAttrSP_ -! -! !INTERFACE: - - subroutine exportRAttrDP_(GGrid, AttrTag, outVect, lsize) -! -! !USES: -! - use m_die - use m_stdio - - use m_realkinds, only : DP - - use m_AttrVect, only : AttrVect_exportRAttr => exportRAttr - - implicit none - -! !INPUT PARAMETERS: - - type(GeneralGrid), intent(in) :: GGrid - character(len=*), intent(in) :: AttrTag - -! !OUTPUT PARAMETERS: - - real(DP), dimension(:), pointer :: outVect - integer, optional, intent(out) :: lsize - -! !REVISION HISTORY: -! 13Dec01 - J.W. Larson - initial prototype. -! -!_______________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::exportRAttrDP_' - - ! Export the data (inheritance from AttrVect) - if(present(lsize)) then - call AttrVect_exportRAttr(GGrid%data, AttrTag, outVect, lsize) - else - call AttrVect_exportRAttr(GGrid%data, AttrTag, outVect) - endif - - end subroutine exportRAttrDP_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: importIAttr_ - Import GeneralGrid INTEGER Attribute -! -! !DESCRIPTION: -! This routine imports data provided in the input {\tt INTEGER} vector -! {\tt inVect} into the {\tt GeneralGrid} argument {\tt GGrid}, storing -! it as the integer attribute corresponding to the tag defined in -! the input {\tt CHARACTER} argument {\tt AttrTag}. The input -! {\tt INTEGER} argument {\tt lsize} is used to ensure there is -! sufficient space in the {\tt GeneralGrid} to store the data. -! -! {\bf N.B.:} This routine will fail if the {\tt AttrTag} is not in -! the {\tt GeneralGrid} {\tt List} component {\tt GGrid\%data\%iList}. -! -! !INTERFACE: - - subroutine importIAttr_(GGrid, AttrTag, inVect, lsize) -! -! !USES: -! - use m_die - use m_stdio - - use m_AttrVect, only : AttrVect_importIAttr => importIAttr - - implicit none - -! !INPUT PARAMETERS: - - character(len=*), intent(in) :: AttrTag - integer, dimension(:), pointer :: inVect - integer, intent(in) :: lsize - -! !INPUT/OUTPUT PARAMETERS: - - type(GeneralGrid), intent(inout) :: GGrid - -! !REVISION HISTORY: -! 13Dec01 - J.W. Larson - initial prototype. -! 27Mar02 - Jay Larson - improved error handling. -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::importIAttr_' - - ! Argument Check: - - if(lsize > lsize_(GGrid)) then - write(stderr,*) myname_,':: ERROR, lsize > lsize_(GGrid).', & - 'lsize = ',lsize,'lsize_(GGrid) = ',lsize_(GGrid) - call die(myname_) - endif - - ! Import the data (inheritance from AttrVect) - - call AttrVect_importIAttr(GGrid%data, AttrTag, inVect, lsize) - - end subroutine importIAttr_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: importRAttrSP_ - Import GeneralGrid REAL Attribute -! -! !DESCRIPTION: -! This routine imports data provided in the input {\tt REAL} vector -! {\tt inVect} into the {\tt GeneralGrid} argument {\tt GGrid}, storing -! it as the real attribute corresponding to the tag defined in -! the input {\tt CHARACTER} argument {\tt AttrTag}. The input -! {\tt INTEGER} argument {\tt lsize} is used to ensure there is -! sufficient space in the {\tt GeneralGrid} to store the data. -! -! {\bf N.B.:} This routine will fail if the {\tt AttrTag} is not in -! the {\tt GeneralGrid} {\tt List} component {\tt GGrid\%data\%rList}. -! -! !INTERFACE: - - subroutine importRAttrSP_(GGrid, AttrTag, inVect, lsize) -! -! !USES: -! - use m_die , only : die - use m_die , only : MP_perr_die - use m_stdio , only : stderr - - use m_realkinds, only : SP - - use m_AttrVect, only : AttrVect_importRAttr => importRAttr - - implicit none - -! !INPUT PARAMETERS: - - character(len=*), intent(in) :: AttrTag - real(SP), dimension(:), pointer :: inVect - integer, intent(in) :: lsize - -! !INPUT/OUTPUT PARAMETERS: - - type(GeneralGrid), intent(inout) :: GGrid - -! !REVISION HISTORY: -! 13Dec01 - J.W. Larson - initial prototype. -! 27Mar02 - Jay Larson - improved error handling. -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::importRAttrSP_' - - ! Argument Check: - - if(lsize > lsize_(GGrid)) then - write(stderr,*) myname_,':: ERROR, lsize > lsize_(GGrid).', & - 'lsize = ',lsize,'lsize_(GGrid) = ',lsize_(GGrid) - call die(myname_) - endif - - ! Import the data (inheritance from AttrVect) - - call AttrVect_importRAttr(GGrid%data, AttrTag, inVect, lsize) - - end subroutine importRAttrSP_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!----------------------------------------------------------------------- -! -! !IROUTINE: importRAttrDP_ - Import GeneralGrid REAL Attribute -! -! !DESCRIPTION: -! Double precision version of importRAttrSP_ -! -! !INTERFACE: - - subroutine importRAttrDP_(GGrid, AttrTag, inVect, lsize) -! -! !USES: -! - use m_die , only : die - use m_die , only : MP_perr_die - use m_stdio , only : stderr - - use m_realkinds, only : DP - - use m_AttrVect, only : AttrVect_importRAttr => importRAttr - - implicit none - -! !INPUT PARAMETERS: - - character(len=*), intent(in) :: AttrTag - real(DP), dimension(:), pointer :: inVect - integer, intent(in) :: lsize - -! !INPUT/OUTPUT PARAMETERS: - - type(GeneralGrid), intent(inout) :: GGrid - -! !REVISION HISTORY: -! 13Dec01 - J.W. Larson - initial prototype. -! 27Mar02 - Jay Larson - improved error handling. -!_______________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::importRAttrDP_' - - ! Argument Check: - - if(lsize > lsize_(GGrid)) then - write(stderr,*) myname_,':: ERROR, lsize > lsize_(GGrid).', & - 'lsize = ',lsize,'lsize_(GGrid) = ',lsize_(GGrid) - call die(myname_) - endif - - ! Import the data (inheritance from AttrVect) - - call AttrVect_importRAttr(GGrid%data, AttrTag, inVect, lsize) - - end subroutine importRAttrDP_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: Sort_ - Generate Sort Permutation Defined by Arbitrary Keys. -! -! !DESCRIPTION: -! The subroutine {\tt Sort\_()} uses the list of keys present in the -! input {\tt List} variable {\tt key\_List}. This list of keys is -! checked to ensure that {\em only} coordinate attributes are present -! in the sorting keys, and that there are no redundant keys. Once -! checked, this list is used to find the appropriate real attributes -! referenced by the items in {\tt key\_list} ( that is, it identifies the -! appropriate entries in {\tt GGrid\%data\%rList}), and then uses these -! keys to generate a an output permutation {\tt perm} that will put -! the entries of the attribute vector {\tt GGrid\%data} in lexicographic -! order as defined by {\tt key\_list} (the ordering in {\tt key\_list} -! being from left to right. -! -! !INTERFACE: - - subroutine Sort_(GGrid, key_List, perm, descend) - -! -! !USES: -! - use m_stdio - use m_die - - use m_AttrVect, only : AttrVect_Sort => Sort - use m_List, only : List_nitem => nitem - - implicit none - -! !INPUT PARAMETERS: -! - type(GeneralGrid), intent(in) :: GGrid - type(List), intent(in) :: key_list - logical, dimension(:), optional, intent(in) :: descend - -! !OUTPUT PARAMETERS: -! - integer, dimension(:), pointer :: perm - - -! !REVISION HISTORY: -! 15Jan01 - Jay Larson - Initial version. -! 20Mar01 - Jay Larson - Final working version. -!EOP ___________________________________________________________________ -! - character(len=*),parameter :: myname_=myname//'::Sort_' - logical, dimension(:), allocatable :: descending - integer :: n, ierr - - ! Here is how we transmit the sort order keys stored - ! in descending (if present): - - n = List_nitem(key_list) - allocate(descending(n), stat=ierr) - if(ierr /= 0) then - call die(myname_,"allocate(descending...",ierr) - endif - - if(present(descend)) then - descending = descend - else - descending = .false. - endif - - ! This is a straightforward call to AttrVect_Sort(). - - call AttrVect_Sort(GGrid%data, key_list, perm, descending) - - ! Clean up... - - deallocate(descending, stat=ierr) - if(ierr /= 0) then - call die(myname_,"deallocate(descending...",ierr) - endif - - end subroutine Sort_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: Sortg_ - Generate Sort Permutation Based on GeneralGrid Keys. -! -! !DESCRIPTION: -! The subroutine {\tt Sortg\_()} uses the list of sorting keys present in -! the input {\tt GeneralGrid} variable {\tt GGrid\%coordinate\_sort\_order} -! to create a sort permutation {\tt perm(:)}. Sorting is either in ascending -! or descending order based on the entries of {\tt GGrid\%descend(:)}. -! The output index permutation is stored in the array {\tt perm(:)} that -! will put the entries of the attribute vector {\tt GGrid\%data} in -! lexicographic order as defined by {\tt GGrid\%coordinate\_sort\_order}. The -! ordering in {\tt GGrid\%coordinate\_sort\_order} being from left to right. -! -! {\bf N.B.:} This routine returnss an allocatable array perm(:). This -! allocated array must be deallocated when the user no longer needs it. -! Failure to do so will cause a memory leak. -! -! {\bf N.B.:} This routine will fail if {\tt GGrid} has not been initialized -! with sort keys in the {\tt List} component {\tt GGrid\%coordinate\_sort\_order}. -! -! !INTERFACE: - - subroutine Sortg_(GGrid, perm) - -! -! !USES: -! - use m_List, only : List_allocated => allocated - use m_die, only : die - - implicit none - -! !INPUT PARAMETERS: -! - type(GeneralGrid), intent(in) :: GGrid - -! !OUTPUT PARAMETERS: -! - integer, dimension(:), pointer :: perm - -! !REVISION HISTORY: -! 22Mar01 - Jay Larson - Initial version. -! 5Aug02 - E. Ong - revise with more error checking. -!EOP ___________________________________________________________________ -! - character(len=*),parameter :: myname_=myname//'::Sortg_' - - if(.not.List_allocated(GGrid%coordinate_sort_order)) then - call die(myname_, "GGrid%coordinate_aort_order must be & - &allocated for use in any sort function") - endif - - if(associated(GGrid%descend)) then - call Sort_(GGrid, GGrid%coordinate_sort_order, & - perm, GGrid%descend) - else - call Sort_(GGrid=GGrid, key_list=GGrid%coordinate_sort_order, & - perm=perm) - endif - - end subroutine Sortg_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: Permute_ - Permute GeneralGrid Attributes Using Supplied Index Permutation -! -! !DESCRIPTION: -! The subroutine {\tt Permute\_()} uses an input index permutation {\tt perm} -! to re-order the coordinate data stored in the {\tt GeneralGrid} argument -! {\tt GGrid}. This permutation can be generated by either of the routines -! {\tt Sort\_()} or {\tt Sortg\_()} contained in this module. -! -! !INTERFACE: - - subroutine Permute_(GGrid, perm) - -! -! !USES: -! - - use m_stdio - use m_die - - use m_AttrVect, only : AttrVect - use m_AttrVect, only : AttrVect_Permute => Permute - - implicit none - -! !INPUT PARAMETERS: -! - integer, dimension(:), intent(in) :: perm - -! !INPUT/OUTPUT PARAMETERS: -! - type(GeneralGrid), intent(inout) :: GGrid - - -! !REVISION HISTORY: -! 15Jan01 - Jay Larson - API specification. -! 10Apr01 - Jay Larson - API modified, working -! code. -!EOP ___________________________________________________________________ -! - character(len=*),parameter :: myname_=myname//'::Permute_' - - ! This is a straightforward call to AttrVect_Permute: - - call AttrVect_Permute(GGrid%data, perm) - - end subroutine Permute_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: SortPermute_ - Sort and Permute GeneralGrid Attributes -! -! !DESCRIPTION: -! The subroutine {\tt SortPermute\_()} uses the list of keys defined in -! {\tt GGrid\%coordinate\_sort\_order} to create an index permutation -! {\tt perm}, which is then applied to re-order the coordinate data stored -! in the {\tt GeneralGrid} argument {\tt GGrid} (more specifically, the -! gridpoint data stored in {\tt GGrid\%data}. This permutation is generated -! by the routine {\tt Sortg\_()} contained in this module. The permutation -! is carried out by the routine {\tt Permute\_()} contained in this module. -! -! {\bf N.B.:} This routine will fail if {\tt GGrid} has not been initialized -! with sort keys in the {\tt List} component {\tt GGrid\%coordinate\_sort\_order}. -! -! !INTERFACE: - - subroutine SortPermute_(GGrid) - -! -! !USES: -! - use m_stdio - use m_die - - implicit none - -! !INPUT/OUTPUT PARAMETERS: -! - type(GeneralGrid), intent(inout) :: GGrid - -! !REVISION HISTORY: -! 15Jan01 - Jay Larson - API specification. -! 10Apr01 - Jay Larson - API modified, working -! code. -! 13Apr01 - Jay Larson - Simplified API and -! code (Thanks to Tony Craig of NCAR for detecting the -! bug that inspired these changes). -!EOP ___________________________________________________________________ -! - character(len=*),parameter :: myname_=myname//'::SortPermute_' - - integer, dimension(:), pointer :: perm - integer :: ierr - - call Sortg_(GGrid, perm) - - call Permute_(GGrid, perm) - -! Clean up--deallocate temporary permutation array: - - deallocate(perm, stat=ierr) - if(ierr /= 0) then - call die(myname_,"deallocate(perm)",ierr) - endif - - end subroutine SortPermute_ - - end module m_GeneralGrid - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - diff --git a/cesm/models/utils/mct/mct/m_GeneralGridComms.F90 b/cesm/models/utils/mct/mct/m_GeneralGridComms.F90 deleted file mode 100644 index 349d2af..0000000 --- a/cesm/models/utils/mct/mct/m_GeneralGridComms.F90 +++ /dev/null @@ -1,1536 +0,0 @@ -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!----------------------------------------------------------------------- -! CVS $Id$ -! CVS $Name$ -!BOP ------------------------------------------------------------------- -! -! !MODULE: m_GeneralGridComms - Communications for the GeneralGrid type. -! -! !DESCRIPTION: -! -! In this module, we define communications methods specific to the -! {\tt GeneralGrid} class (see the module {\tt m\_GeneralGrid} for more -! information about this class and its methods). -! -! !INTERFACE: - module m_GeneralGridComms -! -! !USES: -! - use m_GeneralGrid ! GeneralGrid class and its methods - - - implicit none - - private ! except - - public :: gather ! gather all local vectors to the root - public :: scatter ! scatter from the root to all PEs - public :: bcast ! bcast from root to all PEs - public :: send ! Blocking SEND - public :: recv ! Blocking RECEIVE - - interface gather ; module procedure & - GM_gather_, & - GSM_gather_ - end interface - interface scatter ; module procedure & - GM_scatter_, & - GSM_scatter_ - end interface - interface bcast ; module procedure bcast_ ; end interface - interface send ; module procedure send_ ; end interface - interface recv ; module procedure recv_ ; end interface - -! !REVISION HISTORY: -! 27Apr01 - J.W. Larson - Initial module/APIs -! 07Jun01 - J.W. Larson - Added point-to-point -! 27Mar02 - J.W. Larson - Overhaul of error -! handling calls throughout this module. -! 05Aug02 - E. Ong - Added buffer association -! error checks to avoid making bad MPI calls -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname='MCT::m_GeneralGridComms' - - contains - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: send_ - Point-to-point blocking send for the GeneralGrid. -! -! !DESCRIPTION: The point-to-point send routine {\tt send\_()} sends -! the input {\tt GeneralGrid} argument {\tt iGGrid} to component -! {\tt comp\_id}. -! The message is identified by the tag defined by the {\tt INTEGER} -! argument {\tt TagBase}. The value of {\tt TagBase} must match the -! value used in the call to {\tt recv\_()} on process {\tt dest}. The -! success (failure) of this operation corresponds to a zero (nonzero) -! value for the output {\tt INTEGER} flag {\tt status}. -! The argument will be sent to the local root of the component. -! -! {\bf N.B.}: One must avoid assigning elsewhere the MPI tag values -! between {\tt TagBase} and {\tt TagBase+20}, inclusive. This is -! because {\tt send\_()} performs one send operation set up the header -! transfer, up to five {\tt List\_send} operations (two {\tt MPI\_SEND} -! calls in each), two send operations to transfer {\tt iGGrid\%descend(:)}, -! and finally the send of the {\tt AttrVect} component {\tt iGGrid\%data} -! (which comprises eight {\tt MPI\_SEND} operations). -! -! !INTERFACE: - - subroutine send_(iGGrid, comp_id, TagBase, status) - -! -! !USES: -! - use m_stdio - use m_die - use m_mpif90 - - use m_GeneralGrid, only : GeneralGrid - use m_GeneralGrid, only : GeneralGrid_init => init - use m_GeneralGrid, only : GeneralGrid_lsize => lsize - - use m_MCTWorld, only : ComponentToWorldRank - use m_MCTWorld, only : ThisMCTWorld - - use m_AttrVectComms,only : AttrVect_send => send - - use m_List, only : List_send => send - use m_List, only : List_allocated => allocated - - implicit none - -! !INPUT PARAMETERS: -! - type(GeneralGrid), intent(in) :: iGGrid - integer, intent(in) :: comp_id - integer, intent(in) :: TagBase - -! !OUTPUT PARAMETERS: -! - integer, optional, intent(out) :: status - -! !REVISION HISTORY: -! 04Jun01 - J.W. Larson - API Specification. -! 07Jun01 - J.W. Larson - Initial version. -! 10Jun01 - J.W. Larson - Bug fixes--now works. -! 11Jun01 - R. Jacob use component id as input -! argument. -! 13Jun01 - J.W. Larson - Initialize status -! (if present). -! 15Feb02 - J.W. Larson - Made input argument -! comm optional. -! 13Jun02 - J.W. Larson - Removed the argument -! comm. This routine is now explicitly for intercomponent -! communications only. -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::send_' - - integer :: ierr - integer :: dest - logical :: HeaderAssoc(6) - - ! Initialize status (if present) - - if(present(status)) status = 0 - - dest = ComponentToWorldRank(0, comp_id, ThisMCTWorld) - - ! Step 1. Check elements of the GeneralGrid header to see - ! which components of it are allocated. Load the results - ! into HeaderAssoc(:), and send it to process dest. - - HeaderAssoc(1) = List_allocated(iGGrid%coordinate_list) - HeaderAssoc(2) = List_allocated(iGGrid%coordinate_sort_order) - HeaderAssoc(3) = associated(iGGrid%descend) - HeaderAssoc(4) = List_allocated(iGGrid%weight_list) - HeaderAssoc(5) = List_allocated(iGGrid%other_list) - HeaderAssoc(6) = List_allocated(iGGrid%index_list) - - call MPI_SEND(HeaderAssoc, 6, MP_LOGICAL, dest, TagBase, ThisMCTWorld%MCT_comm, ierr) - if(ierr /= 0) then - call MP_perr_die(myname_,':: MPI_SEND(HeaderAssoc...',ierr) - endif - - ! Step 2. If iGGrid%coordinate_list is defined, send it. - - if(HeaderAssoc(1)) then - call List_send(iGGrid%coordinate_list, dest, TagBase+1, ThisMCTWorld%MCT_comm, ierr) - if(ierr /= 0) then - write(stderr,*) myname_,':: call List_send(iGGrid%coordinate_list...', & - 'Error flag ierr = ',ierr - if(present(status)) then - status = ierr - return - else - call die(myname_,':: call List_send(iGGrid%coordinate_list...',ierr) - endif - endif - else ! This constitutes an error, as a GeneralGrid must have coordinates - - if(present(status)) then - write(stderr,*) myname_,':: Error. GeneralGrid%coordinate_list undefined.' - status = -1 - return - else - call die(myname_,':: Error. GeneralGrid%coordinate_list undefined.',-1) - endif - - endif ! if(HeaderAssoc(1))... - - ! Step 3. If iGGrid%coordinate_sort_order is defined, send it. - - if(HeaderAssoc(2)) then - call List_send(iGGrid%coordinate_sort_order, dest, TagBase+3, ThisMCTWorld%MCT_comm, ierr) - if(ierr /= 0) then - if(present(status)) then - write(stderr,*) myname_,':: call List_send(iGGrid%coordinate_sort_order...' - status = ierr - return - else - call die(myname_,':: call List_send(iGGrid%coordinate_sort_order...',ierr) - endif - endif - - endif ! if(HeaderAssoc(2))... - - ! Step 4. If iGGrid%descend is allocated, determine its size, - ! send this size, and then send the elements of iGGrid%descend. - - if(HeaderAssoc(3)) then - - if(size(iGGrid%descend)<=0) call die(myname_,'size(iGGrid%descend)<=0') - - call MPI_SEND(size(iGGrid%descend), 1, MP_type(size(iGGrid%descend)), & - dest, TagBase+5, ThisMCTWorld%MCT_comm, ierr) - if(ierr /= 0) then - call MP_perr_die(myname_,':: call MPI_SEND(size(iGGrid%descend)...',ierr) - endif - - call MPI_SEND(iGGrid%descend, size(iGGrid%descend), MP_type(iGGrid%descend(1)), & - dest, TagBase+6, ThisMCTWorld%MCT_comm, ierr) - if(ierr /= 0) then - call MP_perr_die(myname_,':: call MPI_SEND(iGGrid%descend...',ierr) - endif - - endif ! if(HeaderAssoc(3))... - - ! Step 5. If iGGrid%weight_list is defined, send it. - - if(HeaderAssoc(4)) then - - call List_send(iGGrid%weight_list, dest, TagBase+7, ThisMCTWorld%MCT_comm, ierr) - if(ierr /= 0) then - if(present(status)) then - write(stderr,*) myname_,':: call List_send(iGGrid%weight_list...' - status = ierr - return - else - call die(myname_,':: call List_send(iGGrid%weight_list...',ierr) - endif - endif - - endif ! if(HeaderAssoc(4))... - - ! Step 6. If iGGrid%other_list is defined, send it. - - if(HeaderAssoc(5)) then - - call List_send(iGGrid%other_list, dest, TagBase+9, ThisMCTWorld%MCT_comm, ierr) - if(ierr /= 0) then - if(present(status)) then - write(stderr,*) myname_,':: call List_send(iGGrid%other_list...' - status = ierr - return - else - call die(myname_,':: call List_send(iGGrid%other_list...',ierr) - endif - endif - - endif ! if(HeaderAssoc(5))... - - ! Step 7. If iGGrid%index_list is defined, send it. - - if(HeaderAssoc(6)) then - - call List_send(iGGrid%index_list, dest, TagBase+11, ThisMCTWorld%MCT_comm, ierr) - if(ierr /= 0) then - if(present(status)) then - write(stderr,*) myname_,':: call List_send(iGGrid%index_list...' - status = ierr - return - else - call die(myname_,':: call List_send(iGGrid%index_list...',ierr) - endif - endif - - else ! This constitutes an error, as a GeneralGrid must at a minimum - ! contain the index GlobGridNum - - if(present(status)) then - write(stderr,*) myname_,':: Error. GeneralGrid%index_list undefined.' - status = -2 - return - else - call die(myname_,':: Error. GeneralGrid%index_list undefined.',-2) - endif - - endif ! if(HeaderAssoc(6))... - - ! Step 8. Finally, send the AttrVect iGGrid%data. - - call AttrVect_send(iGGrid%data, dest, TagBase+13, ThisMCTWorld%MCT_comm, ierr) - if(ierr /= 0) then - if(present(status)) then - write(stderr,*) myname_,':: call AttrVect_send(iGGrid%data...' - status = ierr - return - else - call die(myname_,':: call AttrVect_send(iGGrid%data...',ierr) - endif - endif - - ! The GeneralGrid send is now complete. - - end subroutine send_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: recv_ - Point-to-point blocking recv for the GeneralGrid. -! -! !DESCRIPTION: The point-to-point receive routine {\tt recv\_()} -! receives the output {\tt GeneralGrid} argument {\tt oGGrid} from component -! {\tt comp\_id}. The message is identified by the tag defined by the -! {\tt INTEGER} argument {\tt TagBase}. The value of {\tt TagBase} must -! match the value used in the call to {\tt send\_()} on the other component. -! The success (failure) of this operation corresponds to a zero (nonzero) -! value for the output {\tt INTEGER} flag {\tt status}. -! -! {\bf N.B.}: This routine assumes that the {\tt GeneralGrid} argument -! {\tt oGGrid} is uninitialized on input; that is, all the {\tt List} -! components are blank, the {\tt LOGICAL} array {\tt oGGrid\%descend} is -! unallocated, and the {\tt AttrVect} component {\tt oGGrid\%data} is -! uninitialized. The {\tt GeneralGrid} {\tt oGGrid} represents allocated -! memory. When the user no longer needs {\tt oGGrid}, it should be -! deallocated by invoking {\tt GeneralGrid\_clean()} (see -! {\tt m\_GeneralGrid} for further details). -! -! {\bf N.B.}: One must avoid assigning elsewhere the MPI tag values -! between {\tt TagBase} and {\tt TagBase+20}, inclusive. This is -! because {\tt recv\_()} performs one receive operation set up the header -! transfer, up to five {\tt List\_recv} operations (two {\tt MPI\_RECV} -! calls in each), two receive operations to transfer {\tt iGGrid\%descend(:)}, -! and finally the receive of the {\tt AttrVect} component {\tt iGGrid\%data} -! (which comprises eight {\tt MPI\_RECV} operations). -! -! !INTERFACE: - - subroutine recv_(oGGrid, comp_id, TagBase, status) - -! -! !USES: -! - use m_stdio - use m_die - use m_mpif90 - - use m_GeneralGrid, only : GeneralGrid - use m_GeneralGrid, only : GeneralGrid_init => init - use m_GeneralGrid, only : GeneralGrid_lsize => lsize - - use m_MCTWorld, only : ComponentToWorldRank - use m_MCTWorld, only : ThisMCTWorld - - use m_AttrVectComms,only : AttrVect_recv => recv - - use m_List,only : List_recv => recv - use m_List,only : List_nullify => nullify - - implicit none - -! !INPUT PARAMETERS: -! - integer, intent(in) :: comp_id - integer, intent(in) :: TagBase - -! !OUTPUT PARAMETERS: -! - type(GeneralGrid), intent(out) :: oGGrid - integer, optional, intent(out) :: status - -! !REVISION HISTORY: -! 04Jun01 - J.W. Larson - API Specification. -! 07Jun01 - J.W. Larson - Initial version. -! 10Jun01 - J.W. Larson - Bug fixes--now works. -! 11Jun01 - R. Jacob use component id as input -! argument. -! 13Jun01 - J.W. Larson - Initialize status -! (if present). -! 13Jun02 - J.W. Larson - Removed the argument -! comm. This routine is now explicitly for intercomponent -! communications only. -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::recv_' - - integer :: ierr - integer :: source - integer :: MPstatus(MP_STATUS_SIZE), DescendSize - logical :: HeaderAssoc(6) - -! for now, assume the components root is the source. - source = ComponentToWorldRank(0, comp_id, ThisMCTWorld) - - ! Step 1. Receive the elements of the LOGICAL flag array - ! HeaderAssoc. TRUE entries in this array correspond to - ! Check elements of the GeneralGrid header that are not - ! blank, and are being sent by process source. - ! - ! The significance of the entries of HeaderAssoc has been - ! defined in send_(). Here are the definitions of these - ! values: - ! - ! HeaderAssoc(1) = List_allocated(oGGrid%coordinate_list) - ! HeaderAssoc(2) = List_allocated(oGGrid%coordinate_sort_order) - ! HeaderAssoc(3) = associated(oGGrid%descend) - ! HeaderAssoc(4) = List_allocated(oGGrid%weight_list) - ! HeaderAssoc(5) = List_allocated(oGGrid%other_list) - ! HeaderAssoc(6) = List_allocated(oGGrid%index_list) - - ! Initialize status (if present) - - if(present(status)) status = 0 - - ! Step 1. Nullify oGGrid components, set HeaderAssoc(:) to .FALSE., - ! then receive incoming HeaderAssoc(:) data - - call List_nullify(oGGrid%coordinate_list) - call List_nullify(oGGrid%coordinate_sort_order) - call List_nullify(oGGrid%weight_list) - call List_nullify(oGGrid%other_list) - call List_nullify(oGGrid%index_list) - nullify(oGGrid%descend) - - HeaderAssoc = .FALSE. - - call MPI_RECV(HeaderAssoc, 6, MP_LOGICAL, source, TagBase, ThisMCTWorld%MCT_comm, MPstatus, ierr) - if(ierr /= 0) then - call MP_perr_die(myname_,':: MPI_RECV(HeaderAssoc...',ierr) - endif - - ! Step 2. If oGGrid%coordinate_list is defined, receive it. - - if(HeaderAssoc(1)) then - call List_recv(oGGrid%coordinate_list, source, TagBase+1, ThisMCTWorld%MCT_comm, ierr) - if(ierr /= 0) then - if(present(status)) then - write(stderr,*) myname_,':: call List_recv(oGGrid%coordinate_list...' - status = ierr - return - else - call die(myname_,':: call List_recv(oGGrid%coordinate_list...',ierr) - endif - endif - else ! This constitutes an error, as a GeneralGrid must have coordinates - - if(present(status)) then - write(stderr,*) myname_,':: Error. GeneralGrid%coordinate_list undefined.' - status = -1 - return - else - call die(myname_,':: Error. GeneralGrid%coordinate_list undefined.',-1) - endif - - endif ! if(HeaderAssoc(1))... - - ! Step 3. If oGGrid%coordinate_sort_order is defined, receive it. - - if(HeaderAssoc(2)) then - call List_recv(oGGrid%coordinate_sort_order, source, TagBase+3, ThisMCTWorld%MCT_comm, ierr) - if(ierr /= 0) then - if(present(status)) then - write(stderr,*) myname_,':: Error calling ',& - 'List_recv(oGGrid%coordinate_sort_order...' - status = ierr - return - else - call die(myname_,':: call List_recv(oGGrid%coordinate_sort_order...', ierr) - endif - endif - endif ! if(HeaderAssoc(2))... - - ! Step 4. If oGGrid%descend is allocated, determine its size, - ! receive this size, allocate oGGrid%descend, and then receive - ! the elements of oGGrid%descend. - - if(HeaderAssoc(3)) then - - call MPI_RECV(DescendSize, 1, MP_type(DescendSize), & - source, TagBase+5, ThisMCTWorld%MCT_comm, MPstatus, ierr) - if(ierr /= 0) then - call MP_perr_die(myname_,':: call MPI_RECV(size(oGGrid%descend)...',ierr) - endif - - allocate(oGGrid%descend(DescendSize), stat=ierr) - if(ierr /= 0) then - if(present(status)) then - write(stderr,*) myname_,':: allocate(oGGrid%descend...' - status = ierr - return - else - call die(myname_,':: allocate(oGGrid%descend... failed.',ierr) - endif - endif - - call MPI_RECV(oGGrid%descend, DescendSize, MP_type(oGGrid%descend(1)), & - source, TagBase+6, ThisMCTWorld%MCT_comm, MPstatus, ierr) - if(ierr /= 0) then - call MP_perr_die(myname_,':: call MPI_RECV(oGGrid%descend...',ierr) - endif - - endif ! if(HeaderAssoc(3))... - - ! Step 5. If oGGrid%weight_list is defined, receive it. - - if(HeaderAssoc(4)) then - - call List_recv(oGGrid%weight_list, source, TagBase+7, ThisMCTWorld%MCT_comm, ierr) - if(ierr /= 0) then - if(present(status)) then - write(stderr,*) myname_,':: call List_recv(oGGrid%weight_list...' - status = ierr - return - else - call die(myname_,':: call List_recv(oGGrid%weight_list...',ierr) - endif - endif - - endif ! if(HeaderAssoc(4))... - - ! Step 6. If oGGrid%other_list is defined, receive it. - - if(HeaderAssoc(5)) then - - call List_recv(oGGrid%other_list, source, TagBase+9, ThisMCTWorld%MCT_comm, ierr) - if(ierr /= 0) then - if(present(status)) then - write(stderr,*) myname_,':: call List_recv(oGGrid%other_list...' - status = ierr - return - else - call die(myname_,':: call List_recv(oGGrid%other_list...',ierr) - endif - endif - - endif ! if(HeaderAssoc(5))... - - ! Step 7. If oGGrid%index_list is defined, receive it. - - if(HeaderAssoc(6)) then - - call List_recv(oGGrid%index_list, source, TagBase+11, ThisMCTWorld%MCT_comm, ierr) - if(ierr /= 0) then - if(present(status)) then - write(stderr,*) myname_,':: call List_recv(oGGrid%index_list...' - status = ierr - return - else - call die(myname_,':: call List_recv(oGGrid%index_list...',ierr) - endif - endif - - else ! This constitutes an error, as a GeneralGrid must at a minimum - ! contain the index GlobGridNum - - if(present(status)) then - write(stderr,*) myname_,':: Error. GeneralGrid%index_list undefined.' - status = -2 - return - else - call die(myname_,':: Error. GeneralGrid%index_list undefined.',-2) - endif - - endif ! if(HeaderAssoc(6))... - - ! Step 8. Finally, receive the AttrVect oGGrid%data. - - call AttrVect_recv(oGGrid%data, source, TagBase+13, ThisMCTWorld%MCT_comm, ierr) - if(ierr /= 0) then - if(present(status)) then - write(stderr,*) myname_,':: call AttrVect_recv(oGGrid%data...' - status = ierr - return - else - call die(myname_,':: call AttrVect_recv(oGGrid%data...',ierr) - endif - endif - - ! The GeneralGrid receive is now complete. - - end subroutine recv_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: GM_gather_ - gather a GeneralGrid using input GlobalMap. -! -! !DESCRIPTION: {\tt GM\_gather\_()} takes an input {\tt GeneralGrid} -! argument {\tt iG} whose decomposition on the communicator associated -! with the F90 handle {\tt comm} is described by the {\tt GlobalMap} -! argument {\tt GMap}, and gathers it to the {\tt GeneralGrid} output -! argument {\tt oG} on the {\tt root}. The success (failure) of this -! operation is reported as a zero (nonzero) value in the optional -! {\tt INTEGER} output argument {\tt stat}. - -! {\bf N.B.}: An important assumption made here is that the distributed -! {\tt GeneralGrid} {\tt iG} has been initialized with the same -! coordinate system, sort order, other real attributes, and the same -! indexing attributes for all processes on {\tt comm}. -! -! {\bf N.B.}: Once the gridpoint data of the {\tt GeneralGrid} are assembled -! on the {\tt root}, they are stored in the order determined by the input -! {\tt GlobalMap} {\tt GMap}. The user may need to sorted these gathered -! data to order them in accordance with the {\tt coordinate\_sort\_order} -! attribute of {\tt iG}. -! -! {\bf N.B.}: The output {\tt GeneralGrid} {\tt oG} represents allocated -! memory on the {\tt root}. When the user no longer needs {\tt oG} it -! should be deallocated using {\tt GeneralGrid\_clean()} to avoid a memory -! leak -! -! !INTERFACE: -! - subroutine GM_gather_(iG, oG, GMap, root, comm, stat) -! -! !USES: -! - use m_stdio - use m_die - use m_mpif90 - - use m_GlobalMap, only : GlobalMap - use m_GlobalMap, only : GlobalMap_gsize => gsize - - use m_GeneralGrid, only : GeneralGrid - use m_GeneralGrid, only : GeneralGrid_init => init - - use m_AttrVectComms,only : AttrVect_Gather => gather - - implicit none - -! !INPUT PARAMETERS: -! - type(GeneralGrid), intent(in) :: iG - type(GlobalMap), intent(in) :: GMap - integer, intent(in) :: root - integer, intent(in) :: comm - -! !OUTPUT PARAMETERS: -! - type(GeneralGrid), intent(out) :: oG - integer, optional, intent(out) :: stat - -! !REVISION HISTORY: -! 27Apr01 - J.W. Larson - API Specification. -! 02May01 - J.W. Larson - Initial code. -! 13Jun01 - J.W. Larson - Initialize stat -! (if present). -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::GM_gather_' -!Process ID - integer :: myID -!Error flag - integer :: ierr -!Number of points on the _Gathered_ grid: - integer :: length - - ! Initialize stat (if present) - - if(present(stat)) stat = 0 - - ! Which process am I? - - call MPI_COMM_RANK(comm, myID, ierr) - if(ierr /= 0) then - call MP_perr_die(myname_,'call MPI_COMM_RANK()',ierr) - endif - - if(myID == root) then ! prepare oG: - - ! The length of the _gathered_ GeneralGrid oG is determined by - ! the GlobalMap function GlobalMap_gsize() - - length = GlobalMap_gsize(GMap) - - ! Initialize attributes of oG from iG - call copyGeneralGridHeader_(iG,oG) - - endif - - ! Gather gridpoint data in iG%data to oG%data - - call AttrVect_Gather(iG%data, oG%data, GMap, root, comm, ierr) - - if(ierr /= 0) then - write(stderr,*) myname_,':: Error--call AttrVect_Gather() failed.', & - ' ierr = ',ierr - if(present(stat)) then - stat=ierr - return - else - call die(myname_,'call AttrVect_Gather(ig%data...',ierr) - endif - endif - - end subroutine GM_gather_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: GSM_gather_ - gather a GeneralGrid using input GlobalSegMap. -! -! !DESCRIPTION: {\tt GMS\_gather\_()} takes an input {\tt GeneralGrid} -! argument {\tt iG} whose decomposition on the communicator associated -! with the F90 handle {\tt comm} is described by the {\tt GlobalSegMap} -! argument {\tt GSMap}, and gathers it to the {\tt GeneralGrid} output -! argument {\tt oG} on the {\tt root}. The success (failure) of this -! operation is reported as a zero (nonzero) value in the optional -! {\tt INTEGER} output argument {\tt stat}. -! -! {\bf N.B.}: An important assumption made here is that the distributed -! {\tt GeneralGrid} {\tt iG} has been initialized with the same -! coordinate system, sort order, other real attributes, and the same -! indexing attributes for all processes on {\tt comm}. -! -! {\bf N.B.}: Once the gridpoint data of the {\tt GeneralGrid} are assembled -! on the {\tt root}, they are stored in the order determined by the input -! {\tt GlobalSegMap} {\tt GSMap}. The user may need to sorted these gathered -! data to order them in accordance with the {\tt coordinate\_sort\_order} -! attribute of {\tt iG}. -! -! {\bf N.B.}: The output {\tt GeneralGrid} {\tt oG} represents allocated -! memory on the {\tt root}. When the user no longer needs {\tt oG} it -! should be deallocated using {\tt GeneralGrid\_clean()} to avoid a memory -! leak -! -! !INTERFACE: - - subroutine GSM_gather_(iG, oG, GSMap, root, comm, stat) -! -! !USES: -! - use m_stdio - use m_die - use m_mpif90 - - use m_GlobalSegMap, only : GlobalSegMap - use m_GlobalSegMap, only : GlobalSegMap_lsize => lsize - use m_GlobalSegMap, only : GlobalSegMap_gsize => gsize - - use m_GeneralGrid, only : GeneralGrid - use m_GeneralGrid, only : GeneralGrid_init => init - use m_GeneralGrid, only : GeneralGrid_lsize => lsize - - use m_AttrVectComms,only : AttrVect_Gather => gather - - implicit none - -! !INPUT PARAMETERS: -! - type(GeneralGrid), intent(in) :: iG - type(GlobalSegMap), intent(in) :: GSMap - integer, intent(in) :: root - integer, intent(in) :: comm - -! !OUTPUT PARAMETERS: -! - type(GeneralGrid), intent(out) :: oG - integer, optional, intent(out) :: stat - -! !REVISION HISTORY: -! 27Apr01 - J.W. Larson - API Specification. -! 01May01 - J.W. Larson - Working Version. -! 13Jun01 - J.W. Larson - Initialize stat -! (if present). -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::GSM_gather_' - -!Process ID - integer :: myID -!Error flag - integer :: ierr -!Number of points on the _Gathered_ grid: - integer :: length - - ! Initialize stat (if present) - - if(present(stat)) stat = 0 - - ! Which process am I? - - call MPI_COMM_RANK(comm, myID, ierr) - if(ierr /= 0) then - call MP_perr_die(myname_,'MPI_COMM_RANK()',ierr) - endif - - if(myID == root) then ! prepare oG: - - ! The length of the _gathered_ GeneralGrid oG is determined by - ! the GlobalMap function GlobalSegMap_gsize() - - length = GlobalSegMap_gsize(GSMap) - - ! Initialize attributes of oG from iG - call copyGeneralGridHeader_(iG,oG) - - endif - - ! Gather gridpoint data in iG%data to oG%data - - call AttrVect_Gather(iG%data, oG%data, GSMap, root, comm, ierr) - if(ierr /= 0) then - write(stderr,*) myname_,':: ERROR--call AttrVect_Gather() failed.', & - ' ierr = ',ierr - if(present(stat)) then - stat=ierr - return - else - call die(myname_) - endif - endif - - end subroutine GSM_gather_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: GM_scatter_ - scatter a GeneralGrid using input GlobalMap. -! -! !DESCRIPTION: {\tt GM\_scatter\_()} takes an input {\tt GeneralGrid} -! argument {\tt iG} (valid only on the {\tt root} process), and scatters -! it to the distributed {\tt GeneralGrid} variable {\tt oG}. The -! {\tt GeneralGrid} {\tt oG} is distributed on the communicator -! associated with the F90 handle {\tt comm} using the domain -! decomposition described by the {\tt GlobalMap} argument {\tt GMap}. -! The success (failure) of this operation is reported as a zero (nonzero) -! value in the optional {\tt INTEGER} output argument {\tt stat}. -! -! {\bf N.B.}: The output {\tt GeneralGrid} {\tt oG} represents allocated -! memory on the {\tt root}. When the user no longer needs {\tt oG} it -! should be deallocated using {\tt GeneralGrid\_clean()} to avoid a memory -! leak. -! -! !INTERFACE: - - subroutine GM_scatter_(iG, oG, GMap, root, comm, stat) -! -! !USES: -! - use m_stdio - use m_die - use m_mpif90 - - use m_GlobalMap, only : GlobalMap - use m_GlobalMap, only : GlobalMap_lsize => lsize - use m_GlobalMap, only : GlobalMap_gsize => gsize - - use m_AttrVectComms, only : AttrVect_scatter => scatter - - use m_GeneralGrid, only : GeneralGrid - use m_GeneralGrid, only : GeneralGrid_init => init - use m_GeneralGrid, only : GeneralGrid_lsize => lsize - - implicit none - -! !INPUT PARAMETERS: -! - type(GeneralGrid), intent(in) :: iG - type(GlobalMap), intent(in) :: GMap - integer, intent(in) :: root - integer, intent(in) :: comm - -! !OUTPUT PARAMETERS: -! - type(GeneralGrid), intent(out) :: oG - integer, optional, intent(out) :: stat - -! !REVISION HISTORY: -! 27Apr01 - J.W. Larson - API Specification. -! 04Jun01 - J.W. Larson - Changed comms model -! to MPI-style (i.e. iG valid on root only). -! 13Jun01 - J.W. Larson - Initialize stat -! (if present). -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::GM_scatter_' - - logical :: DescendAssoc - integer :: DescendSize - integer :: ierr, myID - - ! Initialize status (if present) - - if(present(stat)) stat = 0 - - ! Step 1. Determine process ID number myID - - call MPI_COMM_RANK(comm, myID, ierr) - if(ierr /= 0) then - call MP_perr_die(myname_,'MPI_COMM_RANK(comm...',ierr) - endif - - ! Step 2. On the root, initialize the List and LOGICAL - ! attributes of the GeneralGrid variable iG to oG. - - if(myID == root) then - call copyGeneralGridHeader_(iG, oG) - endif - - ! Step 3. Broadcast from the root the List and LOGICAL - ! attributes of the GeneralGrid variable oG. - - call bcastGeneralGridHeader_(oG, root, comm, ierr) - if(ierr /= 0) then - write(stderr,*) myname_,':: Error calling bcastGeneralGridHeader_().',& - ' ierr = ',ierr - if(present(stat)) then - stat = ierr - return - else - call die(myname_,'call bcastGeneralGridHeader_(oG...',ierr) - endif - endif - - - ! Step 4. Using the GeneralMap GMap, scatter the AttrVect - ! portion of the input GeneralGrid iG to the GeneralGrid oG. - - call AttrVect_scatter(iG%data, oG%data, GMap, root, comm, ierr) - if(ierr /= 0) then - write(stderr,*) myname_,':: Error calling AttrVect_scatter(iG%data...',& - ' ierr = ',ierr - if(present(stat)) then - stat = ierr - return - else - call die(myname_,'call AttrVect_scatter(iG%data...',ierr) - endif - endif - - ! The GeneralGrid scatter is now complete. - - end subroutine GM_scatter_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: GSM_scatter_ - scatter a GeneralGrid using input GlobalSegMap. -! -! !DESCRIPTION: {\tt GM\_scatter\_()} takes an input {\tt GeneralGrid} -! argument {\tt iG} (valid only on the {\tt root} process), and scatters -! it to the distributed {\tt GeneralGrid} variable {\tt oG}. The -! {\tt GeneralGrid} {\tt oG} is distributed on the communicator -! associated with the F90 handle {\tt comm} using the domain -! decomposition described by the {\tt GlobalSegMap} argument {\tt GSMap}. -! The success (failure) of this operation is reported as a zero (nonzero) -! value in the optional {\tt INTEGER} output argument {\tt stat}. -! -! {\bf N.B.}: The output {\tt GeneralGrid} {\tt oG} represents allocated -! memory on the {\tt root}. When the user no longer needs {\tt oG} it -! should be deallocated using {\tt GeneralGrid\_clean()} to avoid a memory -! leak. -! -! !INTERFACE: - - subroutine GSM_scatter_(iG, oG, GSMap, root, comm, stat) -! -! !USES: -! - use m_stdio - use m_die - use m_mpif90 - - use m_GlobalSegMap, only : GlobalSegMap - use m_GlobalSegMap, only : GlobalSegMap_lsize => lsize - use m_GlobalSegMap, only : GlobalSegMap_gsize => gsize - - use m_AttrVectComms, only : AttrVect_scatter => scatter - - use m_GeneralGrid, only : GeneralGrid - use m_GeneralGrid, only : GeneralGrid_init => init - use m_GeneralGrid, only : GeneralGrid_lsize => lsize - - implicit none - -! !INPUT PARAMETERS: -! - type(GeneralGrid), intent(in) :: iG - type(GlobalSegMap), intent(in) :: GSMap - integer, intent(in) :: root - integer, intent(in) :: comm - -! !OUTPUT PARAMETERS: -! - type(GeneralGrid), intent(out) :: oG - integer, optional, intent(out) :: stat - -! !REVISION HISTORY: -! 27Apr01 - J.W. Larson - API Specification. -! 04Jun01 - J.W. Larson - Initial code. -! 13Jun01 - J.W. Larson - Initialize stat -! (if present). -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::GSM_scatter_' - - integer :: ierr, myID - - ! Initialize stat (if present) - - if(present(stat)) stat = 0 - - ! Step 1. Determine process ID number myID - - call MPI_COMM_RANK(comm, myID, ierr) - if(ierr /= 0) then - call MP_perr_die(myname_,'MPI_COMM_RANK(comm...',ierr) - endif - - ! Step 2. On the root, initialize the List and LOGICAL - ! attributes of the GeneralGrid variable iG to oG. - - if(myID == root) then - call copyGeneralGridHeader_(iG, oG) - endif - - ! Step 3. Broadcast from the root the List and LOGICAL - ! attributes of the GeneralGrid variable oG. - - call bcastGeneralGridHeader_(oG, root, comm, ierr) - if(ierr /= 0) then - write(stderr,*) myname_,':: Error calling bcastGeneralGridHeader_(...',& - ' ierr = ',ierr - if(present(stat)) then - stat = ierr - return - else - call die(myname_,'bcastGeneralGridHeader_(oG...',ierr) - endif - endif - - ! Step 4. Using the GeneralSegMap GSMap, scatter the AttrVect - ! portion of the input GeneralGrid iG to the GeneralGrid oG. - - call AttrVect_scatter(iG%data, oG%data, GSMap, root, comm, ierr) - if(ierr /= 0) then - write(stderr,*) myname_,':: Error calling AttrVect_scatter(iG%data...',& - ' ierr = ',ierr - if(present(stat)) then - stat = ierr - return - else - call die(myname_,'call AttrVect_scatter(iG%data...',ierr) - endif - endif - - ! The GeneralGrid scatter is now complete. - - end subroutine GSM_scatter_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: bcast_ - Broadcast a GeneralGrid. -! -! !DESCRIPTION: {\tt bcast\_()} takes an input {\tt GeneralGrid} -! argument {\tt ioG} (valid only on the {\tt root} process), and -! broadcasts it to all processes on the communicator associated with the -! F90 handle {\tt comm}. The success (failure) of this operation is -! reported as a zero (nonzero) value in the optional {\tt INTEGER} -! output argument {\tt stat}. -! -! {\bf N.B.}: On the non-root processes, the output {\tt GeneralGrid} -! {\tt ioG} represents allocated memory. When the user no longer needs -! {\tt ioG} it should be deallocated by invoking {\tt GeneralGrid\_clean()}. -! Failure to do so risks a memory leak. -! -! !INTERFACE: - - subroutine bcast_(ioG, root, comm, stat) -! -! !USES: -! - use m_stdio - use m_die - use m_mpif90 - - use m_GlobalSegMap, only : GlobalSegMap - use m_GlobalSegMap, only : GlobalSegMap_lsize => lsize - use m_GlobalSegMap, only : GlobalSegMap_gsize => gsize - - use m_GeneralGrid, only : GeneralGrid - use m_GeneralGrid, only : GeneralGrid_init => init - use m_GeneralGrid, only : GeneralGrid_lsize => lsize - - use m_AttrVectComms,only : AttrVect_bcast => bcast - - implicit none - -! !INPUT PARAMETERS: -! - integer, intent(in) :: root - integer, intent(in) :: comm - -! !INPUT/OUTPUT PARAMETERS: -! - type(GeneralGrid), intent(inout) :: ioG - -! !OUTPUT PARAMETERS: -! - integer, optional, intent(out) :: stat - -! !REVISION HISTORY: -! 27Apr01 - J.W. Larson - API Specification. -! 02May01 - J.W. Larson - Initial version. -! 13Jun01 - J.W. Larson - Initialize stat -! (if present). -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::bcast_' - - integer :: ierr, myID - - ! Initialize status (if present) - - if(present(stat)) stat = 0 - - ! Step 1. Determine process ID number myID - - call MPI_COMM_RANK(comm, myID, ierr) - if(ierr /= 0) then - call MP_perr_die(myname_,'MPI_COMM_RANK(comm...',ierr) - endif - - ! Step 2. Broadcast from the root the List and LOGICAL - ! attributes of the GeneralGrid variable ioG. - - call bcastGeneralGridHeader_(ioG, root, comm, ierr) - if(ierr /= 0) then - write(stderr,*) myname_,':: Error calling bcastGeneralGridHeader_(...',& - ' ierr = ',ierr - if(present(stat)) then - stat = ierr - return - else - call die(myname_) - endif - endif - - ! Step 3. Broadcast ioG%data from the root. - - call AttrVect_bcast(ioG%data, root, comm, ierr) - if(ierr /= 0) then - write(stderr,*) myname_,':: Error calling AttrVect_scatter(iG%data...',& - ' ierr = ',ierr - if(present(stat)) then - stat = ierr - return - else - call die(myname_) - endif - endif - - ! The GeneralGrid broadcast is now complete. - - end subroutine bcast_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: bcastGeneralGridHeader_ - Broadcast the GeneralGrid Header. -! -! !DESCRIPTION: This routine broadcasts the header information from -! the input {\tt GeneralGrid} argument {\tt ioGGrid} (on input valid -! on the {\tt root} only). This broadcast is from the {\tt root} to -! all processes on the communicator associated with the fortran 90 -! {\tt INTEGER} handle {\tt comm}. The success (failure) of this operation -! corresponds to a zero (nonzero) value for the output {\tt INTEGER} flag -! {\tt stat}. -! -! The {\em header information} in a {\tt GeneralGrid} variable comprises -! all the non-{\tt AttrVect} components of the {\tt GeneralGrid}; that -! is, everything except the gridpoint coordinate, geometry, and index -! data stored in {\tt iGGrid\%data}. This information includes: -! \begin{enumerate} -! \item The coordinates in {\tt iGGrid\%coordinate\_list} -! \item The coordinate sort order in {\tt iGGrid\%coordinate\_sort\_order} -! \item The area/volume weights in {\tt iGGrid\%weight\_list} -! \item Other {\tt REAL} geometric information in {\tt iGGrid\%other\_list} -! \item Indexing information in {\tt iGGrid\%index\_list} -! \item The {\tt LOGICAL} descending/ascending order sort flags in -! {\tt iGGrid\%descend(:)}. -! \end{enumerate} -! -! !INTERFACE: - - subroutine bcastGeneralGridHeader_(ioGGrid, root, comm, stat) -! -! !USES: -! - use m_stdio - use m_die - use m_mpif90 - - use m_GlobalSegMap, only : GlobalSegMap - use m_GlobalSegMap, only : GlobalSegMap_lsize => lsize - use m_GlobalSegMap, only : GlobalSegMap_gsize => gsize - - use m_GeneralGrid, only : GeneralGrid - use m_GeneralGrid, only : GeneralGrid_init => init - use m_GeneralGrid, only : GeneralGrid_lsize => lsize - - use m_List, only : List - use m_List, only : List_allocated => allocated - use m_List, only : List_nullify => nullify - use m_List, only : List_bcast => bcast - - implicit none - -! !INPUT PARAMETERS: -! - integer, intent(in) :: root - integer, intent(in) :: comm - -! !INPUT/OUTPUT PARAMETERS: -! - type(GeneralGrid), intent(inout) :: ioGGrid - -! !OUTPUT PARAMETERS: -! - integer, optional, intent(out) :: stat - -! !REVISION HISTORY: -! 05Jun01 - J.W. Larson - Initial code. -! 13Jun01 - J.W. Larson - Initialize stat -! (if present). -! 05Aug02 - E. Ong - added association checking -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::bcastGeneralGridHeader_' - -! Process ID - integer :: myID -! Error flag - integer :: ierr -! Size of array ioGGrid%descend(:) - integer :: DescendSize -! Header-Assocation array - logical :: HeaderAssoc(6) - - ! Initialize stat (if present) - - if(present(stat)) stat = 0 - - ! Determine process ID number myID - - call MPI_COMM_RANK(comm, myID, ierr) - if(ierr /= 0) then - call MP_perr_die(myname_,'MPI_COMM_RANK(comm...',ierr) - endif - - ! Step 0.5. Check elements of the GeneralGrid header to see - ! which components of it are allocated. Load the results - ! into HeaderAssoc(:), and broadcast it. - - if(myID == root) then - - HeaderAssoc(1) = List_allocated(ioGGrid%coordinate_list) - HeaderAssoc(2) = List_allocated(ioGGrid%coordinate_sort_order) - HeaderAssoc(3) = List_allocated(ioGGrid%weight_list) - HeaderAssoc(4) = List_allocated(ioGGrid%other_list) - HeaderAssoc(5) = List_allocated(ioGGrid%index_list) - HeaderAssoc(6) = associated(ioGGrid%descend) - - else - - call List_nullify(ioGGrid%coordinate_list) - call List_nullify(ioGGrid%coordinate_sort_order) - call List_nullify(ioGGrid%weight_list) - call List_nullify(ioGGrid%other_list) - call List_nullify(ioGGrid%index_list) - nullify(ioGGrid%descend) - - endif - - call MPI_BCAST(HeaderAssoc,6,MP_LOGICAL,root,comm,ierr) - - ! Step 1. Broadcast List attributes of the GeneralGrid. - - if(HeaderAssoc(1)) then - call List_bcast(ioGGrid%coordinate_list, root, comm, ierr) - if(ierr /= 0) then - write(stderr,*) myname_,'List_bcast(ioGGrid%coordinate_list... failed.',& - ' ierr = ',ierr - if(present(stat)) then - stat = ierr - return - else - call die(myname_) - endif - endif - endif - - if(HeaderAssoc(2)) then - call List_bcast(ioGGrid%coordinate_sort_order, root, comm, ierr) - if(ierr /= 0) then - write(stderr,*) myname_,'List_bcast(ioGGrid%coordinate_sort_order... failed', & - ' ierr = ',ierr - if(present(stat)) then - stat = ierr - return - else - call die(myname_) - endif - endif - endif - - if(HeaderAssoc(3)) then - call List_bcast(ioGGrid%weight_list, root, comm, ierr) - if(ierr /= 0) then - write(stderr,*) myname_,'List_bcast(ioGGrid%weight_list... failed',& - ' ierr = ',ierr - if(present(stat)) then - stat = ierr - return - else - call die(myname_) - endif - endif - endif - - if(HeaderAssoc(4)) then - call List_bcast(ioGGrid%other_list, root, comm, ierr) - if(ierr /= 0) then - write(stderr,*) myname_,'List_bcast(ioGGrid%other_list... failed',& - ' ierr = ',ierr - if(present(stat)) then - stat = ierr - return - else - call die(myname_) - endif - endif - endif - - if(HeaderAssoc(5)) then - call List_bcast(ioGGrid%index_list, root, comm, ierr) - if(ierr /= 0) then - write(stderr,*) myname_,'List_bcast(ioGGrid%index_list... failed',& - ' ierr = ',ierr - if(present(stat)) then - stat = ierr - return - else - call die(myname_) - endif - endif - endif - - ! If ioGGrid%descend is associated on the root, prepare and - ! execute its broadcast - - if(HeaderAssoc(6)) then - - ! On the root, get the size of ioGGrid%descend(:) - - if(myID == root) then - DescendSize = size(ioGGrid%descend) - if(DescendSize<=0) call die(myname_,'size(ioGGrid%descend)<=0') - endif - - ! Broadcast the size of ioGGrid%descend(:) from the root. - - call MPI_BCAST(DescendSize, 1, MP_INTEGER, root, comm, ierr) - if(ierr /= 0) then - call MP_perr_die(myname_,'MPI_BCAST(DescendSize...',ierr) - endif - - ! Off the root, allocate ioGGrid%descend(:) - - if(myID /= root) then - allocate(ioGGrid%descend(DescendSize), stat=ierr) - if(ierr /= 0) then - write(stderr,*) myname_,':: ERROR in allocate(ioGGrid%descend...',& - ' ierr = ',ierr - call die(myname_) - endif - endif - - ! Finally, broadcast ioGGrid%descend(:) from the root - - call MPI_BCAST(ioGGrid%descend, DescendSize, MP_LOGICAL, root, & - comm, ierr) - if(ierr /= 0) then - call MP_perr_die(myname_,'MPI_BCAST(ioGGrid%descend...',ierr) - endif - - endif - - ! The broadcast of the GeneralGrid Header from the & - ! root is complete. - - - end subroutine bcastGeneralGridHeader_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: copyGeneralGridHeader_ - Copy the GeneralGrid Header. -! -! !DESCRIPTION: This routine copies the header information from the -! input {\tt GeneralGrid} argument {\tt iGGrid} to the output -! {\tt GeneralGrid} argument {\tt oGGrid}. The {\em header information} -! in a {\tt GeneralGrid} variable comprises all the non-{\tt AttrVect} -! components of the {\tt GeneralGrid}; that is, everything except the -! gridpoint coordinate, geometry, and index data stored in -! {\tt iGGrid\%data}. This information includes: -! \begin{enumerate} -! \item The coordinates in {\tt iGGrid\%coordinate\_list} -! \item The coordinate sort order in {\tt iGGrid\%coordinate\_sort\_order} -! \item The area/volume weights in {\tt iGGrid\%weight\_list} -! \item Other {\tt REAL} geometric information in {\tt iGGrid\%other\_list} -! \item Indexing information in {\tt iGGrid\%index\_list} -! \item The {\tt LOGICAL} descending/ascending order sort flags in -! {\tt iGGrid\%descend(:)}. -! \end{enumerate} -! -! !INTERFACE: - - subroutine copyGeneralGridHeader_(iGGrid, oGGrid) -! -! !USES: -! - use m_stdio - use m_die - - use m_List, only : List - use m_List, only : List_copy => copy - use m_List, only : List_allocated => allocated - use m_List, only : List_nullify => nullify - - use m_GeneralGrid, only : GeneralGrid - - implicit none - -! !INPUT PARAMETERS: -! - type(GeneralGrid), intent(in) :: iGGrid - -! !OUTPUT PARAMETERS: -! - type(GeneralGrid), intent(out) :: oGGrid - -! !REVISION HISTORY: -! 05Jun01 - J.W. Larson - Initial code. -! 08Aug01 - E.T. Ong - changed list assignments(=) -! to list copy. -! 05Aug02 - E. Ong - added association checking -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::copyGeneralGridHeader_' - - logical :: DescendAssoc - integer :: DescendSize, i, ierr - - ! Step 1. Copy GeneralGrid List attributes from iGGrid - ! to oGGrid. - - call List_nullify(oGGrid%coordinate_list) - call List_nullify(oGGrid%coordinate_sort_order) - call List_nullify(oGGrid%weight_list) - call List_nullify(oGGrid%other_list) - call List_nullify(oGGrid%index_list) - nullify(oGGrid%descend) - - if(List_allocated(iGGrid%coordinate_list)) then - call List_copy(oGGrid%coordinate_list,iGGrid%coordinate_list) - endif - - if(List_allocated(iGGrid%coordinate_sort_order)) then - call List_copy(oGGrid%coordinate_sort_order,iGGrid%coordinate_sort_order) - endif - - if(List_allocated(iGGrid%weight_list)) then - call List_copy(oGGrid%weight_list,iGGrid%weight_list) - endif - - if(List_allocated(iGGrid%other_list)) then - call List_copy(oGGrid%other_list,iGGrid%other_list) - endif - - if(List_allocated(iGGrid%index_list)) then - call List_copy(oGGrid%index_list,iGGrid%index_list) - endif - - DescendAssoc = associated(iGGrid%descend) - if(DescendAssoc) then - - DescendSize = size(iGGrid%descend) - allocate(oGGrid%descend(DescendSize), stat=ierr) - if(ierr /= 0) then - write(stderr,*) myname_,':: ERROR--allocate(iGGrid%descend(... failed.',& - ' ierr = ', ierr, 'DescendSize = ', DescendSize - call die(myname_) - endif - do i=1,DescendSize - oGGrid%descend(i) = iGGrid%descend(i) - end do - - endif - - ! The GeneralGrid header copy is now complete. - - end subroutine copyGeneralGridHeader_ - - end module m_GeneralGridComms - - - - - - - - - - - - - - - - - - - - - - - - diff --git a/cesm/models/utils/mct/mct/m_GlobalMap.F90 b/cesm/models/utils/mct/mct/m_GlobalMap.F90 deleted file mode 100644 index c4389c7..0000000 --- a/cesm/models/utils/mct/mct/m_GlobalMap.F90 +++ /dev/null @@ -1,672 +0,0 @@ -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!----------------------------------------------------------------------- -! CVS $Id$ -! CVS $Name$ -!BOP ------------------------------------------------------------------- -! -! !MODULE: m_GlobalMap - One-Dimensional Domain Decomposition Descriptor -! -! !DESCRIPTION: -! The {\tt GlobalMap} is a datatype used to store descriptors of a -! one-dimensional domain decomposition for a vector on an MPI communicator. -! It is defined with three assumptions: -! \begin{enumerate} -! \item Each process ID owns only one segment; -! \item No two segments in the decomposition overlap; and -! \item The segments are laid out in identical order to the MPI rank of -! each process participating in the decomposition. -! \end{enumerate} -! per process ID). It is the simpler of the two domain decomposition -! descriptors offerd by MCT (the other being the {\tt GlobalSegMap}). -! It consists of the following components: -! \begin{itemize} -! \item The MCT component identification number (see the module -! {\tt m\_MCTWorld} for more information about MCT's component model -! registry); -! \item The {\em global} number of elements in the distributed vector; -! \item The number of elements {\em stored locally}; -! \item The number of elements {\em stored on each process} on the -! communicator over which the vector is distributed; and -! \item The index of the elemnent {\em immediately before} the starting -! element of each local segment (this choice allows for direct use of -! this information with MPI's scatter and gather operations). We refer -! to this quantity as the {\em displacement} of the segment, a term used -! both here and in the definition of the MCT {\tt Navigator} datatype. -! \end{itemize} -! -! Both the segment displacement and length data are stored in arrays -! whose indices run from zero to $N-1$, where $N$ is the number of MPI -! processes on the communicator on which the {\tt GlobalMap} is defined. -! This is done so this information corresponds directly to the MPI process -! ID's on whihc the segments reside. -! -! This module contains the definition of the {\tt GlobalMap} datatype, -! all-processor and an on-root creation methods (both of which can be -! used to create a {\tt GlobalMap} on the local communicator), a creation -! method to create/propagate a {\tt GlobalMap} native to a remote -! communicator, a destruction method, and a variety of query methods. -! -! !INTERFACE: - - module m_GlobalMap - -! !USES -! No external modules are used in the declaration section of this module. - - implicit none - - private ! except - -! !PUBLIC TYPES: - - public :: GlobalMap ! The class data structure - - Type GlobalMap - integer :: comp_id ! Component ID number - integer :: gsize ! the Global size - integer :: lsize ! my local size - integer,dimension(:),pointer :: counts ! all local sizes - integer,dimension(:),pointer :: displs ! PE ordered locations - End Type GlobalMap - -! !PUBLIC MEMBER FUNCTIONS: - - public :: gsize - public :: lsize - public :: init - public :: init_remote - public :: clean - public :: rank - public :: bounds - public :: comp_id - - interface gsize; module procedure gsize_; end interface - interface lsize; module procedure lsize_; end interface - interface init ; module procedure & - initd_, & ! initialize from all PEs - initr_ ! initialize from the root - end interface - interface init_remote; module procedure init_remote_; end interface - interface clean; module procedure clean_; end interface - interface rank ; module procedure rank_ ; end interface - interface bounds; module procedure bounds_; end interface - interface comp_id ; module procedure comp_id_ ; end interface - -! !SEE ALSO: -! The MCT module m_MCTWorld for more information regarding component -! ID numbers. -! -! !REVISION HISTORY: -! 21Apr98 - Jing Guo - initial prototype/prolog/code -! 9Nov00 - J.W. Larson - added init_remote -! interface. -! 26Jan01 - J.W. Larson - added storage for -! component ID number GlobalMap%comp_id, and associated -! method comp_id_() -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname='MCT::m_GlobalMap' - - contains - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: initd_ - Collective Creation on the Local Communicator -! -! !DESCRIPTION: -! This routine creates the {\tt GlobalMap} {\tt GMap} from distributed -! data spread across the MPI communicatior associated with the input -! {\tt INTEGER} handle {\tt comm}. The {\tt INTEGER} input argument -! {\tt comp\_id} is used to define the MCT component ID for {\tt GMap}. -! The input {\tt INTEGER} argument {\tt ln} is the number of elements -! in the local vector segment. -! -! !INTERFACE: - - subroutine initd_(GMap, comp_id, ln, comm) - -! !USES: - - use m_mpif90 - use m_die - - implicit none - -! !INPUT PARAMETERS: - - integer, intent(in) :: comp_id ! Component ID - integer, intent(in) :: ln ! the local size - integer, intent(in) :: comm ! f90 MPI communicator - ! handle - -! !OUTPUT PARAMETERS: - - type(GlobalMap), intent(out) :: GMap - -! !SEE ALSO: -! The MCT module m_MCTWorld for more information regarding component -! ID numbers. -! -! !REVISION HISTORY: -! 21Apr98 - Jing Guo - initial prototype/prolog/code -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::initd_' - integer :: nPEs,myID,ier,l,i - - call MP_comm_size(comm,nPEs,ier) - if(ier /= 0) call MP_perr_die(myname_,'MP_comm_size()',ier) - - call MP_comm_rank(comm,myID,ier) - if(ier /= 0) call MP_perr_die(myname_,'MP_comm_rank()',ier) - - allocate(GMap%counts(0:nPEs-1),GMap%displs(0:nPEs-1),stat=ier) - if(ier /= 0) call die(myname_,'allocate()',ier) - -#ifdef MALL_ON - call mall_ci(size(transfer(GMap%counts,(/1/))),myname_) - call mall_ci(size(transfer(GMap%displs,(/1/))),myname_) -#endif - - call MPI_allgather(ln,1,MP_INTEGER,GMap%counts,1,MP_INTEGER,comm,ier) - if(ier/=0) call MP_perr_die(myname_,'MPI_allgather()',ier) - - l=0 - do i=0,nPEs-1 - GMap%displs(i)=l - l=l+GMap%counts(i) - end do - - GMap%lsize=GMap%counts(myID) ! the local size - GMap%gsize=l ! the global size - GMap%comp_id = comp_id ! the component ID number - - end subroutine initd_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: initr_ Create a GlobalMap from the Root Process -! -! !DESCRIPTION: -! This routine creates the {\tt GlobalMap} {\tt GMap}, and propagates -! it to all processes on the communicator associated with the MPI -! {\tt INTEGER} handle {\tt comm}. The input {\tt INTEGER} arguments -! {\tt comp\_id} (the MCT component ID number) and {\tt lns(:)} need -! only be valid on the process whose rank is equal to {\tt root} on -! {\tt comm}. The array {\tt lns(:)} should have length equal to the -! number of processes on {\tt comm}, and contains the length of each -! local segment. -! -! !INTERFACE: - - subroutine initr_(GMap, comp_id, lns, root, comm) - -! !USES: - - use m_mpif90 - use m_die - use m_stdio - - implicit none - -! !INPUT PARAMETERS: - - integer, intent(in) :: comp_id ! component ID number - integer, dimension(:), intent(in) :: lns ! segment lengths - integer, intent(in) :: root ! root process ID - integer, intent(in) :: comm ! communicator ID - -! !OUTPUT PARAMETERS: - - type(GlobalMap), intent(out) :: GMap - -! !SEE ALSO: -! The MCT module m_MCTWorld for more information regarding component -! ID numbers. -! -! !REVISION HISTORY: -! 29May98 - Jing Guo - initial prototype/prolog/code -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::initr_' - integer :: nPEs,myID,ier,l,i - - call MP_comm_size(comm,nPEs,ier) - if(ier /= 0) call MP_perr_die(myname_,'MP_comm_size()',ier) - - call MP_comm_rank(comm,myID,ier) - if(ier /= 0) call MP_perr_die(myname_,'MP_comm_rank()',ier) - - allocate(GMap%counts(0:nPEs-1),GMap%displs(0:nPEs-1),stat=ier) - if(ier /= 0) call die(myname_,'allocate()',ier) - -#ifdef MALL_ON - call mall_ci(size(transfer(GMap%counts,(/1/))),myname_) - call mall_ci(size(transfer(GMap%displs,(/1/))),myname_) -#endif - - if(myID == root) then - if(size(lns(:)) /= nPEs) then - write(stderr,'(2a,2(a,i4))') myname_, & - ': _root_ argument error', & - ', size(lns) =',size(lns), & - ', nPEs =',nPEs - call die(myname_) - endif - - GMap%counts(:)=lns(:) - endif - - call MPI_bcast(GMap%counts, nPEs, MP_INTEGER, root, comm, ier) - if(ier/=0) call MP_perr_die(myname_,'MPI_bcast()',ier) - - ! on each process, use GMap%counts(:) to compute GMap%displs(:) - - l=0 - do i=0,nPEs-1 - GMap%displs(i)=l - l=l+GMap%counts(i) - end do - - GMap%lsize=GMap%counts(myID) ! the local size - GMap%gsize=l ! the global size - - ! finally, set and broadcast the component ID number GMap%comp_id - - if(myID == root) GMap%comp_id = comp_id - - call MPI_bcast(GMap%comp_id,1,MP_INTEGER,root,comm,ier) - if(ier/=0) call MP_perr_die(myname_,'MPI_bcast()',ier) - - end subroutine initr_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: init_remote_ Initialize Remote GlobalMap from the Root -! -! !DESCRIPTION: -! This routine creates and propagates across the local communicator a -! {\tt GlobalMap} associated with a remote component. The controlling -! process in this operation has MPI process ID defined by the input -! {\tt INTEGER} argument {\tt my\_root}, and its MPI communinicator -! is defined by the input {\tt INTEGER} argument {\tt my\_comm}. The -! input {\tt INTEGER} argument {\tt remote\_npes} is the number of MPI -! processes on the remote component's communicator (which need be valid -! only on the process {\tt my\_root}). The input the {\tt INTEGER} -! array {\tt remote\_lns(:)}, and the {\tt INTEGER} argument -! {\tt remote\_comp\_id} need only be valid on the process -! whose rank on the communicator {\tt my\_comm} is {\tt my\_root}. The -! argument {\tt remote\_lns(:)} defines the vector segment length on each -! process of the remote component's communicator, and the argument -! {\tt remote\_comp\_id} defines the remote component's ID number in -! the MCT component registry {\tt MCTWorld}. -! -! !INTERFACE: - - subroutine init_remote_(GMap, remote_lns, remote_npes, my_root, & - my_comm, remote_comp_id) -! !USES: - - use m_mpif90 - use m_die - use m_stdio - - implicit none - -! !INPUT PARAMETERS: - - integer, dimension(:), intent(in) :: remote_lns - integer, intent(in) :: remote_npes - integer, intent(in) :: my_root - integer, intent(in) :: my_comm - integer, intent(in) :: remote_comp_id - -! !OUTPUT PARAMETERS: - - type(GlobalMap), intent(out) :: GMap - -! !SEE ALSO: -! The MCT module m_MCTWorld for more information regarding component -! ID numbers. -! -! !REVISION HISTORY: -! 8Nov00 - J.W. Larson - initial prototype -! 26Jan01 - J.W. Larson - slight change--remote -! communicator is replaced by remote component ID number -! in argument remote_comp_id. -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::init_remote_' - integer :: nPEs,myID,ier,l,i - - - ! Which processor am I on communicator my_comm? Store - ! the answer in myID: - - call MP_comm_rank(my_comm, myID, ier) - if(ier /= 0) call MP_perr_die(myname_,'MP_comm_rank()',ier) - - ! allocate counts and displacements component arrays - ! for the sake of compactness, store the value of remote_npes - ! in the more tersely named variable nPEs. - - if(myID == my_root) nPEs = remote_npes - - call MPI_bcast(nPEs, 1, MP_INTEGER, my_root, my_comm, ier) - if(ier/=0) call MP_perr_die(myname_,'MPI_bcast(nPEs...)',ier) - - allocate(GMap%counts(0:nPEs-1),GMap%displs(0:nPEs-1),stat=ier) - if(ier /= 0) call die(myname_,'allocate()',ier) - -#ifdef MALL_ON - call mall_ci(size(transfer(GMap%counts,(/1/))),myname_) - call mall_ci(size(transfer(GMap%displs,(/1/))),myname_) -#endif - - ! On the Root processor, check the size of remote_lns(:) - ! to see it is equal to nPEs, the number of remote processes, - ! then store it as GMap%counts and broadcast it. - - if(myID == my_root) then - if(size(remote_lns(:)) /= nPEs) then - write(stderr,'(2a,2(a,i4))') myname_, & - ': _root_ argument error', & - ', size(remote_lns) =',size(remote_lns), & - ', nPEs =',nPEs - call die(myname_) - endif - - GMap%counts(:)=remote_lns(:) - endif - - call MPI_bcast(GMap%counts, nPEs, MP_INTEGER, my_root, my_comm, ier) - if(ier/=0) call MP_perr_die(myname_,'MPI_bcast()',ier) - - ! Now, on each processor of my_comm, compute from - ! GMap%counts(:) the entries of GMap%displs(:) - - l=0 - do i=0,nPEs-1 - GMap%displs(i)=l - l=l+GMap%counts(i) - end do - - GMap%lsize = -1 ! In this case, the local size is invalid!!! - GMap%gsize = l ! the global size - - ! Finally, set GMap's component ID (recall only the value on - ! process my_root is valid). - - if(myID == my_root) GMap%comp_id = remote_comp_id - call MPI_bcast(GMap%comp_id, 1, MP_INTEGER, my_root, my_comm,ier) - if(ier/=0) call MP_perr_die(myname_,'MPI_bcast(GMap%comp_id...)',ier) - - end subroutine init_remote_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: clean_ - Destroy a GlobalMap -! -! !DESCRIPTION: -! This routine deallocates all allocated memory associated with the -! input/output {\tt GlobalMap} argument {\tt GMap}, and sets to zero -! all of its statically defined components. The success (failure) of -! this operation is signified by the zero (non-zero) value of the -! optional output {\tt INTEGER} argument {\tt stat}. -! -! !INTERFACE: - - subroutine clean_(GMap, stat) - -! !USES: - - use m_die - - implicit none - -! !INPUT/OUTPUT PARAMETERS: - - type(GlobalMap), intent(inout) :: GMap - -! !OUTPUT PARAMETERS: - - integer, optional, intent(out) :: stat - -! !REVISION HISTORY: -! 21Apr98 - Jing Guo - initial prototype/prolog/code -! 26Jan01 - J. Larson incorporated comp_id. -! 1Mar02 - E.T. Ong removed the die to prevent -! crashes and added stat argument. -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::clean_' - integer :: ier - - deallocate(GMap%counts,GMap%displs,stat=ier) - - if(present(stat)) then - stat=ier - else - if(ier /= 0) call warn(myname_,'deallocate(GMap%...)',ier) - endif - - if(ier == 0) then - -#ifdef MALL_ON - call mall_co(size(transfer(GMap%counts,(/1/))),myname_) - call mall_co(size(transfer(GMap%displs,(/1/))),myname_) -#endif - - endif - - GMap%lsize = 0 - GMap%gsize = 0 - GMap%comp_id = 0 - - end subroutine clean_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: lsize_ - Return Local Segment Length -! -! !DESCRIPTION: -! This {\tt INTEGER} function returns the length of the local vector -! segment as defined by the input {\tt GlobalMap} argument {\tt GMap}. - -! !INTERFACE: - - integer function lsize_(GMap) - -! !USES: - - implicit none - -! !INPUT PARAMETERS: - - type(GlobalMap), intent(in) :: GMap - -! !REVISION HISTORY: -! 21Apr98 - Jing Guo - initial prototype/prolog/code -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::lsize_' - - lsize_=GMap%lsize - - end function lsize_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: gsize_ - Return Global Vector Length -! -! !DESCRIPTION: -! This {\tt INTEGER} function returns the global length of a vector -! that is decomposed according to the input {\tt GlobalMap} argument -! {\tt GMap}. -! -! !INTERFACE: - - integer function gsize_(GMap) - -! !USES: - - implicit none - -! !INPUT PARAMETERS: - - type(GlobalMap), intent(in) :: GMap - - -! !REVISION HISTORY: -! 21Apr98 - Jing Guo - initial prototype/prolog/code -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::gsize_' - - gsize_=GMap%gsize - - end function gsize_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: rank_ - Process ID Location of a Given Vector Element -! -! !DESCRIPTION: -! This routine uses the input {\tt GlobalMap} argument {\tt GMap} to -! determine the process ID (on the communicator on which {\tt GMap} was -! defined) of the vector element with global index {\tt i\_g}. This -! process ID is returned in the output {\tt INTEGER} argument {\tt rank}. -! -! !INTERFACE: - - subroutine rank_(GMap, i_g, rank) - -! !USES: - - implicit none - -! !INPUT PARAMETERS: - - type(GlobalMap), intent(in) :: GMap - integer, intent(in) :: i_g - -! !OUTPUT PARAMETERS: - - integer, intent(out) :: rank - -! !REVISION HISTORY: -! 5May98 - Jing Guo - initial prototype/prolog/code -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::rank_' - integer :: i,ilc,ile - - rank=-1 ! if nowhere fits - do i=0,size(GMap%displs)-1 - ilc=GMap%displs(i) - ile=ilc+GMap%counts(i) - - ! If i_g in (ilc,ile]. Note that i_g := [1:..] - - if(ilc < i_g .and. i_g <= ile) then - rank=i - return - endif - end do - - end subroutine rank_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: bounds_ - First/Last Global Indicies for a Process' Segment -! -! !DESCRIPTION: -! This routine takes as input a process ID (defined by the input -! {\tt INTEGER} argument {\tt pe\_no}), examines the input {\tt GlobalMap} -! argument {\tt GMap}, and returns the global indices for the first and -! last elements of the segment owned by this process in the output -! {\tt INTEGER} arguments {\tt lbnd} and {\tt ubnd}, respectively. -! -! !INTERFACE: - - subroutine bounds_(GMap, pe_no, lbnd, ubnd) - -! !USES: - - implicit none - -! !INPUT PARAMETERS: - - type(GlobalMap), intent(in) :: GMap - integer, intent(in) :: pe_no - -! !OUTPUT PARAMETERS: - - integer, intent(out) :: lbnd - integer, intent(out) :: ubnd - -! !REVISION HISTORY: -! 30Jan01 - J. Larson - initial code -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::bounds_' - - lbnd = GMap%displs(pe_no) + 1 - ubnd = lbnd + GMap%counts(pe_no) - 1 - - end subroutine bounds_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: comp_id_ - Return the Component ID Number -! -! !DESCRIPTION: -! This {\tt INTEGER} query function returns the MCT component ID number -! stored in the input {\tt GlobalMap} argument {\tt GMap}. -! -! !INTERFACE: - - integer function comp_id_(GMap) - -! !USES: - - implicit none - -! !INPUT PARAMETERS: - - type(GlobalMap), intent(in) :: GMap - -! !SEE ALSO: -! The MCT module m_MCTWorld for more information regarding component -! ID numbers. -! -! !REVISION HISTORY: -! 25Jan02 - J. Larson - initial version -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::comp_id_' - - comp_id_ = GMap%comp_id - - end function comp_id_ - - end module m_GlobalMap diff --git a/cesm/models/utils/mct/mct/m_GlobalSegMap.F90 b/cesm/models/utils/mct/mct/m_GlobalSegMap.F90 deleted file mode 100644 index 7a81eaa..0000000 --- a/cesm/models/utils/mct/mct/m_GlobalSegMap.F90 +++ /dev/null @@ -1,2527 +0,0 @@ -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!----------------------------------------------------------------------- -! CVS $Id: m_GlobalSegMap.F90,v 1.56 2009-03-17 16:51:49 jacob Exp $ -! CVS $Name: $ -!BOP ------------------------------------------------------------------- -! -! !MODULE: m_GlobalSegMap - a nontrivial 1-D decomposition of an array. -! -! !DESCRIPTION: -! Consider the problem of the 1-dimensional decomposition of an array -! across multiple processes. If each process owns only one contiguous -! segment, then the {\tt GlobalMap} (see {\tt m\_GlobalMap} or details) -! is sufficient to describe the decomposition. If, however, each -! process owns multiple, non-adjacent segments of the array, a more -! sophisticated approach is needed. The {\tt GlobalSegMap} data type -! allows one to describe a one-dimensional decomposition of an array -! with each process owning multiple, non-adjacent segments of the array. -! -! In the current implementation of the {\tt GlobalSegMap}, there is no -! santity check to guarantee that -!$${\tt GlobalSegMap\%gsize} = \sum_{{\tt i}=1}^{\tt ngseg} -! {\tt GlobalSegMap\%length(i)} . $$ -! The reason we have not implemented such a check is to allow the user -! to use the {\tt GlobalSegMap} type to support decompositions of both -! {\em haloed} and {\em masked} data. -! -! !INTERFACE: - - module m_GlobalSegMap - - implicit none - - private ! except - -! !PUBLIC MEMBER FUNCTIONS: - - public :: GlobalSegMap ! The class data structure - public :: init ! Create - public :: clean ! Destroy - public :: comp_id ! Return component ID number - public :: gsize ! Return global vector size (excl. halos) - public :: GlobalStorage ! Return total number of points in map, - ! including halo points (if present). - public :: ProcessStorage ! Return local storage on a given process. - public :: OrderedPoints ! Return grid points of a given process in - ! MCT-assumed order. - public :: lsize ! Return local--that is, on-process--storage - ! size (incl. halos) - public :: ngseg ! Return global number of segments - public :: nlseg ! Return local number of segments - public :: max_nlseg ! Return max local number of segments - public :: active_pes ! Return number of pes with at least 1 - ! datum, and if requested, a list of them. - public :: peLocs ! Given an input list of point indices, - ! return its (unique) process ID. - public :: haloed ! Is the input GlobalSegMap haloed? - public :: rank ! Rank which process owns a datum - public :: Sort ! compute index permutation to re-order - ! GlobalSegMap%start, GlobalSegMap%length, - ! and GlobalSegMap%pe_loc - public :: Permute ! apply index permutation to re-order - ! GlobalSegMap%start, GlobalSegMap%length, - ! and GlobalSegMap%pe_loc - public :: SortPermute ! compute index permutation and apply it to - ! re-order the GlobalSegMap components - ! GlobalSegMap%start, GlobalSegMap%length, - ! and GlobalSegMap%pe_loc - public :: increasing ! Are the indices for each pe strictly - ! increasing? - public :: copy ! Copy the gsmap - public :: print ! Print the contents of the GSMap - -! !PUBLIC TYPES: - - type GlobalSegMap -#ifdef SEQUENCE - sequence -#endif - integer :: comp_id ! Component ID number - integer :: ngseg ! No. of Global segments - integer :: gsize ! No. of Global elements - integer,dimension(:),pointer :: start ! global seg. start index - integer,dimension(:),pointer :: length ! segment lengths - integer,dimension(:),pointer :: pe_loc ! PE locations - end type GlobalSegMap - - interface init ; module procedure & - initd_, & ! initialize from all PEs - initr_, & ! initialize from the root - initp_, & ! initialize in parallel from replicated arrays - initp1_, & ! initialize in parallel from 1 replicated array - initp0_, & ! null constructor using replicated data - init_index_ ! initialize from local index arrays - end interface - - interface clean ; module procedure clean_ ; end interface - interface comp_id ; module procedure comp_id_ ; end interface - interface gsize ; module procedure gsize_ ; end interface - interface GlobalStorage ; module procedure & - GlobalStorage_ - end interface - interface ProcessStorage ; module procedure & - ProcessStorage_ - end interface - interface OrderedPoints ; module procedure & - OrderedPoints_ - end interface - interface lsize ; module procedure lsize_ ; end interface - interface ngseg ; module procedure ngseg_ ; end interface - interface nlseg ; module procedure nlseg_ ; end interface - interface max_nlseg ; module procedure max_nlseg_ ; end interface - interface active_pes ; module procedure active_pes_ ; end interface - interface peLocs ; module procedure peLocs_ ; end interface - interface haloed ; module procedure haloed_ ; end interface - interface rank ; module procedure & - rank1_ , & ! single rank case - rankm_ ! degenerate (multiple) ranks for halo case - end interface - interface Sort ; module procedure Sort_ ; end interface - interface Permute ; module procedure & - PermuteInPlace_ - end interface - interface SortPermute ; module procedure & - SortPermuteInPlace_ - end interface - interface increasing ; module procedure increasing_ ; end interface - interface copy ; module procedure copy_ ; end interface - interface print ; module procedure & - print_ ,& - printFromRootnp_ - end interface - - -! !REVISION HISTORY: -! 28Sep00 - J.W. Larson - initial prototype -! 26Jan01 - J.W. Larson - replaced the component -! GlobalSegMap%comm with GlobalSegMap%comp_id. -! 06Feb01 - J.W. Larson - removed the -! GlobalSegMap%lsize component. Also, added the -! GlobalStorage query function. -! 24Feb01 - J.W. Larson - Added the replicated -! initialization routines initp_() and initp1(). -! 25Feb01 - J.W. Larson - Added the routine -! ProcessStorage_(). -! 18Apr01 - J.W. Larson - Added the routine -! peLocs(). -! 26Apr01 - R. Jacob - Added the routine -! OrderedPoints_(). -! 03Aug01 - E. Ong - In initd_, call initr_ -! with actual shaped arguments on non-root processes to satisfy -! F90 standard. See comments in initd. -! 18Oct01 - J.W. Larson - Added the routine -! bcast(), and also cleaned up prologues. -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname='m_GlobalSegMap' - - contains - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: initd_ - define the map from distributed data -! -! !DESCRIPTION: -! This routine takes the {\em scattered} input {\tt INTEGER} arrays -! {\tt start}, {\tt length}, and {\tt pe\_loc}, gathers these data to -! the {\tt root} process, and from them creates a {\em global} set of -! segment information for the output {\tt GlobalSegMap} argument -! {\tt GSMap}. The input {\tt INTEGER} arguments {\tt comp\_id}, -! {\tt gsize} provide the {\tt GlobalSegMap} component ID number and -! global grid size, respectively. The input argument {\tt my\_comm} is -! the F90 {\tt INTEGER} handle for the MPI communicator. If the input -! arrays are overdimensioned, optional argument {\em numel} can be -! used to specify how many elements should be used. -! -! -! !INTERFACE: - - subroutine initd_(GSMap, start, length, root, my_comm, & - comp_id, pe_loc, gsize, numel) - -! -! !USES: -! - use m_mpif90 - use m_die - use m_stdio - use m_FcComms, only : fc_gather_int, fc_gatherv_int - - implicit none - -! !INPUT PARAMETERS: - - integer,dimension(:),intent(in) :: start ! segment local start - ! indices - integer,dimension(:),intent(in) :: length ! segment local lengths - integer,intent(in) :: root ! root on my_com - integer,intent(in) :: my_comm ! local communicatior - integer,intent(in) :: comp_id ! component model ID - integer,dimension(:), pointer, optional :: pe_loc ! process location - integer,intent(in), optional :: gsize ! global vector size - ! (optional). It can - ! be computed by this - ! routine if no haloing - ! is assumed. - integer,intent(in), optional :: numel ! specify number of elements - ! to use in start, length - -! !OUTPUT PARAMETERS: - - type(GlobalSegMap),intent(out) :: GSMap ! Output GlobalSegMap - -! !REVISION HISTORY: -! 29Sep00 - J.W. Larson - initial prototype -! 14Nov00 - J.W. Larson - final working version -! 09Jan01 - J.W. Larson - repaired: a subtle -! bug concerning the usage of the argument pe_loc (result -! was the new pointer variable my_pe_loc); a mistake in -! the tag arguments to MPI_IRECV; a bug in the declaration -! of the array status used by MPI_WAITALL. -! 26Jan01 - J.W. Larson - replaced optional -! argument gsm_comm with required argument comp_id. -! 23Sep02 - Add optional argument numel to allow start, length -! arrays to be overdimensioned. -! 31Jan09 - P.H. Worley - replaced irecv/send/waitall -! logic with calls to flow controlled gather routines -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::initd_' - integer :: nPEs, myID, ier, l, i - integer :: ngseg ! number of global segments - integer :: nlseg ! number of local segments - integer :: nlseg_tmp(1) ! workaround for explicit interface expecting an array - - ! arrays allocated on the root to which data are gathered - integer, dimension(:), allocatable :: root_start, root_length, root_pe_loc - ! arrays allocated on the root to coordinate gathering of - ! data and non-blocking receives by the root - integer, dimension(:), allocatable :: counts, displs - ! data and non-blocking receives by the root - integer, dimension(:), pointer :: my_pe_loc - - ! Determine local process ID: - - call MP_COMM_RANK(my_comm, myID, ier) - - if(ier /= 0) call MP_perr_die(myname_,'MP_comm_rank()',ier) - - - ! Check consistency of sizes of input arrays: - - if(size(length) /= size(start)) then - ier = -1 - call die(myname_,'length/start array size mismatch',ier) - endif - - if(present(pe_loc)) then - if(size(pe_loc) /= size(start)) then - ier = -1 - call die(myname_,'pe_loc/start array size mismatch',ier) - endif - endif - - ! Store in the variable nlseg the local size - ! array start(:) - - if(present(numel)) then - nlseg=numel - else - nlseg = size(start) - endif - - ! If the argument pe_loc is not present, then we are - ! initializing the GlobalSegMap on the communicator - ! my_comm. We will need pe_loc to be allocated and - ! with local size given by the input value of nlseg, - ! and then initialize it with the local process id myID. - - if(present(pe_loc)) then - my_pe_loc => pe_loc - else - allocate(my_pe_loc(nlseg), stat=ier) - if(ier /= 0) call die(myname_,'allocate(my_pe_loc)',ier) - my_pe_loc = myID - endif - - call MPI_COMM_SIZE(my_comm, npes, ier) - if(ier /= 0) call MP_perr_die(myname_,'MPI_COMM_SIZE()',ier) - - ! Allocate an array of displacements (displs) and counts - ! to hold the local values of nlseg on the root - - if(myID == root) then - allocate(counts(0:npes-1), displs(0:npes-1), stat=ier) - if (ier /= 0) then - call die(myname_, 'allocate(counts,...',ier) - endif - else - allocate(counts(1), displs(1), stat=ier) - if (ier /= 0) then - call die(myname_, 'allocate(counts,...',ier) - endif - endif - - ! Send local number of segments to the root. - - nlseg_tmp(1) = nlseg - call fc_gather_int(nlseg_tmp, 1, MP_INTEGER, counts, 1, MP_INTEGER, & - root, my_comm) - - ! On the root compute the value of ngseg, along with - ! the entries of counts and displs. - - if(myID == root) then - ngseg = 0 - do i=0,npes-1 - ngseg = ngseg + counts(i) - if(i == 0) then - displs(i) = 0 - else - displs(i) = displs(i-1) + counts(i-1) - endif - end do - endif - - ! Now only the root has the correct value of ngseg. - - ! On the root, allocate memory for the arrays root_start, - ! and root_length. If the argument pe_loc is present, - ! allocate root_pe_loc, too. - - ! Non-root processes call initr_ with root_start, root_length, - ! and root_pe_loc, although these arguments are not used in the - ! subroutine. Since these correspond to dummy shaped array arguments - ! in initr_, the Fortran 90 standard dictates that the actual - ! arguments must contain complete shape information. Therefore, - ! these array arguments must be allocated on all processes. - - if(myID == root) then - - allocate(root_start(ngseg), root_length(ngseg), & - root_pe_loc(ngseg), stat=ier) - if (ier /= 0) then - call die(myname_, 'allocate(root_start...',ier) - endif - - else - - allocate(root_start(1), root_length(1), & - root_pe_loc(1), stat=ier) - if (ier /= 0) then - call die(myname_, 'allocate((non)root_start...',ier) - endif - - endif - - ! Now, each process sends its values of start(:) to fill in - ! the appropriate portion of root_start(:y) on the root. - - call fc_gatherv_int(start, nlseg, MP_INTEGER, & - root_start, counts, displs, MP_INTEGER, & - root, my_comm) - - ! Next, each process sends its values of length(:) to fill in - ! the appropriate portion of root_length(:) on the root. - - call fc_gatherv_int(length, nlseg, MP_INTEGER, & - root_length, counts, displs, MP_INTEGER, & - root, my_comm) - - ! Finally, if the argument pe_loc is present, each process sends - ! its values of pe_loc(:) to fill in the appropriate portion of - ! root_pe_loc(:) on the root. - - call fc_gatherv_int(my_pe_loc, nlseg, MP_INTEGER, & - root_pe_loc, counts, displs, MP_INTEGER, & - root, my_comm) - - call MPI_BARRIER(my_comm, ier) - if(ier /= 0) call MP_perr_die(myname_,'MPI_BARRIER my_pe_loc',ier) - - ! Now, we have everything on the root needed to call initr_(). - - if(present(gsize)) then - call initr_(GSMap, ngseg, root_start, root_length, & - root_pe_loc, root, my_comm, comp_id, gsize) - else - call initr_(GSMap, ngseg, root_start, root_length, & - root_pe_loc, root, my_comm, comp_id) - endif - - - ! Clean up the array pe_loc(:) if it was allocated - - if(present(pe_loc)) then - nullify(my_pe_loc) - else - deallocate(my_pe_loc, stat=ier) - if(ier /= 0) call die(myname_, 'deallocate(my_pe_loc)', ier) - endif - - ! Clean up the arrays root_start(:), et cetera... - - deallocate(root_start, root_length, root_pe_loc, stat=ier) - if(ier /= 0) then - call die(myname_, 'deallocate(root_start,...)', ier) - endif - - ! Clean up the arrays counts(:) and displs(:) - - deallocate(counts, displs, stat=ier) - if(ier /= 0) then - call die(myname_, 'deallocate(counts,...)', ier) - endif - - end subroutine initd_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: initr_ initialize the map from the root -! -! !DESCRIPTION: -! This routine takes the input {\tt INTEGER} arrays {\tt start}, -! {\tt length}, and {\tt pe\_loc} (all valid only on the {\tt root} -! process), and from them creates a {\em global} set of segment -! information for the output {\tt GlobalSegMap} argument -! {\tt GSMap}. The input {\tt INTEGER} arguments {\tt ngseg}, -! {\tt comp\_id}, {\tt gsize} (again, valid only on the {\tt root} -! process) provide the {\tt GlobalSegMap} global segment count, component -! ID number, and global grid size, respectively. The input argument -! {\tt my\_comm} is the F90 {\tt INTEGER} handle for the MPI communicator. -! -! !INTERFACE: - - subroutine initr_(GSMap, ngseg, start, length, pe_loc, root, & - my_comm, comp_id, gsize) -! -! !USES: -! - use m_mpif90 - use m_die - use m_stdio - - implicit none - -! !INPUT PARAMETERS: - - integer, intent(in) :: ngseg ! no. of global segments - integer,dimension(:),intent(in) :: start ! segment local start index - integer,dimension(:),intent(in) :: length ! the distributed sizes - integer,dimension(:),intent(in) :: pe_loc ! process location - integer,intent(in) :: root ! root on my_com - integer,intent(in) :: my_comm ! local communicatior - integer,intent(in) :: comp_id ! component id number - integer,intent(in), optional :: gsize ! global vector size - ! (optional). It can - ! be computed by this - ! routine if no haloing - ! is assumed. - -! !OUTPUT PARAMETERS: - - type(GlobalSegMap),intent(out) :: GSMap ! Output GlobalSegMap - -! !REVISION HISTORY: -! 29Sep00 - J.W. Larson - initial prototype -! 09Nov00 - J.W. Larson - final working version -! 10Jan01 - J.W. Larson - minor bug fix -! 12Jan01 - J.W. Larson - minor bug fix regarding -! disparities in ngseg on -! the root and other -! processes -! 26Jan01 - J.W. Larson - replaced optional -! argument gsm_comm with required argument comp_id. -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::initr_' - integer :: myID,ier,l,i - - ! Determine the local process ID myID: - - call MPI_COMM_RANK(my_comm, myID, ier) - if(ier/=0) call MP_perr_die(myname_,'MPI_COMM_RANK()',ier) - - ! Argument checking: check to make sure the arrays - ! start, length, and pe_loc each have ngseg elements. - ! If not, stop with an error. This is done on the - ! root process since it owns the initialization data. - - if(myID == root) then - if( size(start(:)) /= ngseg ) then - write(stderr,'(2a,2(a,i4))') myname_, & - ': _root_ argument error', & - ', size(start) =',size(start), & - ', ngseg =',ngseg - call die(myname_) - endif - if( size(length(:)) /= ngseg ) then - write(stderr,'(2a,2(a,i4))') myname_, & - ': _root_ argument error', & - ', size(length) =',size(length), & - ', ngseg =',ngseg - call die(myname_) - endif - if( size(pe_loc(:)) /= ngseg ) then - write(stderr,'(2a,2(a,i4))') myname_, & - ': _root_ argument error', & - ', size(pe_loc) =',size(pe_loc), & - ', ngseg =',ngseg - call die(myname_) - endif - endif - - ! Initialize GSMap%ngseg and GSMap%comp_id on the root: - - if(myID == root) then - GSMap%ngseg = ngseg - GSMap%comp_id = comp_id - endif - - ! Broadcast the value of GSMap%ngseg - - call MPI_BCAST(GSMap%ngseg, 1, MP_INTEGER, root, my_comm, ier) - if(ier/=0) call MP_perr_die(myname_,'MPI_BCAST(GSmap%ngseg)',ier) - - ! Broadcast the value of GSMap%comp_id - - call MPI_BCAST(GSMap%comp_id, 1, MP_INTEGER, root, my_comm, ier) - if(ier/=0) call MP_perr_die(myname_,'MPI_BCAST(GSmap%comp_id)',ier) - - ! Allocate the components GSMap%start(:), GSMap%length(:), - ! and GSMap%pe_loc(:) - - allocate(GSMap%start(GSMap%ngseg), GSMap%length(GSMap%ngseg), & - GSMap%pe_loc(GSMap%ngseg), stat = ier) - if(ier/=0) call die(myname_,'allocate(GSmap%start(:),...',ier) - -#ifdef MALL_ON - call mall_ci(size(transfer(GSMap%start,(/1/))),myname_) - call mall_ci(size(transfer(GSMap%length,(/1/))),myname_) - call mall_ci(size(transfer(GSMap%pe_loc,(/1/))),myname_) -#endif - - ! On the root process, initialize GSMap%start(:), GSMap%length(:), - ! and GSMap%pe_loc(:) with the data contained in start(:), - ! length(:) and pe_loc(:), respectively - - if(myID == root) then - GSMap%start(1:GSMap%ngseg) = start(1:GSMap%ngseg) - GSMap%length(1:GSMap%ngseg) = length(1:GSMap%ngseg) - GSMap%pe_loc(1:GSMap%ngseg) = pe_loc(1:GSMap%ngseg) - endif - - ! Broadcast the root values of GSMap%start(:), GSMap%length(:), - ! and GSMap%pe_loc(:) - - call MPI_BCAST(GSMap%start, GSMap%ngseg, MP_INTEGER, root, my_comm, ier) - if(ier/=0) call MP_perr_die(myname_,'MPI_BCAST(GSMap%start)',ier) - - call MPI_BCAST(GSMap%length, GSMap%ngseg, MP_INTEGER, root, my_comm, ier) - if(ier/=0) call MP_perr_die(myname_,'MPI_BCAST(GSMap%length)',ier) - - call MPI_BCAST(GSMap%pe_loc, GSMap%ngseg, MP_INTEGER, root, my_comm, ier) - if(ier/=0) call MP_perr_die(myname_,'MPI_BCAST(GSMap%pe_loc)',ier) - - ! If the argument gsize is present, use the root value to - ! set GSMap%gsize and broadcast it. If it is not present, - ! this will be computed by summing the entries of GSM%length(:). - ! Again, note that if one is storing halo points, the sum will - ! produce a result larger than the actual global vector. If - ! halo points are to be used in the mapping we advise strongly - ! that the user specify the value gsize as an argument. - - if(present(gsize)) then - if(myID == root) then - GSMap%gsize = gsize - endif - call MPI_BCAST(GSMap%gsize, 1, MP_INTEGER, root, my_comm, ier) - if(ier/=0) call MP_perr_die(myname_, 'MPI_BCAST(GSMap%gsize)', ier) - else - GSMap%gsize = 0 - do i=1,GSMap%ngseg - GSMap%gsize = GSMap%gsize + GSMap%length(i) - end do - endif - - end subroutine initr_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: initp_ - define the map from replicated data. -! -! !DESCRIPTION: -! -! The routine {\tt initp\_()} takes the input {\em replicated} arguments -! {\tt comp\_id}, {\tt ngseg}, {\tt gsize}, {\tt start(:)}, -! {\tt length(:)}, and {\tt pe\_loc(:)}, and uses them to initialize an -! output {\tt GlobalSegMap} {\tt GSMap}. This routine operates on the -! assumption that these data are replicated across the communicator on -! which the {\tt GlobalSegMap} is being created. -! -! !INTERFACE: - - subroutine initp_(GSMap, comp_id, ngseg, gsize, start, length, pe_loc) - -! -! !USES: -! - use m_mpif90 - use m_die, only : die - use m_stdio - - implicit none - -! !INPUT PARAMETERS: - - integer,intent(in) :: comp_id ! component model ID - integer,intent(in) :: ngseg ! global number of segments - integer,intent(in) :: gsize ! global vector size - integer,dimension(:),intent(in) :: start ! segment local start index - integer,dimension(:),intent(in) :: length ! the distributed sizes - integer,dimension(:),intent(in) :: pe_loc ! process location - -! !OUTPUT PARAMETERS: - - type(GlobalSegMap),intent(out) :: GSMap ! Output GlobalSegMap - -! !REVISION HISTORY: -! 24Feb01 - J.W. Larson - Initial version. -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::initp_' - integer :: ierr, n - - ! Argument Checks -- Is comp_id positive? - - if(comp_id <= 0) then - call die(myname_,'non-positive value of comp_id',comp_id) - endif - - ! Is gsize positive? - - if(gsize <= 0) then - call die(myname_,'non-positive value of gsize',gsize) - endif - - - ! Is ngseg positive? - - if(ngseg <= 0) then - call die(myname_,'non-positive value of ngseg',ngseg) - endif - - ! Are the arrays start(:), length(:), and pe_loc(:) the - !correct size? - - if(size(start) /= ngseg) then - call die(myname_,'start(:)/ngseg size mismatch',ngseg) - endif - if (size(length) /= ngseg) then - call die(myname_,'length(:)/ngseg size mismatch',ngseg) - endif - if (size(pe_loc) /= ngseg) then - call die(myname_,'pe_loc(:)/ngseg size mismatch',ngseg) - endif - - ! Allocate index and location arrays for GSMap: - - allocate(GSMap%start(ngseg), GSMap%length(ngseg), GSMap%pe_loc(ngseg), & - stat = ierr) - if (ierr /= 0) then - call die(myname_,'allocate(GSMap%start...',ngseg) - endif - - ! Assign the components of GSMap: - - GSMap%comp_id = comp_id - GSMap%ngseg = ngseg - GSMap%gsize = gsize - - do n=1,ngseg - GSMap%start(n) = start(n) - GSMap%length(n) = length(n) - GSMap%pe_loc(n) = pe_loc(n) - end do - - end subroutine initp_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: initp1_ - define the map from replicated data using 1 array. -! -! !DESCRIPTION: -! -! The routine {\tt initp1\_()} takes the input {\em replicated} arguments -! {\tt comp\_id}, {\tt ngseg}, {\tt gsize}, and {\tt all\_arrays(:)}, -! and uses them to initialize an output {\tt GlobalSegMap} {\tt GSMap}. -! This routine operates on the assumption that these data are replicated -! across the communicator on which the {\tt GlobalSegMap} is being created. -! The input array {\tt all\_arrays(:)} should be of length {\tt 2 * ngseg}, -! and is packed so that -! $$ {\tt all\_arrays(1:ngseg)} = {\tt GSMap\%start(1:ngseg)} $$ -! $$ {\tt all\_arrays(ngseg+1:2*ngseg)} = {\tt GSMap\%length(1:ngseg)} $$ -! $$ {\tt all\_arrays(2*ngseg+1:3*ngseg)} = {\tt GSMap\%pe\_loc(1:ngseg)} .$$ -! -! !INTERFACE: - - subroutine initp1_(GSMap, comp_id, ngseg, gsize, all_arrays) - -! -! !USES: -! - use m_mpif90 - use m_die, only : die - use m_stdio - - implicit none - -! !INPUT PARAMETERS: - - integer,intent(in) :: comp_id ! component model ID - integer,intent(in) :: ngseg ! global no. of segments - integer,intent(in) :: gsize ! global vector size - integer,dimension(:),intent(in) :: all_arrays ! packed array of length - ! 3*ngseg containing (in - ! this order): start(:), - ! length(:), and pe_loc(:) - -! !OUTPUT PARAMETERS: - - type(GlobalSegMap),intent(out) :: GSMap ! Output GlobalSegMap - -! !REVISION HISTORY: -! 24Feb01 - J.W. Larson - Initial version. -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::initp1_' - integer :: ierr, n - - ! Argument Checks -- Is comp_id positive? - - if(comp_id <= 0) then - call die(myname_,'non-positive value of comp_id',comp_id) - endif - - ! Is gsize positive? - - if(gsize <= 0) then - call die(myname_,'non-positive value of gsize',gsize) - endif - - - ! Is ngseg positive? - - if(ngseg <= 0) then - call die(myname_,'non-positive value of ngseg',ngseg) - endif - - ! Is the array all_arrays(:) the right length? - - if(size(all_arrays) /= 3*ngseg) then - call die(myname_,'all_arrays(:)/3*ngseg size mismatch',ngseg) - endif - - ! Allocate index and location arrays for GSMap: - - allocate(GSMap%start(ngseg), GSMap%length(ngseg), GSMap%pe_loc(ngseg), & - stat = ierr) - if (ierr /= 0) then - call die(myname_,'allocate(GSMap%start...',ngseg) - endif - - ! Assign the components of GSMap: - - GSMap%comp_id = comp_id - GSMap%ngseg = ngseg - GSMap%gsize = gsize - - do n=1,ngseg - GSMap%start(n) = all_arrays(n) - GSMap%length(n) = all_arrays(ngseg + n) - GSMap%pe_loc(n) = all_arrays(2*ngseg + n) - end do - - end subroutine initp1_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: initp0_ - Null Constructor Using Replicated Data -! -! !DESCRIPTION: -! -! The routine {\tt initp0\_()} takes the input {\em replicated} arguments -! {\tt comp\_id}, {\tt ngseg}, {\tt gsize}, and uses them perform null -! construction of the output {\tt GlobalSegMap} {\tt GSMap}. This is a -! null constructor in the sense that we are not filling in the segment -! information arrays. This routine operates on the assumption that these -! data are replicated across the communicator on which the -! {\tt GlobalSegMap} is being created. -! -! !INTERFACE: - - subroutine initp0_(GSMap, comp_id, ngseg, gsize) - -! -! !USES: -! - use m_die, only : die - use m_stdio - - implicit none - -! !INPUT PARAMETERS: - - integer,intent(in) :: comp_id ! component model ID - integer,intent(in) :: ngseg ! global number of segments - integer,intent(in) :: gsize ! global vector size - -! !OUTPUT PARAMETERS: - - type(GlobalSegMap),intent(out) :: GSMap ! Output GlobalSegMap - -! !REVISION HISTORY: -! 13Aug03 - J.W. Larson - Initial version. -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::initp0_' - - integer :: ierr - - nullify(GSMap%start) - nullify(GSMap%length) - nullify(GSMap%pe_loc) - - GSMap%comp_id = comp_id - GSMap%ngseg = ngseg - GSMap%gsize = gsize - - allocate(GSMap%start(ngseg), GSMap%length(ngseg), GSMap%pe_loc(ngseg), & - stat=ierr) - if(ierr /= 0) then - write(stderr,'(3a,i8)') myname_, & - ':: FATAL--allocate of segment information storage space failed.', & - ' ierr = ',ierr - call die(myname_) - endif - - end subroutine initp0_ - - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: init_index_ - initialize GSM from local index arrays -! -! !DESCRIPTION: -! -! The routine {\tt init\_index\_()} takes a local array of indices -! {\tt lindx} and uses them to create a {\tt GlobalSegMap}. -! {\tt lindx} is parsed to determine the lengths of the runs, and -! then a call is made to {\tt initd\_}. The optional argument -! {\tt lsize} can be used if only the first {\tt lsize} number -! of elements of {\tt lindx} are valid. The optional argument -! {\tt gsize} is used to specify the global number of unique points -! if this can not be determined from the collective {\tt lindx}. -! -! -! !INTERFACE: - - subroutine init_index_(GSMap, lindx, my_comm, comp_id, lsize, gsize) - -! -! !USES: -! - -! use m_GlobalSegMap,only: GlobalSegMap -! use m_GlobalSegMap,only: MCT_GSMap_init => init - -! use shr_sys_mod - - use m_die - implicit none - -! !INPUT PARAMETERS: - - integer , dimension(:),intent(in) :: lindx ! index buffer - integer , intent(in) :: my_comm ! mpi communicator group (mine) - integer , intent(in) :: comp_id ! component id (mine) - - integer , intent(in),optional :: lsize ! size of index buffer - integer , intent(in),optional :: gsize ! global vector size - -! !OUTPUT PARAMETERS: - - type(GlobalSegMap),intent(out) :: GSMap ! Output GlobalSegMap - - -! !REVISION HISTORY: -! 30Jul02 - T. Craig - initial version in cpl6. -! 17Nov05 - R. Loy - install into MCT -! 18Nov05 - R. Loy - make lsize optional -! 25Jul06 - R. Loy - error check on lindex/alloc/dealloc -!EOP ___________________________________________________________________ - - - !--- local --- - - character(len=*),parameter :: myname_=myname//'::init_index_' - - integer :: i,j,k,n ! generic indicies - integer :: nseg ! counts number of segments for GSMap - integer,allocatable :: start(:) ! used to init GSMap - integer,allocatable :: count(:) ! used to init GSMap - integer,parameter :: pid0=0 ! mpi process id for root pe - integer,parameter :: debug=0 ! - - integer rank,ierr - integer mysize - - - if (present(lsize)) then - mysize=lsize - else - mysize=size(lindx) - endif - - if (mysize<0) call die(myname_, & - 'lindx size is negative (you may have run out of points)') - -!! -!! Special case if this processor doesn't have any data indices -!! - if (mysize==0) then - allocate(start(0),count(0),stat=ierr) - if(ierr/=0) call die(myname_,'allocate(start,count)',ierr) - - nseg=0 - else - - call MPI_COMM_RANK(my_comm,rank, ierr) - - ! compute segment's start indicies and length counts - - ! first pass - count how many runs of consecutive numbers - - nseg=1 - do n = 2,mysize - i = lindx(n-1) - j = lindx(n) - if ( j-i /= 1) nseg=nseg+1 - end do - - allocate(start(nseg),count(nseg),stat=ierr) - if(ierr/=0) call die(myname_,'allocate(start,count)',ierr) - - ! second pass - determine how long each run is - - nseg = 1 - start(nseg) = lindx(1) - count(nseg) = 1 - do n = 2,mysize - i = lindx(n-1) - j = lindx(n) - if ( j-i /= 1) then - nseg = nseg+1 - start(nseg) = lindx(n) - count(nseg) = 1 - else - count(nseg) = count(nseg)+1 - end if - end do - - endif ! if mysize==0 - - - if (debug.ne.0) then - write(6,*) rank,'init_index: SIZE ',nseg - - do n=1,nseg - write(6,*) rank,'init_index: START,COUNT ',start(n),count(n) - end do - endif - - - if (present(gsize)) then - call initd_( GSMap, start, count, pid0, my_comm, & - comp_id, gsize=gsize) - else - call initd_( GSMap, start, count, pid0, my_comm, & - comp_id) - endif - - - deallocate(start, count, stat=ierr) - if(ierr/=0) call warn(myname_,'deallocate(start,count)',ierr) - - - end subroutine init_index_ - - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: clean_ - clean the map -! -! !DESCRIPTION: -! This routine deallocates the array components of the {\tt GlobalSegMap} -! argument {\tt GSMap}: {\tt GSMap\%start}, {\tt GSMap\%length}, and -! {\tt GSMap\%pe\_loc}. It also zeroes out the values of the integer -! components {\tt GSMap\%ngseg}, {\tt GSMap\%comp\_id}, and -! {\tt GSMap\%gsize}. -! -! !INTERFACE: - - subroutine clean_(GSMap,stat) -! -! !USES: -! - use m_die - - implicit none - -! !INPUT/OUTPUT PARAMETERS: - - type(GlobalSegMap), intent(inout) :: GSMap - integer, optional, intent(out) :: stat - -! !REVISION HISTORY: -! 29Sep00 - J.W. Larson - initial prototype -! 01Mar02 - E.T. Ong - added stat argument. -! Removed dies to prevent crashing. -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::clean_' - integer :: ier - -#ifdef MALL_ON - - if( (associated(GSMap%start) .and. associated(GSMap%length)) & - .and. associated(GSMap%pe_loc) ) - call mall_co(size(transfer(GSMap%start,(/1/))),myname_) - call mall_co(size(transfer(GSMap%length,(/1/))),myname_) - call mall_co(size(transfer(GSMap%pe_loc,(/1/))),myname_) - endif - -#endif - - deallocate(GSMap%start, GSMap%length, GSMap%pe_loc, stat=ier) - - if(present(stat)) then - stat=ier - else - if(ier /= 0) call warn(myname_,'deallocate(GSMap%start,...)',ier) - endif - - GSMap%ngseg = 0 - GSMap%comp_id = 0 - GSMap%gsize = 0 - - end subroutine clean_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: ngseg_ - Return the global number of segments from the map -! -! !DESCRIPTION: -! The function {\tt ngseg\_()} returns the global number of vector -! segments in the {\tt GlobalSegMap} argument {\tt GSMap}. This is -! merely the value of {\tt GSMap\%ngseg}. -! -! !INTERFACE: - - integer function ngseg_(GSMap) - - implicit none - -! !INPUT PARAMETERS: - - type(GlobalSegMap),intent(in) :: GSMap - -! !REVISION HISTORY: -! 29Sep00 - J.W. Larson - initial prototype -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::ngseg_' - - ngseg_=GSMap%ngseg - - end function ngseg_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: nlseg_ - Return the local number of segments from the map -! -! !DESCRIPTION: -! The function {\tt nlseg\_()} returns the number of vector segments -! in the {\tt GlobalSegMap} argument {\tt GSMap} that reside on the -! process specified by the input argument {\tt pID}. This is the -! number of entries {\tt GSMap\%pe\_loc} whose value equals {\tt pID}. -! -! !INTERFACE: - - integer function nlseg_(GSMap, pID) - - implicit none - -! !INPUT PARAMETERS: - - type(GlobalSegMap),intent(in) :: GSMap - integer, intent(in) :: pID - -! !REVISION HISTORY: -! 29Sep00 - J.W. Larson - initial prototype -! 14Jun01 - J.W. Larson - Bug fix in lower -! limit of loop over elements of GSMap%pe_loc(:). The -! original code had this lower limit set to 0, which -! was out-of-bounds (but uncaught). The correct lower -! index is 1. This bug was discovered by Everest Ong. -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::nlseg_' - integer :: i, nlocseg - - ! Initialize the number of segments residing on pID, nlocseg - - nlocseg = 0 - - ! Compute the number of segments residing on pID, nlocseg - - do i=1,GSMap%ngseg - if(GSMap%pe_loc(i) == pID) then - nlocseg = nlocseg + 1 - endif - end do - - ! Return the total - - nlseg_ = nlocseg - - end function nlseg_ - - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: max_nlseg_ - Return the max number of segments over all procs -! -! !DESCRIPTION: -! The function {\tt max\_nlseg\_()} returns the maximum number -! over all processors of the vector -! segments in the {\tt GlobalSegMap} argument {\tt gsap} -! E.g. max\_p(nlseg(gsmap,p)) but computed more efficiently -! -! !INTERFACE: - - integer function max_nlseg_(gsmap) - -! !USES: - - use m_MCTWorld, only :ThisMCTWorld - use m_mpif90 - use m_die - - use m_stdio ! rml - - implicit none - -! !INPUT PARAMETERS: - - type(GlobalSegMap), intent(in) :: gsmap - - -! !REVISION HISTORY: -! 17Jan07 - R. Loy - initial prototype -!EOP ___________________________________________________________________ - - - -! Local variables - - character(len=*),parameter :: myname_=myname//'::max_local_segs' - - integer i - integer this_comp_id - integer nprocs - - integer, allocatable:: segcount(:) ! segments on proc i - integer ier - - integer this_ngseg - integer segment_pe - integer max_segcount - - -! Start of routine - - this_comp_id = comp_id(gsmap) - nprocs=ThisMCTWorld%nprocspid(this_comp_id) - - allocate( segcount(nprocs), stat=ier ) - if (ier/=0) call die(myname_,'allocate segcount') - - segcount=0 - - this_ngseg=ngseg(gsmap) - - do i=1,this_ngseg - - segment_pe = gsmap%pe_loc(i) + 1 ! want value 1..nprocs - - if (segment_pe < 1 .OR. segment_pe > nprocs) then - call die(myname_,'bad segment location',segment_pe) - endif - - segcount(segment_pe) = segcount(segment_pe) + 1 - enddo - - max_segcount=0 - do i=1,nprocs - max_segcount= max( max_segcount, segcount(i) ) - enddo - - deallocate(segcount, stat=ier) - if (ier/=0) call die(myname_,'deallocate segcount') - - - max_nlseg_=max_segcount - - end function max_nlseg_ - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: comp_id_ - Return the commponent ID from the GlobalSegMap. -! -! !DESCRIPTION: -! The function {\tt comp\_id\_()} returns component ID number stored in -! {\tt GSMap\%comp\_id}. -! -! !INTERFACE: - - integer function comp_id_(GSMap) - -! !USES: - - use m_die,only: die - use m_stdio, only :stderr - - implicit none - -! !INPUT PARAMETERS: - - type(GlobalSegMap),intent(in) :: GSMap - -! !REVISION HISTORY: -! 29Sep00 - J.W. Larson - initial prototype -! 26Jan01 - J.W. Larson - renamed comp_id_ -! to fit within MCT_World component ID context. -! 01May01 - R.L. Jacob - make sure GSMap -! is defined. -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::comp_id_' - - if(.not.associated(GSMap%start) ) then - write(stderr,'(2a)') myname_, & - ' MCTERROR: GSMap argument not initialized...exiting' - call die(myname_) - endif - - comp_id_ = GSMap%comp_id - - end function comp_id_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: gsize_ - Return the global vector size from the GlobalSegMap. -! -! !DESCRIPTION: -! The function {\tt gsize\_()} takes the input {\tt GlobalSegMap} -! arguement {\tt GSMap} and returns the global vector length stored -! in {\tt GlobalSegMap\%gsize}. -! -! !INTERFACE: - - integer function gsize_(GSMap) - - implicit none - -! !INPUT PARAMETERS: - - type(GlobalSegMap),intent(in) :: GSMap - -! !REVISION HISTORY: -! 29Sep00 - J.W. Larson - initial prototype -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::gsize_' - - gsize_=GSMap%gsize - - end function gsize_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: GlobalStorage_ - Return global storage space required. -! -! !DESCRIPTION: -! The function {\tt GlobalStorage\_()} takes the input {\tt GlobalSegMap} -! arguement {\tt GSMap} and returns the global storage space required -! ({\em i.e.}, the vector length) to hold all the data specified by -! {\tt GSMap}. -! -! {\bf N.B.: } If {\tt GSMap} contains halo or masked points, the value -! by {\tt GlobalStorage\_()} may differ from {\tt GSMap\%gsize}. -! -! !INTERFACE: - - integer function GlobalStorage_(GSMap) - - implicit none - -! !INPUT PARAMETERS: - - type(GlobalSegMap),intent(in) :: GSMap - -! !REVISION HISTORY: -! 06Feb01 - J.W. Larson - initial version -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::GlobalStorage_' - - integer :: global_storage, ngseg, n - - ! Return global number of segments: - - ngseg = ngseg_(GSMap) - - ! Initialize global_storage (the total number of points in the - ! GlobalSegMap: - - global_storage = 0 - - ! Add up the number of points present in the GlobalSegMap: - - do n=1,ngseg - global_storage = global_storage + GSMap%length(n) - end do - - GlobalStorage_ = global_storage - - end function GlobalStorage_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: ProcessStorage_ - Number of points on a given process. -! -! !DESCRIPTION: -! The function {\tt ProcessStorage\_()} takes the input {\tt GlobalSegMap} -! arguement {\tt GSMap} and returns the storage space required by process -! {\tt PEno} ({\em i.e.}, the vector length) to hold all the data specified -! by {\tt GSMap}. -! -! !INTERFACE: - - integer function ProcessStorage_(GSMap, PEno) - - implicit none - -! !INPUT PARAMETERS: - - type(GlobalSegMap),intent(in) :: GSMap - integer, intent(in) :: PEno - -! !REVISION HISTORY: -! 06Feb01 - J.W. Larson - initial version -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::ProcessStorage_' - - integer :: pe_storage, ngseg, n - - ! Return global number of segments: - - ngseg = ngseg_(GSMap) - - ! Initialize pe_storage (the total number of points on process - ! PEno in the GlobalSegMap): - - pe_storage = 0 - - ! Add up the number of points on process PEno in the GlobalSegMap: - - do n=1,ngseg - if(GSMap%pe_loc(n) == PEno) then - pe_storage = pe_storage + GSMap%length(n) - endif - end do - - ProcessStorage_ = pe_storage - - end function ProcessStorage_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: OrderedPoints_ - The grid points on a given process -! returned in the assumed MCT order. -! -! !DESCRIPTION: -! The function {\tt OrderedPoints\_()} takes the input {\tt GlobalSegMap} -! arguement {\tt GSMap} and returns a vector of the points owned by -! {\tt PEno}. {\tt Points} is allocated here. The calling process -! is responsible for deallocating the space. -! -! !INTERFACE: - - subroutine OrderedPoints_(GSMap, PEno, Points) - -! -! !USES: -! - use m_die,only: die - - implicit none - - ! !INPUT PARAMETERS: - - type(GlobalSegMap), intent(in) :: GSMap ! input GlobalSegMap - integer, intent(in) :: PEno ! input process number - integer,dimension(:),pointer :: Points ! the vector of points - -! !REVISION HISTORY: -! 25Apr01 - R. Jacob - initial prototype -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::OrderedPoints_' - integer :: nlsegs,mysize,ier,i,j,k - integer,dimension(:),allocatable :: mystarts,mylengths - - nlsegs = nlseg(GSMap,PEno) - mysize=ProcessStorage(GSMap,PEno) - - allocate(mystarts(nlsegs),mylengths(nlsegs), & - Points(mysize),stat=ier) - if(ier/=0) call die(myname_,'allocate(mystarts,..)',ier) - -! pull out the starts and lengths that PEno owns in the order -! they appear in the GSMap. - j=1 - do i=1,GSMap%ngseg - if(GSMap%pe_loc(i)==PEno) then - mystarts(j)=GSMap%start(i) - mylengths(j)=GSMap%length(i) - j=j+1 - endif - enddo - -! now recalculate the values of the grid point numbers -! based on the starts and lengths -! form one long vector which is all local GSMap points - i=1 - do j=1,nlsegs - do k=1,mylengths(j) - Points(i)=mystarts(j)+k-1 - i=i+1 - enddo - enddo - - deallocate(mystarts,mylengths, stat=ier) - if(ier/=0) call die(myname_,'deallocate(mystarts,..)',ier) - - end subroutine OrderedPoints_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: lsize_ - find the local storage size from the map -! -! !DESCRIPTION: -! This function returns the number of points owned by the local process, -! as defined by the input {\tt GlobalSegMap} argument {\tt GSMap}. The -! local process ID is determined through use of the input {\tt INTEGER} -! argument {\tt comm}, which is the Fortran handle for the MPI -! communicator. -! -! !INTERFACE: - - integer function lsize_(GSMap, comm) -! -! !USES: -! - use m_mpif90 - use m_die , only : MP_perr_die - - implicit none - -! !INPUT PARAMETERS: - - type(GlobalSegMap), intent(in) :: GSMap - integer, intent(in) :: comm - - -! !REVISION HISTORY: -! 29Sep00 - J.W. Larson - initial prototype -! 06Feb01 - J.W. Larson - Computed directly -! from the GlobalSegMap, rather than returning a hard- -! wired local attribute. This required the addition of -! the communicator argument. -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::lsize_' - integer :: ierr, local_size, myID, n, ngseg - - ! Determine local rank myID: - - call MP_COMM_RANK(comm, myID, ierr) - if(ierr /= 0) call MP_perr_die(myname_,'MP_COMM_RANK',ierr) - - ! Determine global number of segments: - - ngseg = ngseg_(GSMap) - - ! Compute the local size of the distributed vector by summing - ! the entries of GSMap%length(:) whose corresponding values in - ! GSMap%pe_loc(:) equal the local process ID. This automatically - ! takes into account haloing (if present). - - local_size = 0 - - do n=1,ngseg - if(GSMap%pe_loc(n) == myID) then - local_size = local_size + GSMap%length(n) - endif - end do - - lsize_ = local_size - - end function lsize_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: rank1_ - rank which process owns a datum with given global -! index. -! -! !DESCRIPTION: -! This routine assumes that there is one process that owns the datum with -! a given global index. It should not be used when the input -! {\tt GlobalSegMap} argument {\tt GSMap} has been built to incorporate -! halo points. -! -! !INTERFACE: - - subroutine rank1_(GSMap, i_g, rank) - - implicit none - -! !INPUT PARAMETERS: - - type(GlobalSegMap), intent(in) :: GSMap ! input GlobalSegMap - integer, intent(in) :: i_g ! a global index - -! !OUTPUT PARAMETERS: - - integer, intent(out) :: rank ! the pe on which this - ! element resides -! !REVISION HISTORY: -! 29Sep00 - J.W. Larson - initial prototype -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::rank1_' - integer :: i,ilc,ile - - ! Initially, set the rank to -1 (invalid). - rank=-1 - - do i=1,size(GSMap%start) - ilc = GSMap%start(i) - ile = ilc + GSMap%length(i) - 1 - - ! If i_g in [ilc,ile]. Note that i_g := [1:..] - - if(ilc <= i_g .and. i_g <= ile) then - rank = GSMap%pe_loc(i) - return - endif - end do - - end subroutine rank1_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: rankm_ - rank which processes own a datum with given global -! index. -! -! !DESCRIPTION: -! This routine assumes that there may be more than one process that owns -! the datum with a given global index. This routine should be used when -! the input {\tt GlobalSegMap} argument {\tt GSMap} has been built to -! incorporate ! halo points. {\em Nota Bene}: The output array {\tt rank} -! is allocated in this routine and must be deallocated by the routine calling -! {\tt rankm\_()}. Failure to do so could result in a memory leak. -! -! !INTERFACE: - - subroutine rankm_(GSMap, i_g, num_loc, rank) - - implicit none - -! !INPUT PARAMETERS: - - type(GlobalSegMap), intent(in) :: GSMap ! input GlobalSegMap - integer, intent(in) :: i_g ! a global index - -! !OUTPUT PARAMETERS: - - integer, intent(out) :: num_loc ! the number of processes - ! which own element i_g - integer, dimension(:), pointer :: rank ! the process(es) on which - ! element i_g resides -! !REVISION HISTORY: -! 29Sep00 - J.W. Larson - initial prototype -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::rankm_' - integer :: i, ilc, ile, ier, n - - ! First sweep: determine the number of processes num_loc - ! that own the given datum: - - num_loc = 0 - - do i=1,size(GSMap%start) - - ilc = GSMap%start(i) - ile = ilc + GSMap%length(i) - 1 - - ! If i_g in [ilc,ile]. Note that i_g := [1:..] - - if(ilc <= i_g .and. i_g <= ile) then - num_loc = num_loc + 1 - endif - - end do - - if(num_loc == 0) then - - ! If i_g is nowhere to be found in GSMap, set num_loc to - ! unity and return a null value for rank - - num_loc = 1 - allocate(rank(num_loc), stat=ier) - rank = -1 ! null value - return - - else - ! Allocate output array rank(1:num_loc) - - allocate(rank(num_loc), stat=ier) - - ! Second sweep: fill in the entries to rank(:) - - n = 0 ! counter - - do i=1,size(GSMap%start) - - ilc = GSMap%start(i) - ile = ilc + GSMap%length(i) - 1 - - ! If i_g in [ilc,ile]. Note that i_g := [1:..] - - if(ilc <= i_g .and. i_g <= ile) then - n = n + 1 - rank(n) = GSMap%pe_loc(i) - endif - - end do - - endif - - end subroutine rankm_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: active_pes_ - number of processes that own data. -! index. -! -! !DESCRIPTION: -! This routine scans the pe location list of the input {\tt GlobalSegMap} -! {\tt GSMap\%pe\_loc(:)}, and counts the number of pe locations that -! own at least one datum. This value is returned in the {\tt INTEGER} -! argument {\tt n\_active}. If the optional {\tt INTEGER} array argument -! {\tt list} is included in the call, a sorted list (in ascending order) of -! the active processes will be returned. -! -! {\bf N.B.:} If {\tt active\_pes\_()} is invoked with the optional argument -! {\tt pe\_list} included, this routine will allocate and return this array. -! The user must deallocate this array once it is no longer needed. Failure -! to do so will result in a memory leak. -! -! !INTERFACE: - - subroutine active_pes_(GSMap, n_active, pe_list) -! -! !USES: -! - use m_die , only : die - use m_SortingTools , only : IndexSet - use m_SortingTools , only : IndexSort - use m_SortingTools , only : Permute - - implicit none - -! !INPUT PARAMETERS: - - type(GlobalSegMap), intent(in) :: GSMap - -! !OUTPUT PARAMETERS: - - integer, intent(out) :: n_active - integer, dimension(:), pointer, optional :: pe_list - -! !REVISION HISTORY: -! 03Feb01 - J.W. Larson - initial version. -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::active_pes_' - - integer :: count, i, n, ngseg, ierr - logical :: new - integer, dimension(:), allocatable :: temp_list - integer, dimension(:), allocatable :: perm - - ! retrieve total number of segments in the map: - - ngseg = ngseg_(GSMap) - - ! allocate workspace to tally process id list: - - allocate(temp_list(ngseg), stat=ierr) - if(ierr /= 0) call die(myname_,'allocate(temp_list...',ierr) - - ! initialize temp_list to -1 (which can never be a process id) - - temp_list = -1 - - ! initialize the distinct active process count: - - count = 0 - - ! scan entries of GSMap%pe_loc to count active processes: - - do n=1,ngseg - if(GSMap%pe_loc(n) >= 0) then ! a legitimate pe_location - - ! assume initially that GSMap%pe_loc(n) is a process id previously - ! not encountered - - new = .true. - - ! test this proposition against the growing list of distinct - ! process ids stored in temp_list(:) - - do i=1, count - if(GSMap%pe_loc(n) == temp_list(i)) new = .false. - end do - - ! If GSMap%pe_loc(n) represents a previously unencountered - ! process id, increment the count, and add this id to the list - - if(new) then - count = count + 1 - temp_list(count) = GSMap%pe_loc(n) - endif - - else ! a negative entry in GSMap%pe_loc(n) - ierr = 2 - call die(myname_,'negative value of GSMap%pe_loc',ierr) - endif - end do - - ! If the argument pe_list is present, we must allocate this - ! array, fill it, and sort it - - if(present(pe_list)) then - - ! allocate pe_list and permutation array perm - - allocate(pe_list(count), perm(count), stat=ierr) - if (ierr /= 0) then - call die(myname_,'allocate(pe_list...',ierr) - endif - - do n=1,count - pe_list(n) = temp_list(n) - end do - - ! sorting and permutation... - - call IndexSet(perm) - call IndexSort(count, perm, pe_list, descend=.false.) - call Permute(pe_list, perm, count) - - ! deallocate permutation array... - - deallocate(perm, stat=ierr) - if (ierr /= 0) then - call die(myname_,'deallocate(perm)',ierr) - endif - - endif ! if(present(pe_list))... - - ! deallocate work array temp_list... - - deallocate(temp_list, stat=ierr) - if (ierr /= 0) then - call die(myname_,'deallocate(temp_list)',ierr) - endif - - ! finally, store the active process count in output variable - ! n_active: - - n_active = count - - end subroutine active_pes_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: peLocs_ - process ID locations for distributed points. -! index. -! -! !DESCRIPTION: -! This routine takes an input {\tt INTEGER} array of point indices -! {\tt points(:)}, compares them with an input {\tt GlobalSegMap} -! {\tt pointGSMap}, and returns the {\em unique} process ID location -! for each point. Note the emphasize on unique. The assumption here -! (which is tested) is that {\tt pointGSMap} is not haloed. The process -! ID locations for the points is returned in the array {\tt pe\_locs(:)}. -! -! {\bf N.B.:} The test of {\tt pointGSMap} for halo points, and the -! subsequent search for the process ID for each point is very slow. This -! first version of the routine is serial. A parallel version of this -! routine will need to be developed. -! -! !INTERFACE: - - subroutine peLocs_(pointGSMap, npoints, points, pe_locs) -! -! !USES: -! - use m_die , only : die - - implicit none - -! !INPUT PARAMETERS: - - type(GlobalSegMap), intent(in) :: pointGSMap - integer, intent(in) :: npoints - integer, dimension(:), intent(in) :: points - -! !OUTPUT PARAMETERS: - - integer, dimension(:), intent(out) :: pe_locs - -! !REVISION HISTORY: -! 18Apr01 - J.W. Larson - initial version. -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::peLocs_' - integer :: ierr - integer :: iseg, ngseg, ipoint - integer :: lower_index, upper_index - -! Input argument checks: - - if(size(points) < npoints) then - ierr = size(points) - call die(myname_,'input points list array too small',ierr) - endif - - if(size(pe_locs) < npoints) then - ierr = size(pe_locs) - call die(myname_,'output pe_locs array too small',ierr) - endif - - if(haloed_(pointGSMap)) then - ierr = 1 - call die(myname_,'input pointGSMap haloed--not valid',ierr) - endif - -! Brute-force indexing...no assumptions regarding sorting of points(:) -! or pointGSMap%start(:) - -! Number of segments in pointGSMap: - - ngseg = ngseg_(pointGSMap) - - do ipoint=1,npoints ! loop over points - - do iseg=1,ngseg ! loop over segments - - lower_index = pointGSMap%start(iseg) - upper_index = lower_index + pointGSMap%length(iseg) - 1 - - if((points(ipoint) >= lower_index) .and. & - (points(ipoint) <= upper_index)) then - pe_locs(ipoint) = pointGSMap%pe_loc(iseg) - endif - - end do ! do iseg=1, ngseg - end do ! do ipoint=1,npoints - - end subroutine peLocs_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: haloed_ - test GlobalSegMap for presence of halo points. -! index. -! -! !DESCRIPTION: -! This {\tt LOGICAL} function tests the input {\tt GlobalSegMap} -! {\tt GSMap} for the presence of halo points. Halo points are points -! that appear in more than one segment of a {\tt GlobalSegMap}. If -! {\em any} halo point is found, the function {\tt haloed\_()} returns -! immediately with value {\tt .TRUE.} If, after an exhaustive search -! of the map has been completed, no halo points are found, the function -! {\tt haloed\_()} returns with value {\tt .FALSE.} -! -! The search algorithm is: -! -! \begin{enumerate} -! \item Extract the segment start and length information from -! {\tt GSMap\%start} and {\tt GSMap\%length} into the temporary -! arrays {\tt start(:)} and {\tt length(:)}. -! \item Sort these arrays in {\em ascending order} keyed by {\tt start}. -! \item Scan the arrays {\tt start} and{\tt length}. A halo point is -! present if for at least one value of the index -! $1 \leq {\tt n} \leq {\tt GSMap\%ngseg}$ -! $${\tt start(n)} + {\tt length(n)} - 1 \geq {\tt start(n+1)}$$. -! \end{enumerate} -! -! {\bf N.B.:} Beware that the search for halo points is potentially -! expensive. -! -! !INTERFACE: - - logical function haloed_(GSMap) -! -! !USES: -! - use m_die , only : die - use m_SortingTools , only : IndexSet - use m_SortingTools , only : IndexSort - use m_SortingTools , only : Permute - - implicit none - - ! !INPUT PARAMETERS: - - type(GlobalSegMap), intent(in) :: GSMap - -! !REVISION HISTORY: -! 08Feb01 - J.W. Larson - initial version. -! 26Apr01 - J.W. Larson - Bug fix. -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::haloed_' - -! Error Flag - - integer :: ierr - -! Loop index and storage for number of segments in GSMap - - integer :: n, ngseg - -! Temporary storage for GSMap%start, GSMap%length, and index -! permutation array: - - integer, dimension(:), allocatable :: start, length, perm - -! Logical flag indicating segment overlap - - logical :: overlap - - ! How many segments in GSMap? - - ngseg = ngseg_(GSMap) - - ! allocate temporary arrays: - - allocate(start(ngseg), length(ngseg), perm(ngseg), stat=ierr) - if (ierr /= 0) then - call die(myname_,'allocate(start...',ierr) - endif - - ! Fill the temporary arrays start(:) and length(:) - - do n=1,ngseg - start(n) = GSMap%start(n) - length(n) = GSMap%length(n) - end do - - ! Initialize the index permutation array: - - call IndexSet(perm) - - ! Create the index permutation that will order the data so the - ! entries of start(:) appear in ascending order: - - call IndexSort(ngseg, perm, start, descend=.false.) - - ! Permute the data so the entries of start(:) are now in - ! ascending order: - - call Permute(start,perm,ngseg) - - ! Apply this same permutation to length(:) - - call Permute(length,perm,ngseg) - - ! Set LOGICAL flag indicating segment overlap to .FALSE. - - overlap = .FALSE. - - ! Now, scan the segments, looking for overlapping segments. Upon - ! discovery of the first overlapping pair of segments, set the - ! flag overlap to .TRUE. and exit. - - n = 0 - - SCAN_LOOP: do - n = n + 1 - if(n == ngseg) EXIT ! we are finished, and there were no halo pts. - if((start(n) + length(n) - 1) >= start(n+1)) then ! found overlap - overlap = .TRUE. - EXIT - endif - end do SCAN_LOOP - - ! Clean up allocated memory: - - deallocate(start, length, perm, stat=ierr) - if (ierr /= 0) then - call die(myname_,'deallocate(start...',ierr) - endif - - ! Assign function return value: - - haloed_ = overlap - - end function haloed_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: Sort_ - generate index permutation for GlobalSegMap. -! -! !DESCRIPTION: -! {\tt Sort\_()} uses the supplied keys {\tt key1} and {\tt key2} to -! generate a permutation {\tt perm} that will put the entries of the -! components {\tt GlobalSegMap\%start}, {\tt GlobalSegMap\%length} and -! {\tt GlobalSegMap\%pe\_loc} in {\em ascending} lexicographic order. -! -! {\bf N.B.:} {\tt Sort\_()} returns an allocated array {\tt perm(:)}. It -! the user must deallocate this array once it is no longer needed. Failure -! to do so could create a memory leak. -! -! !INTERFACE: - - subroutine Sort_(GSMap, key1, key2, perm) -! -! !USES: -! - use m_die , only : die - use m_SortingTools , only : IndexSet - use m_SortingTools , only : IndexSort - - implicit none - -! !INPUT PARAMETERS: - - type(GlobalSegMap), intent(in) :: GSMap ! input GlobalSegMap - integer, dimension(:), intent(in) :: key1 ! first sort key - integer, dimension(:), intent(in), optional :: key2 ! second sort key - -! !OUTPUT PARAMETERS: - - integer, dimension(:), pointer :: perm ! output index permutation - -! !REVISION HISTORY: -! 02Feb01 - J.W. Larson - initial version -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::Sort_' - - integer :: ierr, length - - length = ngseg_(GSMap) - - ! Argument checking. are key1 and key2 (if supplied) the - ! same length as the components of GSMap? If not, stop with - ! an error. - - ierr = 0 - - if(size(key1) /= length) then - ierr = 1 - call die(myname_,'key1 GSMap size mismatch',ierr) - endif - - if(present(key2)) then - if(size(key2) /= length) then - ierr = 2 - call die(myname_,'key2 GSMap size mismatch',ierr) - endif - if(size(key1) /= size(key2)) then - ierr = 3 - call die(myname_,'key1 key2 size mismatch',ierr) - endif - endif - - ! allocate space for permutation array perm(:) - - allocate(perm(length), stat=ierr) - if(ierr /= 0) call die(myname_,'allocate(perm)',ierr) - - ! Initialize perm(i)=i, for i=1,length - - call IndexSet(perm) - - ! Index permutation is achieved by successive calls to IndexSort(), - ! with the keys supplied one at a time in the order reversed from - ! the desired sort order. - - if(present(key2)) then - call IndexSort(length, perm, key2, descend=.false.) - endif - - call IndexSort(length, perm, key1, descend=.false.) - - ! Yes, it is that simple. The desired index permutation is now - ! stored in perm(:) - - end subroutine Sort_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: PermuteInPlace_ - apply index permutation to GlobalSegMap. -! -! !DESCRIPTION: -! {\tt PermuteInPlace\_()} uses a supplied index permutation {\tt perm} -! to re-order {\tt GlobalSegMap\%start}, {\tt GlobalSegMap\%length} and -! {\tt GlobalSegMap\%pe\_loc}. -! -! !INTERFACE: - - subroutine PermuteInPlace_(GSMap, perm) -! -! !USES: -! - use m_die , only : die - use m_SortingTools , only : Permute - - implicit none - -! !INPUT PARAMETERS: - - integer, dimension(:), intent(in) :: perm - -! !INPUT/OUTPUT PARAMETERS: - - type(GlobalSegMap), intent(inout) :: GSMap - -! !REVISION HISTORY: -! 02Feb01 - J.W. Larson - initial version. -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::PermuteInPlace_' - - integer :: length, ierr - - length = ngseg_(GSMap) - - ! Argument checking. Do the components of GSMap - ! (e.g. GSMap%start) have the same length as the - ! permutation array perm? If not, stop with an error. - - ierr = 0 - - if(size(perm) /= length) then - ierr = 1 - call die(myname_,'perm GSMap size mismatch',ierr) - endif - - ! In-place index permutation using perm(:) : - - call Permute(GSMap%start,perm,length) - call Permute(GSMap%length,perm,length) - call Permute(GSMap%pe_loc,perm,length) - - ! Now, the components of GSMap are ordered according to - ! perm(:). - - end subroutine PermuteInPlace_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: SortPermuteInPlace_ - Sort in-place GlobalSegMap components. -! -! !DESCRIPTION: -! {\tt SortPermuteInPlace\_()} uses a the supplied key(s) to generate -! and apply an index permutation that will place the {\tt GlobalSegMap} -! components {\tt GlobalSegMap\%start}, {\tt GlobalSegMap\%length} and -! {\tt GlobalSegMap\%pe\_loc} in lexicographic order. -! -! !INTERFACE: - - subroutine SortPermuteInPlace_(GSMap, key1, key2) -! -! !USES: -! - use m_die , only : die - - implicit none - -! !INPUT PARAMETERS: - - integer, dimension(:), intent(in) :: key1 - integer, dimension(:), intent(in), optional :: key2 - -! !INPUT/OUTPUT PARAMETERS: - - type(GlobalSegMap), intent(inout) :: GSMap - -! !REVISION HISTORY: -! 02Feb01 - J.W. Larson - initial version. -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::SortPermuteInPlace_' - - integer :: length, ierr - integer, dimension(:), pointer :: perm - - length = ngseg_(GSMap) - - ! Argument checking. are key1 and key2 (if supplied) the - ! same length as the components of GSMap? If not, stop with - ! an error. - ierr = 0 - if(size(key1) /= length) then - ierr = 1 - call die(myname_,'key1 GSMap size mismatch',ierr) - endif - - if(present(key2)) then - if(size(key2) /= length) then - ierr = 2 - call die(myname_,'key2 GSMap size mismatch',ierr) - endif - if(size(key1) /= size(key2)) then - ierr = 3 - call die(myname_,'key1 key2 size mismatch',ierr) - endif - endif - - ! Generate desired index permutation: - - if(present(key2)) then - call Sort_(GSMap, key1, key2, perm) - else - call Sort_(GSMap, key1=key1, perm=perm) - endif - - ! Apply index permutation: - - call PermuteInPlace_(GSMap, perm) - - ! Now the components of GSMap have been re-ordered. - ! Deallocate the index permutation array perm(:) - - deallocate(perm, stat=ierr) - if(ierr /= 0) call die(myname_,'deallocate(perm...)',ierr) - - end subroutine SortPermuteInPlace_ - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: increasing_ - Return .TRUE. if GSMap has increasing indices -! -! !DESCRIPTION: -! The function {\tt increasing\_()} returns .TRUE. if each proc's -! indices in the {\tt GlobalSegMap} argument {\tt GSMap} have -! strictly increasing indices. I.e. the proc's segments have indices -! in ascending order and are non-overlapping. -! -! !INTERFACE: - - logical function increasing_(gsmap) - -! !USES: - use m_MCTWorld, only: ThisMCTWorld - use m_die - - implicit none - -! !INPUT PARAMETERS: - - type(GlobalSegMap),intent(in) :: gsmap - -! !REVISION HISTORY: -! 06Jun07 - R. Loy - initial version -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::increasing_' - - integer comp_id - integer nprocs - integer i - integer this_ngseg - integer ier - integer, allocatable:: last_index(:) - integer pe_loc - - comp_id = gsmap%comp_id - nprocs=ThisMCTWorld%nprocspid(comp_id) - - allocate( last_index(nprocs), stat=ier ) - if (ier/=0) call die(myname_,'allocate last_index') - - last_index= -1 - increasing_ = .TRUE. - this_ngseg=ngseg(gsmap) - - iloop: do i=1,this_ngseg - pe_loc=gsmap%pe_loc(i)+1 ! want value 1..nprocs - if (gsmap%start(i) <= last_index(pe_loc)) then - increasing_ = .FALSE. - exit iloop - endif - last_index(pe_loc)=gsmap%start(i)+gsmap%length(i)-1 - enddo iloop - - deallocate( last_index, stat=ier ) - if (ier/=0) call die(myname_,'deallocate last_index') - - end function increasing_ - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: copy_ - Copy the gsmap to a new gsmap -! -! !DESCRIPTION: -! Make a copy of a gsmap. -! Note this is a deep copy of all arrays. -! -! !INTERFACE: - - subroutine copy_(src,dest) - -! !USES: - use m_MCTWorld, only: ThisMCTWorld - use m_die - - implicit none - -! !INPUT PARAMETERS: - - type(GlobalSegMap),intent(in) :: src - -! !OUTPUT PARAMETERS: - - type(GlobalSegMap),intent(out) :: dest - - -! !REVISION HISTORY: -! 27Jul07 - R. Loy - initial version -!EOP ___________________________________________________________________ - - - call initp_( dest, src%comp_id, src%ngseg, src%gsize, & - src%start, src%length, src%pe_loc ) - - end subroutine copy_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: print_ - Print GSMap info -! -! !DESCRIPTION: -! Print out contents of GSMAP on unit number 'lun' -! -! !INTERFACE: - - subroutine print_(gsmap,lun) -! -! !USES: -! - use m_die - - implicit none - -!INPUT/OUTPUT PARAMETERS: - type(GlobalSegMap), intent(in) :: gsmap - integer, intent(in) :: lun - -! !REVISION HISTORY: -! 06Jul12 - R. Jacob - initial version -!EOP ___________________________________________________________________ - - - integer n - character(len=*),parameter :: myname_=myname//'::print_' - - write(lun,*) gsmap%comp_id - write(lun,*) gsmap%ngseg - write(lun,*) gsmap%gsize - do n=1,gsmap%ngseg - write(lun,*) gsmap%start(n),gsmap%length(n),gsmap%pe_loc(n) - end do - - end subroutine print_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: printFromRoot_ - Print GSMap info -! -! !DESCRIPTION: -! Print out contents of GSMAP on unit number 'lun' -! -! !INTERFACE: - - subroutine printFromRootnp_(gsmap,mycomm,lun) -! -! !USES: -! - use m_MCTWorld, only : printnp - use m_die - use m_mpif90 - - implicit none - -!INPUT/OUTPUT PARAMETERS: - type(GlobalSegMap), intent(in) :: gsmap - integer, intent(in) :: mycomm - integer, intent(in) :: lun - -! !REVISION HISTORY: -! 06Jul12 - R. Jacob - initial version -!EOP ___________________________________________________________________ - - - integer myrank - integer ier - character(len=*),parameter :: myname_=myname//'::print_' - - call MP_comm_rank(mycomm,myrank,ier) - if(ier/=0) call MP_perr_die(myname_,'MP_comm_rank',ier) - - if (myrank == 0) then - call printnp(gsmap%comp_id,lun) - call print_(gsmap,lun) - endif - - end subroutine printFromRootnp_ - - - - - end module m_GlobalSegMap - diff --git a/cesm/models/utils/mct/mct/m_GlobalSegMapComms.F90 b/cesm/models/utils/mct/mct/m_GlobalSegMapComms.F90 deleted file mode 100644 index 910823f..0000000 --- a/cesm/models/utils/mct/mct/m_GlobalSegMapComms.F90 +++ /dev/null @@ -1,555 +0,0 @@ -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!----------------------------------------------------------------------- -! CVS $Id$ -! CVS $Name$ -!BOP ------------------------------------------------------------------- -! -! !MODULE: m_GlobalSegMapComms - GlobalSegMap Communications Support -! -! !DESCRIPTION: -! -! This module provides communications support for the {\tt GlobalSegMap} -! datatype. Both blocking and non-blocking point-to-point communications -! are provided for send (analogues to {\tt MPI\_SEND()/MPI\_ISEND()}) -! A receive and broadcast method is also supplied. -! -! !INTERFACE: - - module m_GlobalSegMapComms - - implicit none - - private ! except - -! !PUBLIC MEMBER FUNCTIONS: - - public :: send - public :: recv - public :: isend - public :: bcast - - interface bcast ; module procedure bcast_ ; end interface - interface send ; module procedure send_ ; end interface - interface recv ; module procedure recv_ ; end interface - interface isend ; module procedure isend_ ; end interface - -! !REVISION HISTORY: -! 11Aug03 - J.W. Larson - initial version -! -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname='MCT::m_GlobalSegMapComms' - - contains - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: send_ - Point-to-point blocking Send of a GlobalSegMap -! -! !DESCRIPTION: -! This routine performs a blocking send of a {\tt GlobalSegMap} (the -! input argument {\tt outgoingGSMap}) to the root processor on component -! {\tt comp\_id}. The input {\tt INTEGER} argument {\tt TagBase} -! is used to generate tags for the messages associated with this operation; -! there are six messages involved, so the user should avoid using tag -! values {\tt TagBase} and {\tt TagBase + 5}. All six messages are blocking. -! The success (failure) of this operation is reported in the zero -! (non-zero) value of the optional {\tt INTEGER} output variable {\tt status}. -! -! !INTERFACE: - - subroutine send_(outgoingGSMap, comp_id, TagBase, status) - -! -! !USES: -! - use m_mpif90 - use m_die, only : MP_perr_die,die - use m_stdio - - use m_GlobalSegMap, only : GlobalSegMap - use m_GlobalSegMap, only : GlobalSegMap_ngseg => ngseg - use m_GlobalSegMap, only : GlobalSegMap_comp_id => comp_ID - use m_GlobalSegMap, only : GlobalSegMap_gsize => gsize - - use m_MCTWorld, only : ComponentToWorldRank - use m_MCTWorld, only : ThisMCTWorld - - implicit none - -! !INPUT PARAMETERS: - - type(GlobalSegMap), intent(IN) :: outgoingGSMap - integer, intent(IN) :: comp_id - integer, intent(IN) :: TagBase - -! !OUTPUT PARAMETERS: - - integer, optional, intent(OUT) :: status - -! !REVISION HISTORY: -! 13Aug03 - J.W. Larson - API and initial version. -! 26Aug03 - R. Jacob - use same method as isend_ -! 05Mar04 - R. Jacob - match new isend_ method. -!EOP ___________________________________________________________________ - character(len=*),parameter :: myname_=myname//'::send_' - - integer :: ierr - integer :: destID - integer :: nsegs - - if(present(status)) status = 0 ! the success value - - destID = ComponentToWorldRank(0, comp_id, ThisMCTWorld) - - ! Next, send the buffer size to destID so it can prepare a - ! receive buffer of the correct size. - nsegs = GlobalSegMap_ngseg(outgoingGSMap) - - call MPI_SEND(outgoingGSMap%comp_id, 1, MP_Type(outgoingGSMap%comp_id), destID, & - TagBase, ThisMCTWorld%MCT_comm, ierr) - if(ierr /= 0) then - call MP_perr_die(myname_, 'Send compid failed',ierr) - endif - - call MPI_SEND(outgoingGSMap%ngseg, 1, MP_Type(outgoingGSMap%ngseg), destID, & - TagBase+1, ThisMCTWorld%MCT_comm, ierr) - if(ierr /= 0) then - call MP_perr_die(myname_, 'Send ngseg failed',ierr) - endif - - call MPI_SEND(outgoingGSMap%gsize, 1, MP_Type(outgoingGSMap%gsize), destID, & - TagBase+2, ThisMCTWorld%MCT_comm, ierr) - if(ierr /= 0) then - call MP_perr_die(myname_, 'Send gsize failed',ierr) - endif - - - ! Send segment information data (3 messages) - - call MPI_SEND(outgoingGSMap%start, nsegs, & - MP_Type(outgoingGSMap%start(1)), & - destID, TagBase+3, ThisMCTWorld%MCT_comm, ierr) - if(ierr /= 0) then - call MP_perr_die(myname_, 'Send outgoingGSMap%start failed',ierr) - endif - - call MPI_SEND(outgoingGSMap%length, nsegs, & - MP_Type(outgoingGSMap%length(1)), & - destID, TagBase+4, ThisMCTWorld%MCT_comm, ierr) - if(ierr /= 0) then - call MP_perr_die(myname_, 'Send outgoingGSMap%length failed',ierr) - endif - - call MPI_SEND(outgoingGSMap%pe_loc, nsegs, & - MP_Type(outgoingGSMap%pe_loc(1)), & - destID, TagBase+5, ThisMCTWorld%MCT_comm, ierr) - if(ierr /= 0) then - call MP_perr_die(myname_, 'Send outgoingGSMap%pe_loc failed',ierr) - endif - - end subroutine send_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: isend_ - Point-to-point Non-blocking Send of a GlobalSegMap -! -! !DESCRIPTION: -! This routine performs a non-blocking send of a {\tt GlobalSegMap} (the -! input argument {\tt outgoingGSMap}) to the root processor on component -! {\tt comp\_id} The input {\tt INTEGER} argument {\tt TagBase} -! is used to generate tags for the messages associated with this operation; -! there are six messages involved, so the user should avoid using tag -! values {\tt TagBase} and {\tt TagBase + 5}. All six messages are non- -! blocking, and the request handles for them are returned in the output -! {\tt INTEGER} array {\tt reqHandle}, which can be checked for completion -! using any of MPI's wait functions. The success (failure) of -! this operation is reported in the zero (non-zero) value of the optional -! {\tt INTEGER} output variable {\tt status}. -! -! {\bf N.B.}: Data is sent directly out of {\tt outgoingGSMap} so it -! must not be deleted until the send has completed. -! -! {\bf N.B.}: The array {\tt reqHandle} represents allocated memory that -! must be deallocated when it is no longer needed. Failure to do so will -! create a memory leak. -! -! !INTERFACE: - - subroutine isend_(outgoingGSMap, comp_id, TagBase, reqHandle, status) - -! -! !USES: -! - use m_mpif90 - use m_die, only : MP_perr_die,die - use m_stdio - - use m_GlobalSegMap, only : GlobalSegMap - use m_GlobalSegMap, only : GlobalSegMap_ngseg => ngseg - - use m_MCTWorld, only : ComponentToWorldRank - use m_MCTWorld, only : ThisMCTWorld - - implicit none - -! !INPUT PARAMETERS: - - type(GlobalSegMap), intent(IN) :: outgoingGSMap - integer, intent(IN) :: comp_id - integer, intent(IN) :: TagBase - -! !OUTPUT PARAMETERS: - - integer, dimension(:), pointer :: reqHandle - integer, optional, intent(OUT) :: status - -! !REVISION HISTORY: -! 13Aug03 - J.W. Larson - API and initial version. -! 05Mar04 - R. Jacob - Send everything directly out -! of input GSMap. Don't use a SendBuffer. -! -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::isend_' - - integer :: ierr,destID,nsegs - - if(present(status)) status = 0 ! the success value - - destID = ComponentToWorldRank(0, comp_id, ThisMCTWorld) - - allocate(reqHandle(6), stat=ierr) - if(ierr /= 0) then - write(stderr,'(2a,i8)') myname_, & - 'FATAL--allocation of send buffer failed with ierr=',ierr - call die(myname_) - endif - - ! Next, send the buffer size to destID so it can prepare a - ! receive buffer of the correct size (3 messages). - nsegs = GlobalSegMap_ngseg(outgoingGSMap) - - call MPI_ISEND(outgoingGSMap%comp_id, 1, MP_Type(outgoingGSMap%comp_id), destID, & - TagBase, ThisMCTWorld%MCT_comm, reqHandle(1), ierr) - if(ierr /= 0) then - call MP_perr_die(myname_, 'Send compid failed',ierr) - endif - - call MPI_ISEND(outgoingGSMap%ngseg, 1, MP_Type(outgoingGSMap%ngseg), destID, & - TagBase+1, ThisMCTWorld%MCT_comm, reqHandle(2), ierr) - if(ierr /= 0) then - call MP_perr_die(myname_, 'Send ngseg failed',ierr) - endif - - call MPI_ISEND(outgoingGSMap%gsize, 1, MP_Type(outgoingGSMap%gsize), destID, & - TagBase+2, ThisMCTWorld%MCT_comm, reqHandle(3), ierr) - if(ierr /= 0) then - call MP_perr_die(myname_, 'Send gsize failed',ierr) - endif - - ! Send segment information data (3 messages) - - call MPI_ISEND(outgoingGSMap%start, nsegs, & - MP_Type(outgoingGSMap%start(1)), & - destID, TagBase+3, ThisMCTWorld%MCT_comm, reqHandle(4), ierr) - if(ierr /= 0) then - call MP_perr_die(myname_, 'Send outgoingGSMap%start failed',ierr) - endif - - call MPI_ISEND(outgoingGSMap%length, nsegs, & - MP_Type(outgoingGSMap%length(1)), & - destID, TagBase+4, ThisMCTWorld%MCT_comm, reqHandle(5), ierr) - if(ierr /= 0) then - call MP_perr_die(myname_, 'Send outgoingGSMap%length failed',ierr) - endif - - call MPI_ISEND(outgoingGSMap%pe_loc, nsegs, & - MP_Type(outgoingGSMap%pe_loc(1)), & - destID, TagBase+5, ThisMCTWorld%MCT_comm, reqHandle(6), ierr) - if(ierr /= 0) then - call MP_perr_die(myname_, 'Send outgoingGSMap%pe_loc failed',ierr) - endif - - end subroutine isend_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: recv_ - Point-to-point blocking Receive of a GlobalSegMap -! -! !DESCRIPTION: -! This routine performs a blocking receive of a {\tt GlobalSegMap} (the -! input argument {\tt outgoingGSMap}) from the root processor on component -! {\tt comp\_id}. The input {\tt INTEGER} argument {\tt TagBase} -! is used to generate tags for the messages associated with this operation; -! there are six messages involved, so the user should avoid using tag -! values {\tt TagBase} and {\tt TagBase + 5}. The success (failure) of this -! operation is reported in the zero (non-zero) value of the optional {\tt INTEGER} -! output variable {\tt status}. -! -! !INTERFACE: - - subroutine recv_(incomingGSMap, comp_id, TagBase, status) - -! -! !USES: -! - use m_mpif90 - use m_die, only : MP_perr_die, die - use m_stdio - - use m_GlobalSegMap, only : GlobalSegMap - use m_GlobalSegMap, only : GlobalSegMap_init => init - - use m_MCTWorld, only : ComponentToWorldRank - use m_MCTWorld, only : ThisMCTWorld - - implicit none - -! !INPUT PARAMETERS: - - integer, intent(IN) :: comp_id - integer, intent(IN) :: TagBase - -! !OUTPUT PARAMETERS: - - type(GlobalSegMap), intent(OUT) :: incomingGSMap - integer, optional, intent(OUT) :: status - -! !REVISION HISTORY: -! 13Aug03 - J.W. Larson - API and initial version. -! 25Aug03 - R.Jacob - rename to recv_. -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::recv_' - - integer :: ierr,sourceID - integer :: MPstatus(MP_STATUS_SIZE) - integer :: RecvBuffer(3) - - if(present(status)) status = 0 ! the success value - - sourceID = ComponentToWorldRank(0, comp_id, ThisMCTWorld) - - ! Receive the GlobalSegMap's basic constants: component id, - ! grid size, and number of segments. The number of segments - ! is needed to construct the arrays into which segment - ! information will be received. Thus, this receive blocks. - - call MPI_RECV(RecvBuffer(1), 1, MP_Type(RecvBuffer(1)), sourceID, & - TagBase, ThisMCTWorld%MCT_comm, MPstatus, ierr) - if(ierr /= 0) then - call MP_perr_die(myname_, 'Receive of compid failed',ierr) - endif - call MPI_RECV(RecvBuffer(2), 1, MP_Type(RecvBuffer(2)), sourceID, & - TagBase+1, ThisMCTWorld%MCT_comm, MPstatus, ierr) - if(ierr /= 0) then - call MP_perr_die(myname_, 'Receive of ngseg failed',ierr) - endif - call MPI_RECV(RecvBuffer(3), 1, MP_Type(RecvBuffer(3)), sourceID, & - TagBase+2, ThisMCTWorld%MCT_comm, MPstatus, ierr) - if(ierr /= 0) then - call MP_perr_die(myname_, 'Receive of gsize failed',ierr) - endif - - ! Create Empty GlobaSegMap into which segment information - ! will be received - - call GlobalSegMap_init(incomingGSMap, RecvBuffer(1), RecvBuffer(2), & - RecvBuffer(3)) - - ! Receive segment information data (3 messages) - - call MPI_RECV(incomingGSMap%start, RecvBuffer(2), & - MP_Type(incomingGSMap%start(1)), & - sourceID, TagBase+3, ThisMCTWorld%MCT_comm, MPstatus, ierr) - if(ierr /= 0) then - call MP_perr_die(myname_, 'Recv incomingGSMap%start failed',ierr) - endif - - call MPI_RECV(incomingGSMap%length, RecvBuffer(2), & - MP_Type(incomingGSMap%length(1)), & - sourceID, TagBase+4, ThisMCTWorld%MCT_comm, MPstatus, ierr) - if(ierr /= 0) then - call MP_perr_die(myname_, 'Recv incomingGSMap%length failed',ierr) - endif - - call MPI_RECV(incomingGSMap%pe_loc, RecvBuffer(2), & - MP_Type(incomingGSMap%pe_loc(1)), & - sourceID, TagBase+5, ThisMCTWorld%MCT_comm, MPstatus, ierr) - if(ierr /= 0) then - call MP_perr_die(myname_, 'Recv incomingGSMap%pe_loc failed',ierr) - endif - - end subroutine recv_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: bcast_ - broadcast a GlobalSegMap object -! -! !DESCRIPTION: -! -! The routine {\tt bcast\_()} takes the input/output {\em GlobalSegMap} -! argument {\tt GSMap} (on input valid only on the {\tt root} process, -! on output valid on all processes) and broadcasts it to all processes -! on the communicator associated with the F90 handle {\tt comm}. The -! success (failure) of this operation is returned as a zero (non-zero) -! value of the optional output {\tt INTEGER} argument {\tt status}. -! -! !INTERFACE: - - subroutine bcast_(GSMap, root, comm, status) - -! -! !USES: -! - use m_mpif90 - use m_die, only : MP_perr_die,die - use m_stdio - - use m_GlobalSegMap, only : GlobalSegMap - - implicit none - -! !INPUT PARAMETERS: - - integer, intent(in) :: root - integer, intent(in) :: comm - -! !INPUT/OUTPUT PARAMETERS: - - type(GlobalSegMap), intent(inout) :: GSMap ! Output GlobalSegMap - -! !OUTPUT PARAMETERS: - - integer, optional, intent(out) :: status ! global vector size - -! !REVISION HISTORY: -! 17Oct01 - J.W. Larson - Initial version. -! 11Aug03 - J.W. Larson - Relocated from original -! location in m_GlobalSegMap. -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::bcast_' - - integer :: myID, ierr, n - integer, dimension(:), allocatable :: IntBuffer - - ! Step One: which process am I? - - call MP_COMM_RANK(comm, myID, ierr) - if(ierr /= 0) call MP_perr_die(myname_,'MP_comm_rank()',ierr) - - ! Step Two: Broadcast the scalar bits of the GlobalSegMap from - ! the root. - - allocate(IntBuffer(3), stat=ierr) ! allocate buffer space (all PEs) - if(ierr /= 0) then - if(.not. present(status)) then - call die(myname_,'allocate(IntBuffer)',ierr) - else - write(stderr,*) myname_,':: error during allocate(IntBuffer)' - status = 2 - return - endif - endif - - if(myID == root) then ! pack the buffer - IntBuffer(1) = GSMap%comp_id - IntBuffer(2) = GSMap%ngseg - IntBuffer(3) = GSMap%gsize - endif - - call MPI_BCAST(IntBuffer, 3, MP_type(IntBuffer(1)), root, comm, ierr) - if(ierr /= 0) call MP_perr_die(myname_,'MPI_BCAST(IntBuffer)',ierr) - - if(myID /= root) then ! unpack from buffer to GSMap - GSMap%comp_id = IntBuffer(1) - GSMap%ngseg = IntBuffer(2) - GSMap%gsize = IntBuffer(3) - endif - - deallocate(IntBuffer, stat=ierr) ! deallocate buffer space - if(ierr /= 0) then - if(.not. present(status)) then - call die(myname_,'deallocate(IntBuffer)',ierr) - else - write(stderr,*) myname_,':: error during deallocate(IntBuffer)' - status = 4 - return - endif - endif - - ! Step Three: Broadcast the vector bits of GSMap from the root. - ! Pack them into one big array to save latency costs associated - ! with multiple broadcasts. - - allocate(IntBuffer(3*GSMap%ngseg), stat=ierr) ! allocate buffer space (all PEs) - if(ierr /= 0) then - if(.not. present(status)) then - call die(myname_,'second allocate(IntBuffer)',ierr) - else - write(stderr,*) myname_,':: error during second allocate(IntBuffer)' - status = 5 - return - endif - endif - - if(myID == root) then ! pack outgoing broadcast buffer - do n=1,GSMap%ngseg - IntBuffer(n) = GSMap%start(n) - IntBuffer(GSMap%ngseg+n) = GSMap%length(n) - IntBuffer(2*GSMap%ngseg+n) = GSMap%pe_loc(n) - end do - endif - - call MPI_BCAST(IntBuffer, 3*GSMap%ngseg, MP_Type(IntBuffer(1)), root, comm, ierr) - if(ierr /= 0) call MP_perr_die(myname_,'Error in second MPI_BCAST(IntBuffer)',ierr) - - if(myID /= root) then ! Allocate GSMap%start, GSMap%length,...and fill them - - allocate(GSMap%start(GSMap%ngseg), GSMap%length(GSMap%ngseg), & - GSMap%pe_loc(GSMap%ngseg), stat=ierr) - if(ierr /= 0) then - if(.not. present(status)) then - call die(myname_,'off-root allocate(GSMap%start...)',ierr) - else - write(stderr,*) myname_,':: error during off-root allocate(GSMap%start...)' - status = 7 - return - endif - endif - - do n=1,GSMap%ngseg ! unpack the buffer into the GlobalSegMap - GSMap%start(n) = IntBuffer(n) - GSMap%length(n) = IntBuffer(GSMap%ngseg+n) - GSMap%pe_loc(n) = IntBuffer(2*GSMap%ngseg+n) - end do - - endif - - ! Clean up buffer space: - - deallocate(IntBuffer, stat=ierr) - if(ierr /= 0) then - if(.not. present(status)) then - call die(myname_,'second deallocate(IntBuffer)',ierr) - else - write(stderr,*) myname_,':: error during second deallocate(IntBuffer)' - status = 8 - return - endif - endif - - end subroutine bcast_ - - end module m_GlobalSegMapComms diff --git a/cesm/models/utils/mct/mct/m_GlobalToLocal.F90 b/cesm/models/utils/mct/mct/m_GlobalToLocal.F90 deleted file mode 100644 index 936826c..0000000 --- a/cesm/models/utils/mct/mct/m_GlobalToLocal.F90 +++ /dev/null @@ -1,719 +0,0 @@ -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!----------------------------------------------------------------------- -! CVS $Id$ -! CVS $Name$ -!BOP ------------------------------------------------------------------- -! -! !MODULE: m_GlobalToLocal - Global to Local Index Translation -! -! !DESCRIPTION: -! This module contains routines for translating global array indices -! into their local counterparts (that is, the indices into the local -! data structure holding a given process' chunk of a distributed array). -! The MCT domain decomposition descriptors {\tt GlobalMap} and -! {\tt GlobalSegMap} are both supported. Indices can be translated -! one-at-a-time using the {\tt GlobalToLocalIndex} routine or many -! at once using the {\tt GlobalToLocalIndices} routine. -! -! This module also provides facilities for setting the local row and -! column indices for a {\tt SparseMatrix} through the -! {\tt GlobalToLocalMatrix} routines. -! -! !INTERFACE: - - module m_GlobalToLocal - -! !USES: -! No external modules are used in the declaration section of this module. - - implicit none - - private ! except - -! !PUBLIC MEMBER FUNCTIONS: - - public :: GlobalToLocalIndex ! Translate Global to Local index - ! (i.e. recover local index for a - ! point from its global index). - - public :: GlobalToLocalIndices ! Translate Global to Local indices - ! (i.e. recover local starts/lengths - ! of distributed data segments). - - public :: GlobalToLocalMatrix ! Re-indexing of row or column - ! indices for a SparseMatrix - - interface GlobalToLocalIndices ; module procedure & - GlobalSegMapToIndices_, & ! local arrays of starts/lengths - GlobalSegMapToNavigator_, & ! return local indices as Navigator - GlobalSegMapToIndexArr_ - end interface - - interface GlobalToLocalIndex ; module procedure & - GlobalSegMapToIndex_, & - GlobalMapToIndex_ - end interface - - interface GlobalToLocalMatrix ; module procedure & - GlobalSegMapToLocalMatrix_ - end interface - - -! !SEE ALSO: -! -! The MCT modules {\tt m\_GlobalMap} and {m\_GlobalSegMap} for more -! information regarding MCT's domain decomposition descriptors. -! -! The MCT module {\tt m\_SparseMatrix} for more information regarding -! the {\tt SparseMatrix} datatype. -! -! !REVISION HISTORY: -! 2Feb01 - J.W. Larson - initial prototype -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname='MCT::m_GlobalToLocal' - - contains - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: GlobalSegMapToIndices_ - Return _local_ indices in arrays. -! -! !DESCRIPTION: {\tt GlobalSegMapToIndices\_()} takes a user-supplied -! {\tt GlobalSegMap} data type {\tt GSMap}, which desribes a decomposition -! on the input MPI communicator corresponding to the Fortran {\tt INTEGER} -! handle {\tt comm} to translate the global directory of segment locations -! into local indices for referencing the on-pe storage of the mapped -! distributed data. -! -! {\bf N.B.:} This routine returns two allocated arrays---{\tt start(:)} -! and {\tt length(:)}---which must be deallocated once the user no longer -! needs them. Failure to do this will create a memory leak. -! -! !INTERFACE: - - subroutine GlobalSegMapToIndices_(GSMap, comm, start, length) - -! -! !USES: -! - use m_mpif90 - use m_die, only : MP_perr_die, die, warn - use m_GlobalSegMap, only : GlobalSegMap - use m_GlobalSegMap, only : GlobalSegMap_ngseg => ngseg - use m_GlobalSegMap, only : GlobalSegMap_nlseg => nlseg - - implicit none - -! !INPUT PARAMETERS: - - type(GlobalSegMap), intent(in) :: GSMap ! Output GlobalSegMap - integer, intent(in) :: comm ! communicator handle - -! !OUTPUT PARAMETERS: - - integer,dimension(:), pointer :: start ! local segment start indices - integer,dimension(:), pointer :: length ! local segment sizes - -! !REVISION HISTORY: -! 2Feb01 - J.W. Larson - initial version -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::GlobalSegMapToIndices_' - - integer :: myID, ierr, ngseg, nlseg, n, count - - ! determine local process id myID - - call MP_COMM_RANK(comm, myID, ierr) - if(ierr /= 0) call MP_perr_die(myname_,'MP_COMM_RANK',ierr) - - ! determine number of global segments ngseg: - - ngseg = GlobalSegMap_ngseg(GSMap) - - ! determine number of local segments on process myID nlseg: - - nlseg = GlobalSegMap_nlseg(GSMap, myID) - - ! allocate arrays start(:) and length(:) to store local - ! segment information. - - allocate(start(nlseg), length(nlseg), stat=ierr) - if(ierr /= 0) call die(myname_,'allocate(start...',ierr) - - ! Loop over GlobalSegMap%pe_loc(:) values to isolate - ! global index values of local data. Record number of - ! matches in the INTEGER count. - - count = 0 - do n=1, ngseg - if(GSMap%pe_loc(n) == myID) then - count = count + 1 - if(count > nlseg) then - ierr = 2 - call die(myname_,'too many pe matches',ierr) - endif - start(count) = GSMap%start(n) - length(count) = GSMap%length(n) - endif - end do - - if(count < nlseg) then - ierr = 3 - call die(myname_,'too few pe matches',ierr) - endif - - ! translate global start indices to their local - ! values, based on their storage order and number - ! of elements in each segment - - do n=1, count - if(n == 1) then - start(n) = 1 - else - start(n) = start(n-1) + length(n-1) - endif - end do - - end subroutine GlobalSegMapToIndices_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: GlobalSegMapToIndex_ - Global to Local Index Translation -! -! !DESCRIPTION: This {\tt INTEGER} query function takes a user-supplied -! {\tt GlobalSegMap} data type {\tt GSMap}, which desribes a decomposition -! on the input MPI communicator corresponding to the Fortran {\tt INTEGER} -! handle {\tt comm}, and the input global index value {\tt i\_g}, and -! returns a positive local index value if the datum {\tt i\_g}. If -! the datum {\tt i\_g} is not stored on the local process ID, a value -! of {\tt -1} is returned. -! -! !INTERFACE: - - - integer function GlobalSegMapToIndex_(GSMap, i_g, comm) - -! -! !USES: -! - use m_mpif90 - use m_die, only : MP_perr_die, die, warn - use m_GlobalSegMap, only : GlobalSegMap - use m_GlobalSegMap, only : GlobalSegMap_ngseg => ngseg - use m_GlobalSegMap, only : GlobalSegMap_nlseg => nlseg - - implicit none - -! !INPUT PARAMETERS: - - type(GlobalSegMap), intent(in) :: GSMap ! Output GlobalSegMap - integer, intent(in) :: i_g ! global index - integer, intent(in) :: comm ! communicator handle - -! !REVISION HISTORY: -! 2Feb01 - J.W. Larson - initial version -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::GlobalSegMapToIndex_' - - integer :: myID - integer :: count, ierr, ngseg, nlseg, n - integer :: lower_bound, upper_bound - integer :: local_start, local_index - logical :: found - - ! Determine local process id myID: - - call MP_COMM_RANK(comm, myID, ierr) - if(ierr /= 0) call MP_perr_die(myname_,'MP_COMM_RANK()',ierr) - - ! Extract the global number of segments in GSMap - - ngseg = GlobalSegMap_ngseg(GSMap) - - ! Extract the global number of segments in GSMap for myID - - nlseg = GlobalSegMap_nlseg(GSMap, myID) - - ! set the counter count, which records the number of times myID - ! matches entries in GSMap%pe_loc(:) - - count = 0 - - ! set local_start, which is the current local storage segment - ! starting position - - local_start = 1 - - ! set logical flag found to signify we havent found i_g: - - found = .false. - - n = 0 - - SEARCH_LOOP: do - - n = n+1 - if (n > ngseg) EXIT - - if(GSMap%pe_loc(n) == myID) then - - ! increment / check the pe_loc match counter - - count = count + 1 - if(count > nlseg) then - ierr = 2 - call die(myname_,'too many pe matches',ierr) - endif - - ! is i_g in this segment? - - lower_bound = GSMap%start(n) - upper_bound = GSMap%start(n) + GSMap%length(n) - 1 - - if((lower_bound <= i_g) .and. (i_g <= upper_bound)) then - local_index = local_start + (i_g - GSMap%start(n)) - found = .true. - EXIT - else - local_start = local_start + GSMap%length(n) - endif - - endif - end do SEARCH_LOOP - - ! We either found the local index, or have exhausted our options. - - if(found) then - GlobalSegMapToIndex_ = local_index - else - GlobalSegMapToIndex_ = -1 - endif - - end function GlobalSegMapToIndex_ - - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: GlobalSegMapToIndexArr_ - Global to Local Index Array Translation -! -! !DESCRIPTION: Given a {\tt GlobalSegMap} data type {\tt GSMap} -! and MPI communicator corresponding to the Fortran {\tt INTEGER} -! handle {\tt comm}, convert an array of global index values -! {\tt i\_global()} to an array of local index values {\tt i\_local()}. If -! the datum {\tt i\_global(j)} is not stored on the local process ID, -! then {\tt i\_local(j)} will be set to {\tt -1}/ -! -! !INTERFACE: - - -subroutine GlobalSegMapToIndexArr_(GSMap, i_global, i_local, nindex, comm) - -! -! !USES: -! - use m_stdio - use m_mpif90 - use m_die, only : MP_perr_die, die, warn - use m_GlobalSegMap, only : GlobalSegMap - use m_GlobalSegMap, only : GlobalSegMap_ngseg => ngseg - use m_GlobalSegMap, only : GlobalSegMap_nlseg => nlseg - - implicit none - -! !INPUT PARAMETERS: - - type(GlobalSegMap), intent(in) :: GSMap ! Output GlobalSegMap - integer, intent(in) :: i_global(:) ! global index - integer, intent(out) :: i_local(:) ! local index - integer, intent(in) :: nindex ! size of i_global() - integer, intent(in) :: comm ! communicator handle - -! !REVISION HISTORY: -! 12-apr-2006 R. Loy - initial version -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::GlobalSegMapToIndexArr_' - - integer :: myID - integer :: count, ierr, ngseg, nlseg - integer,allocatable :: mygs_lb(:),mygs_ub(:),mygs_len(:),mygs_lstart(:) - - integer :: i,j,n,startj - - ! Determine local process id myID: - - call MP_COMM_RANK(comm, myID, ierr) - if(ierr /= 0) call MP_perr_die(myname_,'MP_COMM_RANK()',ierr) - - - ngseg = GlobalSegMap_ngseg(GSMap) - nlseg = GlobalSegMap_nlseg(GSMap, myID) - - if (nlseg <= 0) return; - - allocate( mygs_lb(nlseg), mygs_ub(nlseg), mygs_len(nlseg) ) - allocate( mygs_lstart(nlseg) ) - - -!! -!! determine the global segments on this processor -!! just once, so the info be used repeatedly below -!! - - n = 0 - do i=1,ngseg - if (GSMap%pe_loc(i) == myID ) then - n=n+1 - mygs_lb(n)=GSMap%start(i) - mygs_ub(n)=GSMap%start(i) + GSMap%length(i) -1 - mygs_len(n)=GSMap%length(i) - endif - enddo - - if (n .ne. nlseg) then - write(stderr,*) myname_,"mismatch nlseg",n,nlseg - call die(myname) - endif - - mygs_lstart(1)=1 - do j=2,nlseg - mygs_lstart(j)=mygs_lstart(j-1)+mygs_len(j-1) - enddo - - -!! -!! this loop is optimized for the case that the indices in iglobal() -!! are in the same order that they appear in the global segments, -!! which seems usually (always?) to be the case. -!! -!! note that the j loop exit condition is only executed when the index -!! is not found in the current segment, which saves a factor of 2 -!! since many consecutive indices are in the same segment. -!! - - - j=1 - do i=1,nindex - - i_local(i)= -1 - - startj=j - SEARCH_LOOP: do - - if ( (mygs_lb(j) <= i_global(i)) .and. & - (i_global(i) <= mygs_ub(j))) then - i_local(i) = mygs_lstart(j) + (i_global(i) - mygs_lb(j)) - EXIT SEARCH_LOOP - else - j=j+1 - if (j > nlseg) j=1 ! wrap around - if (j == startj) EXIT SEARCH_LOOP - endif - - end do SEARCH_LOOP - - end do - -!!!! this version vectorizes (outer loop) -!!!! performance for in-order input is slightly slower than the above -!!!! but performance on out-of-order input is probably much better -!!!! at the moment we are going on the assumption that caller is -!!!! likely providing in-order, so we won't use this version. -!! -!! do i=1,nindex -!! -!! i_local(i)= -1 -!! -!! SEARCH_LOOP: do j=1,nlseg -!! -!! if ( (mygs_lb(j) <= i_global(i)) .and. & -!! (i_global(i) <= mygs_ub(j))) then -!! i_local(i) = mygs_lstart(j) + (i_global(i) - mygs_lb(j)) -!! endif -!! -!! end do SEARCH_LOOP -!! -!! end do - - - deallocate( mygs_lb, mygs_ub, mygs_len, mygs_lstart ) - - end subroutine GlobalSegMapToIndexArr_ - - - - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: GlobalMapToIndex_ - Global to Local Index Translation -! -! !DESCRIPTION: -! This {\tt INTEGER} query function takes as its input a user-supplied -! {\tt GlobalMap} data type {\tt GMap}, which desribes a decomposition -! on the input MPI communicator corresponding to the Fortran {\tt INTEGER} -! handle {\tt comm}, and the input global index value {\tt i\_g}, and -! returns a positive local index value if the datum {\tt i\_g}. If -! the datum {\tt i\_g} is not stored on the local process ID, a value -! of {\tt -1} is returned. -! -! !INTERFACE: - - - integer function GlobalMapToIndex_(GMap, i_g, comm) - -! -! !USES: -! - use m_mpif90 - use m_die, only : MP_perr_die, die, warn - use m_GlobalMap, only : GlobalMap - - implicit none - -! !INPUT PARAMETERS: - - type(GlobalMap), intent(in) :: GMap ! Input GlobalMap - integer, intent(in) :: i_g ! global index - integer, intent(in) :: comm ! communicator handle - -! !REVISION HISTORY: -! 2Feb01 - J.W. Larson - initial version -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::GlobalMapToIndex_' - - integer :: myID - integer :: count, ierr, ngseg, nlseg, n - integer :: lower_bound, upper_bound - integer :: local_start, local_index - logical :: found - - ! Determine local process id myID: - - call MP_COMM_RANK(comm, myID, ierr) - if(ierr /= 0) call MP_perr_die(myname_,'MP_COMM_RANK()',ierr) - - ! Initialize logical "point located" flag found as false - - found = .false. - - lower_bound = GMap%displs(myID) + 1 - upper_bound = GMap%displs(myID) + GMap%counts(myID) - - if((lower_bound <= i_g) .and. (i_g <= upper_bound)) then - found = .true. - local_index = i_g - lower_bound + 1 - endif - - if(found) then - GlobalMapToIndex_ = local_index - else - GlobalMapToIndex_ = -1 - endif - - end function GlobalMapToIndex_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: GlobalSegMapToNavigator_ - Return Navigator to Local Segments -! -! !DESCRIPTION: -! This routine takes as its input takes a user-supplied -! {\tt GlobalSegMap} data type {\tt GSMap}, which desribes a decomposition -! on the input MPI communicator corresponding to the Fortran {\tt INTEGER} -! handle {\tt comm}, and returns the local segment start index and length -! information for referencing the on-pe storage of the mapped distributed -! data. These data are returned in the form of the output {\tt Navigator} -! argument {Nav}. -! -! {\bf N.B.:} This routine returns a {\tt Navigator} variable {\tt Nav}, -! which must be deallocated once the user no longer needs it. Failure to -! do this will create a memory leak. -! -! !INTERFACE: - - subroutine GlobalSegMapToNavigator_(GSMap, comm, oNav) - -! -! !USES: -! - use m_mpif90 - use m_die, only : MP_perr_die, die, warn - use m_GlobalSegMap, only : GlobalSegMap - use m_GlobalSegMap, only : GlobalSegMap_ngseg => ngseg - use m_GlobalSegMap, only : GlobalSegMap_nlseg => nlseg - use m_Navigator, only : Navigator - use m_Navigator, only : Navigator_init => init - - implicit none - -! !INPUT PARAMETERS: - - type(GlobalSegMap), intent(in) :: GSMap ! Input GlobalSegMap - integer, intent(in) :: comm ! communicator handle - -! !OUTPUT PARAMETERS: - - type(Navigator), intent(out) :: oNav ! Output Navigator - -! !REVISION HISTORY: -! 2Feb01 - J.W. Larson - initial version -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::GlobalSegMapToNavigator_' - - integer :: myID, ierr, ngseg, nlseg, n, count - - ! determine local process id myID - - call MP_COMM_RANK(comm, myID, ierr) - if(ierr /= 0) call MP_perr_die(myname_,'MP_COMM_RANK',ierr) - - ! determine number of global segments ngseg: - - ngseg = GlobalSegMap_ngseg(GSMap) - - ! determine number of local segments on process myID nlseg: - - nlseg = GlobalSegMap_nlseg(GSMap, myID) - - ! Allocate space for the Navigator oNav: - - call Navigator_init(oNav, nlseg, ierr) - if(ierr /= 0) call die(myname_,'Navigator_init',ierr) - - call GlobalSegMapToIndices_(GSMap, comm, oNav%displs, oNav%counts) - - end subroutine GlobalSegMapToNavigator_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: GlobalSegMapToLocalMatrix_ - Set Local SparseMatrix Indices -! -! !DESCRIPTION: -! This routine takes as its input a user-supplied {\tt GlobalSegMap} -! domain decomposition {\tt GSMap}, which describes the decomposition of -! either the rows or columns of the input/output {\tt SparseMatrix} -! argument {\tt sMat} on the communicator associated with the {\tt INTEGER} -! handle {\tt comm}, and to translate the global row or column indices -! of {\tt sMat} into their local counterparts. The choice of either row -! or column is governed by the value of the input {\tt CHARACTER} -! argument {\tt RCFlag}. One sets this variable to either {\tt 'ROW'} or -! {\tt 'row'} to specify row re-indexing (which are stored in -! {\tt sMat} and retrieved by indexing the attribute {\tt lrow}), and -! {\tt 'COLUMN'} or {\tt 'column'} to specify column re-indexing (which -! are stored in {\tt sMat} and retrieved by indexing the {\tt SparseMatrix} -! attribute {\tt lcol}). -! -! !INTERFACE: - - subroutine GlobalSegMapToLocalMatrix_(sMat, GSMap, RCFlag, comm) - -! -! !USES: -! - use m_stdio - use m_die, only : die - - use m_SparseMatrix, only : SparseMatrix - use m_SparseMatrix, only : SparseMatrix_indexIA => indexIA - use m_SparseMatrix, only : SparseMatrix_lsize => lsize - - use m_GlobalSegMap, only : GlobalSegMap - - - implicit none - -! !INPUT PARAMETERS: - - type(GlobalSegMap), intent(in) :: GSMap ! Input GlobalSegMap - character(len=*), intent(in) :: RCFlag ! 'row' or 'column' - integer, intent(in) :: comm ! communicator handle - -! !INPUT/OUTPUT PARAMETERS: - - type(SparseMatrix), intent(inout) :: sMat - -! !SEE ALSO: -! The MCT module m_SparseMatrix for more information about the -! SparseMatrix type and its storage of global and local row-and -! column indices. -! -! !REVISION HISTORY: -! 3May01 - J.W. Larson - initial version, which -! is _extremely_ slow, but safe. This must be re-examined -! later. -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::GlobalSegMapToLocalMatrix_' - - - integer :: i, GlobalIndex, gindex, lindex, lsize - - integer, allocatable :: temp_gindex(:) !! rml - integer, allocatable :: temp_lindex(:) !! rml - - - ! What are we re-indexing, rows or columns? - - select case(RCFlag) - case('ROW','row') - gindex = SparseMatrix_indexIA(sMat, 'grow', dieWith=myname_) - lindex = SparseMatrix_indexIA(sMat,'lrow', dieWith=myname_) - case('COLUMN','column') - gindex = SparseMatrix_indexIA(sMat,'gcol', dieWith=myname_) - lindex = SparseMatrix_indexIA(sMat,'lcol', dieWith=myname_) - case default - write(stderr,'(3a)') myname_,":: unrecognized value of RCFLag ",RCFlag - call die(myname) - end select - - - ! How many matrix elements are there? - - lsize = SparseMatrix_lsize(sMat) - - - !! rml new code from here down - do the mapping all in one - !! function call which has been tuned for speed - - allocate( temp_gindex(lsize) ) - allocate( temp_lindex(lsize) ) - - - do i=1,lsize - temp_gindex(i) = sMat%data%iAttr(gindex,i) - end do - - call GlobalSegMapToIndexArr_(GSMap, temp_gindex, temp_lindex, lsize, comm) - - do i=1,lsize - sMat%data%iAttr(lindex,i) = temp_lindex(i) - end do - - - deallocate(temp_gindex) ! rml - deallocate(temp_lindex) ! rml - - - end subroutine GlobalSegMapToLocalMatrix_ - - end module m_GlobalToLocal diff --git a/cesm/models/utils/mct/mct/m_MCTWorld.F90 b/cesm/models/utils/mct/mct/m_MCTWorld.F90 deleted file mode 100644 index 8ff6055..0000000 --- a/cesm/models/utils/mct/mct/m_MCTWorld.F90 +++ /dev/null @@ -1,879 +0,0 @@ -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!----------------------------------------------------------------------- -! CVS m_MCTWorld.F90,v 1.26 2007/06/01 19:56:25 rloy Exp -! CVS MCT_2_4_0 -!BOP ------------------------------------------------------------------- -! -! !MODULE: m_MCTWorld -- MCTWorld Class -! -! !DESCRIPTION: -! MCTWorld is a datatype which acts as a component model registry. -! All models communicating through MCT must participate in initialization -! of MCTWorld. The single instance of MCTWorld, {\tt ThisMCTWorld} stores -! the component id and local and global processor rank of each component. -! This module contains methods for creating and destroying {\tt ThisMCTWorld} -! as well as inquiry functions. -! -! !INTERFACE: - - module m_MCTWorld -! -! !USES: - use m_List, only : List ! Support for List components. - - implicit none - - private ! except - -! !PUBLIC TYPES: - - public :: MCTWorld ! The MCTWorld class data structure - - type MCTWorld - integer :: MCT_comm ! MCT communicator - integer :: ncomps ! Total number of components - integer :: mygrank ! Rank of this processor in - ! global communicator. - integer,dimension(:),pointer :: nprocspid => null() ! Number of processes - ! each component is on (e.g. rank of its - ! local communicator. - integer,dimension(:,:),pointer :: idGprocid => null() ! Translate between local component rank - ! rank in global communicator. - ! idGprocid(modelid,localrank)=globalrank - end type MCTWorld - -! !PUBLIC DATA MEMBERS: - - type(MCTWorld) :: ThisMCTWorld ! declare the MCTWorld - -! !PUBLIC MEMBER FUNCTIONS: - public :: initialized ! Determine if MCT is initialized - public :: init ! Create a MCTWorld - public :: clean ! Destroy a MCTWorld - public :: printnp ! Print contents of a MCTWorld - public :: NumComponents ! Number of Components in the MCTWorld - public :: ComponentNumProcs ! Number of processes owned by a given - ! component - public :: ComponentToWorldRank ! Given the rank of a process on a - ! component, return its rank on the - ! world communicator - public :: ComponentRootRank ! Return the rank on the world - ! communicator of the root process of - ! a component - public :: ThisMCTWorld ! Instantiation of the MCTWorld - -! - - interface initialized ; module procedure & - initialized_ - end interface - interface init ; module procedure & - initd_, & - initm_, & - initr_ - end interface - interface clean ; module procedure clean_ ; end interface - interface printnp ; module procedure printnp_ ; end interface - interface NumComponents ; module procedure & - NumComponents_ - end interface - interface ComponentNumProcs ; module procedure & - ComponentNumProcs_ - end interface - interface ComponentToWorldRank ; module procedure & - ComponentToWorldRank_ - end interface - interface ComponentRootRank ; module procedure & - ComponentRootRank_ - end interface - - - -! !REVISION HISTORY: -! 19Jan01 - R. Jacob - initial prototype -! 05Feb01 - J. Larson - added query and -! local-to-global mapping services NumComponents, -! ComponentNumProcs, ComponentToWorldRank, and ComponentRootRank -! 08Feb01 - R. Jacob - add mylrank and mygrank -! to datatype -! 20Apr01 - R. Jacob - remove allids from -! MCTWorld datatype. Not needed because component -! ids are always from 1 to number-of-components. -! 07Jun01 - R. Jacob - remove myid, mynprocs -! and mylrank from MCTWorld datatype because they are not -! clearly defined in PCM mode. Add MCT_comm for future use. -! 03Aug01 - E. Ong - explicity specify starting -! address in mpi_irecv -! 27Nov01 - E. Ong - added R. Jacob's version of initd_ -! to support PCM mode. -! 15Feb02 - R. Jacob - elminate use of MP_COMM_WORLD. Use -! argument globalcomm instead. Create MCT_comm from -! globalcomm -!EOP __________________________________________________________________ - - character(len=*),parameter :: myname='MCT::m_MCTWorld' - - contains - - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: initialized_ - determine if MCTWorld is initialized -! -! !DESCRIPTION: -! This routine may be used to determine whether {\tt MCTWorld::init} -! has been called. If not, the user must call {\tt init} before -! performing any other MCT library calls. -! -! !INTERFACE: - - logical function initialized_() - -! -! !USES: -! - -! !INPUT PARAMETERS: - - -! !REVISION HISTORY: -! 01June07 - R. Loy - initial version -!EOP ___________________________________________________________________ -! - - initialized_ = associated(ThisMCTWorld%nprocspid) - - end function initialized_ - - - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: initm_ - initialize MCTWorld -! -! !DESCRIPTION: -! Do a distributed init of MCTWorld for the case where a set of processors -! contains more then one model and the models may not span the set of processors. -! {\tt ncomps} is the total number of components in the entire coupled system. -! {\tt globalcomm} encompasses all the models (typically this can be MPI\_COMM\_WORLD). -! {\tt mycomms} is an array of MPI communicators, each sized for the appropriate model -! and {\tt myids} is a corresponding array of integers containing the model ids for -! the models on this particular set of processors. -! -! This routine is called once for the models covered by the set of processors. -! -! !INTERFACE: - - subroutine initm_(ncomps,globalcomm,mycomms,myids) -! -! !USES: -! - use m_mpif90 - use m_die - use m_stdio - - implicit none - -! !INPUT PARAMETERS: - - integer, intent(in) :: ncomps ! number of components - integer, intent(in) :: globalcomm ! global communicator - integer, dimension(:),pointer :: mycomms ! my communicators - integer, dimension(:),pointer :: myids ! component ids - -! !REVISION HISTORY: -! 20Sep07 - T. Craig migrated code from initd routine -! 20Sep07 - T. Craig - made mycomms an array -!EOP ___________________________________________________________________ -! - character(len=*),parameter :: myname_=myname//'::initm_' - integer :: ier,myGid,myLid,i,mysize,Gsize,j - -! arrays allocated on the root to coordinate gathring of data -! and non-blocking receives by the root - integer, dimension(:), allocatable :: compids,reqs,nprocs,Gprocids - integer, dimension(:), allocatable :: root_nprocs - integer, dimension(:,:),allocatable :: status,root_idGprocid - integer, dimension(:,:),pointer :: tmparray - integer,dimension(:),pointer :: apoint -! ------------------------------------------------------------------ - -! Check that ncomps is a legal value - if(ncomps < 1) then - call die(myname_, "argument ncomps can't less than one!",ncomps) - endif - - if (size(myids) /= size(mycomms)) then - call die(myname_, "size of myids and mycomms inconsistent") - endif - -! make sure this has not been called already - if(associated(ThisMCTWorld%nprocspid) ) then - write(stderr,'(2a)') myname_, & - 'MCTERROR: MCTWorld has already been initialized...Continuing' - RETURN - endif - -! determine overall size - call MP_comm_size(globalcomm,Gsize,ier) - if(ier /= 0) call MP_perr_die(myname_,'MP_comm_size()',ier) - -! determine my rank in comm_world - call MP_comm_rank(globalcomm,myGid,ier) - if(ier /= 0) call MP_perr_die(myname_,'MP_comm_rank()',ier) - -! allocate space on global root to receive info about -! the other components - if(myGid == 0) then - allocate(nprocs(ncomps),compids(ncomps),& - reqs(ncomps),status(MP_STATUS_SIZE,ncomps),& - root_nprocs(ncomps),stat=ier) - if (ier /= 0) then - call die(myname_, 'allocate(nprocs,...)',ier) - endif - endif - - -!!!!!!!!!!!!!!!!!! -! Gather the number of procs from the root of each component -!!!!!!!!!!!!!!!!!! -! -! First on the global root, post a receive for each component - if(myGid == 0) then - do i=1,ncomps - call MPI_IRECV(root_nprocs(i), 1, MP_INTEGER, MP_ANY_SOURCE,i, & - globalcomm, reqs(i), ier) - if(ier /= 0) call MP_perr_die(myname_,'MPI_IRECV(root_nprocs)',ier) - enddo - endif - -! The local root on each component sends - do i=1,size(myids) - if(mycomms(i)/=MP_COMM_NULL) then - call MP_comm_size(mycomms(i),mysize,ier) - if(ier /= 0) call MP_perr_die(myname_,'MP_comm_size()',ier) - call MP_comm_rank(mycomms(i),myLid,ier) - if(ier /= 0) call MP_perr_die(myname_,'MP_comm_rank()',ier) - if(myLid == 0) then - call MPI_SEND(mysize,1,MP_INTEGER,0,myids(i),globalcomm,ier) - if(ier /= 0) call MP_perr_die(myname_,'MPI_SEND(mysize)',ier) - endif - endif - enddo - -! Global root waits for all sends - if(myGid == 0) then - call MPI_WAITALL(size(reqs), reqs, status, ier) - if(ier /= 0) call MP_perr_die(myname_,'MPI_WAITALL()',ier) - endif -! Global root now knows how many processors each component is using - -!!!!!!!!!!!!!!!!!! -! end of nprocs -!!!!!!!!!!!!!!!!!! - - -! allocate a tmp array for the receive on root. - if(myGid == 0) then - allocate(tmparray(0:Gsize-1,ncomps),stat=ier) - if(ier/=0) call die(myname_,'allocate(tmparray)',ier) - -! fill tmparray with a bad rank value for later error checking - tmparray = -1 - endif - -!!!!!!!!!!!!!!!!!! -! Gather the Gprocids from each local root -!!!!!!!!!!!!!!!!!! -! -! First on the global root, post a receive for each component - if(myGid == 0) then - do i=1,ncomps - apoint => tmparray(0:Gsize-1,i) - call MPI_IRECV(apoint(1), root_nprocs(i),MP_INTEGER, & - MP_ANY_SOURCE,i,globalcomm, reqs(i), ier) - if(ier /= 0) call MP_perr_die(myname_,'MPI_IRECV()',ier) - enddo - endif - -! The root on each component sends - do i=1,size(myids) - if(mycomms(i)/=MP_COMM_NULL) then - call MP_comm_size(mycomms(i),mysize,ier) - if(ier /= 0) call MP_perr_die(myname_,'MP_comm_size()',ier) - call MP_comm_rank(mycomms(i),myLid,ier) - if(ier /= 0) call MP_perr_die(myname_,'MP_comm_rank()',ier) - -! make the master list of global proc ids -! -! allocate space to hold global ids -! only needed on root, but allocate everywhere to avoid complaints. - allocate(Gprocids(mysize),stat=ier) - if(ier/=0) call die(myname_,'allocate(Gprocids)',ier) -! gather over the LOCAL comm - call MPI_GATHER(myGid,1,MP_INTEGER,Gprocids,1,MP_INTEGER,0,mycomms(i),ier) - if(ier/=0) call die(myname_,'MPI_GATHER Gprocids',ier) - - if(myLid == 0) then - call MPI_SEND(Gprocids,mysize,MP_INTEGER,0,myids(i),globalcomm,ier) - if(ier /= 0) call MP_perr_die(myname_,'MPI_SEND(Gprocids)',ier) - endif - - deallocate(Gprocids,stat=ier) - if(ier/=0) call die(myname_,'deallocate(Gprocids)',ier) - endif - enddo - -! Global root waits for all sends - if(myGid == 0) then - call MPI_WAITALL(size(reqs), reqs, status, ier) - if(ier /= 0) call MP_perr_die(myname_,'MPI_WAITALL(Gprocids)',ier) - endif - -! Now store the Gprocids in the World description and Broadcast - - if(myGid == 0) then - allocate(root_idGprocid(ncomps,0:Gsize-1),stat=ier) - if(ier/=0) call die(myname_,'allocate(root_idGprocid)',ier) - - root_idGprocid = transpose(tmparray) - endif - - if(myGid /= 0) then - allocate(root_nprocs(1),root_idGprocid(1,1),stat=ier) - if(ier/=0) call die(myname_,'non-root allocate(root_idGprocid)',ier) - endif - -!!!!!!!!!!!!!!!!!! -! end of Gprocids -!!!!!!!!!!!!!!!!!! - -! now call the init from root. - call initr_(ncomps,globalcomm,root_nprocs,root_idGprocid) - -! if(myGid==0 .or. myGid==17) then -! write(*,*)'MCTA',myGid,ThisMCTWorld%ncomps,ThisMCTWorld%MCT_comm,ThisMCTWorld%nprocspid -! do i=1,ThisMCTWorld%ncomps -! write(*,*)'MCTK',myGid,i,ThisMCTWorld%idGprocid(i,0:ThisMCTWorld%nprocspid(i)-1) -! enddo -! endif - -! deallocate temporary arrays - deallocate(root_nprocs,root_idGprocid,stat=ier) - if(ier/=0) call die(myname_,'deallocate(root_nprocs,..)',ier) - if(myGid == 0) then - deallocate(compids,reqs,status,nprocs,tmparray,stat=ier) - if(ier/=0) call die(myname_,'deallocate(compids,..)',ier) - endif - - end subroutine initm_ - -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: initd_ - initialize MCTWorld -! -! !DESCRIPTION: -! Do a distributed init of MCTWorld using the total number of components -! {\tt ncomps} and either a unique integer component id {\tt myid} or, -! if more than one model is placed on a processor, an array of integer ids -! specifying the models {\tt myids}. Also required is -! the local communicator {\tt mycomm} and global communicator {\tt globalcomm} -! which encompasses all the models (typically this can be MPI\_COMM\_WORLD). -! This routine must be called once by each component (using {\em myid}) or -! component group (using {\em myids}). -! -! !INTERFACE: - - subroutine initd_(ncomps,globalcomm,mycomm,myid,myids) -! -! !USES: -! - use m_mpif90 - use m_die - use m_stdio - - implicit none - -! !INPUT PARAMETERS: - - integer, intent(in) :: ncomps ! number of components - integer, intent(in) :: globalcomm ! global communicator - integer, intent(in) :: mycomm ! my communicator - integer, intent(in),optional :: myid ! my component id - integer, dimension(:),pointer,optional :: myids ! component ids - -! !REVISION HISTORY: -! 19Jan01 - R. Jacob - initial prototype -! 07Feb01 - R. Jacob - non fatal error -! if init is called a second time. -! 08Feb01 - R. Jacob - initialize the new -! mygrank and mylrank -! 20Apr01 - R. Jacob - remove allids from -! MCTWorld datatype. Not needed because component -! ids are always from 1 to number-of-components. -! 22Jun01 - R. Jacob - move Bcast and init -! of MCTWorld to initr_ -! 20Sep07 - T. Craig migrated code to new initm routine -!EOP ___________________________________________________________________ -! - character(len=*),parameter :: myname_=myname//'::initd_' - integer :: msize,ier - integer, dimension(:), pointer :: mycomm1d,myids1d - -! ------------------------------------------------------------------ - - -! only one of myid and myids should be present - if(present(myid) .and. present(myids)) then - write(stderr,'(2a)') myname_, & - 'MCTERROR: Must define myid or myids in MCTWord init' - call die(myname_) - endif - - if(.not.present(myid) .and. .not.present(myids)) then - write(stderr,'(2a)') myname_, & - 'MCTERROR: Must define one of myid or myids in MCTWord init' - call die(myname_) - endif - - if (present(myids)) then - msize = size(myids) - else - msize = 1 - endif - - allocate(mycomm1d(msize),myids1d(msize),stat=ier) - if(ier/=0) call die(myname_,'non-root allocate(root_idGprocid)',ier) - mycomm1d(:) = mycomm - - if (present(myids)) then - myids1d(:) = myids(:) - else - myids1d(:) = myid - endif - - call initm_(ncomps,globalcomm,mycomm1d,myids1d) - - deallocate(mycomm1d,myids1d) - - end subroutine initd_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: initr_ - initialize MCTWorld from global root -! -! !DESCRIPTION: -! Initialize MCTWorld using information valid only on the global root. -! This is called by initm\_ but could also be called by the user -! for very complex model--processor geometries. -! -! !INTERFACE: - - subroutine initr_(ncomps,globalcomm,rnprocspid,ridGprocid) -! -! !USES: -! - use m_mpif90 - use m_die - use m_stdio - - implicit none - -! !INPUT PARAMETERS: - - integer, intent(in) :: ncomps ! total number of components - integer, intent(in) :: globalcomm ! the global communicator - integer, dimension(:),intent(in) :: rnprocspid ! number of processors for each component - integer, dimension(:,:),intent(in) :: ridGprocid ! an array of size (1:ncomps) x (0:Gsize-1) - ! which maps local ranks to global ranks - ! it's actually 1:Gsize here - -! !REVISION HISTORY: -! 22Jun01 - R. Jacob - initial prototype -!EOP ___________________________________________________________________ -! - character(len=*),parameter :: myname_=myname//'::initr_' - integer :: ier,Gsize,myGid,MCTcomm,i,j - -! Check that ncomps is a legal value - if(ncomps < 1) then - call die(myname_, "argument ncomps can't less than one!",ncomps) - endif - -! determine overall size - call MP_comm_size(globalcomm,Gsize,ier) - if(ier /= 0) call MP_perr_die(myname_,'MP_comm_size()',ier) - -! determine my rank in comm_world - call MP_comm_rank(globalcomm,myGid,ier) - if(ier /= 0) call MP_perr_die(myname_,'MP_comm_rank()',ier) - -! create the MCT comm world - call MP_comm_dup(globalcomm,MCTcomm,ier) - if(ier /= 0) call MP_perr_die(myname_,'MP_comm_dup()',ier) - - allocate(ThisMCTWorld%nprocspid(ncomps),stat=ier) - if(ier/=0) call die(myname_,'allocate(MCTWorld%nprocspid(:),...',ier) - allocate(ThisMCTWorld%idGprocid(ncomps,0:Gsize-1),stat=ier) - if(ier/=0) call die(myname_,'allocate(MCTWorld%nprocspid(:),...',ier) - -! set the MCTWorld - ThisMCTWorld%ncomps = ncomps - ThisMCTWorld%MCT_comm = MCTcomm - ThisMCTWorld%mygrank = myGid - -! Now store the component ids in the World description and Broadcast - if(myGid == 0) then - ThisMCTWorld%nprocspid(1:ncomps) = rnprocspid(1:ncomps) - ThisMCTWorld%idGprocid = ridGprocid - endif - - call MPI_BCAST(ThisMCTWorld%nprocspid, ncomps, MP_INTEGER, 0, MCTcomm, ier) - if(ier/=0) call MP_perr_die(myname_,'MPI_BCast nprocspid',ier) - - call MPI_BCAST(ThisMCTWorld%idGprocid, ncomps*Gsize,MP_INTEGER, 0,MCTcomm, ier) - if(ier/=0) call MP_perr_die(myname_,'MPI_BCast Gprocids',ier) - -! if(myGid==17) then -! do i=1,ThisMCTWorld%ncomps -! do j=1,ThisMCTWorld%nprocspid(i) -! write(*,*)'MCTK',myGid,i,j-1,ThisMCTWorld%idGprocid(i,j-1) -! enddo -! enddo -! endif - - end subroutine initr_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: clean_ - Destroy a MCTWorld -! -! !DESCRIPTION: -! This routine deallocates the arrays of {\tt ThisMCTWorld} -! It also zeros out the integer components. -! -! !INTERFACE: - - subroutine clean_() -! -! !USES: -! - use m_die - - implicit none - -! !REVISION HISTORY: -! 19Jan01 - R. Jacob - initial prototype -! 08Feb01 - R. Jacob - clean the new -! mygrank and mylrank -! 20Apr01 - R. Jacob - remove allids from -! MCTWorld datatype. Not needed because component -! ids are always from 1 to number-of-components. -! 07Jun01 - R. Jacob - remove myid,mynprocs -! and mylrank. -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::clean_' - integer :: ier - - deallocate(ThisMCTWorld%nprocspid,ThisMCTWorld%idGprocid,stat=ier) - if(ier /= 0) call warn(myname_,'deallocate(MCTW,...)',ier) - - ThisMCTWorld%ncomps = 0 - ThisMCTWorld%mygrank = 0 - - end subroutine clean_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: NumComponents_ - Determine number of components in World. -! -! !DESCRIPTION: -! The function {\tt NumComponents\_} takes an input {\tt MCTWorld} -! argument {\tt World}, and returns the number of component models -! present. -! -! !INTERFACE: - - integer function NumComponents_(World) -! -! !USES: -! - use m_die - use m_stdio - - implicit none - -! !INPUT PARAMETERS: - - type(MCTWorld), intent(in) :: World - -! !REVISION HISTORY: -! 05Feb01 - J. Larson - initial version -!EOP ___________________________________________________________________ -! - character(len=*),parameter :: myname_=myname//'::NumComponents_' - - integer :: ncomps - - ncomps = World%ncomps - - if(ncomps <= 0) then - write(stderr,'(2a,1i3)') myname,":: invalid no. of components = ",ncomps - call die(myname_,'ncomps = ',ncomps) - endif - - NumComponents_ = ncomps - - end function NumComponents_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: ComponentNumProcs_ - Number of processes a component owns. -! -! !DESCRIPTION: -! The function {\tt ComponentNumProcs\_} takes an input {\tt MCTWorld} -! argument {\tt World}, and a component ID {\tt comp\_id}, and returns -! the number of processes owned by that component. -! -! !INTERFACE: - - integer function ComponentNumProcs_(World, comp_id) -! -! !USES: -! - use m_die - use m_stdio - - implicit none - -! !INPUT PARAMETERS: - type(MCTWorld), intent(in) :: World - integer, intent(in) :: comp_id - -! !REVISION HISTORY: -! 05Feb01 - J. Larson - initial version -! 07Jun01 - R. Jacob - modify to use -! nprocspid and comp_id instead of World%mynprocs -!EOP ___________________________________________________________________ -! - character(len=*),parameter :: myname_=myname//'::ComponentNumPros_' - - integer :: mynprocs - - mynprocs = World%nprocspid(comp_id) - - if(mynprocs <= 0) then - write(stderr,'(2a,1i6)') myname,":: invalid no. of processes = ",mynprocs - call die(myname_,'Number of processes = ',mynprocs) - endif - - ComponentNumProcs_ = mynprocs - - end function ComponentNumProcs_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: ComponentToWorldRank_ - Determine rank on COMM_WORLD. -! -! !DESCRIPTION: -! The function {\tt ComponentToWorldRank\_} takes an input component ID -! {\tt comp\_id} and input rank on that component communicator -! {\tt comp\_rank}, and returns the rank of that process on the world -! communicator of {\tt MCTWorld}. -! -! !INTERFACE: - - integer function ComponentToWorldRank_(comp_rank, comp_id, World) -! -! !USES: -! - use m_die - use m_stdio - - implicit none - -! !INPUT PARAMETERS: - integer, intent(in) :: comp_rank ! process rank on the communicator - ! associated with comp_id - integer, intent(in) :: comp_id ! component id - type(MCTWorld), intent(in) :: World ! World - - -! !REVISION HISTORY: -! 05Feb01 - J. Larson - initial version -! 14Jul02 - E. Ong - made argument checking required -!EOP ___________________________________________________________________ -! - character(len=*),parameter :: myname_=myname//'::ComponentToWorldRank_' - - logical :: valid - integer :: n, world_rank - - - ! Do we want the potentially time-consuming argument checks? - ! The first time we use this function during execution on a - ! given set of components and component ranks, we will. In - ! later invocations, these argument checks are probably not - ! necessary (unless one alters MCTWorld), and impose a cost - ! one may wish to avoid. - - ! These checks are just conditional statements and are - ! not particularly time-consuming. It's better to be safe - ! than sorry. -EONG - - - ! Check argument comp_id for validity--assume initially it is not... - - valid = .false. - n = 0 - - if((comp_id <= World%ncomps) .and. & - (comp_id > 0)) then - valid = .true. - endif - - if(.not. valid) then - write(stderr,'(2a,1i7)') myname,":: invalid component id no. = ",& - comp_id - call die(myname_,'invalid comp_id = ',comp_id) - endif - - ! Check argument comp_rank for validity on the communicator associated - ! with comp_id. Assume initialy it is invalid. - - valid = .false. - - if((0 <= comp_rank) .or. & - (comp_rank < ComponentNumProcs_(World, comp_id))) then - valid = .true. - endif - - if(.not. valid) then - write(stderr,'(2a,1i5,1a,1i2)') myname, & - ":: invalid process ID. = ", & - comp_rank, "on component ",comp_id - call die(myname_,'invalid comp_rank = ',comp_rank) - endif - - - ! If we have reached this point, the input data are valid. - ! Return the global rank for comp_rank on component comp_id - - world_rank = World%idGprocid(comp_id, comp_rank) - - if(world_rank < 0) then - write(stderr,'(2a,1i6)') myname,":: negative world rank = ",world_rank - call die(myname_,'negative world rank = ',world_rank) - endif - - ComponentToWorldRank_ = world_rank - - end function ComponentToWorldRank_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: ComponentRootRank_ - Rank of component root on COMM_WORLD. -! -! !DESCRIPTION: -! The function {\tt ComponentRootRank\_} takes an input component ID -! {\tt comp\_id} and input {\tt MCTWorld} variable {\tt World}, and -! returns the global rank of the root of this component. -! -! !INTERFACE: - - integer function ComponentRootRank_(comp_id, World) -! -! !USES: -! - use m_die - use m_stdio - - implicit none - -! !INPUT PARAMETERS: - integer, intent(in) :: comp_id ! component id - type(MCTWorld), intent(in) :: World ! World - -! !REVISION HISTORY: -! 05Feb01 - J. Larson - initial version -! 14Jul02 - E. Ong - made argument checking required -!EOP ___________________________________________________________________ -! - character(len=*),parameter :: myname_=myname//'::ComponentRootRank_' - - integer :: world_comp_root - - ! Call ComponentToWorldRank_ assuming the root on a remote component - ! has rank zero on the communicator associated with that component. - - world_comp_root = ComponentToWorldRank_(0, comp_id, World) - - if(world_comp_root < 0) then - write(stderr,'(2a,1i6)') myname,":: negative world rank = ",& - world_comp_root - call die(myname_,'invalid root id = ',world_comp_root) - endif - - ComponentRootRank_ = world_comp_root - - end function ComponentRootRank_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: printnp_ - Print number of procs for a component id. -! -! !DESCRIPTION: -! Print out number of MPI processes for the givin component id. -! -! !INTERFACE: - - subroutine printnp_(compid,lun) -! -! !USES: -! - use m_die - use m_mpif90 - - implicit none - -!INPUT/OUTPUT PARAMETERS: - integer, intent(in) :: compid - integer, intent(in) :: lun - -! !REVISION HISTORY: -! 06Jul12 - R. Jacob - initial version -!EOP ___________________________________________________________________ - - - integer ier - character(len=*),parameter :: myname_=myname//'::printnp_' - - write(lun,*) ThisMCTWorld%nprocspid(compid) - - end subroutine printnp_ - - - end module m_MCTWorld - diff --git a/cesm/models/utils/mct/mct/m_MatAttrVectMul.F90 b/cesm/models/utils/mct/mct/m_MatAttrVectMul.F90 deleted file mode 100644 index 00061c1..0000000 --- a/cesm/models/utils/mct/mct/m_MatAttrVectMul.F90 +++ /dev/null @@ -1,632 +0,0 @@ -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math + Computer Science Division / Argonne National Laboratory ! -!----------------------------------------------------------------------- -! CVS $Id$ -! CVS $Name$ -!BOP ------------------------------------------------------------------- -! -! !MODULE: m_MatAttrVectMul - Sparse Matrix AttrVect Multipication. -! -! !DESCRIPTION: -! -! This module contains routines supporting the sparse matrix-vector -! multiplication -! $${\bf y} = {\bf M} {\bf x},$$ -! where the vectors {\bf x} and {\bf y} are stored using the MCT -! {\tt AttrVect} datatype, and {\bf M} is stored using either the MCT -! {\tt SparseMatrix} or {\tt SparseMatrixPlus} type. The {\tt SparseMatrix} -! type is used to represent {\bf M} if the multiplication process is -! purely data-local (e.g., in a global address space, or if the process -! has been rendered embarrasingly parallel by earlier or subsequent -! vector data redistributions). If the multiplication process is to -! be explicitly distributed-memory parallel, then the {\tt SparseMatrixPlus} -! type is used to store the elements of {\bf M} and all information needed -! to coordinate data redistribution and reduction of partial sums. -! -! {\bf N.B.:} The matrix-vector multiplication routines in this module -! process only the {\bf real} attributes of the {\tt AttrVect} arguments -! corresponding to {\bf x} and {\bf y}. They ignore the integer attributes. -! -! !INTERFACE: - - module m_MatAttrVectMul - - private ! except - - public :: sMatAvMult ! The master Sparse Matrix - - ! Attribute Vector multipy API - - interface sMatAvMult ; module procedure & - sMatAvMult_DataLocal_, & - sMatAvMult_sMPlus_ - end interface - -! !SEE ALSO: -! The MCT module m_AttrVect for more information about the AttrVect type. -! The MCT module m_SparseMatrix for more information about the SparseMatrix -! type. -! The MCT module m_SparseMatrixPlus for more details about the master class -! for parallel sparse matrix-vector multiplication, the SparseMatrixPlus. - -! !REVISION HISTORY: -! 12Jan01 - J.W. Larson - initial module. -! 26Sep02 - J.W. Larson - added high-level, distributed -! matrix-vector multiply routine using the SparseMatrixPlus class. -! -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname='MCT::m_MatAttrVectMul' - - contains - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math + Computer Science Division / Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: sMatAvMult_DataLocal -- Purely local matrix-vector multiply -! -! !DESCRIPTION: -! -! The sparse matrix-vector multiplication routine {\tt sMatAvMult\_DataLocal\_()} -! operates on the assumption of total data locality, which is equivalent -! to the following two conditions: -! \begin{enumerate} -! \item The input {\tt AttrVect} {\tt xAV} contains all the values referenced -! by the local column indices stored in the input {\tt SparsMatrix} argument -! {\tt sMat}; and -! \item The output {\tt AttrVect} {\tt yAV} contains all the values referenced -! by the local row indices stored in the input {\tt SparsMatrix} argument -! {\tt sMat}. -! \end{enumerate} -! By default, the multiplication occurs for each of the common {\tt REAL} attributes -! shared by {\tt xAV} and {\tt yAV}. This routine is capable of -! cross-indexing the attributes and performing the necessary multiplications. -! -! If the optional argument {\tt rList} is present, only the attributes listed will -! be multiplied. If the attributes have different names in {\tt yAV}, the optional -! {\tt TrList} argument can be used to provide the translation. -! -! If the optional argument {\tt Vector} is present and true, the vector -! architecture-friendly portions of this routine will be invoked. It -! will also cause the vector parts of {\\ sMat} to be initialized if they -! have not been already. -! -! !INTERFACE: - - subroutine sMatAvMult_DataLocal_(xAV, sMat, yAV, Vector, rList, TrList) -! -! !USES: -! - use m_realkinds, only : FP - use m_stdio, only : stderr - use m_die, only : MP_perr_die, die, warn - - use m_List, only : List_identical => identical - use m_List, only : List_nitem => nitem - use m_List, only : GetIndices => get_indices - - use m_AttrVect, only : AttrVect - use m_AttrVect, only : AttrVect_lsize => lsize - use m_AttrVect, only : AttrVect_zero => zero - use m_AttrVect, only : AttrVect_nRAttr => nRAttr - use m_AttrVect, only : AttrVect_indexRA => indexRA - use m_AttrVect, only : SharedAttrIndexList - - use m_SparseMatrix, only : SparseMatrix - use m_SparseMatrix, only : SparseMatrix_lsize => lsize - use m_SparseMatrix, only : SparseMatrix_indexIA => indexIA - use m_SparseMatrix, only : SparseMatrix_indexRA => indexRA - use m_SparseMatrix, only : SparseMatrix_vecinit => vecinit - - implicit none - -! !INPUT PARAMETERS: - - type(AttrVect), intent(in) :: xAV - logical,optional, intent(in) :: Vector - character(len=*),optional, intent(in) :: rList - character(len=*),optional, intent(in) :: TrList - - -! !INPUT/OUTPUT PARAMETERS: - - type(SparseMatrix), intent(inout) :: sMat - type(AttrVect), intent(inout) :: yAV - -! !REVISION HISTORY: -! 15Jan01 - J.W. Larson - API specification. -! 10Feb01 - J.W. Larson - Prototype code. -! 24Apr01 - J.W. Larson - Modified to accomodate -! changes to the SparseMatrix datatype. -! 25Apr01 - J.W. Larson - Reversed loop order -! for cache-friendliness -! 17May01 - R. Jacob - Zero the output -! attribute vector -! 10Oct01 - J. Larson - Added optional LOGICAL -! input argument InterpInts to make application of the -! multiply to INTEGER attributes optional -! 15Oct01 - J. Larson - Added feature to -! detect when attribute lists are identical, and cross- -! indexing of attributes is not needed. -! 29Nov01 - E.T. Ong - Removed MP_PERR_DIE if -! there are zero elements in sMat. This allows for -! decompositions where a process may own zero points. -! 29Oct03 - R. Jacob - add Vector argument to -! optionally use the vector-friendly version provided by -! Fujitsu -! 21Nov06 - R. Jacob - Allow attributes to be -! to be multiplied to be specified with rList and TrList. -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::sMatAvMult_DataLocal_' - -! Matrix element count: - integer :: num_elements - -! Matrix row, column, and weight indices: - integer :: icol, irow, iwgt - -! Overlapping attribute index number - integer :: num_indices - -! Overlapping attribute index storage arrays: - integer, dimension(:), pointer :: xAVindices, yAVindices - -! Temporary variables for multiply do-loop - integer :: row, col - real(FP) :: wgt - -! Error flag and loop indices - integer :: ierr, i, m, n, l,ier - integer :: inxmin,outxmin - integer :: ysize, numav,j - -! Character variable used as a data type flag: - character*7 :: data_flag - -! logical flag - logical :: usevector,TrListIsPresent,rListIsPresent - logical :: contiguous,ycontiguous - - usevector = .false. - if(present(Vector)) then - if(Vector) usevector = .true. - endif - - rListIsPresent = .false. - if(present(rList)) then - rListIsPresent = .true. - endif - -! TrList is present if it is provided and its length>0 - TrListIsPresent = .false. - if(present(TrList)) then - if(.not.present(rList)) then - call die(myname_,'MCTERROR: TrList provided without rList',2) - endif - if(len_trim(TrList) > 0) then - TrListIsPresent = .true. - endif - endif - - - ! Retrieve the number of elements in sMat: - - num_elements = SparseMatrix_lsize(sMat) - - ! Indexing the sparse matrix sMat: - - irow = SparseMatrix_indexIA(sMat,'lrow') ! local row index - icol = SparseMatrix_indexIA(sMat,'lcol') ! local column index - iwgt = SparseMatrix_indexRA(sMat,'weight') ! weight index - - - ! Multiplication sMat by REAL attributes in xAV: - - if(List_identical(xAV%rList, yAV%rList).and. & - .not.rListIsPresent) then ! no cross-indexing - - ! zero the output AttributeVector - call AttrVect_zero(yAV, zeroInts=.FALSE.) - - num_indices = List_nitem(xAV%rList) - - if(usevector) then - - if(.not.sMat%vecinit) then - call SparseMatrix_vecinit(sMat) - endif - -!DIR$ CONCURRENT - do m=1,num_indices - do l=1,sMat%tbl_end -!CDIR NOLOOPCHG -!DIR$ CONCURRENT - do i=sMat%row_s(l),sMat%row_e(l) - col = sMat%tcol(i,l) - wgt = sMat%twgt(i,l) - if (col < 0) cycle - yAV%rAttr(m,i) = yAV%rAttr(m,i) + wgt * xAV%rAttr(m,col) - enddo - enddo - enddo - - else - - do n=1,num_elements - - row = sMat%data%iAttr(irow,n) - col = sMat%data%iAttr(icol,n) - wgt = sMat%data%rAttr(iwgt,n) - - ! loop over attributes being regridded. - -!DIR$ CONCURRENT - do m=1,num_indices - - yAV%rAttr(m,row) = yAV%rAttr(m,row) + wgt * xAV%rAttr(m,col) - - end do ! m=1,num_indices - - end do ! n=1,num_elements - - endif - -! lists are not identical or only want to do part. - else - - if(rListIsPresent) then - call GetIndices(xAVindices,xAV%rList,trim(rList)) - - if(TrListIsPresent) then - call GetIndices(yAVindices,yAV%rList,trim(TrList)) - - if(size(xAVindices) /= size(yAVindices)) then - call die(myname_,"Arguments rList and TrList do not& - &contain the same number of items") - endif - - else - call GetIndices(yAVindices,yAV%rList,trim(rList)) - endif - - num_indices=size(yAVindices) - - ! nothing to do if num_indices <=0 - if (num_indices <= 0) then - deallocate(xaVindices, yAVindices, stat=ier) - if(ier/=0) call die(myname_,"deallocate(xAVindices...)",ier) - return - endif - - else - - data_flag = 'REAL' - call SharedAttrIndexList(xAV, yAV, data_flag, num_indices, & - xAVindices, yAVindices) - - ! nothing to do if num_indices <=0 - if (num_indices <= 0) then - deallocate(xaVindices, yAVindices, stat=ier) - call warn(myname_,"No matching indicies found, returning.") - if(ier/=0) call die(myname_,"deallocate(xaVinindices...)",ier) - return - endif - endif - -! Check if the indices are contiguous in memory for faster copy - contiguous=.true. - ycontiguous=.true. - do i=2,num_indices - if(xaVindices(i) /= xAVindices(i-1)+1) contiguous = .false. - enddo - if(contiguous) then - do i=2,num_indices - if(yAVindices(i) /= yAVindices(i-1)+1) then - contiguous=.false. - ycontiguous=.false. - endif - enddo - endif - - ! zero the right parts of the output AttributeVector - ysize = AttrVect_lsize(yAV) - numav=size(yAVindices) - - if(ycontiguous) then - outxmin=yaVindices(1)-1 - do j=1,ysize - do i=1,numav - yAV%rAttr(outxmin+i,j)=0._FP - enddo - enddo - else - do j=1,ysize - do i=1,numav - yAV%rAttr(yaVindices(i),j)=0._FP - enddo - enddo - endif - - ! loop over matrix elements - - if(contiguous) then - outxmin=yaVindices(1)-1 - inxmin=xaVindices(1)-1 - do n=1,num_elements - - row = sMat%data%iAttr(irow,n) - col = sMat%data%iAttr(icol,n) - wgt = sMat%data%rAttr(iwgt,n) - - ! loop over attributes being regridded. -!DIR$ CONCURRENT - do m=1,num_indices - yAV%rAttr(outxmin+m,row) = & - yAV%rAttr(outxmin+m,row) + & - wgt * xAV%rAttr(inxmin+m,col) - end do ! m=1,num_indices - end do ! n=1,num_elements - - else - do n=1,num_elements - - row = sMat%data%iAttr(irow,n) - col = sMat%data%iAttr(icol,n) - wgt = sMat%data%rAttr(iwgt,n) - - ! loop over attributes being regridded. -!DIR$ CONCURRENT - do m=1,num_indices - yAV%rAttr(yAVindices(m),row) = & - yAV%rAttr(yAVindices(m),row) + & - wgt * xAV%rAttr(xAVindices(m),col) - end do ! m=1,num_indices - end do ! n=1,num_elements - endif - - - deallocate(xAVindices, yAVindices, stat=ierr) - if(ierr /= 0) call die(myname_,'first deallocate(xAVindices...',ierr) - - endif ! if(List_identical(xAV%rAttr, yAV%rAttr))... - ! And we are finished! - - end subroutine sMatAvMult_DataLocal_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math + Computer Science Division / Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: sMatAvMult_SMPlus_ - Parallel Multiply Using SparseMatrixPlus -! -! !DESCRIPTION: -! This routine performs distributed parallel sparse matrix-vector -! multiplication ${\bf y} = {\bf M} {\bf x}$, where {\bf y} and -! {\bf x} are represented by the {\tt AttrVect} arguments {\tt yAV} and -! {\tt xAV}, respectively. The matrix {\bf M} is stored in the input -! {\tt SparseMatrixPlus} argument {\tt sMatPlus}, which also contains -! all the information needed to coordinate the communications required to -! gather intermediate vectors used in the multiplication process, and to -! reduce partial sums as needed. -! By default, the multiplication occurs for each of the common {\tt REAL} attributes -! shared by {\tt xAV} and {\tt yAV}. This routine is capable of -! cross-indexing the attributes and performing the necessary multiplications. -! -! If the optional argument {\tt rList} is present, only the attributes listed will -! be multiplied. If the attributes have different names in {\tt yAV}, the optional -! {\tt TrList} argument can be used to provide the translation. -! -! If the optional argument {\tt Vector} is present and true, the vector -! architecture-friendly portions of this routine will be invoked. It -! will also cause the vector parts of {\tt sMatPlus} to be initialized if they -! have not been already. -! -! !INTERFACE: - - subroutine sMatAvMult_SMPlus_(xAV, sMatPlus, yAV, Vector, rList, TrList) -! -! !USES: -! - use m_stdio - use m_die - use m_mpif90 - - use m_String, only : String - use m_String, only : String_ToChar => ToChar - - use m_AttrVect, only : AttrVect - use m_AttrVect, only : AttrVect_init => init - use m_AttrVect, only : AttrVect_lsize => lsize - use m_AttrVect, only : AttrVect_clean => clean - use m_AttrVect, only : AttrVect_Rcopy => Rcopy - use m_AttrVect, only : AttrVect_zero => zero - - use m_Rearranger, only : Rearranger - use m_Rearranger, only : Rearrange - - use m_SparseMatrixPlus, only : SparseMatrixPlus - use m_SparseMatrixPlus, only : Xonly - use m_SparseMatrixPlus, only : Yonly - use m_SparseMatrixPlus, only : XandY - - implicit none - -! !INPUT PARAMETERS: - - type(AttrVect), intent(in) :: xAV - logical, optional, intent(in) :: Vector - character(len=*),optional, intent(in) :: rList - character(len=*),optional, intent(in) :: TrList - -! !INPUT/OUTPUT PARAMETERS: - - type(AttrVect), intent(inout) :: yAV - type(SparseMatrixPlus), intent(inout) :: sMatPlus - -! !SEE ALSO: -! The MCT module m_AttrVect for more information about the AttrVect type. -! The MCT module m_SparseMatrixPlus for more information about the -! SparseMatrixPlus type. - -! !REVISION HISTORY: -! 26Sep02 - J.W. Larson - API specification and -! implementation. -! 29Oct03 - R. Jacob - add vector argument to all -! calls to Rearrange and DataLocal_. Add optional input -! argument to change value (assumed false) -! 22Nov06 - R. Jacob - add rList,TrList arguments -! 10Jan08 - T. Craig - zero out intermediate aVs before -! they are used -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::sMatAvMult_SMPlus_' - type(AttrVect) :: xPrimeAV, yPrimeAV - type(AttrVect) :: yAVre - integer :: ierr - logical :: usevector - character(len=5) :: strat - - ! check arguments - if(present(TrList)) then - if(.not.present(rList)) then - call die(myname_,'MCTERROR: TrList provided without rList',2) - endif - endif - - usevector = .FALSE. - if(present(Vector)) then - if(Vector)usevector = .TRUE. - endif - ! Examine the parallelization strategy, and act accordingly - - strat = String_ToChar(sMatPlus%Strategy) - select case( strat ) - case('Xonly') - ! Create intermediate AttrVect for x' - call AttrVect_init(xPrimeAV, xAV, sMatPlus%XPrimeLength) - call AttrVect_zero(xPrimeAV) - ! Rearrange data from x to get x' - call Rearrange(xAV, xPrimeAV, sMatPlus%XToXPrime, & - sMatPlus%Tag ,vector=usevector) - - ! Perform perfectly data-local multiply y = Mx' - if (present(TrList).and.present(rList)) then - call sMatAvMult_DataLocal_(xPrimeAV, sMatPlus%Matrix, yaV, & - Vector=usevector,rList=rList,TrList=TrList) - else if(.not.present(TrList) .and. present(rList)) then - call sMatAvMult_DataLocal_(xPrimeAV, sMatPlus%Matrix, yaV, & - Vector=usevector,rList=rList) - else - call sMatAvMult_DataLocal_(xPrimeAV, sMatPlus%Matrix, yaV, & - Vector=usevector) - endif - - ! Clean up space occupied by x' - call AttrVect_clean(xPrimeAV, ierr) - case('Yonly') - ! Create intermediate AttrVect for y' - if (present(TrList).and.present(rList)) then - call AttrVect_init(yPrimeAV, rList=TrList, lsize=sMatPlus%YPrimeLength) - else if(.not.present(TrList) .and. present(rList)) then - call AttrVect_init(yPrimeAV, rList=rList, lsize=sMatPlus%YPrimeLength) - else - call AttrVect_init(yPrimeAV, yAV, sMatPlus%YPrimeLength) - endif - call AttrVect_zero(yPrimeAV) - - if (present(TrList).or.present(rList)) then - call AttrVect_init(yAVre, yPrimeAV , lsize=AttrVect_lsize(yAV)) - call AttrVect_zero(yAVre) - endif - - ! Perform perfectly data-local multiply y' = Mx - if (present(TrList).and.present(rList)) then - call sMatAvMult_DataLocal_(xAV, sMatPlus%Matrix, yPrimeAV, & - Vector=usevector,rList=rList,TrList=TrList) - else if(.not.present(TrList) .and. present(rList)) then - call sMatAvMult_DataLocal_(xAV, sMatPlus%Matrix, yPrimeAV, & - Vector=usevector,rList=rList) - else - call sMatAvMult_DataLocal_(xAV, sMatPlus%Matrix, yPrimeAV, & - Vector=usevector) - endif - - ! Rearrange/reduce partial sums in y' to get y - if (present(TrList).or.present(rList)) then - call Rearrange(yPrimeAV, yAVre, sMatPlus%YPrimeToY, sMatPlus%Tag, & - .TRUE., Vector=usevector) - call AttrVect_Rcopy(yAVre,yAV,vector=usevector) - call AttrVect_clean(yAVre, ierr) - else - call Rearrange(yPrimeAV, yAV, sMatPlus%YPrimeToY, sMatPlus%Tag, & - .TRUE., Vector=usevector) - endif - ! Clean up space occupied by y' - call AttrVect_clean(yPrimeAV, ierr) - - case('XandY') - ! Create intermediate AttrVect for x' - call AttrVect_init(xPrimeAV, xAV, sMatPlus%XPrimeLength) - call AttrVect_zero(xPrimeAV) - - ! Create intermediate AttrVect for y' - if (present(TrList).and.present(rList)) then - call AttrVect_init(yPrimeAV, rList=TrList, lsize=sMatPlus%YPrimeLength) - else if(.not.present(TrList) .and. present(rList)) then - call AttrVect_init(yPrimeAV, rList=rList, lsize=sMatPlus%YPrimeLength) - else - call AttrVect_init(yPrimeAV, yAV, sMatPlus%YPrimeLength) - endif - call AttrVect_zero(yPrimeAV) - - if (present(TrList).or.present(rList)) then - call AttrVect_init(yAVre, yPrimeAV , lsize=AttrVect_lsize(yAV)) - call AttrVect_zero(yAVre) - endif - - ! Rearrange data from x to get x' - call Rearrange(xAV, xPrimeAV, sMatPlus%XToXPrime, sMatPlus%Tag, & - Vector=usevector) - - ! Perform perfectly data-local multiply y' = Mx' - if (present(TrList).and.present(rList)) then - call sMatAvMult_DataLocal_(xPrimeAV, sMatPlus%Matrix, yPrimeAV, & - Vector=usevector,rList=rList,TrList=TrList) - else if(.not.present(TrList) .and. present(rList)) then - call sMatAvMult_DataLocal_(xPrimeAV, sMatPlus%Matrix, yPrimeAV, & - Vector=usevector,rList=rList) - else - call sMatAvMult_DataLocal_(xPrimeAV, sMatPlus%Matrix, yPrimeAV, & - Vector=usevector) - endif - - ! Rearrange/reduce partial sums in y' to get y - if (present(TrList).or.present(rList)) then - call Rearrange(yPrimeAV, yAVre, sMatPlus%YPrimeToY, sMatPlus%Tag, & - .TRUE., Vector=usevector) - call AttrVect_Rcopy(yAVre,yAV,vector=usevector) - call AttrVect_clean(yAVre, ierr) - else - call Rearrange(yPrimeAV, yAV, sMatPlus%YPrimeToY, sMatPlus%Tag, & - .TRUE., Vector=usevector) - endif - - ! Clean up space occupied by x' - call AttrVect_clean(xPrimeAV, ierr) - ! Clean up space occupied by y' - call AttrVect_clean(yPrimeAV, ierr) - case default - write(stderr,'(4a)') myname_, & - ':: FATAL ERROR--parallelization strategy name ',& - String_ToChar(sMatPlus%Strategy),' not supported.' - call die(myname_) - end select - - end subroutine sMatAvMult_SMPlus_ - - end module m_MatAttrVectMul - - - - diff --git a/cesm/models/utils/mct/mct/m_Merge.F90 b/cesm/models/utils/mct/mct/m_Merge.F90 deleted file mode 100644 index c9cb7de..0000000 --- a/cesm/models/utils/mct/mct/m_Merge.F90 +++ /dev/null @@ -1,2912 +0,0 @@ -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!----------------------------------------------------------------------- -! CVS $Id$ -! CVS $Name$ -!BOP ------------------------------------------------------------------- -! -! !MODULE: m_Merge - Merge flux and state data from multiple sources. -! -! !DESCRIPTION: This module supports {\em merging} of state and flux -! data from multiple components with overlapping spatial domains for use -! by another component. For example, let the vectors ${\bf a}$ and -! ${\bf b}$ be data from Components $A$ and $B$ that have been -! interpolated onto the physical grid of another component $C$. We wish -! to combine the data from $A$ and $B$ to get a vector ${\bf c}$, which -! represents the merged data on the grid of component $C$. This merge -! process is an element-by-element masked weighted average: -! $$ c_i = {{{{\prod_{j=1}^J} M_{i}^j} {{\prod_{k=1}^K} F_{i}^k} a_i + -! {{\prod_{p=1}^P} N_{i}^p} {{\prod_{q=1}^Q} G_{i}^q} b_i} \over -! {{{\prod_{j=1}^J} M_{i}^j} {{\prod_{k=1}^K} F_{i}^k} + -! {{\prod_{p=1}^P} N_{i}^p} {{\prod_{q=1}^Q} G_{i}^q}}}, $$ -! Where ${M_{i}^j}$ and ${N_{i}^p}$ are {\em integer masks} (which have -! value either $0$ or $1$), and ${F_{i}^k}$ and ${G_{i}^q}$ are {\em real -! masks} (which are in the closed interval $[0,1]$). -! -! Currently, we assume that the integer and real masks are stored in -! the same {\tt GeneralGrid} datatype. We also assume--and this is of -! critical importance to the user--that the attributes to be merged are -! the same for all the inputs and output. If the user violates this -! assumption, incorrect merges will occur for any attributes that are -! present in only some (that is not all) of the inputs. -! -! This module supports explicitly the merging data from two, three, and -! four components. There is also a routine named {\tt MergeInData} that -! allows the user to construct other merging schemes. -! -! !INTERFACE: - - module m_Merge - -! -! !USES: -! -! No other modules used in the declaration section of this module. - - implicit none - - private ! except - -! !PUBLIC TYPES: - -! None. - -! !PUBLIC MEMBER FUNCTIONS: - - public :: MergeTwo ! Merge Output from two components - ! for use by a third. - public :: MergeThree ! Merge Output from three components - ! for use by a fourth. - public :: MergeFour ! Merge Output from four components - ! for use by a fifth. - public :: MergeInData ! Merge in data from a single component. - - interface MergeTwo ; module procedure & - MergeTwoGGSP_, & - MergeTwoGGDP_ - end interface - interface MergeThree ; module procedure & - MergeThreeGGSP_, & - MergeThreeGGDP_ - end interface - interface MergeFour ; module procedure & - MergeFourGGSP_, & - MergeFourGGDP_ - end interface - interface MergeInData ; module procedure & - MergeInDataGGSP_, & - MergeInDataGGDP_ - end interface - -! !PUBLIC DATA MEMBERS: - -! None. - -! !REVISION HISTORY: -! 19Jun02 - J.W. Larson - Initial version. -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname='MCT::m_Merge' - - contains - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: MergeTwoGGSP_ - Merge Data from Two Sources -! -! !DESCRIPTION: This routine merges {\tt REAL} attribute data from -! two input {\tt AttrVect} arguments {\tt inAv1} and {\tt inAv2} to -! a third {\tt AttrVect} {\tt outAv}. The attributes to be merged are -! determined entirely by the real attributes of {\tt outAv}. If -! {\tt outAv} shares one or more attributes with either of the inputs -! {\tt inAv1} or {\tt inAv2}, a merge is performed on the individual -! {\em intersections} of attributes between the pairs $({\tt outAv}, -! {\tt inAv1})$ and $({\tt outAv},{\tt inAv1})$. Currently, it is assumed -! that these pairwise intersections are all equal. This assumption is of -! critical importance to the user. If the user violates this -! assumption, incorrect merges of attributes that are present in some -! (but not all) of the inputs will result. -! -! The merge operatrion is a masked -! weighted element-by-element sum, as outlined in the following example. -! Let the vectors ${\bf a}$ and ${\bf b}$ be data from Components $A$ -! and $B$ that have been interpolated onto the physical grid of another -! component $C$. We wish to combine the data from $A$ and $B$ to get -! a vector ${\bf c}$, which represents the merged data on the grid of -! component $C$. The merge relation to obtain the $i$th element of -! {\bf c} is -! $$ c_i = {1 \over {W_i}} \bigg\{ {{\prod_{j=1}^J} \kappa_{i}^j} -! {{\prod_{k=1}^K} \alpha_{i}^k} {a_i} + {{\prod_{l=1}^L} \lambda_{i}^l} -! {{\prod_{m=1}^M} \beta_{i}^m} {b_i} \bigg\} , $$ -! where -! $$ {W_i} = {{\prod_{j=1}^J} \kappa_{i}^j} {{\prod_{k=1}^K} \alpha_{i}^k} + -! {{\prod_{l=1}^L} \lambda_{i}^l} {{\prod_{m=1}^M} \beta_{i}^m}. $$ -! The quantities ${\kappa_{i}^j}$ and ${\lambda_{i}^l}$ are {\em integer -! masks} (which have value either $0$ or $1$), and ${\alpha_{i}^k}$ and -! ${\beta_{i}^m}$ are {\em real masks} (which are in the closed interval -! $[0,1]$). -! -! The integer and real masks are stored as attributes to the same input -! {\tt GeneralGrid} argument {\tt GGrid}. The mask attribute names are -! stored as substrings to the colon-separated strings contained in the -! input {\tt CHARACTER} arguments {\tt iMaskTags1}, {\tt iMaskTags2}, -! {\tt rMaskTags1}, and {\tt rMaskTags2}. The {\tt LOGICAL} input -! argument {\tt CheckMasks} governs how the masks are applied. If -! ${\tt CheckMasks} = {\tt .TRUE.}$, the entries are checked to ensure -! they meet the definitions of real and integer masks. If -! ${\tt CheckMasks} = {\tt .TRUE.}$ then the masks are multiplied -! together on an element-by-element basis with no validation of their -! entries (this option results in slightly higher performance). -! -! This routine returns the sume of the masked weights as a diagnostic. -! This quantity is returned in the output {\tt REAL} array {\tt WeightSum}. -! -! The correspondence between the quantities in the above merge relation -! and the arguments to this routine are summarized in the table. -! \begin{center} -! \begin{tabular}{|l|l|l|}\hline -! {\bf Quantity} & {\bf Stored in} & {\bf Referenced by} \\ -! & {\bf Argument} & {\bf Argument} \\ -! \hline -! \hline -! $ {a_i} $ & {\tt inAv1} & \\ -! \hline -! $ {b_i} $ & {\tt inAv2} & \\ -! \hline -! $ {c_i} $ & {\tt outAv} & \\ -! \hline -! $ {\kappa_i^j}, j=1,\ldots,J $ & {\tt GGrid} & {\tt iMaskTags1}\\ -! & & ($J$ items) \\ -! \hline -! $ {\alpha_i^k}, k=1,\ldots,K $ & {\tt GGrid} & {\tt rMaskTags1}\\ -! & & ($K$ items) \\ -! \hline -! $ {\lambda_i^l}, l=1,\ldots,L $ & {\tt GGrid} & {\tt iMaskTags2}\\ -! & & ($L$ items) \\ -! \hline -! $ {\beta_i^m}, m=1,\ldots,M $ & {\tt GGrid} & {\tt rMaskTags2}\\ -! & & ($M$ items) \\ -! \hline -! $ {W_i} $ & {\tt WeightSum} & \\ -! \hline -! \end{tabular} -! \end{center} -! -! !INTERFACE: - - subroutine MergeTwoGGSP_(inAv1, iMaskTags1, rMaskTags1, & - inAv2, iMaskTags2, rMaskTags2, & - GGrid, CheckMasks, outAv, WeightSum) -! -! !USES: -! - use m_stdio - use m_die - - use m_realkinds, only : SP, FP - - use m_List, only : List - use m_List, only : List_allocated => allocated - - use m_AttrVect, only : AttrVect - use m_AttrVect, only : AttrVect_lsize => lsize - use m_AttrVect, only : AttrVect_nRAttr => nRAttr - - use m_GeneralGrid, only : GeneralGrid - use m_GeneralGrid, only : GeneralGrid_lsize => lsize - - implicit none - -! !INPUT PARAMETERS: -! - type(AttrVect), intent(IN) :: inAv1 - character(len=*), optional, intent(IN) :: iMaskTags1 - character(len=*), optional, intent(IN) :: rMaskTags1 - type(AttrVect), intent(IN) :: inAv2 - character(len=*), optional, intent(IN) :: iMaskTags2 - character(len=*), optional, intent(IN) :: rMaskTags2 - type(GeneralGrid), intent(IN) :: GGrid - logical, intent(IN) :: CheckMasks - -! !INPUT/OUTPUT PARAMETERS: -! - type(AttrVect), intent(INOUT) :: outAv - real(SP), dimension(:), pointer :: WeightSum - -! !REVISION HISTORY: -! 19Jun02 - Jay Larson - Interface spec. -! 3Jul02 - Jay Larson - Implementation. -! 10Jul02 - J. Larson - Improved argument -! checking. -!EOP ___________________________________________________________________ -! - character(len=*),parameter :: myname_=myname//'::MergeTwoGGSP_' - - integer :: i, j - real(FP) :: invWeightSum - - ! Begin argument sanity checks... - - ! Have the input arguments been allocated? - - if(.not.(List_allocated(inAv1%rList))) then - write(stderr,'(2a)') myname_, & - 'ERROR--INPUT argument inAv1 has no real attributes!' - call die(myname_) - endif - - if(.not.(List_allocated(inAv2%rList))) then - write(stderr,'(2a)') myname_, & - 'ERROR--INPUT argument inAv2 has no real attributes!' - call die(myname_) - endif - - if(.not.(List_allocated(outaV%rList))) then - write(stderr,'(2a)') myname_, & - 'ERROR--INPUT/OUTPUT argument outAv has no real attributes!' - call die(myname_) - endif - - if(present(iMaskTags1) .or. present(iMaskTags2)) then - if(.not.(List_allocated(GGrid%data%iList))) then - write(stderr,'(3a)') myname_, & - 'ERROR--Integer masking requested, but input argument GGrid ', & - 'has no integer attributes!' - call die(myname_) - endif - endif - - if(present(rMaskTags1) .or. present(rMaskTags2)) then - if(.not.(List_allocated(GGrid%data%rList))) then - write(stderr,'(3a)') myname_, & - 'ERROR--Real masking requested, but input argument GGrid ', & - 'has no real attributes!' - call die(myname_) - endif - endif - - if(.not.(associated(WeightSum))) then - write(stderr,'(2a)') myname_, & - 'ERROR--INPUT/OUPUT argument WeightSum has not been allocated!' - call die(myname_) - endif - - ! Do the vector lengths match? - - if(AttrVect_lsize(inAv1) /= AttrVect_lsize(outAv)) then - write(stderr,'(2a,2(a,i8))') myname_, & - ':: ERROR--Lengths of AttrVect arguments inAv1 and outAv must match.', & - 'AttrVect_lsize(inAv1) = ',AttrVect_lsize(inAv1), & - 'AttrVect_lsize(outAv) = ',AttrVect_lsize(outAv) - call die(myname_) - endif - - if(AttrVect_lsize(inAv2) /= AttrVect_lsize(outAv)) then - write(stderr,'(2a,2(a,i8))') myname_, & - ':: ERROR--Lengths of AttrVect arguments inAv2 and outAv must match.', & - 'AttrVect_lsize(inAv2) = ',AttrVect_lsize(inAv2), & - 'AttrVect_lsize(outAv) = ',AttrVect_lsize(outAv) - call die(myname_) - endif - - if(AttrVect_lsize(inAv1) /= GeneralGrid_lsize(GGrid)) then - write(stderr,'(2a,2(a,i8))') myname_, & - ':: ERROR--Lengths of arguments inAv1 and GGrid must match.', & - 'AttrVect_lsize(inAv1) = ',AttrVect_lsize(inAv1), & - 'AttrVect_lsize(outAv) = ',GeneralGrid_lsize(GGrid) - call die(myname_) - endif - - if(AttrVect_lsize(inAv1) /= size(WeightSum)) then - write(stderr,'(2a,2(a,i8))') myname_, & - ':: ERROR--Lengths of arguments inAv1 and WeightSum must match.', & - 'AttrVect_lsize(inAv1) = ',AttrVect_lsize(inAv1), & - 'size(WeightSum) = ',size(WeightSum) - call die(myname_) - endif - - ! ...end argument sanity checks. - - ! Initialize the elements of WeightSum(:) to zero: - - do i=1,size(WeightSum) - WeightSum(i) = 0._FP - end do - - ! Process the incoming data one input AttrVect and mask tag - ! combination at a time. - - ! First input AttrVect/mask combination...must work through - ! all the possible cases for optional arguments iMaskTags1 and - ! rMaskTags1. - - if(present(iMaskTags1)) then - - if(present(rMaskTags1)) then ! both real and integer masks - call MergeInDataGGSP_(inAv1, iMaskTags1, rMaskTags1, GGrid, & - CheckMasks, outAv, WeightSum) - else ! only integer masks - call MergeInDataGGSP_(inAv1, iMaskTags=iMaskTags1, GGrid=GGrid, & - CheckMasks=CheckMasks, outAv=outAv, & - WeightSum=WeightSum) - endif - - else - - if(present(rMaskTags1)) then ! only real masks - call MergeInDataGGSP_(inAv1, rMaskTags=rMaskTags1, GGrid=GGrid, & - CheckMasks=CheckMasks, outAv=outAv, & - WeightSum=WeightSum) - else ! no masks at all - call MergeInDataGGSP_(inAv1, GGrid=GGrid, & - CheckMasks=CheckMasks, outAv=outAv, & - WeightSum=WeightSum) - endif - - endif ! if(present(iMaskTags1))... - - ! Second input AttrVect/mask combination...must work through - ! all the possible cases for optional arguments iMaskTags2 and - ! rMaskTags2. - - if(present(iMaskTags2)) then - - if(present(rMaskTags2)) then ! both real and integer masks - call MergeInDataGGSP_(inAv2, iMaskTags2, rMaskTags2, GGrid, & - CheckMasks, outAv, WeightSum) - else ! only integer masks - call MergeInDataGGSP_(inAv2, iMaskTags=iMaskTags2, GGrid=GGrid, & - CheckMasks=CheckMasks, outAv=outAv, & - WeightSum=WeightSum) - endif - - else - - if(present(rMaskTags2)) then ! only real masks - call MergeInDataGGSP_(inAv2, rMaskTags=rMaskTags2, GGrid=GGrid, & - CheckMasks=CheckMasks, outAv=outAv, & - WeightSum=WeightSum) - else ! no masks at all - call MergeInDataGGSP_(inAv2, GGrid=GGrid, & - CheckMasks=CheckMasks, outAv=outAv, & - WeightSum=WeightSum) - endif - - endif ! if(present(iMaskTags2))... - - ! Now we must renormalize the entries in outAv by dividing - ! element-by-element by the sums of the merge weights, which - ! were accumulated in WeightSum(:) - - do i=1,AttrVect_lsize(outAv) - - if(WeightSum(i) /= 0._FP) then - invWeightSum = 1._FP / WeightSum(i) - else - write(stderr,'(2a,i8,a)') myname_,':: FATAL--WeightSum(', & - i,') is zero!' - call die(myname_) - endif - - do j=1,AttrVect_nRAttr(outAv) - outAv%rAttr(j,i) = invWeightSum * outAv%rAttr(j,i) - end do - - end do - - ! The merge is now complete. - - end subroutine MergeTwoGGSP_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!----------------------------------------------------------------------- -! -! !IROUTINE: MergeTwoGGDP_ - merge data from two components. -! -! !DESCRIPTION: -! Double precision version of MergeTwoGGSP_ -! -! !INTERFACE: - - subroutine MergeTwoGGDP_(inAv1, iMaskTags1, rMaskTags1, & - inAv2, iMaskTags2, rMaskTags2, & - GGrid, CheckMasks, outAv, WeightSum) -! -! !USES: -! - use m_stdio - use m_die - - use m_realkinds, only : DP, FP - - use m_List, only : List - use m_List, only : List_allocated => allocated - - use m_AttrVect, only : AttrVect - use m_AttrVect, only : AttrVect_lsize => lsize - use m_AttrVect, only : AttrVect_nRAttr => nRAttr - - use m_GeneralGrid, only : GeneralGrid - use m_GeneralGrid, only : GeneralGrid_lsize => lsize - - implicit none - -! !INPUT PARAMETERS: -! - type(AttrVect), intent(IN) :: inAv1 - character(len=*), optional, intent(IN) :: iMaskTags1 - character(len=*), optional, intent(IN) :: rMaskTags1 - type(AttrVect), intent(IN) :: inAv2 - character(len=*), optional, intent(IN) :: iMaskTags2 - character(len=*), optional, intent(IN) :: rMaskTags2 - type(GeneralGrid), intent(IN) :: GGrid - logical, intent(IN) :: CheckMasks - -! !INPUT/OUTPUT PARAMETERS: -! - type(AttrVect), intent(INOUT) :: outAv - real(DP), dimension(:), pointer :: WeightSum - -! !REVISION HISTORY: -! 19Jun02 - Jay Larson - Interface spec. -! 3Jul02 - Jay Larson - Implementation. -! 10Jul02 - J. Larson - Improved argument -! checking. -!_______________________________________________________________________ -! - character(len=*),parameter :: myname_=myname//'::MergeTwoGGDP_' - - integer :: i, j - real(FP) :: invWeightSum - - ! Begin argument sanity checks... - - ! Have the input arguments been allocated? - - if(.not.(List_allocated(inAv1%rList))) then - write(stderr,'(2a)') myname_, & - 'ERROR--INPUT argument inAv1 has no real attributes!' - call die(myname_) - endif - - if(.not.(List_allocated(inAv2%rList))) then - write(stderr,'(2a)') myname_, & - 'ERROR--INPUT argument inAv2 has no real attributes!' - call die(myname_) - endif - - if(.not.(List_allocated(outaV%rList))) then - write(stderr,'(2a)') myname_, & - 'ERROR--INPUT/OUTPUT argument outAv has no real attributes!' - call die(myname_) - endif - - if(present(iMaskTags1) .or. present(iMaskTags2)) then - if(.not.(List_allocated(GGrid%data%iList))) then - write(stderr,'(3a)') myname_, & - 'ERROR--Integer masking requested, but input argument GGrid ', & - 'has no integer attributes!' - call die(myname_) - endif - endif - - if(present(rMaskTags1) .or. present(rMaskTags2)) then - if(.not.(List_allocated(GGrid%data%rList))) then - write(stderr,'(3a)') myname_, & - 'ERROR--Real masking requested, but input argument GGrid ', & - 'has no real attributes!' - call die(myname_) - endif - endif - - if(.not.(associated(WeightSum))) then - write(stderr,'(2a)') myname_, & - 'ERROR--INPUT/OUPUT argument WeightSum has not been allocated!' - call die(myname_) - endif - - ! Do the vector lengths match? - - if(AttrVect_lsize(inAv1) /= AttrVect_lsize(outAv)) then - write(stderr,'(2a,2(a,i8))') myname_, & - ':: ERROR--Lengths of AttrVect arguments inAv1 and outAv must match.', & - 'AttrVect_lsize(inAv1) = ',AttrVect_lsize(inAv1), & - 'AttrVect_lsize(outAv) = ',AttrVect_lsize(outAv) - call die(myname_) - endif - - if(AttrVect_lsize(inAv2) /= AttrVect_lsize(outAv)) then - write(stderr,'(2a,2(a,i8))') myname_, & - ':: ERROR--Lengths of AttrVect arguments inAv2 and outAv must match.', & - 'AttrVect_lsize(inAv2) = ',AttrVect_lsize(inAv2), & - 'AttrVect_lsize(outAv) = ',AttrVect_lsize(outAv) - call die(myname_) - endif - - if(AttrVect_lsize(inAv1) /= GeneralGrid_lsize(GGrid)) then - write(stderr,'(2a,2(a,i8))') myname_, & - ':: ERROR--Lengths of arguments inAv1 and GGrid must match.', & - 'AttrVect_lsize(inAv1) = ',AttrVect_lsize(inAv1), & - 'AttrVect_lsize(outAv) = ',GeneralGrid_lsize(GGrid) - call die(myname_) - endif - - if(AttrVect_lsize(inAv1) /= size(WeightSum)) then - write(stderr,'(2a,2(a,i8))') myname_, & - ':: ERROR--Lengths of arguments inAv1 and WeightSum must match.', & - 'AttrVect_lsize(inAv1) = ',AttrVect_lsize(inAv1), & - 'size(WeightSum) = ',size(WeightSum) - call die(myname_) - endif - - ! ...end argument sanity checks. - - ! Initialize the elements of WeightSum(:) to zero: - - do i=1,size(WeightSum) - WeightSum(i) = 0._FP - end do - - ! Process the incoming data one input AttrVect and mask tag - ! combination at a time. - - ! First input AttrVect/mask combination...must work through - ! all the possible cases for optional arguments iMaskTags1 and - ! rMaskTags1. - - if(present(iMaskTags1)) then - - if(present(rMaskTags1)) then ! both real and integer masks - call MergeInDataGGDP_(inAv1, iMaskTags1, rMaskTags1, GGrid, & - CheckMasks, outAv, WeightSum) - else ! only integer masks - call MergeInDataGGDP_(inAv1, iMaskTags=iMaskTags1, GGrid=GGrid, & - CheckMasks=CheckMasks, outAv=outAv, & - WeightSum=WeightSum) - endif - - else - - if(present(rMaskTags1)) then ! only real masks - call MergeInDataGGDP_(inAv1, rMaskTags=rMaskTags1, GGrid=GGrid, & - CheckMasks=CheckMasks, outAv=outAv, & - WeightSum=WeightSum) - else ! no masks at all - call MergeInDataGGDP_(inAv1, GGrid=GGrid, & - CheckMasks=CheckMasks, outAv=outAv, & - WeightSum=WeightSum) - endif - - endif ! if(present(iMaskTags1))... - - ! Second input AttrVect/mask combination...must work through - ! all the possible cases for optional arguments iMaskTags2 and - ! rMaskTags2. - - if(present(iMaskTags2)) then - - if(present(rMaskTags2)) then ! both real and integer masks - call MergeInDataGGDP_(inAv2, iMaskTags2, rMaskTags2, GGrid, & - CheckMasks, outAv, WeightSum) - else ! only integer masks - call MergeInDataGGDP_(inAv2, iMaskTags=iMaskTags2, GGrid=GGrid, & - CheckMasks=CheckMasks, outAv=outAv, & - WeightSum=WeightSum) - endif - - else - - if(present(rMaskTags2)) then ! only real masks - call MergeInDataGGDP_(inAv2, rMaskTags=rMaskTags2, GGrid=GGrid, & - CheckMasks=CheckMasks, outAv=outAv, & - WeightSum=WeightSum) - else ! no masks at all - call MergeInDataGGDP_(inAv2, GGrid=GGrid, & - CheckMasks=CheckMasks, outAv=outAv, & - WeightSum=WeightSum) - endif - - endif ! if(present(iMaskTags2))... - - ! Now we must renormalize the entries in outAv by dividing - ! element-by-element by the sums of the merge weights, which - ! were accumulated in WeightSum(:) - - do i=1,AttrVect_lsize(outAv) - - if(WeightSum(i) /= 0._FP) then - invWeightSum = 1._FP / WeightSum(i) - else - write(stderr,'(2a,i8,a)') myname_,':: FATAL--WeightSum(', & - i,') is zero!' - call die(myname_) - endif - - do j=1,AttrVect_nRAttr(outAv) - outAv%rAttr(j,i) = invWeightSum * outAv%rAttr(j,i) - end do - - end do - - ! The merge is now complete. - - end subroutine MergeTwoGGDP_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: MergeThreeGGSP_ - Merge Data from Three Sources -! -! !DESCRIPTION: This routine merges {\tt REAL} attribute data from -! three input {\tt AttrVect} arguments {\tt inAv1} , {\tt inAv2}, and -! {\tt inAv3} to a fourth {\tt AttrVect} {\tt outAv}. The attributes to -! be merged are determined entirely by the real attributes of {\tt outAv}. -! If {\tt outAv} shares one or more attributes with any of the inputs -! {\tt inAv1}, {\tt inAv2}, or {\tt inAv3}, a merge is performed on the -! individual {\em intersections} of attributes between the pairs -! $({\tt outAv},{\tt inAv1})$, $({\tt outAv},{\tt inAv2})$, -! and $({\tt outAv},{\tt inAv3})$. Currently, it is assumed that these -! pairwise intersections are all equal. This assumption is of -! critical importance to the user. If the user violates this -! assumption, incorrect merges of any attributes present only in some -! (but not all) inputs will result. -! -! The merge operatrion is a masked -! weighted element-by-element sum, as outlined in the following example. -! Let the vectors ${\bf a}$,${\bf b}$, and ${\bf c}$ be data from -! Components $A$, $B$, and $C$ that have been interpolated onto the -! physical grid of another component $D$. We wish to combine the data -! from $A$, $B$ and $C$ to get a vector ${\bf d}$, which represents the -! merged data on the grid of component $D$. The merge relation to obtain -! the $i$th element of ${\bf d}$ is -! $$ d_i = {1 \over {W_i}} \bigg\{ {{\prod_{j=1}^J} \kappa_{i}^j} -! {{\prod_{k=1}^K} \alpha_{i}^k} {a_i} + {{\prod_{l=1}^L} \lambda_{i}^l} -! {{\prod_{m=1}^M} \beta_{i}^m} {b_i} + {{\prod_{p=1}^P} \mu_{i}^p} -! {{\prod_{q=1}^Q} \gamma_{i}^q} {c_i} \bigg\} , $$ -! where -! $$ {W_i} = {{\prod_{j=1}^J} \kappa_{i}^j} {{\prod_{k=1}^K} \alpha_{i}^k} + -! {{\prod_{l=1}^L} \lambda_{i}^l} {{\prod_{m=1}^M} \beta_{i}^m} + -! {{\prod_{p=1}^P} \mu_{i}^p} {{\prod_{q=1}^Q} \gamma_{i}^q}. $$ -! The quantities ${\kappa_{i}^j}$, ${\lambda_{i}^p}$, and ${\mu_{i}^p}$ are -! {\em integer masks} (which have value either $0$ or $1$), and -! ${\alpha_{i}^k}$, ${\beta_{i}^m}$, and ${\gamma_{i}^q}$ are {\em real -! masks} (which are in the closed interval $[0,1]$). -! -! The integer and real masks are stored as attributes to the same input -! {\tt GeneralGrid} argument {\tt GGrid}. The mask attribute names are -! stored as substrings to the colon-separated strings contained in the -! input {\tt CHARACTER} arguments {\tt iMaskTags1}, {\tt iMaskTags2}, -! {\tt iMaskTags3}, {\tt rMaskTags1}, {\tt rMaskTags2}, and -! {\tt rMaskTags3}. The {\tt LOGICAL} input argument {\tt CheckMasks} -! governs how the masks are applied. If ${\tt CheckMasks} = {\tt .TRUE.}$, -! the entries are checked to ensure they meet the definitions of real -! and integer masks. If ${\tt CheckMasks} = {\tt .FALSE.}$ then the masks -! are multiplied together on an element-by-element basis with no validation -! of their entries (this option results in slightly higher performance). -! -! This routine returns the sum of the masked weights as a diagnostic. -! This quantity is returned in the output {\tt REAL} array {\tt WeightSum}. -! -! The correspondence between the quantities in the above merge relation -! and the arguments to this routine are summarized in the table. -! \begin{center} -! \begin{tabular}{|l|l|l|}\hline -! {\bf Quantity} & {\bf Stored in} & {\bf Referenced by} \\ -! & {\bf Argument} & {\bf Argument} \\ -! \hline -! \hline -! $ {a_i} $ & {\tt inAv1} & \\ -! \hline -! $ {b_i} $ & {\tt inAv2} & \\ -! \hline -! $ {c_i} $ & {\tt inAv3} & \\ -! \hline -! $ {d_i} $ & {\tt outAv} & \\ -! \hline -! $ {\kappa_i^j}, j=1,\ldots,J $ & {\tt GGrid} & {\tt iMaskTags1}\\ -! & & ($J$ items) \\ -! \hline -! $ {\alpha_i^k}, k=1,\ldots,K $ & {\tt GGrid} & {\tt rMaskTags1}\\ -! & & ($K$ items) \\ -! \hline -! $ {\lambda_i^l}, l=1,\ldots,L $ & {\tt GGrid} & {\tt iMaskTags2}\\ -! & & ($L$ items) \\ -! \hline -! $ {\beta_i^m}, m=1,\ldots,M $ & {\tt GGrid} & {\tt rMaskTags2}\\ -! & & ($M$ items) \\ -! \hline -! $ {\mu_i^p}, p=1,\ldots,P $ & {\tt GGrid} & {\tt iMaskTags3}\\ -! & & ($L$ items) \\ -! \hline -! $ {\gamma_i^q}, q=1,\ldots,Q $ & {\tt GGrid} & {\tt rMaskTags3}\\ -! & & ($M$ items) \\ -! \hline -! $ {W_i} $ & {\tt WeightSum} & \\ -! \hline -! \end{tabular} -! \end{center} -! -! !INTERFACE: - - subroutine MergeThreeGGSP_(inAv1, iMaskTags1, rMaskTags1, & - inAv2, iMaskTags2, rMaskTags2, & - inAv3, iMaskTags3, rMaskTags3, & - GGrid, CheckMasks, outAv, WeightSum) -! -! !USES: -! - use m_stdio - use m_die - - use m_realkinds, only : SP, FP - - use m_List, only : List - use m_List, only : List_allocated => allocated - - use m_AttrVect, only : AttrVect - use m_AttrVect, only : AttrVect_lsize => lsize - use m_AttrVect, only : AttrVect_nRAttr => nRAttr - - use m_GeneralGrid, only : GeneralGrid - use m_GeneralGrid, only : GeneralGrid_lsize => lsize - - implicit none - -! !INPUT PARAMETERS: -! - type(AttrVect), intent(IN) :: inAv1 - character(len=*), optional, intent(IN) :: iMaskTags1 - character(len=*), optional, intent(IN) :: rMaskTags1 - type(AttrVect), intent(IN) :: inAv2 - character(len=*), optional, intent(IN) :: iMaskTags2 - character(len=*), optional, intent(IN) :: rMaskTags2 - type(AttrVect), intent(IN) :: inAv3 - character(len=*), optional, intent(IN) :: iMaskTags3 - character(len=*), optional, intent(IN) :: rMaskTags3 - type(GeneralGrid), intent(IN) :: GGrid - logical, intent(IN) :: CheckMasks - -! !INPUT/OUTPUT PARAMETERS: -! - type(AttrVect), intent(INOUT) :: outAv - real(SP), dimension(:), pointer :: WeightSum - -! !REVISION HISTORY: -! 19Jun02 - Jay Larson - Interface spec. -! 3Jul02 - Jay Larson - Implementation. -! 10Jul02 - J. Larson - Improved argument -! checking. -!EOP ___________________________________________________________________ -! - character(len=*),parameter :: myname_=myname//'::MergeThreeGGSP_' - - integer :: i, j - real(FP) :: invWeightSum - - ! Begin argument sanity checks... - - ! Have the input arguments been allocated? - - if(.not.(List_allocated(inAv1%rList))) then - write(stderr,'(2a)') myname_, & - 'ERROR--INPUT argument inAv1 has no real attributes!' - call die(myname_) - endif - - if(.not.(List_allocated(inAv2%rList))) then - write(stderr,'(2a)') myname_, & - 'ERROR--INPUT argument inAv2 has no real attributes!' - call die(myname_) - endif - - if(.not.(List_allocated(inAv3%rList))) then - write(stderr,'(2a)') myname_, & - 'ERROR--INPUT argument inAv3 has no real attributes!' - call die(myname_) - endif - - if(.not.(List_allocated(outaV%rList))) then - write(stderr,'(2a)') myname_, & - 'ERROR--INPUT/OUTPUT argument outAv has no real attributes!' - call die(myname_) - endif - - if(present(iMaskTags1) .or. present(iMaskTags2) .or. present(iMaskTags3)) then - if(.not.(List_allocated(GGrid%data%iList))) then - write(stderr,'(3a)') myname_, & - 'ERROR--Integer masking requested, but input argument GGrid ', & - 'has no integer attributes!' - call die(myname_) - endif - endif - - if(present(rMaskTags1) .or. present(rMaskTags2) .or. present(rMaskTags3)) then - if(.not.(List_allocated(GGrid%data%rList))) then - write(stderr,'(3a)') myname_, & - 'ERROR--Real masking requested, but input argument GGrid ', & - 'has no real attributes!' - call die(myname_) - endif - endif - - if(.not.(associated(WeightSum))) then - write(stderr,'(2a)') myname_, & - 'ERROR--INPUT/OUPUT argument WeightSum has not been allocated!' - call die(myname_) - endif - - ! Do the vector lengths match? - - if(AttrVect_lsize(inAv1) /= AttrVect_lsize(outAv)) then - write(stderr,'(2a,2(a,i8))') myname_, & - ':: ERROR--Lengths of AttrVect arguments inAv1 and outAv must match.', & - 'AttrVect_lsize(inAv1) = ',AttrVect_lsize(inAv1), & - 'AttrVect_lsize(outAv) = ',AttrVect_lsize(outAv) - call die(myname_) - endif - - if(AttrVect_lsize(inAv2) /= AttrVect_lsize(outAv)) then - write(stderr,'(2a,2(a,i8))') myname_, & - ':: ERROR--Lengths of AttrVect arguments inAv2 and outAv must match.', & - 'AttrVect_lsize(inAv2) = ',AttrVect_lsize(inAv2), & - 'AttrVect_lsize(outAv) = ',AttrVect_lsize(outAv) - call die(myname_) - endif - - if(AttrVect_lsize(inAv3) /= AttrVect_lsize(outAv)) then - write(stderr,'(2a,2(a,i8))') myname_, & - ':: ERROR--Lengths of AttrVect arguments inAv3 and outAv must match.', & - 'AttrVect_lsize(inAv3) = ',AttrVect_lsize(inAv3), & - 'AttrVect_lsize(outAv) = ',AttrVect_lsize(outAv) - call die(myname_) - endif - - if(AttrVect_lsize(inAv1) /= GeneralGrid_lsize(GGrid)) then - write(stderr,'(2a,2(a,i8))') myname_, & - ':: ERROR--Lengths of arguments inAv1 and GGrid must match.', & - 'AttrVect_lsize(inAv1) = ',AttrVect_lsize(inAv1), & - 'AttrVect_lsize(outAv) = ',GeneralGrid_lsize(GGrid) - call die(myname_) - endif - - if(AttrVect_lsize(inAv1) /= size(WeightSum)) then - write(stderr,'(2a,2(a,i8))') myname_, & - ':: ERROR--Lengths of arguments inAv1 and WeightSum must match.', & - 'AttrVect_lsize(inAv1) = ',AttrVect_lsize(inAv1), & - 'size(WeightSum) = ',size(WeightSum) - call die(myname_) - endif - - ! ...end argument sanity checks. - - ! Initialize the elements of WeightSum(:) to zero: - - do i=1,size(WeightSum) - WeightSum(i) = 0._FP - end do - - ! Process the incoming data one input AttrVect and mask tag - ! combination at a time. - - ! First input AttrVect/mask combination...must work through - ! all the possible cases for optional arguments iMaskTags1 and - ! rMaskTags1. - - if(present(iMaskTags1)) then - - if(present(rMaskTags1)) then ! both real and integer masks - call MergeInDataGGSP_(inAv1, iMaskTags1, rMaskTags1, GGrid, & - CheckMasks, outAv, WeightSum) - else ! only integer masks - call MergeInDataGGSP_(inAv1, iMaskTags=iMaskTags1, GGrid=GGrid, & - CheckMasks=CheckMasks, outAv=outAv, & - WeightSum=WeightSum) - endif - - else - - if(present(rMaskTags1)) then ! only real masks - call MergeInDataGGSP_(inAv1, rMaskTags=rMaskTags1, GGrid=GGrid, & - CheckMasks=CheckMasks, outAv=outAv, & - WeightSum=WeightSum) - else ! no masks at all - call MergeInDataGGSP_(inAv1, GGrid=GGrid, & - CheckMasks=CheckMasks, outAv=outAv, & - WeightSum=WeightSum) - endif - - endif ! if(present(iMaskTags1))... - - ! Second input AttrVect/mask combination...must work through - ! all the possible cases for optional arguments iMaskTags2 and - ! rMaskTags2. - - if(present(iMaskTags2)) then - - if(present(rMaskTags2)) then ! both real and integer masks - call MergeInDataGGSP_(inAv2, iMaskTags2, rMaskTags2, GGrid, & - CheckMasks, outAv, WeightSum) - else ! only integer masks - call MergeInDataGGSP_(inAv2, iMaskTags=iMaskTags2, GGrid=GGrid, & - CheckMasks=CheckMasks, outAv=outAv, & - WeightSum=WeightSum) - endif - - else - - if(present(rMaskTags2)) then ! only real masks - call MergeInDataGGSP_(inAv2, rMaskTags=rMaskTags2, GGrid=GGrid, & - CheckMasks=CheckMasks, outAv=outAv, & - WeightSum=WeightSum) - else ! no masks at all - call MergeInDataGGSP_(inAv2, GGrid=GGrid, & - CheckMasks=CheckMasks, outAv=outAv, & - WeightSum=WeightSum) - endif - - endif ! if(present(iMaskTags2))... - - ! Third input AttrVect/mask combination...must work through - ! all the possible cases for optional arguments iMaskTags3 and - ! rMaskTags3. - - if(present(iMaskTags3)) then - - if(present(rMaskTags3)) then ! both real and integer masks - call MergeInDataGGSP_(inAv3, iMaskTags3, rMaskTags3, GGrid, & - CheckMasks, outAv, WeightSum) - else ! only integer masks - call MergeInDataGGSP_(inAv3, iMaskTags=iMaskTags3, GGrid=GGrid, & - CheckMasks=CheckMasks, outAv=outAv, & - WeightSum=WeightSum) - endif - - else - - if(present(rMaskTags3)) then ! only real masks - call MergeInDataGGSP_(inAv3, rMaskTags=rMaskTags3, GGrid=GGrid, & - CheckMasks=CheckMasks, outAv=outAv, & - WeightSum=WeightSum) - else ! no masks at all - call MergeInDataGGSP_(inAv3, GGrid=GGrid, & - CheckMasks=CheckMasks, outAv=outAv, & - WeightSum=WeightSum) - endif - - endif ! if(present(iMaskTags3))... - - ! Now we must renormalize the entries in outAv by dividing - ! element-by-element by the sums of the merge weights, which - ! were accumulated in WeightSum(:) - - do i=1,AttrVect_lsize(outAv) - - if(WeightSum(i) /= 0._FP) then - invWeightSum = 1._FP / WeightSum(i) - else - write(stderr,'(2a,i8,a)') myname_,':: FATAL--WeightSum(', & - i,') is zero!' - call die(myname_) - endif - - do j=1,AttrVect_nRAttr(outAv) - outAv%rAttr(j,i) = invWeightSum * outAv%rAttr(j,i) - end do - - end do - - ! The merge is now complete. - - end subroutine MergeThreeGGSP_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!----------------------------------------------------------------------- -! -! !IROUTINE: MergeThreeGGDP_ - merge data from three components. -! -! !DESCRIPTION: -! Double precision version of MergeThreeGGSP_ -! -! !INTERFACE: - - subroutine MergeThreeGGDP_(inAv1, iMaskTags1, rMaskTags1, & - inAv2, iMaskTags2, rMaskTags2, & - inAv3, iMaskTags3, rMaskTags3, & - GGrid, CheckMasks, outAv, WeightSum) -! -! !USES: -! - use m_stdio - use m_die - - use m_realkinds, only : DP, FP - - use m_List, only : List - use m_List, only : List_allocated => allocated - - use m_AttrVect, only : AttrVect - use m_AttrVect, only : AttrVect_lsize => lsize - use m_AttrVect, only : AttrVect_nRAttr => nRAttr - - use m_GeneralGrid, only : GeneralGrid - use m_GeneralGrid, only : GeneralGrid_lsize => lsize - - implicit none - -! !INPUT PARAMETERS: -! - type(AttrVect), intent(IN) :: inAv1 - character(len=*), optional, intent(IN) :: iMaskTags1 - character(len=*), optional, intent(IN) :: rMaskTags1 - type(AttrVect), intent(IN) :: inAv2 - character(len=*), optional, intent(IN) :: iMaskTags2 - character(len=*), optional, intent(IN) :: rMaskTags2 - type(AttrVect), intent(IN) :: inAv3 - character(len=*), optional, intent(IN) :: iMaskTags3 - character(len=*), optional, intent(IN) :: rMaskTags3 - type(GeneralGrid), intent(IN) :: GGrid - logical, intent(IN) :: CheckMasks - -! !INPUT/OUTPUT PARAMETERS: -! - type(AttrVect), intent(INOUT) :: outAv - real(DP), dimension(:), pointer :: WeightSum - -! !REVISION HISTORY: -! 19Jun02 - Jay Larson - Interface spec. -! 3Jul02 - Jay Larson - Implementation. -! 10Jul02 - J. Larson - Improved argument -! checking. -!_______________________________________________________________________ -! - character(len=*),parameter :: myname_=myname//'::MergeThreeGGDP_' - - integer :: i, j - real(FP) :: invWeightSum - - ! Begin argument sanity checks... - - ! Have the input arguments been allocated? - - if(.not.(List_allocated(inAv1%rList))) then - write(stderr,'(2a)') myname_, & - 'ERROR--INPUT argument inAv1 has no real attributes!' - call die(myname_) - endif - - if(.not.(List_allocated(inAv2%rList))) then - write(stderr,'(2a)') myname_, & - 'ERROR--INPUT argument inAv2 has no real attributes!' - call die(myname_) - endif - - if(.not.(List_allocated(inAv3%rList))) then - write(stderr,'(2a)') myname_, & - 'ERROR--INPUT argument inAv3 has no real attributes!' - call die(myname_) - endif - - if(.not.(List_allocated(outaV%rList))) then - write(stderr,'(2a)') myname_, & - 'ERROR--INPUT/OUTPUT argument outAv has no real attributes!' - call die(myname_) - endif - - if(present(iMaskTags1) .or. present(iMaskTags2) .or. present(iMaskTags3)) then - if(.not.(List_allocated(GGrid%data%iList))) then - write(stderr,'(3a)') myname_, & - 'ERROR--Integer masking requested, but input argument GGrid ', & - 'has no integer attributes!' - call die(myname_) - endif - endif - - if(present(rMaskTags1) .or. present(rMaskTags2) .or. present(rMaskTags3)) then - if(.not.(List_allocated(GGrid%data%rList))) then - write(stderr,'(3a)') myname_, & - 'ERROR--Real masking requested, but input argument GGrid ', & - 'has no real attributes!' - call die(myname_) - endif - endif - - if(.not.(associated(WeightSum))) then - write(stderr,'(2a)') myname_, & - 'ERROR--INPUT/OUPUT argument WeightSum has not been allocated!' - call die(myname_) - endif - - ! Do the vector lengths match? - - if(AttrVect_lsize(inAv1) /= AttrVect_lsize(outAv)) then - write(stderr,'(2a,2(a,i8))') myname_, & - ':: ERROR--Lengths of AttrVect arguments inAv1 and outAv must match.', & - 'AttrVect_lsize(inAv1) = ',AttrVect_lsize(inAv1), & - 'AttrVect_lsize(outAv) = ',AttrVect_lsize(outAv) - call die(myname_) - endif - - if(AttrVect_lsize(inAv2) /= AttrVect_lsize(outAv)) then - write(stderr,'(2a,2(a,i8))') myname_, & - ':: ERROR--Lengths of AttrVect arguments inAv2 and outAv must match.', & - 'AttrVect_lsize(inAv2) = ',AttrVect_lsize(inAv2), & - 'AttrVect_lsize(outAv) = ',AttrVect_lsize(outAv) - call die(myname_) - endif - - if(AttrVect_lsize(inAv3) /= AttrVect_lsize(outAv)) then - write(stderr,'(2a,2(a,i8))') myname_, & - ':: ERROR--Lengths of AttrVect arguments inAv3 and outAv must match.', & - 'AttrVect_lsize(inAv3) = ',AttrVect_lsize(inAv3), & - 'AttrVect_lsize(outAv) = ',AttrVect_lsize(outAv) - call die(myname_) - endif - - if(AttrVect_lsize(inAv1) /= GeneralGrid_lsize(GGrid)) then - write(stderr,'(2a,2(a,i8))') myname_, & - ':: ERROR--Lengths of arguments inAv1 and GGrid must match.', & - 'AttrVect_lsize(inAv1) = ',AttrVect_lsize(inAv1), & - 'AttrVect_lsize(outAv) = ',GeneralGrid_lsize(GGrid) - call die(myname_) - endif - - if(AttrVect_lsize(inAv1) /= size(WeightSum)) then - write(stderr,'(2a,2(a,i8))') myname_, & - ':: ERROR--Lengths of arguments inAv1 and WeightSum must match.', & - 'AttrVect_lsize(inAv1) = ',AttrVect_lsize(inAv1), & - 'size(WeightSum) = ',size(WeightSum) - call die(myname_) - endif - - ! ...end argument sanity checks. - - ! Initialize the elements of WeightSum(:) to zero: - - do i=1,size(WeightSum) - WeightSum(i) = 0._FP - end do - - ! Process the incoming data one input AttrVect and mask tag - ! combination at a time. - - ! First input AttrVect/mask combination...must work through - ! all the possible cases for optional arguments iMaskTags1 and - ! rMaskTags1. - - if(present(iMaskTags1)) then - - if(present(rMaskTags1)) then ! both real and integer masks - call MergeInDataGGDP_(inAv1, iMaskTags1, rMaskTags1, GGrid, & - CheckMasks, outAv, WeightSum) - else ! only integer masks - call MergeInDataGGDP_(inAv1, iMaskTags=iMaskTags1, GGrid=GGrid, & - CheckMasks=CheckMasks, outAv=outAv, & - WeightSum=WeightSum) - endif - - else - - if(present(rMaskTags1)) then ! only real masks - call MergeInDataGGDP_(inAv1, rMaskTags=rMaskTags1, GGrid=GGrid, & - CheckMasks=CheckMasks, outAv=outAv, & - WeightSum=WeightSum) - else ! no masks at all - call MergeInDataGGDP_(inAv1, GGrid=GGrid, & - CheckMasks=CheckMasks, outAv=outAv, & - WeightSum=WeightSum) - endif - - endif ! if(present(iMaskTags1))... - - ! Second input AttrVect/mask combination...must work through - ! all the possible cases for optional arguments iMaskTags2 and - ! rMaskTags2. - - if(present(iMaskTags2)) then - - if(present(rMaskTags2)) then ! both real and integer masks - call MergeInDataGGDP_(inAv2, iMaskTags2, rMaskTags2, GGrid, & - CheckMasks, outAv, WeightSum) - else ! only integer masks - call MergeInDataGGDP_(inAv2, iMaskTags=iMaskTags2, GGrid=GGrid, & - CheckMasks=CheckMasks, outAv=outAv, & - WeightSum=WeightSum) - endif - - else - - if(present(rMaskTags2)) then ! only real masks - call MergeInDataGGDP_(inAv2, rMaskTags=rMaskTags2, GGrid=GGrid, & - CheckMasks=CheckMasks, outAv=outAv, & - WeightSum=WeightSum) - else ! no masks at all - call MergeInDataGGDP_(inAv2, GGrid=GGrid, & - CheckMasks=CheckMasks, outAv=outAv, & - WeightSum=WeightSum) - endif - - endif ! if(present(iMaskTags2))... - - ! Third input AttrVect/mask combination...must work through - ! all the possible cases for optional arguments iMaskTags3 and - ! rMaskTags3. - - if(present(iMaskTags3)) then - - if(present(rMaskTags3)) then ! both real and integer masks - call MergeInDataGGDP_(inAv3, iMaskTags3, rMaskTags3, GGrid, & - CheckMasks, outAv, WeightSum) - else ! only integer masks - call MergeInDataGGDP_(inAv3, iMaskTags=iMaskTags3, GGrid=GGrid, & - CheckMasks=CheckMasks, outAv=outAv, & - WeightSum=WeightSum) - endif - - else - - if(present(rMaskTags3)) then ! only real masks - call MergeInDataGGDP_(inAv3, rMaskTags=rMaskTags3, GGrid=GGrid, & - CheckMasks=CheckMasks, outAv=outAv, & - WeightSum=WeightSum) - else ! no masks at all - call MergeInDataGGDP_(inAv3, GGrid=GGrid, & - CheckMasks=CheckMasks, outAv=outAv, & - WeightSum=WeightSum) - endif - - endif ! if(present(iMaskTags3))... - - ! Now we must renormalize the entries in outAv by dividing - ! element-by-element by the sums of the merge weights, which - ! were accumulated in WeightSum(:) - - do i=1,AttrVect_lsize(outAv) - - if(WeightSum(i) /= 0._FP) then - invWeightSum = 1._FP / WeightSum(i) - else - write(stderr,'(2a,i8,a)') myname_,':: FATAL--WeightSum(', & - i,') is zero!' - call die(myname_) - endif - - do j=1,AttrVect_nRAttr(outAv) - outAv%rAttr(j,i) = invWeightSum * outAv%rAttr(j,i) - end do - - end do - - ! The merge is now complete. - - end subroutine MergeThreeGGDP_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: MergeFourGGSP_ - Merge Data from Four Sources -! -! !DESCRIPTION: This routine merges {\tt REAL} attribute data from -! four input {\tt AttrVect} arguments {\tt inAv1} , {\tt inAv2}, -! {\tt inAv3}, and {\tt inAv4} to a fifth {\tt AttrVect} {\tt outAv}. The -! attributes to be merged are determined entirely by the real attributes -! of {\tt outAv}. If {\tt outAv} shares one or more attributes with any of -! the inputs {\tt inAv1}, {\tt inAv2}, {\tt inAv3}, or {\tt inAv4}, a merge -! is performed on the individual {\em intersections} of attributes between -! the pairs $({\tt outAv},{\tt inAv1})$, $({\tt outAv},{\tt inAv2})$, -! $({\tt outAv},{\tt inAv3})$, and $({\tt outAv},{\tt inAv3})$. Currently, -! it is assumed that these pairwise intersections are all equal. This -! assumption is of critical importance to the user. If the user violates -! this assumption, incorrect merges of any attributes present only in some -! (but not all) the inputs will result. -! -! The merge operatrion is a masked -! weighted element-by-element sum, as outlined in the following example. -! Let the vectors ${\bf a}$,${\bf b}$, ${\bf c}$ and ${\bf d}$ be data from -! Components $A$, $B$, $C$, and $D$ that have been interpolated onto the -! physical grid of another component $E$. We wish to combine the data -! from $A$, $B$, $C$, and $D$ to get a vector ${\bf e}$, which represents the -! merged data on the grid of component $E$. The merge relation to obtain -! the $i$th element of {\bf e} is -! $$ e_i = {1 \over {W_i}} \bigg\{ {{\prod_{j=1}^J} \kappa_{i}^j} -! {{\prod_{k=1}^K} \alpha_{i}^k} {a_i} + {{\prod_{l=1}^L} \lambda_{i}^l} -! {{\prod_{m=1}^M} \beta_{i}^m} {b_i} + {{\prod_{p=1}^P} \mu_{i}^p} -! {{\prod_{q=1}^Q} \gamma_{i}^q} {c_i} + -! {{\prod_{r=1}^R} \nu_{i}^r} {{\prod_{s=1}^S} \delta_{i}^s} {d_i} \bigg\} , $$ -! where -! $$ {W_i} = {{\prod_{j=1}^J} \kappa_{i}^j} {{\prod_{k=1}^K} \alpha_{i}^k} + -! {{\prod_{l=1}^L} \lambda_{i}^l} {{\prod_{m=1}^M} \beta_{i}^m} + -! {{\prod_{p=1}^P} \mu_{i}^p} {{\prod_{q=1}^Q} \gamma_{i}^q} + -! {{\prod_{r=1}^R} \nu_{i}^r} {{\prod_{s=1}^S} \delta_{i}^s}. $$ -! The quantities ${\kappa_{i}^j}$, ${\lambda_{i}^p}$, ${\mu_{i}^p}$, and -! ${\nu_{i}^r}$ are {\em integer masks} (which have value either $0$ or $1$), -! and ${\alpha_{i}^k}$, ${\beta_{i}^m}$, ${\gamma_{i}^q}$, and ${\delta_{i}^s}$ -! are {\em real masks} (which are in the closed interval $[0,1]$). -! -! The integer and real masks are stored as attributes to the same input -! {\tt GeneralGrid} argument {\tt GGrid}. The mask attribute names are -! stored as substrings to the colon-separated strings contained in the -! input {\tt CHARACTER} arguments {\tt iMaskTags1}, {\tt iMaskTags2}, -! {\tt iMaskTags3}, {\tt iMaskTags4}, {\tt rMaskTags1}, and {\tt rMaskTags2}, -! {\tt rMaskTags3}, and {\tt rMaskTags4}, . The {\tt LOGICAL} input -! argument {\tt CheckMasks} governs how the masks are applied. If -! ${\tt CheckMasks} = {\tt .TRUE.}$, the entries are checked to ensure -! they meet the definitions of real and integer masks. If ${\tt CheckMasks} -! = {\tt .FALSE.}$ then the masks are multiplied together on an -! element-by-element basis with no validation of their entries (this option -! results in slightly higher performance). -! -! This routine returns the sume of the masked weights as a diagnostic. -! This quantity is returned in the output {\tt REAL} array {\tt WeightSum}. -! -! The correspondence between the quantities in the above merge relation -! and the arguments to this routine are summarized in the table. -! \begin{center} -! \begin{tabular}{|l|l|l|}\hline -! {\bf Quantity} & {\bf Stored in} & {\bf Referenced by} \\ -! & {\bf Argument} & {\bf Argument} \\ -! \hline -! \hline -! $ {a_i} $ & {\tt inAv1} & \\ -! \hline -! $ {b_i} $ & {\tt inAv2} & \\ -! \hline -! $ {c_i} $ & {\tt inAv3} & \\ -! \hline -! $ {d_i} $ & {\tt inAv4} & \\ -! \hline -! $ {e_i} $ & {\tt outAv} & \\ -! \hline -! $ {\kappa_i^j}, j=1,\ldots,J $ & {\tt GGrid} & {\tt iMaskTags1}\\ -! & & ($J$ items) \\ -! \hline -! $ {\alpha_i^k}, k=1,\ldots,K $ & {\tt GGrid} & {\tt rMaskTags1}\\ -! & & ($K$ items) \\ -! \hline -! $ {\lambda_i^l}, l=1,\ldots,L $ & {\tt GGrid} & {\tt iMaskTags2}\\ -! & & ($L$ items) \\ -! \hline -! $ {\beta_i^m}, m=1,\ldots,M $ & {\tt GGrid} & {\tt rMaskTags2}\\ -! & & ($M$ items) \\ -! \hline -! $ {\mu_i^p}, p=1,\ldots,P $ & {\tt GGrid} & {\tt iMaskTags3}\\ -! & & ($L$ items) \\ -! \hline -! $ {\gamma_i^q}, q=1,\ldots,Q $ & {\tt GGrid} & {\tt rMaskTags3}\\ -! & & ($M$ items) \\ -! \hline -! $ {\nu_i^r}, r=1,\ldots,R $ & {\tt GGrid} & {\tt iMaskTags4}\\ -! & & ($L$ items) \\ -! \hline -! $ {\delta_i^s}, s=1,\ldots,S $ & {\tt GGrid} & {\tt rMaskTags4}\\ -! & & ($M$ items) \\ -! \hline -! $ {W_i} $ & {\tt WeightSum} & \\ -! \hline -! \end{tabular} -! \end{center} -! -! !INTERFACE: - - subroutine MergeFourGGSP_(inAv1, iMaskTags1, rMaskTags1, & - inAv2, iMaskTags2, rMaskTags2, & - inAv3, iMaskTags3, rMaskTags3, & - inAv4, iMaskTags4, rMaskTags4, & - GGrid, CheckMasks, outAv, WeightSum) -! -! !USES: -! - use m_stdio - use m_die - - use m_realkinds, only : SP, FP - - use m_List, only : List - use m_List, only : List_allocated => allocated - - use m_AttrVect, only : AttrVect - use m_AttrVect, only : AttrVect_lsize => lsize - use m_AttrVect, only : AttrVect_nRAttr => nRAttr - - use m_GeneralGrid, only : GeneralGrid - use m_GeneralGrid, only : GeneralGrid_lsize => lsize - - implicit none - -! !INPUT PARAMETERS: -! - type(AttrVect), intent(IN) :: inAv1 - character(len=*), optional, intent(IN) :: iMaskTags1 - character(len=*), optional, intent(IN) :: rMaskTags1 - type(AttrVect), intent(IN) :: inAv2 - character(len=*), optional, intent(IN) :: iMaskTags2 - character(len=*), optional, intent(IN) :: rMaskTags2 - type(AttrVect), intent(IN) :: inAv3 - character(len=*), optional, intent(IN) :: iMaskTags3 - character(len=*), optional, intent(IN) :: rMaskTags3 - type(AttrVect), intent(IN) :: inAv4 - character(len=*), optional, intent(IN) :: iMaskTags4 - character(len=*), optional, intent(IN) :: rMaskTags4 - type(GeneralGrid), intent(IN) :: GGrid - logical, intent(IN) :: CheckMasks - -! !INPUT/OUTPUT PARAMETERS: -! - type(AttrVect), intent(INOUT) :: outAv - real(SP), dimension(:), pointer :: WeightSum - -! !REVISION HISTORY: -! 19Jun02 - Jay Larson - Interface spec. -! 3Jul02 - Jay Larson - Implementation. -! 10Jul02 - J. Larson - Improved argument -! checking. -!EOP ___________________________________________________________________ -! - character(len=*),parameter :: myname_=myname//'::MergeFourGGSP_' - - integer :: i, j - real(FP) :: invWeightSum - - ! Begin argument sanity checks... - - ! Have the input arguments been allocated? - - if(.not.(List_allocated(inAv1%rList))) then - write(stderr,'(2a)') myname_, & - 'ERROR--INPUT argument inAv1 has no real attributes!' - call die(myname_) - endif - - if(.not.(List_allocated(inAv2%rList))) then - write(stderr,'(2a)') myname_, & - 'ERROR--INPUT argument inAv2 has no real attributes!' - call die(myname_) - endif - - if(.not.(List_allocated(inAv3%rList))) then - write(stderr,'(2a)') myname_, & - 'ERROR--INPUT argument inAv3 has no real attributes!' - call die(myname_) - endif - - if(.not.(List_allocated(inAv4%rList))) then - write(stderr,'(2a)') myname_, & - 'ERROR--INPUT argument inAv4 has no real attributes!' - call die(myname_) - endif - - if(.not.(List_allocated(outaV%rList))) then - write(stderr,'(2a)') myname_, & - 'ERROR--INPUT/OUTPUT argument outAv has no real attributes!' - call die(myname_) - endif - - if(present(iMaskTags1) .or. present(iMaskTags2) .or. & - present(iMaskTags3) .or. present(iMaskTags4)) then - if(.not.(List_allocated(GGrid%data%iList))) then - write(stderr,'(3a)') myname_, & - 'ERROR--Integer masking requested, but input argument GGrid ', & - 'has no integer attributes!' - call die(myname_) - endif - endif - - if(present(rMaskTags1) .or. present(rMaskTags2) .or. & - present(rMaskTags3) .or. present(rMaskTags4)) then - if(.not.(List_allocated(GGrid%data%rList))) then - write(stderr,'(3a)') myname_, & - 'ERROR--Real masking requested, but input argument GGrid ', & - 'has no real attributes!' - call die(myname_) - endif - endif - - if(.not.(associated(WeightSum))) then - write(stderr,'(2a)') myname_, & - 'ERROR--INPUT/OUPUT argument WeightSum has not been allocated!' - call die(myname_) - endif - - ! Do the vector lengths match? - - if(AttrVect_lsize(inAv1) /= AttrVect_lsize(outAv)) then - write(stderr,'(2a,2(a,i8))') myname_, & - ':: ERROR--Lengths of AttrVect arguments inAv1 and outAv must match.', & - 'AttrVect_lsize(inAv1) = ',AttrVect_lsize(inAv1), & - 'AttrVect_lsize(outAv) = ',AttrVect_lsize(outAv) - call die(myname_) - endif - - if(AttrVect_lsize(inAv2) /= AttrVect_lsize(outAv)) then - write(stderr,'(2a,2(a,i8))') myname_, & - ':: ERROR--Lengths of AttrVect arguments inAv2 and outAv must match.', & - 'AttrVect_lsize(inAv2) = ',AttrVect_lsize(inAv2), & - 'AttrVect_lsize(outAv) = ',AttrVect_lsize(outAv) - call die(myname_) - endif - - if(AttrVect_lsize(inAv3) /= AttrVect_lsize(outAv)) then - write(stderr,'(2a,2(a,i8))') myname_, & - ':: ERROR--Lengths of AttrVect arguments inAv3 and outAv must match.', & - 'AttrVect_lsize(inAv3) = ',AttrVect_lsize(inAv3), & - 'AttrVect_lsize(outAv) = ',AttrVect_lsize(outAv) - call die(myname_) - endif - - if(AttrVect_lsize(inAv4) /= AttrVect_lsize(outAv)) then - write(stderr,'(2a,2(a,i8))') myname_, & - ':: ERROR--Lengths of AttrVect arguments inAv4 and outAv must match.', & - 'AttrVect_lsize(inAv4) = ',AttrVect_lsize(inAv4), & - 'AttrVect_lsize(outAv) = ',AttrVect_lsize(outAv) - call die(myname_) - endif - - if(AttrVect_lsize(inAv1) /= GeneralGrid_lsize(GGrid)) then - write(stderr,'(2a,2(a,i8))') myname_, & - ':: ERROR--Lengths of arguments inAv1 and GGrid must match.', & - 'AttrVect_lsize(inAv1) = ',AttrVect_lsize(inAv1), & - 'AttrVect_lsize(outAv) = ',GeneralGrid_lsize(GGrid) - call die(myname_) - endif - - if(AttrVect_lsize(inAv1) /= size(WeightSum)) then - write(stderr,'(2a,2(a,i8))') myname_, & - ':: ERROR--Lengths of arguments inAv1 and WeightSum must match.', & - 'AttrVect_lsize(inAv1) = ',AttrVect_lsize(inAv1), & - 'size(WeightSum) = ',size(WeightSum) - call die(myname_) - endif - - ! ...end argument sanity checks. - - ! Initialize the elements of WeightSum(:) to zero: - - do i=1,size(WeightSum) - WeightSum(i) = 0._FP - end do - - ! Process the incoming data one input AttrVect and mask tag - ! combination at a time. - - ! First input AttrVect/mask combination...must work through - ! all the possible cases for optional arguments iMaskTags1 and - ! rMaskTags1. - - if(present(iMaskTags1)) then - - if(present(rMaskTags1)) then ! both real and integer masks - call MergeInDataGGSP_(inAv1, iMaskTags1, rMaskTags1, GGrid, & - CheckMasks, outAv, WeightSum) - else ! only integer masks - call MergeInDataGGSP_(inAv1, iMaskTags=iMaskTags1, GGrid=GGrid, & - CheckMasks=CheckMasks, outAv=outAv, & - WeightSum=WeightSum) - endif - - else - - if(present(rMaskTags1)) then ! only real masks - call MergeInDataGGSP_(inAv1, rMaskTags=rMaskTags1, GGrid=GGrid, & - CheckMasks=CheckMasks, outAv=outAv, & - WeightSum=WeightSum) - else ! no masks at all - call MergeInDataGGSP_(inAv1, GGrid=GGrid, & - CheckMasks=CheckMasks, outAv=outAv, & - WeightSum=WeightSum) - endif - - endif ! if(present(iMaskTags1))... - - ! Second input AttrVect/mask combination...must work through - ! all the possible cases for optional arguments iMaskTags2 and - ! rMaskTags2. - - if(present(iMaskTags2)) then - - if(present(rMaskTags2)) then ! both real and integer masks - call MergeInDataGGSP_(inAv2, iMaskTags2, rMaskTags2, GGrid, & - CheckMasks, outAv, WeightSum) - else ! only integer masks - call MergeInDataGGSP_(inAv2, iMaskTags=iMaskTags2, GGrid=GGrid, & - CheckMasks=CheckMasks, outAv=outAv, & - WeightSum=WeightSum) - endif - - else - - if(present(rMaskTags2)) then ! only real masks - call MergeInDataGGSP_(inAv2, rMaskTags=rMaskTags2, GGrid=GGrid, & - CheckMasks=CheckMasks, outAv=outAv, & - WeightSum=WeightSum) - else ! no masks at all - call MergeInDataGGSP_(inAv2, GGrid=GGrid, & - CheckMasks=CheckMasks, outAv=outAv, & - WeightSum=WeightSum) - endif - - endif ! if(present(iMaskTags2))... - - ! Third input AttrVect/mask combination...must work through - ! all the possible cases for optional arguments iMaskTags3 and - ! rMaskTags3. - - if(present(iMaskTags3)) then - - if(present(rMaskTags3)) then ! both real and integer masks - call MergeInDataGGSP_(inAv3, iMaskTags3, rMaskTags3, GGrid, & - CheckMasks, outAv, WeightSum) - else ! only integer masks - call MergeInDataGGSP_(inAv3, iMaskTags=iMaskTags3, GGrid=GGrid, & - CheckMasks=CheckMasks, outAv=outAv, & - WeightSum=WeightSum) - endif - - else - - if(present(rMaskTags3)) then ! only real masks - call MergeInDataGGSP_(inAv3, rMaskTags=rMaskTags3, GGrid=GGrid, & - CheckMasks=CheckMasks, outAv=outAv, & - WeightSum=WeightSum) - else ! no masks at all - call MergeInDataGGSP_(inAv3, GGrid=GGrid, & - CheckMasks=CheckMasks, outAv=outAv, & - WeightSum=WeightSum) - endif - - endif ! if(present(iMaskTags3))... - - ! Fourth input AttrVect/mask combination...must work through - ! all the possible cases for optional arguments iMaskTags4 and - ! rMaskTags4. - - if(present(iMaskTags4)) then - - if(present(rMaskTags4)) then ! both real and integer masks - call MergeInDataGGSP_(inAv4, iMaskTags4, rMaskTags4, GGrid, & - CheckMasks, outAv, WeightSum) - else ! only integer masks - call MergeInDataGGSP_(inAv4, iMaskTags=iMaskTags4, GGrid=GGrid, & - CheckMasks=CheckMasks, outAv=outAv, & - WeightSum=WeightSum) - endif - - else - - if(present(rMaskTags4)) then ! only real masks - call MergeInDataGGSP_(inAv4, rMaskTags=rMaskTags4, GGrid=GGrid, & - CheckMasks=CheckMasks, outAv=outAv, & - WeightSum=WeightSum) - else ! no masks at all - call MergeInDataGGSP_(inAv4, GGrid=GGrid, & - CheckMasks=CheckMasks, outAv=outAv, & - WeightSum=WeightSum) - endif - - endif ! if(present(iMaskTags4))... - - ! Now we must renormalize the entries in outAv by dividing - ! element-by-element by the sums of the merge weights, which - ! were accumulated in WeightSum(:) - - do i=1,AttrVect_lsize(outAv) - - if(WeightSum(i) /= 0._FP) then - invWeightSum = 1._FP / WeightSum(i) - else - write(stderr,'(2a,i8,a)') myname_,':: FATAL--WeightSum(', & - i,') is zero!' - call die(myname_) - endif - - do j=1,AttrVect_nRAttr(outAv) - outAv%rAttr(j,i) = invWeightSum * outAv%rAttr(j,i) - end do - - end do - - ! The merge is now complete. - - end subroutine MergeFourGGSP_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!----------------------------------------------------------------------- -! -! !IROUTINE: MergeFourGGDP_ - merge data from four components. -! -! !DESCRIPTION: -! Double precision versions of MergeFourGGSP_ -! -! !INTERFACE: - - subroutine MergeFourGGDP_(inAv1, iMaskTags1, rMaskTags1, & - inAv2, iMaskTags2, rMaskTags2, & - inAv3, iMaskTags3, rMaskTags3, & - inAv4, iMaskTags4, rMaskTags4, & - GGrid, CheckMasks, outAv, WeightSum) -! -! !USES: -! - use m_stdio - use m_die - - use m_realkinds, only : DP, FP - - use m_List, only : List - use m_List, only : List_allocated => allocated - - use m_AttrVect, only : AttrVect - use m_AttrVect, only : AttrVect_lsize => lsize - use m_AttrVect, only : AttrVect_nRAttr => nRAttr - - use m_GeneralGrid, only : GeneralGrid - use m_GeneralGrid, only : GeneralGrid_lsize => lsize - - implicit none - -! !INPUT PARAMETERS: -! - type(AttrVect), intent(IN) :: inAv1 - character(len=*), optional, intent(IN) :: iMaskTags1 - character(len=*), optional, intent(IN) :: rMaskTags1 - type(AttrVect), intent(IN) :: inAv2 - character(len=*), optional, intent(IN) :: iMaskTags2 - character(len=*), optional, intent(IN) :: rMaskTags2 - type(AttrVect), intent(IN) :: inAv3 - character(len=*), optional, intent(IN) :: iMaskTags3 - character(len=*), optional, intent(IN) :: rMaskTags3 - type(AttrVect), intent(IN) :: inAv4 - character(len=*), optional, intent(IN) :: iMaskTags4 - character(len=*), optional, intent(IN) :: rMaskTags4 - type(GeneralGrid), intent(IN) :: GGrid - logical, intent(IN) :: CheckMasks - -! !INPUT/OUTPUT PARAMETERS: -! - type(AttrVect), intent(INOUT) :: outAv - real(DP), dimension(:), pointer :: WeightSum - -! !REVISION HISTORY: -! 19Jun02 - Jay Larson - Interface spec. -! 3Jul02 - Jay Larson - Implementation. -! 10Jul02 - J. Larson - Improved argument -! checking. -!_______________________________________________________________________ -! - character(len=*),parameter :: myname_=myname//'::MergeFourGGDP_' - - integer :: i, j - real(FP) :: invWeightSum - - ! Begin argument sanity checks... - - ! Have the input arguments been allocated? - - if(.not.(List_allocated(inAv1%rList))) then - write(stderr,'(2a)') myname_, & - 'ERROR--INPUT argument inAv1 has no real attributes!' - call die(myname_) - endif - - if(.not.(List_allocated(inAv2%rList))) then - write(stderr,'(2a)') myname_, & - 'ERROR--INPUT argument inAv2 has no real attributes!' - call die(myname_) - endif - - if(.not.(List_allocated(inAv3%rList))) then - write(stderr,'(2a)') myname_, & - 'ERROR--INPUT argument inAv3 has no real attributes!' - call die(myname_) - endif - - if(.not.(List_allocated(inAv4%rList))) then - write(stderr,'(2a)') myname_, & - 'ERROR--INPUT argument inAv4 has no real attributes!' - call die(myname_) - endif - - if(.not.(List_allocated(outaV%rList))) then - write(stderr,'(2a)') myname_, & - 'ERROR--INPUT/OUTPUT argument outAv has no real attributes!' - call die(myname_) - endif - - if(present(iMaskTags1) .or. present(iMaskTags2) .or. & - present(iMaskTags3) .or. present(iMaskTags4)) then - if(.not.(List_allocated(GGrid%data%iList))) then - write(stderr,'(3a)') myname_, & - 'ERROR--Integer masking requested, but input argument GGrid ', & - 'has no integer attributes!' - call die(myname_) - endif - endif - - if(present(rMaskTags1) .or. present(rMaskTags2) .or. & - present(rMaskTags3) .or. present(rMaskTags4)) then - if(.not.(List_allocated(GGrid%data%rList))) then - write(stderr,'(3a)') myname_, & - 'ERROR--Real masking requested, but input argument GGrid ', & - 'has no real attributes!' - call die(myname_) - endif - endif - - if(.not.(associated(WeightSum))) then - write(stderr,'(2a)') myname_, & - 'ERROR--INPUT/OUPUT argument WeightSum has not been allocated!' - call die(myname_) - endif - - ! Do the vector lengths match? - - if(AttrVect_lsize(inAv1) /= AttrVect_lsize(outAv)) then - write(stderr,'(2a,2(a,i8))') myname_, & - ':: ERROR--Lengths of AttrVect arguments inAv1 and outAv must match.', & - 'AttrVect_lsize(inAv1) = ',AttrVect_lsize(inAv1), & - 'AttrVect_lsize(outAv) = ',AttrVect_lsize(outAv) - call die(myname_) - endif - - if(AttrVect_lsize(inAv2) /= AttrVect_lsize(outAv)) then - write(stderr,'(2a,2(a,i8))') myname_, & - ':: ERROR--Lengths of AttrVect arguments inAv2 and outAv must match.', & - 'AttrVect_lsize(inAv2) = ',AttrVect_lsize(inAv2), & - 'AttrVect_lsize(outAv) = ',AttrVect_lsize(outAv) - call die(myname_) - endif - - if(AttrVect_lsize(inAv3) /= AttrVect_lsize(outAv)) then - write(stderr,'(2a,2(a,i8))') myname_, & - ':: ERROR--Lengths of AttrVect arguments inAv3 and outAv must match.', & - 'AttrVect_lsize(inAv3) = ',AttrVect_lsize(inAv3), & - 'AttrVect_lsize(outAv) = ',AttrVect_lsize(outAv) - call die(myname_) - endif - - if(AttrVect_lsize(inAv4) /= AttrVect_lsize(outAv)) then - write(stderr,'(2a,2(a,i8))') myname_, & - ':: ERROR--Lengths of AttrVect arguments inAv4 and outAv must match.', & - 'AttrVect_lsize(inAv4) = ',AttrVect_lsize(inAv4), & - 'AttrVect_lsize(outAv) = ',AttrVect_lsize(outAv) - call die(myname_) - endif - - if(AttrVect_lsize(inAv1) /= GeneralGrid_lsize(GGrid)) then - write(stderr,'(2a,2(a,i8))') myname_, & - ':: ERROR--Lengths of arguments inAv1 and GGrid must match.', & - 'AttrVect_lsize(inAv1) = ',AttrVect_lsize(inAv1), & - 'AttrVect_lsize(outAv) = ',GeneralGrid_lsize(GGrid) - call die(myname_) - endif - - if(AttrVect_lsize(inAv1) /= size(WeightSum)) then - write(stderr,'(2a,2(a,i8))') myname_, & - ':: ERROR--Lengths of arguments inAv1 and WeightSum must match.', & - 'AttrVect_lsize(inAv1) = ',AttrVect_lsize(inAv1), & - 'size(WeightSum) = ',size(WeightSum) - call die(myname_) - endif - - ! ...end argument sanity checks. - - ! Initialize the elements of WeightSum(:) to zero: - - do i=1,size(WeightSum) - WeightSum(i) = 0._FP - end do - - ! Process the incoming data one input AttrVect and mask tag - ! combination at a time. - - ! First input AttrVect/mask combination...must work through - ! all the possible cases for optional arguments iMaskTags1 and - ! rMaskTags1. - - if(present(iMaskTags1)) then - - if(present(rMaskTags1)) then ! both real and integer masks - call MergeInDataGGDP_(inAv1, iMaskTags1, rMaskTags1, GGrid, & - CheckMasks, outAv, WeightSum) - else ! only integer masks - call MergeInDataGGDP_(inAv1, iMaskTags=iMaskTags1, GGrid=GGrid, & - CheckMasks=CheckMasks, outAv=outAv, & - WeightSum=WeightSum) - endif - - else - - if(present(rMaskTags1)) then ! only real masks - call MergeInDataGGDP_(inAv1, rMaskTags=rMaskTags1, GGrid=GGrid, & - CheckMasks=CheckMasks, outAv=outAv, & - WeightSum=WeightSum) - else ! no masks at all - call MergeInDataGGDP_(inAv1, GGrid=GGrid, & - CheckMasks=CheckMasks, outAv=outAv, & - WeightSum=WeightSum) - endif - - endif ! if(present(iMaskTags1))... - - ! Second input AttrVect/mask combination...must work through - ! all the possible cases for optional arguments iMaskTags2 and - ! rMaskTags2. - - if(present(iMaskTags2)) then - - if(present(rMaskTags2)) then ! both real and integer masks - call MergeInDataGGDP_(inAv2, iMaskTags2, rMaskTags2, GGrid, & - CheckMasks, outAv, WeightSum) - else ! only integer masks - call MergeInDataGGDP_(inAv2, iMaskTags=iMaskTags2, GGrid=GGrid, & - CheckMasks=CheckMasks, outAv=outAv, & - WeightSum=WeightSum) - endif - - else - - if(present(rMaskTags2)) then ! only real masks - call MergeInDataGGDP_(inAv2, rMaskTags=rMaskTags2, GGrid=GGrid, & - CheckMasks=CheckMasks, outAv=outAv, & - WeightSum=WeightSum) - else ! no masks at all - call MergeInDataGGDP_(inAv2, GGrid=GGrid, & - CheckMasks=CheckMasks, outAv=outAv, & - WeightSum=WeightSum) - endif - - endif ! if(present(iMaskTags2))... - - ! Third input AttrVect/mask combination...must work through - ! all the possible cases for optional arguments iMaskTags3 and - ! rMaskTags3. - - if(present(iMaskTags3)) then - - if(present(rMaskTags3)) then ! both real and integer masks - call MergeInDataGGDP_(inAv3, iMaskTags3, rMaskTags3, GGrid, & - CheckMasks, outAv, WeightSum) - else ! only integer masks - call MergeInDataGGDP_(inAv3, iMaskTags=iMaskTags3, GGrid=GGrid, & - CheckMasks=CheckMasks, outAv=outAv, & - WeightSum=WeightSum) - endif - - else - - if(present(rMaskTags3)) then ! only real masks - call MergeInDataGGDP_(inAv3, rMaskTags=rMaskTags3, GGrid=GGrid, & - CheckMasks=CheckMasks, outAv=outAv, & - WeightSum=WeightSum) - else ! no masks at all - call MergeInDataGGDP_(inAv3, GGrid=GGrid, & - CheckMasks=CheckMasks, outAv=outAv, & - WeightSum=WeightSum) - endif - - endif ! if(present(iMaskTags3))... - - ! Fourth input AttrVect/mask combination...must work through - ! all the possible cases for optional arguments iMaskTags4 and - ! rMaskTags4. - - if(present(iMaskTags4)) then - - if(present(rMaskTags4)) then ! both real and integer masks - call MergeInDataGGDP_(inAv4, iMaskTags4, rMaskTags4, GGrid, & - CheckMasks, outAv, WeightSum) - else ! only integer masks - call MergeInDataGGDP_(inAv4, iMaskTags=iMaskTags4, GGrid=GGrid, & - CheckMasks=CheckMasks, outAv=outAv, & - WeightSum=WeightSum) - endif - - else - - if(present(rMaskTags4)) then ! only real masks - call MergeInDataGGDP_(inAv4, rMaskTags=rMaskTags4, GGrid=GGrid, & - CheckMasks=CheckMasks, outAv=outAv, & - WeightSum=WeightSum) - else ! no masks at all - call MergeInDataGGDP_(inAv4, GGrid=GGrid, & - CheckMasks=CheckMasks, outAv=outAv, & - WeightSum=WeightSum) - endif - - endif ! if(present(iMaskTags4))... - - ! Now we must renormalize the entries in outAv by dividing - ! element-by-element by the sums of the merge weights, which - ! were accumulated in WeightSum(:) - - do i=1,AttrVect_lsize(outAv) - - if(WeightSum(i) /= 0._FP) then - invWeightSum = 1._FP / WeightSum(i) - else - write(stderr,'(2a,i8,a)') myname_,':: FATAL--WeightSum(', & - i,') is zero!' - call die(myname_) - endif - - do j=1,AttrVect_nRAttr(outAv) - outAv%rAttr(j,i) = invWeightSum * outAv%rAttr(j,i) - end do - - end do - - ! The merge is now complete. - - end subroutine MergeFourGGDP_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: MergeInDataGGSP_ - Add Data into a Merge -! -! !DESCRIPTION: This routine takes input field data from the input -! {\tt AttrVect} argument {\tt inAv}, and merges the real attributes it -! shares with the input/output {\tt AttrVect} argument {\tt outAv}. -! The merge is a masked merge of the form -! $$ c_i = c_i + {{\prod_{j=1}^J} M_{i}^j} {{\prod_{k=1}^K} F_{i}^k} -! a_i , $$ -! where ${c_i}$ represents one element of one of the real attributes of -! {\tt outAv}, and ${a_i}$ represents one element of one of the real -! attributes of {\tt inAv}. The ${M_{i}^j}$ are {\em integer masks} which -! have value either $0$ or $1$, and are integer attributes of the input -! {\tt GeneralGrid} argument {\tt GGrid}. The ${F_{i}^k}$ are {\em real -! masks} whose values are in the closed interval $[0,1]$, and are real -! attributes of the input {\tt GeneralGrid} argument {\tt GGrid}. The -! input {\tt CHARACTER} argument {\tt iMaskTags} is a string of colon- -! delimited strings that name the integer attributes in {\tt GGrid} -! that are used as the masks ${M_{i}^j}$. The input {\tt CHARACTER} -! argument {\tt rMaskTags} is a string of colon-delimited strings -! that name the real attributes in {\tt GGrid} that are used as the -! masks ${F_{i}^k}$. The output {\tt REAL} array {\tt WeightSum} is -! used to store a running sum of the product of the masks. The -! {\tt LOGICAL} input argument {\tt CheckMasks} governs how the masks -! are applied. If ${\tt CheckMasks} = {\tt .TRUE.}$, the entries are -! checked to ensure they meet the definitions of real and integer masks. -! If ${\tt CheckMasks} = {\tt .FALSE.}$ then the masks are multiplied -! together on an element-by-element basis with no validation of their -! entries (this option results in slightly higher performance). -! -! {\tt N.B.:} The lengths of the {\tt AttrVect} arguments {\tt inAv} -! and {\tt outAv} must be equal, and this length must also equal the -! lengths of {\tt GGrid} and {\tt WeightSum}. -! -! {\tt N.B.:} This algorithm assumes the {\tt AttrVect} argument -! {\tt outAv} has been created, and its real attributes have been -! initialized. -! -! {\tt N.B.:} This algorithm assumes that the array {\tt WeightSum} -! has been created and initialized. -! -! !INTERFACE: - - subroutine MergeInDataGGSP_(inAv, iMaskTags, rMaskTags, GGrid, & - CheckMasks, outAv, WeightSum) -! -! !USES: -! - use m_stdio - use m_die - - use m_realkinds, only : SP, FP - - use m_String, only : String - use m_String, only : String_clean => clean - use m_String, only : String_ToChar => toChar - - use m_List, only : List - use m_List, only : List_init => init - use m_List, only : List_clean => clean - use m_List, only : List_nitem => nitem - use m_List, only : List_get => get - use m_List, only : List_identical => identical - use m_List, only : List_allocated => allocated - - use m_AttrVect, only : AttrVect - use m_AttrVect, only : AttrVect_lsize => lsize - use m_AttrVect, only : AttrVect_nRAttr => nRAttr - use m_AttrVect, only : SharedAttrIndexList - - use m_GeneralGrid, only : GeneralGrid - use m_GeneralGrid, only : GeneralGrid_lsize => lsize - use m_GeneralGrid, only : GeneralGrid_exportIAttr => exportIAttr - use m_GeneralGrid, only : GeneralGrid_exportRAttr => exportRAttr - - implicit none - -! !INPUT PARAMETERS: -! - type(AttrVect), intent(IN) :: inAv - character(len=*), optional, intent(IN) :: iMaskTags - character(len=*), optional, intent(IN) :: rMaskTags - type(GeneralGrid), intent(IN) :: GGrid - logical, intent(IN) :: CheckMasks - -! !INPUT/OUTPUT PARAMETERS: -! - type(AttrVect), intent(INOUT) :: outAv - real(SP), dimension(:), pointer :: WeightSum - -! !REVISION HISTORY: -! 19Jun02 - Jay Larson - initial verson. -! 10Jul02 - J. Larson - Improved argument -! checking. -!EOP ___________________________________________________________________ -! - character(len=*),parameter :: myname_=myname//'::MergeInDataGGSP_' - - integer :: i, ierr, j, length - type(String) :: DummStr - type(List) :: iMaskList, rMaskList - integer, dimension(:), pointer :: iMask,iDummy ! INTEGER mask workspace - real(FP), dimension(:), pointer :: rMask,rDummy ! REAL mask workspace - - logical :: RAttrIdentical ! flag to identify identical REAL attribute - ! lists in inAv and outAv - integer :: NumSharedRAttr ! number of REAL attributes shared by inAv,outAv - ! Cross-index storage for shared REAL attributes of inAv,outAv - integer, dimension(:), pointer :: inAvIndices, outAvIndices - - ! Begin argument sanity checks... - - ! Have the input arguments been allocated? - - if(.not.(List_allocated(inAv%rList))) then - write(stderr,'(2a)') myname_, & - 'ERROR--INPUT argument inAv has no real attributes.' - call die(myname_) - endif - - if(.not.(List_allocated(outaV%rList))) then - write(stderr,'(2a)') myname_, & - 'ERROR--INPUT/OUTPUT argument outAv has no real attributes.' - call die(myname_) - endif - - if(present(iMaskTags)) then - if(.not.(List_allocated(GGrid%data%iList))) then - write(stderr,'(3a)') myname_, & - 'ERROR--Integer masking requested, but input argument GGrid ', & - 'has no integer attributes.' - call die(myname_) - endif - endif - - if(present(rMaskTags)) then - if(.not.(List_allocated(GGrid%data%rList))) then - write(stderr,'(3a)') myname_, & - 'ERROR--Real masking requested, but input argument GGrid ', & - 'has no real attributes.' - call die(myname_) - endif - endif - - if(.not.(associated(WeightSum))) then - write(stderr,'(2a)') myname_, & - 'ERROR--INPUT/OUPUT argument WeightSum has not been allocated.' - call die(myname_) - endif - - ! Do the vector lengths match? - - if(AttrVect_lsize(inAv) /= AttrVect_lsize(outAv)) then - write(stderr,'(2a,2(a,i8))') myname_, & - ':: ERROR--Lengths of AttrVect arguments inAv and outAv must match.', & - 'AttrVect_lsize(inAv) = ',AttrVect_lsize(inAv), & - 'AttrVect_lsize(outAv) = ',AttrVect_lsize(outAv) - call die(myname_) - endif - - if(AttrVect_lsize(inAv) /= GeneralGrid_lsize(GGrid)) then - write(stderr,'(2a,2(a,i8))') myname_, & - ':: ERROR--Lengths of arguments inAv and GGrid must match.', & - 'AttrVect_lsize(inAv) = ',AttrVect_lsize(inAv), & - 'AttrVect_lsize(outAv) = ',GeneralGrid_lsize(GGrid) - call die(myname_) - endif - - if(AttrVect_lsize(inAv) /= size(WeightSum)) then - write(stderr,'(2a,2(a,i8))') myname_, & - ':: ERROR--Lengths of arguments inAv and WeightSum must match.', & - 'AttrVect_lsize(inAv) = ',AttrVect_lsize(inAv), & - 'size(WeightSum) = ',size(WeightSum) - call die(myname_) - endif - - ! ...end argument sanity checks. - - ! Check for INTEGER masks. If they are present, retrieve - ! them and combine them into a single integer mask iMask(:) - - if(present(iMaskTags)) then - - ! allocate two arrays: iMask (the final product), - ! and iDummy (storage space for each mask as it is retrieved) - - allocate(iMask(AttrVect_lsize(inAv)), iDummy(AttrVect_lsize(inAv)), & - stat=ierr) - if(ierr /= 0) then - write(stderr,'(2a,i8)') myname_, & - ':: allocate(iMask(...)...) failed with ierr = ',ierr - call die(myname_) - endif - - ! Initialize all the elements of iMask to unity: - iMask = 1 - - ! turn the colon-delimited string of tags into a List: - call List_init(iMaskList,iMaskTags) - - ! Loop over the items in iMaskList, retrieving each mask - ! into the array iDummy, checking it (if CheckMasks=.TRUE.), - ! and multiplying it element-by-element into the array iMask. - - do i=1,List_nitem(iMaskList) - ! grab item as a String - call List_get(DummStr, i, iMaskList) - ! use this String to identify an INTEGER GeneralGrid attribute - ! for export to iDummy(:) - call GeneralGrid_exportIAttr(GGrid, String_ToChar(DummStr), & - iDummy, length) - - if(.not.(CheckMasks)) then ! Merely multiply iMask by iDummy: - do j=1,length - iMask(j) = iMask(j) * iDummy(j) - end do - else ! check mask elements and include their effect on iMask - do j=1,length - select case(iDummy(j)) - case(0) ! zeroes out iMask(j) - iMask(j) = 0 - case(1) ! leaves iMask(j) untouched - case default ! shut down with an error - write(stderr,'(5a,i8,a,i8)') myname_, & - ':: ERROR--illegal mask value (must be 0 or 1).', & - 'Illegal value stored in mask ', & - String_ToChar(DummStr),'(',j,')=',iDummy(j) - call die(myname_) - end select - end do - endif ! if(CheckMasks)... - ! clean up dummy String DummStr - call String_clean(DummStr) - end do ! do i=1,List_nitem(iMaskList)... - - endif ! if(present(iMaskTags))... - - ! Check for REAL masks. If they are present, retrieve - ! them and combine them into a single real mask rMask(:) - - if(present(rMaskTags)) then - - ! allocate two arrays: rMask (the final product), - ! and rDummy (storage space for each mask as it is retrieved) - - allocate(rMask(AttrVect_lsize(inAv)), rDummy(AttrVect_lsize(inAv)), & - stat=ierr) - if(ierr /= 0) then - write(stderr,'(2a,i8)') myname_, & - ':: allocate(rMask(...)...) failed with ierr = ',ierr - call die(myname_) - endif - - ! Initialize all the elements of rMask to unity: - rMask = 1._FP - - ! turn the colon-delimited string of tags into a List: - call List_init(rMaskList,rMaskTags) - - ! Loop over the items in rMaskList, retrieving each mask - ! into the array rDummy, checking it (if CheckMasks=.TRUE.), - ! and multiplying it element-by-element into the array rMask. - - do i=1,List_nitem(rMaskList) - ! grab item as a String - call List_get(DummStr, i, rMaskList) - ! use this String to identify an INTEGER GeneralGrid attribute - ! for export to rDummy(:) - call GeneralGrid_exportRAttr(GGrid, String_ToChar(DummStr), & - rDummy, length) - - if(.not.(CheckMasks)) then ! Merely multiply rMask by rDummy: - do j=1,length - rMask(j) = rMask(j) * rDummy(j) - end do - else ! check mask elements and include their effect on rMask - do j=1,length - if((iDummy(j) >= 0.) .and. (iDummy(j) <= 1.)) then ! in [0,1] - rMask(j) = rMask(j) * rDummy(j) - else - write(stderr,'(5a,i8,a,i8)') myname_, & - ':: ERROR--illegal mask value (must be in [0.,1.]).', & - 'Illegal value stored in mask ', & - String_ToChar(DummStr),'(',j,')=',rDummy(j) - call die(myname_) - endif - end do - endif ! if(CheckMasks)... - ! clean up dummy String DummStr - call String_clean(DummStr) - end do ! do i=1,List_nitem(rMaskList)... - - endif ! if(present(rMaskTags))... - - ! Now we have (at most) a single INTEGER mask iMask(:) and - ! a single REAL mask rMask(:). Before we perform the merge, - ! we must tackle one more issue: are the REAL attributes - ! of inAv and outAv identical and in the same order? If they - ! are, the merge is a straightforward double loop over the - ! elements and over all the attributes. If the attribute lists - ! differ, we must cross-reference common attributes, and store - ! their indices. - - RAttrIdentical = List_identical(inAv%rList, outAv%rList) - if(.not.(RAttrIdentical)) then - ! Determine the number of shared REAL attributes NumSharedRAttr, - ! and form cross-index tables inAvIndices, outAvIndices. - call SharedAttrIndexList(inAv, outAv, 'REAL', NumSharedRAttr, & - inAvIndices, outAvIndices) - endif - - if(present(rMaskTags)) then ! REAL masking stored in rMask(:) - - if(present(iMaskTags)) then ! also INTEGER mask iMask(:) - - if(RAttrIdentical) then ! straight masked multiply - do i=1, AttrVect_lsize(inAv) - do j=1,AttrVect_nRAttr(inAv) - outAv%rAttr(j,i) = outAv%rAttr(j,i) + & - rMask(i) * iMask(i) * inAv%rAttr(j,i) - end do ! do j=1,AttrVect_nRAttr(inAv) - ! add in mask contribution to total of merge weights - WeightSum(i) = WeightSum(i) + iMask(i) * rMask(i) - end do ! do i=1,AttrVect_lsize(inAv)... - else ! use previously generated cross-indices - do i=1, AttrVect_lsize(inAv) - do j=1,NumSharedRAttr - outAv%rAttr(outAVIndices(j),i) = & - outAv%rAttr(outAvIndices(j),i) + & - rMask(i) * iMask(i) * & - inAv%rAttr(inAvIndices(j),i) - end do ! do j=1,NumSharedRAttr - ! add in mask contribution to total of merge weights - WeightSum(i) = WeightSum(i) + iMask(i) * rMask(i) - end do ! do i=1,AttrVect_lsize(inAv)... - endif ! if(RAttrIdentical)... - - else ! rMask(:), but no iMask(:) - - if(RAttrIdentical) then ! straight masked multiply - do i=1, AttrVect_lsize(inAv) - do j=1,AttrVect_nRAttr(inAv) - outAv%rAttr(j,i) = outAv%rAttr(j,i) + & - rMask(i) * inAv%rAttr(j,i) - end do ! do j=1,AttrVect_nRAttr(inAv) - ! add in mask contribution to total of merge weights - WeightSum(i) = WeightSum(i) + rMask(i) - end do ! do i=1,AttrVect_lsize(inAv)... - else ! use previously generated cross-indices - do i=1, AttrVect_lsize(inAv) - do j=1,NumSharedRAttr - outAv%rAttr(outAVIndices(j),i) = & - outAv%rAttr(outAvIndices(j),i) + & - rMask(i) * inAv%rAttr(inAvIndices(j),i) - end do ! do j=1,NumSharedRAttr - ! add in mask contribution to total of merge weights - WeightSum(i) = WeightSum(i) + rMask(i) - end do ! do i=1,AttrVect_lsize(inAv)... - endif ! if(RAttrIdentical) - - endif ! if(present(iMaskTags))... - - else ! No REAL Mask - - if(present(iMaskTags)) then ! Have iMask(:), but no rMask(:) - - if(RAttrIdentical) then ! straight masked multiply - do i=1, AttrVect_lsize(inAv) - do j=1,AttrVect_nRAttr(inAv) - outAv%rAttr(j,i) = outAv%rAttr(j,i) + & - iMask(i) * inAv%rAttr(j,i) - end do ! do j=1,AttrVect_nRAttr(inAv) - ! add in mask contribution to total of merge weights - WeightSum(i) = WeightSum(i) + iMask(i) - end do ! do i=1,AttrVect_lsize(inAv)... - else ! use previously generated cross-indices - do i=1, AttrVect_lsize(inAv) - do j=1,NumSharedRAttr - outAv%rAttr(outAVIndices(j),i) = & - outAv%rAttr(outAvIndices(j),i) + & - iMask(i) * inAv%rAttr(inAvIndices(j),i) - end do ! do j=1,NumSharedRAttr - ! add in mask contribution to total of merge weights - WeightSum(i) = WeightSum(i) + iMask(i) - end do ! do i=1,AttrVect_lsize(inAv)... - endif ! if(RAttrIdentical) - - else ! Neither iMask(:) nor rMask(:)--all elements weighted by unity - - if(RAttrIdentical) then ! straight masked multiply - do i=1, AttrVect_lsize(inAv) - do j=1,AttrVect_nRAttr(inAv) - outAv%rAttr(j,i) = outAv%rAttr(j,i) + inAv%rAttr(j,i) - end do ! do j=1,AttrVect_nRAttr(inAv) - ! add in mask contribution to total of merge weights - WeightSum(i) = WeightSum(i) + 1._FP - end do ! do i=1,AttrVect_lsize(inAv)... - else ! use previously generated cross-indices - do i=1, AttrVect_lsize(inAv) - do j=1,NumSharedRAttr - outAv%rAttr(outAVIndices(j),i) = & - outAv%rAttr(outAvIndices(j),i) + & - inAv%rAttr(inAvIndices(j),i) - end do ! do j=1,NumSharedRAttr - ! add in mask contribution to total of merge weights - WeightSum(i) = WeightSum(i) + 1._FP - end do ! do i=1,AttrVect_lsize(inAv)... - endif ! if(RAttrIdentical) - - endif ! if(present(iMaskTags))... - - endif ! if(present(rMaskTags))... - - ! At this point the merge has been completed. Now clean - ! up all allocated structures and temporary arrays. - - if(present(iMaskTags)) then ! clean up integer mask work space - deallocate(iMask, iDummy, stat=ierr) - if(ierr /= 0) then - write(stderr,'(2a,i8)') myname_, & - ':: deallocate(iMask,...) failed with ierr = ',ierr - call die(myname_) - endif - call List_clean(iMaskList) - endif - - if(present(rMaskTags)) then ! clean up real mask work space - deallocate(rMask, rDummy, stat=ierr) - if(ierr /= 0) then - write(stderr,'(2a,i8)') myname_, & - ':: deallocate(rMask,...) failed with ierr = ',ierr - call die(myname_) - endif - call List_clean(rMaskList) - endif - - if(.not.(RAttrIdentical)) then ! clean up cross-reference tables - deallocate(inAvIndices, outAvIndices, stat=ierr) - if(ierr /= 0) then - write(stderr,'(2a,i8)') myname_, & - ':: deallocate(inAvIndices,...) failed with ierr = ',ierr - call die(myname_) - endif - endif - - end subroutine MergeInDataGGSP_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!----------------------------------------------------------------------- -! -! !IROUTINE: MergeInDataGGDP_ - merge in data from a component. -! -! !DESCRIPTION: -! Double precision version of MergeInDataGGSP_ -! -! !INTERFACE: - - subroutine MergeInDataGGDP_(inAv, iMaskTags, rMaskTags, GGrid, & - CheckMasks, outAv, WeightSum) -! -! !USES: -! - use m_stdio - use m_die - - use m_realkinds, only : DP, FP - - use m_String, only : String - use m_String, only : String_clean => clean - use m_String, only : String_ToChar => toChar - - use m_List, only : List - use m_List, only : List_init => init - use m_List, only : List_clean => clean - use m_List, only : List_nitem => nitem - use m_List, only : List_get => get - use m_List, only : List_identical => identical - use m_List, only : List_allocated => allocated - - use m_AttrVect, only : AttrVect - use m_AttrVect, only : AttrVect_lsize => lsize - use m_AttrVect, only : AttrVect_nRAttr => nRAttr - use m_AttrVect, only : SharedAttrIndexList - - use m_GeneralGrid, only : GeneralGrid - use m_GeneralGrid, only : GeneralGrid_lsize => lsize - use m_GeneralGrid, only : GeneralGrid_exportIAttr => exportIAttr - use m_GeneralGrid, only : GeneralGrid_exportRAttr => exportRAttr - - implicit none - -! !INPUT PARAMETERS: -! - type(AttrVect), intent(IN) :: inAv - character(len=*), optional, intent(IN) :: iMaskTags - character(len=*), optional, intent(IN) :: rMaskTags - type(GeneralGrid), intent(IN) :: GGrid - logical, intent(IN) :: CheckMasks - -! !INPUT/OUTPUT PARAMETERS: -! - type(AttrVect), intent(INOUT) :: outAv - real(DP), dimension(:), pointer :: WeightSum - -! !REVISION HISTORY: -! 19Jun02 - Jay Larson - initial verson. -! 10Jul02 - J. Larson - Improved argument -! checking. -!_______________________________________________________________________ -! - character(len=*),parameter :: myname_=myname//'::MergeInDataGGDP_' - - integer :: i, ierr, j, length - type(String) :: DummStr - type(List) :: iMaskList, rMaskList - integer, dimension(:), pointer :: iMask,iDummy ! INTEGER mask workspace - real(FP), dimension(:), pointer :: rMask,rDummy ! REAL mask workspace - - logical :: RAttrIdentical ! flag to identify identical REAL attribute - ! lists in inAv and outAv - integer :: NumSharedRAttr ! number of REAL attributes shared by inAv,outAv - ! Cross-index storage for shared REAL attributes of inAv,outAv - integer, dimension(:), pointer :: inAvIndices, outAvIndices - - ! Begin argument sanity checks... - - ! Have the input arguments been allocated? - - if(.not.(List_allocated(inAv%rList))) then - write(stderr,'(2a)') myname_, & - 'ERROR--INPUT argument inAv has no real attributes.' - call die(myname_) - endif - - if(.not.(List_allocated(outaV%rList))) then - write(stderr,'(2a)') myname_, & - 'ERROR--INPUT/OUTPUT argument outAv has no real attributes.' - call die(myname_) - endif - - if(present(iMaskTags)) then - if(.not.(List_allocated(GGrid%data%iList))) then - write(stderr,'(3a)') myname_, & - 'ERROR--Integer masking requested, but input argument GGrid ', & - 'has no integer attributes.' - call die(myname_) - endif - endif - - if(present(rMaskTags)) then - if(.not.(List_allocated(GGrid%data%rList))) then - write(stderr,'(3a)') myname_, & - 'ERROR--Real masking requested, but input argument GGrid ', & - 'has no real attributes.' - call die(myname_) - endif - endif - - if(.not.(associated(WeightSum))) then - write(stderr,'(2a)') myname_, & - 'ERROR--INPUT/OUPUT argument WeightSum has not been allocated.' - call die(myname_) - endif - - ! Do the vector lengths match? - - if(AttrVect_lsize(inAv) /= AttrVect_lsize(outAv)) then - write(stderr,'(2a,2(a,i8))') myname_, & - ':: ERROR--Lengths of AttrVect arguments inAv and outAv must match.', & - 'AttrVect_lsize(inAv) = ',AttrVect_lsize(inAv), & - 'AttrVect_lsize(outAv) = ',AttrVect_lsize(outAv) - call die(myname_) - endif - - if(AttrVect_lsize(inAv) /= GeneralGrid_lsize(GGrid)) then - write(stderr,'(2a,2(a,i8))') myname_, & - ':: ERROR--Lengths of arguments inAv and GGrid must match.', & - 'AttrVect_lsize(inAv) = ',AttrVect_lsize(inAv), & - 'AttrVect_lsize(outAv) = ',GeneralGrid_lsize(GGrid) - call die(myname_) - endif - - if(AttrVect_lsize(inAv) /= size(WeightSum)) then - write(stderr,'(2a,2(a,i8))') myname_, & - ':: ERROR--Lengths of arguments inAv and WeightSum must match.', & - 'AttrVect_lsize(inAv) = ',AttrVect_lsize(inAv), & - 'size(WeightSum) = ',size(WeightSum) - call die(myname_) - endif - - ! ...end argument sanity checks. - - ! Check for INTEGER masks. If they are present, retrieve - ! them and combine them into a single integer mask iMask(:) - - if(present(iMaskTags)) then - - ! allocate two arrays: iMask (the final product), - ! and iDummy (storage space for each mask as it is retrieved) - - allocate(iMask(AttrVect_lsize(inAv)), iDummy(AttrVect_lsize(inAv)), & - stat=ierr) - if(ierr /= 0) then - write(stderr,'(2a,i8)') myname_, & - ':: allocate(iMask(...)...) failed with ierr = ',ierr - call die(myname_) - endif - - ! Initialize all the elements of iMask to unity: - iMask = 1 - - ! turn the colon-delimited string of tags into a List: - call List_init(iMaskList,iMaskTags) - - ! Loop over the items in iMaskList, retrieving each mask - ! into the array iDummy, checking it (if CheckMasks=.TRUE.), - ! and multiplying it element-by-element into the array iMask. - - do i=1,List_nitem(iMaskList) - ! grab item as a String - call List_get(DummStr, i, iMaskList) - ! use this String to identify an INTEGER GeneralGrid attribute - ! for export to iDummy(:) - call GeneralGrid_exportIAttr(GGrid, String_ToChar(DummStr), & - iDummy, length) - - if(.not.(CheckMasks)) then ! Merely multiply iMask by iDummy: - do j=1,length - iMask(j) = iMask(j) * iDummy(j) - end do - else ! check mask elements and include their effect on iMask - do j=1,length - select case(iDummy(j)) - case(0) ! zeroes out iMask(j) - iMask(j) = 0 - case(1) ! leaves iMask(j) untouched - case default ! shut down with an error - write(stderr,'(5a,i8,a,i8)') myname_, & - ':: ERROR--illegal mask value (must be 0 or 1).', & - 'Illegal value stored in mask ', & - String_ToChar(DummStr),'(',j,')=',iDummy(j) - call die(myname_) - end select - end do - endif ! if(CheckMasks)... - ! clean up dummy String DummStr - call String_clean(DummStr) - end do ! do i=1,List_nitem(iMaskList)... - - endif ! if(present(iMaskTags))... - - ! Check for REAL masks. If they are present, retrieve - ! them and combine them into a single real mask rMask(:) - - if(present(rMaskTags)) then - - ! allocate two arrays: rMask (the final product), - ! and rDummy (storage space for each mask as it is retrieved) - - allocate(rMask(AttrVect_lsize(inAv)), rDummy(AttrVect_lsize(inAv)), & - stat=ierr) - if(ierr /= 0) then - write(stderr,'(2a,i8)') myname_, & - ':: allocate(rMask(...)...) failed with ierr = ',ierr - call die(myname_) - endif - - ! Initialize all the elements of rMask to unity: - rMask = 1._FP - - ! turn the colon-delimited string of tags into a List: - call List_init(rMaskList,rMaskTags) - - ! Loop over the items in rMaskList, retrieving each mask - ! into the array rDummy, checking it (if CheckMasks=.TRUE.), - ! and multiplying it element-by-element into the array rMask. - - do i=1,List_nitem(rMaskList) - ! grab item as a String - call List_get(DummStr, i, rMaskList) - ! use this String to identify an INTEGER GeneralGrid attribute - ! for export to rDummy(:) - call GeneralGrid_exportRAttr(GGrid, String_ToChar(DummStr), & - rDummy, length) - - if(.not.(CheckMasks)) then ! Merely multiply rMask by rDummy: - do j=1,length - rMask(j) = rMask(j) * rDummy(j) - end do - else ! check mask elements and include their effect on rMask - do j=1,length - if((iDummy(j) >= 0.) .and. (iDummy(j) <= 1.)) then ! in [0,1] - rMask(j) = rMask(j) * rDummy(j) - else - write(stderr,'(5a,i8,a,i8)') myname_, & - ':: ERROR--illegal mask value (must be in [0.,1.]).', & - 'Illegal value stored in mask ', & - String_ToChar(DummStr),'(',j,')=',rDummy(j) - call die(myname_) - endif - end do - endif ! if(CheckMasks)... - ! clean up dummy String DummStr - call String_clean(DummStr) - end do ! do i=1,List_nitem(rMaskList)... - - endif ! if(present(rMaskTags))... - - ! Now we have (at most) a single INTEGER mask iMask(:) and - ! a single REAL mask rMask(:). Before we perform the merge, - ! we must tackle one more issue: are the REAL attributes - ! of inAv and outAv identical and in the same order? If they - ! are, the merge is a straightforward double loop over the - ! elements and over all the attributes. If the attribute lists - ! differ, we must cross-reference common attributes, and store - ! their indices. - - RAttrIdentical = List_identical(inAv%rList, outAv%rList) - if(.not.(RAttrIdentical)) then - ! Determine the number of shared REAL attributes NumSharedRAttr, - ! and form cross-index tables inAvIndices, outAvIndices. - call SharedAttrIndexList(inAv, outAv, 'REAL', NumSharedRAttr, & - inAvIndices, outAvIndices) - endif - - if(present(rMaskTags)) then ! REAL masking stored in rMask(:) - - if(present(iMaskTags)) then ! also INTEGER mask iMask(:) - - if(RAttrIdentical) then ! straight masked multiply - do i=1, AttrVect_lsize(inAv) - do j=1,AttrVect_nRAttr(inAv) - outAv%rAttr(j,i) = outAv%rAttr(j,i) + & - rMask(i) * iMask(i) * inAv%rAttr(j,i) - end do ! do j=1,AttrVect_nRAttr(inAv) - ! add in mask contribution to total of merge weights - WeightSum(i) = WeightSum(i) + iMask(i) * rMask(i) - end do ! do i=1,AttrVect_lsize(inAv)... - else ! use previously generated cross-indices - do i=1, AttrVect_lsize(inAv) - do j=1,NumSharedRAttr - outAv%rAttr(outAVIndices(j),i) = & - outAv%rAttr(outAvIndices(j),i) + & - rMask(i) * iMask(i) * & - inAv%rAttr(inAvIndices(j),i) - end do ! do j=1,NumSharedRAttr - ! add in mask contribution to total of merge weights - WeightSum(i) = WeightSum(i) + iMask(i) * rMask(i) - end do ! do i=1,AttrVect_lsize(inAv)... - endif ! if(RAttrIdentical)... - - else ! rMask(:), but no iMask(:) - - if(RAttrIdentical) then ! straight masked multiply - do i=1, AttrVect_lsize(inAv) - do j=1,AttrVect_nRAttr(inAv) - outAv%rAttr(j,i) = outAv%rAttr(j,i) + & - rMask(i) * inAv%rAttr(j,i) - end do ! do j=1,AttrVect_nRAttr(inAv) - ! add in mask contribution to total of merge weights - WeightSum(i) = WeightSum(i) + rMask(i) - end do ! do i=1,AttrVect_lsize(inAv)... - else ! use previously generated cross-indices - do i=1, AttrVect_lsize(inAv) - do j=1,NumSharedRAttr - outAv%rAttr(outAVIndices(j),i) = & - outAv%rAttr(outAvIndices(j),i) + & - rMask(i) * inAv%rAttr(inAvIndices(j),i) - end do ! do j=1,NumSharedRAttr - ! add in mask contribution to total of merge weights - WeightSum(i) = WeightSum(i) + rMask(i) - end do ! do i=1,AttrVect_lsize(inAv)... - endif ! if(RAttrIdentical) - - endif ! if(present(iMaskTags))... - - else ! No REAL Mask - - if(present(iMaskTags)) then ! Have iMask(:), but no rMask(:) - - if(RAttrIdentical) then ! straight masked multiply - do i=1, AttrVect_lsize(inAv) - do j=1,AttrVect_nRAttr(inAv) - outAv%rAttr(j,i) = outAv%rAttr(j,i) + & - iMask(i) * inAv%rAttr(j,i) - end do ! do j=1,AttrVect_nRAttr(inAv) - ! add in mask contribution to total of merge weights - WeightSum(i) = WeightSum(i) + iMask(i) - end do ! do i=1,AttrVect_lsize(inAv)... - else ! use previously generated cross-indices - do i=1, AttrVect_lsize(inAv) - do j=1,NumSharedRAttr - outAv%rAttr(outAVIndices(j),i) = & - outAv%rAttr(outAvIndices(j),i) + & - iMask(i) * inAv%rAttr(inAvIndices(j),i) - end do ! do j=1,NumSharedRAttr - ! add in mask contribution to total of merge weights - WeightSum(i) = WeightSum(i) + iMask(i) - end do ! do i=1,AttrVect_lsize(inAv)... - endif ! if(RAttrIdentical) - - else ! Neither iMask(:) nor rMask(:)--all elements weighted by unity - - if(RAttrIdentical) then ! straight masked multiply - do i=1, AttrVect_lsize(inAv) - do j=1,AttrVect_nRAttr(inAv) - outAv%rAttr(j,i) = outAv%rAttr(j,i) + inAv%rAttr(j,i) - end do ! do j=1,AttrVect_nRAttr(inAv) - ! add in mask contribution to total of merge weights - WeightSum(i) = WeightSum(i) + 1._FP - end do ! do i=1,AttrVect_lsize(inAv)... - else ! use previously generated cross-indices - do i=1, AttrVect_lsize(inAv) - do j=1,NumSharedRAttr - outAv%rAttr(outAVIndices(j),i) = & - outAv%rAttr(outAvIndices(j),i) + & - inAv%rAttr(inAvIndices(j),i) - end do ! do j=1,NumSharedRAttr - ! add in mask contribution to total of merge weights - WeightSum(i) = WeightSum(i) + 1._FP - end do ! do i=1,AttrVect_lsize(inAv)... - endif ! if(RAttrIdentical) - - endif ! if(present(iMaskTags))... - - endif ! if(present(rMaskTags))... - - ! At this point the merge has been completed. Now clean - ! up all allocated structures and temporary arrays. - - if(present(iMaskTags)) then ! clean up integer mask work space - deallocate(iMask, iDummy, stat=ierr) - if(ierr /= 0) then - write(stderr,'(2a,i8)') myname_, & - ':: deallocate(iMask,...) failed with ierr = ',ierr - call die(myname_) - endif - call List_clean(iMaskList) - endif - - if(present(rMaskTags)) then ! clean up real mask work space - deallocate(rMask, rDummy, stat=ierr) - if(ierr /= 0) then - write(stderr,'(2a,i8)') myname_, & - ':: deallocate(rMask,...) failed with ierr = ',ierr - call die(myname_) - endif - call List_clean(rMaskList) - endif - - if(.not.(RAttrIdentical)) then ! clean up cross-reference tables - deallocate(inAvIndices, outAvIndices, stat=ierr) - if(ierr /= 0) then - write(stderr,'(2a,i8)') myname_, & - ':: deallocate(inAvIndices,...) failed with ierr = ',ierr - call die(myname_) - endif - endif - - end subroutine MergeInDataGGDP_ - - end module m_Merge diff --git a/cesm/models/utils/mct/mct/m_Navigator.F90 b/cesm/models/utils/mct/mct/m_Navigator.F90 deleted file mode 100644 index 2ca10ac..0000000 --- a/cesm/models/utils/mct/mct/m_Navigator.F90 +++ /dev/null @@ -1,666 +0,0 @@ -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!----------------------------------------------------------------------- -! CVS $Id$ -! CVS $Name$ -!BOP ------------------------------------------------------------------- -! -! !MODULE: m_Navigator - An Object for Indexing Segments of a Vector -! -! !DESCRIPTION: -! A {\em Navigator} is a table used to {\em index} or {\em Navigate} -! segments of a vector, or segments of a dimension of a -! higher-dimensional array. In MCT, this concept is embodied in -! the {\tt Navigator} datatype, which contains -! the following components: -! \begin{itemize} -! \item The {\em number} of segments; -! \item The {\em displacement} of the starting index of each segment -! from the vector's first element (i.e. the starting index minus 1); -! \item The {\em length} of each segment; and -! \item The {\em total length} of the vector or array dimension for which -! segments are defined. This last item is optional, but if defined -! provides the ability for the {\tt Navigator} to check for erroneous -! segment entries (i.e., segments that are out-of-bounds). -! \end{itemize} -! -! This module defines the {\tt Navigator} datatype, creation and -! destruction methods, a variety of query methods, and a method for -! resizing the {\tt Navigator}. -! -! !INTERFACE: - - module m_Navigator - -! !USES: -! No external modules are used in the declaration section of this module. - - implicit none - - private ! except - -! !PUBLIC TYPES: - - public :: Navigator ! The class data structure - - Type Navigator - integer :: NumSegments ! Number of defined Segments - integer :: VectorLength ! Length of the Vector being indexed - integer,pointer,dimension(:) :: displs ! Segment start displacements - integer,pointer,dimension(:) :: counts ! Segment lengths - End Type Navigator - -! !PUBLIC MEMBER FUNCTIONS: - - public :: Navigator_init,init ! initialize an object - public :: clean ! clean an object - public :: NumSegments ! number of vector segments - public :: VectorLength ! indexed vector's total length - public :: msize ! the maximum size - public :: resize ! adjust the true size - public :: get ! get an entry - public :: ptr_displs ! referencing %displs(:) - public :: ptr_counts ! referencing %counts(:) - - interface Navigator_init; module procedure & - init_ - end interface - interface init ; module procedure init_ ; end interface - interface clean ; module procedure clean_ ; end interface - interface NumSegments ; module procedure & - NumSegments_ - end interface - interface VectorLength ; module procedure & - VectorLength_ - end interface - interface msize ; module procedure msize_ ; end interface - interface resize; module procedure resize_; end interface - interface get ; module procedure get_ ; end interface - interface ptr_displs; module procedure & - ptr_displs_ - end interface - interface ptr_counts; module procedure & - ptr_counts_ - end interface - -! !REVISION HISTORY: -! 22May00 - Jing Guo - initial prototype/prolog/code -! 26Aug02 - J. Larson - expanded datatype to inlcude -! VectorLength component. -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname='MCT::m_Navigator' - - contains - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: init_ - Create a Navigator -! -! !DESCRIPTION: -! This routine creates a {\tt Navigator} {\tt Nav} capable of storing -! information about {\tt NumSegments} segments. The user can supply the -! length of the vector (or array subspace) being indexed by supplying the -! optional input {\tt INTEGER} argument {\tt VectorLength} (if it is not -! supplied, this component of {\tt Nav} will be set to zero, signifying -! to other {\tt Navigator} routines that vector length information is -! unavailable). The success (failure) of this operation is signified by -! the zero (non-zero) value of the optional output {\tt INTEGER} argument -! {\tt stat}. -! -! !INTERFACE: - - subroutine init_(Nav, NumSegments, VectorLength, stat) - -! !USES: - - use m_mall,only : mall_ison,mall_mci - use m_die ,only : die,perr - use m_stdio, only : stderr - - implicit none - -! !INPUT PARAMETERS: - - integer, intent(in) :: NumSegments - integer, optional, intent(in) :: VectorLength - -! !OUTPUT PARAMETERS: - - type(Navigator), intent(out) :: Nav - integer, optional, intent(out) :: stat - -! !REVISION HISTORY: -! 22May00 - Jing Guo - initial prototype/prolog/code -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::init_' - integer :: ier - -! If the argument VectorLength is present, use this value to set -! Nav%VectorLength. Otherwise, set Nav%VectorLength to zero. - - if(present(VectorLength)) then - if(VectorLength < 0) then - write(stderr,'(2a,i8)') myname_, & - ':: FATAL -- illegal value of VectorLength=',VectorLength - call die(myname_) - endif - Nav%VectorLength = VectorLength - else - Nav%VectorLength = 0 - endif - -! Allocate segment attribute table arrays: - - allocate(Nav%displs(NumSegments),Nav%counts(NumSegments),stat=ier) - if(ier/=0) then - call perr(myname_,'allocate()',ier) - if(.not.present(stat)) call die(myname_) - stat=ier - return - endif - if(mall_ison()) then - call mall_mci(Nav%displs,myname) - call mall_mci(Nav%counts,myname) - endif - - Nav%NumSegments=NumSegments - - end subroutine init_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: clean_ - Destroy a Navigator -! -! !DESCRIPTION: -! This routine deallocates allocated memory associated with the -! input/output {\tt Navigator} argument {\tt Nav}, and clears the -! vector length and number of segments components The success (failure) -! of this operation is signified by the zero (non-zero) value of the -! optional output {\tt INTEGER} argument {\tt stat}. -! -! !INTERFACE: - - subroutine clean_(Nav, stat) - -! !USES: - - use m_mall, only : mall_ison,mall_mco - use m_die, only : warn - - implicit none - -! !INPUT/OUTPUT PARAMETERS: - - type(Navigator),intent(inout) :: Nav - -! !OUTPUT PARAMETERS: - - integer,optional,intent(out) :: stat - -! !REVISION HISTORY: -! 22May00 - Jing Guo initial prototype/prolog/code -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::clean_' - integer :: ier - - if(mall_ison()) then - if(associated(Nav%displs)) call mall_mco(Nav%displs,myname_) - if(associated(Nav%counts)) call mall_mco(Nav%counts,myname_) - endif - - deallocate(Nav%displs,Nav%counts,stat=ier) - - if(present(stat)) then - stat=ier - else - if(ier /= 0) call warn(myname_,'deallocate(Nav%...)',ier) - endif - - Nav%NumSegments = 0 - Nav%VectorLength = 0 - - end subroutine clean_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: NumSegments_ - Return the Number of Segments -! -! !DESCRIPTION: -! This {\tt INTEGER} query function returns the number of segments -! in the input {\tt Navigator} argument {\tt Nav} for which segment -! start and length information are defined . -! -! !INTERFACE: - - integer function NumSegments_(Nav) - -! !USES: - - implicit none - -! !INPUT PARAMETERS: - - type(Navigator), intent(in) :: Nav - -! !REVISION HISTORY: -! 22May00 - Jing Guo initial prototype/prolog/code -! 1Mar02 - E.T. Ong - removed die to prevent crashes. -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::NumSegments_' - - NumSegments_=Nav%NumSegments - - end function NumSegments_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: msize_ - Return the Maximum Capacity for Segment Storage -! -! !DESCRIPTION: -! This {\tt INTEGER} query function returns the maximum number of -! segments for which start and length information can be stored in the -! input {\tt Navigator} argument {\tt Nav}. -! -! !INTERFACE: - - integer function msize_(Nav) - -! !USES: - - implicit none - -! !INPUT PARAMETERS: - - type(Navigator),intent(in) :: Nav - -! !REVISION HISTORY: -! 22May00 - Jing Guo initial prototype/prolog/code -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::msize_' - - msize_=size(Nav%displs) - - end function msize_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: VectorLength_ - Return the Navigated Vector's Length -! -! !DESCRIPTION: -! This {\tt INTEGER} query function returns the total length of the -! vector navigated by the input {\tt Navigator} argument {\tt Nav}. -! Note that the vector length is a quantity the user must have set -! when {\tt Nav} was initialized. If it has not been set, the return -! value will be zero. -! -! !INTERFACE: - - integer function VectorLength_(Nav) - -! !USES: - - implicit none - -! !INPUT PARAMETERS: - - type(Navigator), intent(in) :: Nav - -! !REVISION HISTORY: -! 26Aug02 - J. Larson - initial implementation -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::VectorLength_' - - VectorLength_=Nav%VectorLength - - end function VectorLength_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: resize_ - Reset the Number of Segments -! -! !DESCRIPTION: -! This routine resets the number of segments stored in the input/output -! {\tt Navigator} argument {\tt Nav}. It behaves in one of two modes: -! If the optional {\tt INTEGER} input argument {\tt NumSegments} is -! provided, then this value is taken to be the new number of segments. -! If this routine is invoked without {\tt NumSegments} provided, then -! the new number of segments is set as per the result of the Fortran -! {\tt size()} function applied to the segment table arrays. -! -! !INTERFACE: - - subroutine resize_(Nav, NumSegments) - -! !USES: - - use m_stdio, only : stderr - use m_die, only : die - - implicit none - -! !INPUT PARAMETERS: - - integer,optional,intent(in) :: NumSegments - -! !INPUT/OUTPUT PARAMETERS: - - type(Navigator),intent(inout) :: Nav - -! !REVISION HISTORY: -! 22May00 - Jing Guo initial prototype/prolog/code -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::resize_' - integer :: m - - m=msize_(Nav) - - if(present(NumSegments)) then - if(NumSegments > m) then - write(stderr,'(3a,2(i8,a))') myname_, & - ':: FATAL value of argument NumSegments exceeds maximum ', & - ' storage for this Navigator. NumSegments = ',NumSegments, & - ' Maximum storage capacity = ',m,' segments.' - call die(myname_) - endif - Nav%NumSegments=NumSegments - else - Nav%NumSegments=m - endif - - end subroutine resize_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: get_ - Retrieve Characteristics of a Segment -! -! !DESCRIPTION: -! This multi-purpose query routine can be used to retrieve various -! characteristics of a given segment (identified by the input -! {\tt INTEGER} argument {\tt iSeg}) stored in the input {\tt Navigator} -! argument {\tt Nav}: -! \begin{enumerate} -! \item The {\em displacement} of the first element in this segment from -! the first element of the vector. This quantity is returned in the -! optional output {\tt INTEGER} argument {\tt displ} -! \item The {\em number of elements} in this segment. This quantity -! is returned in the optional output {\tt INTEGER} argument {\tt displ} -! \item The {\em index} of the first element in this segment This -! quantity is returned in the optional output {\tt INTEGER} argument -! {\tt lc}. -! \item The {\em index} of the final element in this segment This -! quantity is returned in the optional output {\tt INTEGER} argument -! {\tt le}. -! \end{enumerate} -! Any combination of the above characteristics may be obtained by -! invoking this routine with the corresponding optional arguments. -! -! !INTERFACE: - - subroutine get_(Nav, iSeg, displ, count, lc, le) - -! !USES: - - use m_stdio, only : stderr - use m_die, only : die - - implicit none - -! !INPUT PARAMETERS: - - type(Navigator), intent(in) :: Nav - integer, intent(in) :: iSeg - -! !OUTPUT PARAMETERS: - - integer, optional, intent(out) :: displ - integer, optional, intent(out) :: count - integer, optional, intent(out) :: lc - integer, optional, intent(out) :: le - -! !REVISION HISTORY: -! 22May00 - Jing Guo initial prototype/prolog/code -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::get_' - - - ! Argument sanity check: - - if(iSeg > msize_(Nav)) then - write(stderr,'(2a,2(a,i8))') myname_, & - ':: FATAL -- Segment index out of Navigator table bounds, ', & - 'Size of Navigator table = ',msize_(Nav),' iSeg = ',iSeg - call die(myname_) - endif - - if(present(displ)) displ=Nav%displs(iSeg) - if(present(count)) count=Nav%counts(iSeg) - if(present(lc)) lc=Nav%displs(iSeg)+1 - if(present(le)) le=Nav%displs(iSeg)+Nav%counts(iSeg) - - end subroutine get_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: ptr_displs_ - Returns Pointer to the displs(:) Component -! -! !DESCRIPTION: -! This pointer-valued query function returns a pointer to the -! {\em displacements} information (the displacement of the first element -! of each segment from the beginning of the vector) contained in the -! input {\tt Navigator} argument {\tt Nav}. It has four basic modes -! of behavior, depending on which (if any) of the optional input -! {\tt INTEGER} arguments {\tt lbnd} and {\tt ubnd} are supplied. -! \begin{enumerate} -! \item If neither {\tt lbnd} nor {\tt ubnd} is supplied, then -! {\tt ptr\_displs\_} returns a pointer to {\em all} the elements in -! the array {\tt Nav\%displs(:)}. -! \item If both {\tt lbnd} and {\tt ubnd} are supplied, then -! {\tt ptr\_displs\_} returns a pointer to the segment of the -! array {\tt Nav\%displs(lbnd:ubnd)}. -! \item If {\tt lbnd} is supplied but {\tt ubnd} is not, then -! {\tt ptr\_displs\_} returns a pointer to the segment of the -! array {\tt Nav\%displs(lbnd:msize)}, where {\tt msize} is the -! length of the array {\tt Nav\%displs(:)}. -! \item If {\tt lbnd} is not supplied but {\tt ubnd} is, then -! {\tt ptr\_displs\_} returns a pointer to the segment of the -! array {\tt Nav\%displs(1:ubnd)}. -! \end{enumerate} -! -! !INTERFACE: - - function ptr_displs_(Nav, lbnd, ubnd) - -! !USES: - - use m_stdio, only : stderr - use m_die, only : die - - implicit none - -! !INPUT PARAMETERS: - - type(Navigator), intent(in) :: Nav - integer, optional, intent(in) :: lbnd - integer, optional, intent(in) :: ubnd - -! !OUTPUT PARAMETERS: - - integer, dimension(:), pointer :: ptr_displs_ - -! !REVISION HISTORY: -! 22May00 - Jing Guo - initial prototype/prolog/code -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::ptr_displs_' - integer :: lc,le - - ! Argument sanity checks - - if(present(lbnd)) then - if(lbnd <= 0) then - write(stderr,'(3a,i8)') myname_, & - ':: FATAL -- illegal lower bound, which must be >= 1.', & - 'lbnd = ',lbnd - call die(myname_) - endif - endif - - if(present(ubnd)) then - if(ubnd > msize_(Nav)) then - write(stderr,'(2a,2(a,i8))') myname_, & - ':: FATAL -- illegal upper bound, which must be <= msize(Nav).', & - 'msize(Nav) = ',msize_(Nav),' ubnd = ',ubnd - call die(myname_) - endif - endif - - if(present(lbnd) .and. present(ubnd)) then - if(lbnd > ubnd) then - write(stderr,'(2a,2(a,i8))') myname_, & - ':: FATAL -- upper bound, must be >= lower bound.', & - 'Lower bound lbnd = ',lbnd,' Upper bound ubnd = ',ubnd - call die(myname_) - endif - endif - - ! End argument sanity checks - - if(present(lbnd).or.present(ubnd)) then - lc=lbound(Nav%displs,1) - if(present(lbnd)) lc=lbnd - le=ubound(Nav%displs,1) - if(present(ubnd)) le=ubnd - ptr_displs_ => Nav%displs(lc:le) - else - le=Nav%NumSegments - ptr_displs_ => Nav%displs(1:le) - endif - - end function ptr_displs_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: ptr_counts_ - Returns Pointer to counts(:) Component -! -! !DESCRIPTION: -! This pointer-valued query function returns a pointer to the -! {\em counts} information (that is, the number of elements in each -! of each segment the vector being navigated) contained in the -! input {\tt Navigator} argument {\tt Nav}. It has four basic modes -! of behavior, depending on which (if any) of the optional input -! {\tt INTEGER} arguments {\tt lbnd} and {\tt ubnd} are supplied. -! \begin{enumerate} -! \item If neither {\tt lbnd} nor {\tt ubnd} is supplied, then -! {\tt ptr\_counts\_} returns a pointer to {\em all} the elements in -! the array {\tt Nav\%counts(:)}. -! \item If both {\tt lbnd} and {\tt ubnd} are supplied, then -! {\tt ptr\_counts\_} returns a pointer to the segment of the -! array {\tt Nav\%counts(lbnd:ubnd)}. -! \item If {\tt lbnd} is supplied but {\tt ubnd} is not, then -! {\tt ptr\_counts\_} returns a pointer to the segment of the -! array {\tt Nav\%counts(lbnd:msize)}, where {\tt msize} is the -! length of the array {\tt Nav\%counts(:)}. -! \item If {\tt lbnd} is not supplied but {\tt ubnd} is, then -! {\tt ptr\_counts\_} returns a pointer to the segment of the -! array {\tt Nav\%counts(1:ubnd)}. -! \end{enumerate} -! -! !INTERFACE: - - function ptr_counts_(Nav, lbnd, ubnd) - -! !USES: - - use m_stdio, only : stderr - use m_die, only : die - - implicit none - -! !INPUT PARAMETERS: - - type(Navigator), intent(in) :: Nav - integer, optional, intent(in) :: lbnd - integer, optional, intent(in) :: ubnd - -! !OUTPUT PARAMETERS: - - integer, dimension(:), pointer :: ptr_counts_ - -! !REVISION HISTORY: -! 22May00 - Jing Guo - initial prototype/prolog/code -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::ptr_counts_' - integer :: lc,le - - ! Argument sanity checks - - if(present(lbnd)) then - if(lbnd <= 0) then - write(stderr,'(3a,i8)') myname_, & - ':: FATAL -- illegal lower bound, which must be >= 1.', & - 'lbnd = ',lbnd - call die(myname_) - endif - endif - - if(present(ubnd)) then - if(ubnd > msize_(Nav)) then - write(stderr,'(2a,2(a,i8))') myname_, & - ':: FATAL -- illegal upper bound, which must be <= msize(Nav).', & - 'msize(Nav) = ',msize_(Nav),' ubnd = ',ubnd - call die(myname_) - endif - endif - - if(present(lbnd) .and. present(ubnd)) then - if(lbnd > ubnd) then - write(stderr,'(2a,2(a,i8))') myname_, & - ':: FATAL -- upper bound, must be >= lower bound.', & - 'Lower bound lbnd = ',lbnd,' Upper bound ubnd = ',ubnd - call die(myname_) - endif - endif - - ! End argument sanity checks - - if(present(lbnd).or.present(ubnd)) then - lc=lbound(Nav%counts,1) - if(present(lbnd)) lc=lbnd - le=ubound(Nav%counts,1) - if(present(ubnd)) le=ubnd - ptr_counts_ => Nav%counts(lc:le) - else - le=Nav%NumSegments - ptr_counts_ => Nav%counts(1:le) - endif - - end function ptr_counts_ - - end module m_Navigator diff --git a/cesm/models/utils/mct/mct/m_Rearranger.F90 b/cesm/models/utils/mct/mct/m_Rearranger.F90 deleted file mode 100644 index dc62e7b..0000000 --- a/cesm/models/utils/mct/mct/m_Rearranger.F90 +++ /dev/null @@ -1,1343 +0,0 @@ -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!----------------------------------------------------------------------- -! CVS $Id$ -! CVS $Name$ -!BOP ------------------------------------------------------------------- -! -! !MODULE: m_Rearranger -- Remaps an AttrVect within a group of processes -! -! !DESCRIPTION: -! This module provides routines and datatypes for rearranging data -! between two {\tt Attribute Vectors} defined on the same grid but -! with two different {\tt GlobalSegMaps}. ''Rearrange'' is a -! generalized form of a parallel matrix transpose. -! A parallel matrix transpose can take advantage of symmetry in the -! data movement algorithm. An MCT Rearranger makes no assumptions -! about symmetry. -! -! When data needs to move between two components and the components -! share any processors, use m\_Rearranger. If the components are on -! distinct sets of processors, use m\_Transfer. -! -! !SEE ALSO: -! m_Transfer -! -! -! !INTERFACE: - - module m_Rearranger - -! -! !USES: - - use m_Router, only : Router - - implicit none - - private ! except - -! !PUBLIC DATA MEMBERS: - - public :: Rearranger ! The class data structure - - type :: Rearranger -#ifdef SEQUENCE - sequence -#endif - private - type(Router) :: SendRouter - type(Router) :: RecvRouter - integer,dimension(:,:),pointer :: LocalPack - integer :: LocalSize - end type Rearranger - -! !PRIVATE DATA MEMBERS: - integer :: max_nprocs ! size of MPI_COMM_WORLD used for generation of - ! local automatic arrays - -! !PUBLIC MEMBER FUNCTIONS: - - public :: init ! creation method - - public :: rearrange ! the rearrange routine - - public :: clean ! destruction method - public :: print ! print out comm info - - interface init ; module procedure init_ ; end interface - interface Rearrange ; module procedure Rearrange_ ; end interface - interface clean ; module procedure clean_ ; end interface - interface print ; module procedure print_ ; end interface - -! !DEFINED PARAMETERS: - - integer,parameter :: DefaultTag = 500 - - -! !REVISION HISTORY: -! 31Jan02 - E.T. Ong - initial prototype -! 04Jun02 - E.T. Ong - changed local copy structure to -! LocalSize. Made myPid a global process in MCTWorld. -! 27Sep02 - R. Jacob - Remove SrcAVsize and TrgAVsize -! and use Router%lAvsize instead for sanity check. -! 25Jan08 - R. Jacob - Add ability to handle unordered -! gsmaps. -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname='MCT::m_Rearranger' - - contains - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: Init_ - Initialize a Rearranger -! -! !DESCRIPTION: -! This routine takes two {\tt GlobalSegMap} inputs, {\tt SourceGSMap} -! and {\tt TargetGSMap} and build a Rearranger {\tt OutRearranger} -! between them. {\tt myComm} is used for the internal communication. -! -! {\bf N.B.} The two {\tt GlolbalSegMap} inputs must be initialized so -! that the index values on a processor are in ascending order. -! -! !INTERFACE: - - subroutine init_(SourceGSMap,TargetGSMap,myComm,OutRearranger) - -! -! !USES: -! - - use m_MCTWorld, only : ThisMCTWorld - use m_GlobalSegMap, only : GlobalSegMap - use m_GlobalSegMap, only : GSMap_lsize => lsize - use m_GlobalSegMap, only : GSMap_increasing => increasing - use m_Router, only : Router - use m_Router, only : Router_init => init - use m_mpif90 - use m_die - use m_stdio - - implicit none - -! !INPUT PARAMETERS: -! - type(GlobalSegMap), intent(in) :: SourceGSMap, TargetGSMap - integer, intent(in) :: myComm - -! !OUTPUT PARAMETERS: -! - type(Rearranger), intent(out) :: OutRearranger - -! !REVISION HISTORY: -! 31Jan02 - E.T. Ong - initial prototype -! 20Mar02 - E.T. Ong - working code -! 05Jun02 - E.T. Ong - Use LocalPack -! 30Mar06 - P. Worley - added max_nprocs, -! used in communication optimizations in rearrange -!EOP ___________________________________________________________________ - character(len=*),parameter :: myname_=myname//'::init_' - integer,dimension(:,:),pointer :: temp_seg_starts,temp_seg_lengths - integer,dimension(:),pointer :: temp_pe_list,temp_numsegs,temp_locsize - integer :: temp_maxsize,temp_nprocs,maxsegcount - integer :: procindex,nprocs,nseg,len,myPid - integer :: src_seg_start,src_seg_length,trg_seg_start,trg_seg_length - integer :: i,j,k,l,m,n,ier - logical :: SendingToMyself,ReceivingFromMyself - - - ! Initialize Router component of Rearranger - call Router_init(SourceGSMap,TargetGSMap,myComm,OutRearranger%SendRouter) - call Router_init(TargetGSMap,SourceGSMap,myComm,OutRearranger%RecvRouter) - - call MP_comm_size(MP_COMM_WORLD,max_nprocs,ier) - if(ier/=0) call MP_perr_die(myname_,'MP_comm_size',ier) - - ! SANITY CHECK: Make sure that if SendRouter is sending to self, then, - ! by definition, RecvRouter is also receiving from self. If this is not - ! true, then write to stderr and die. - - call MP_comm_rank(ThisMCTWorld%MCT_comm,myPid,ier) - if(ier/=0) call MP_perr_die(myname_,'MP_comm_rank',ier) - - SendingToMyself = .false. - ReceivingFromMyself = .false. - - do i=1,OutRearranger%SendRouter%nprocs - if(OutRearranger%SendRouter%pe_list(i) == myPid) then - SendingToMyself = .true. - endif - enddo - - do i=1,OutRearranger%RecvRouter%nprocs - if(OutRearranger%RecvRouter%pe_list(i) == myPid) then - ReceivingFromMyself = .true. - endif - enddo - - if( SendingToMyself.or.ReceivingFromMyself ) then - if( .not. (SendingToMyself.and.ReceivingFromMyself) ) then - call die(myname_,"SendRouter is not compatible with RecvRouter") - endif - endif - - - ! If not sending to nor receiving from own processor then initialize - ! the rearranger so that no local copy can be made. Then end the routine. - - if( .not. (SendingToMyself.or.ReceivingFromMyself) ) then - nullify(OutRearranger%LocalPack) - allocate(OutRearranger%LocalPack(0,0),stat=ier) - if(ier/=0) call die(myname_,'allocate(OutRearranger%LocalPack(0,0))',ier) - OutRearranger%LocalSize=0 - endif - - - ! Start the process of Router modification: Router information for - ! the local processor is extracted out and put into the local copy - ! structure- Rearranger%LocalPack. Router structures are then reassigned - ! to exclude the local copy information. - - - ! Operate on SendRouter and create local copy structures. - - if( SendingToMyself.and.ReceivingFromMyself ) then - - temp_nprocs = OutRearranger%SendRouter%nprocs-1 - maxsegcount = SIZE(OutRearranger%SendRouter%seg_starts,2) - - ! Allocate temporary Router structures to be used for modifying SendRouter - nullify(temp_seg_starts,temp_seg_lengths,temp_pe_list, & - temp_numsegs,temp_locsize) - allocate(temp_seg_starts(temp_nprocs,maxsegcount), & - temp_seg_lengths(temp_nprocs,maxsegcount), & - temp_pe_list(temp_nprocs), & - temp_numsegs(temp_nprocs), & - temp_locsize(temp_nprocs), stat=ier) - if(ier/=0) call die(myname_,'allocate(temp_seg_starts...)',ier) - - temp_maxsize=0 - procindex=0 - nullify(OutRearranger%LocalPack) - - ! Start assigning Rearranger copy structures and - ! non-local Router components - do i=1,OutRearranger%SendRouter%nprocs - - ! Gather local copy information - if(OutRearranger%SendRouter%pe_list(i) == myPid) then - - ! Allocate Rearranger copy structure - allocate(OutRearranger%LocalPack(2, & - OutRearranger%SendRouter%locsize(i)),stat=ier) - if(ier/=0) call die(myname_,'allocate(OutRearranger%LocalPack)',ier) - OutRearranger%LocalPack = 0 - - m=0 - do nseg = 1,OutRearranger%SendRouter%num_segs(i) - src_seg_start = OutRearranger%SendRouter%seg_starts(i,nseg) - src_seg_length = OutRearranger%SendRouter%seg_lengths(i,nseg)-1 - do len=0,src_seg_length - m=m+1 - OutRearranger%LocalPack(2,m) = src_seg_start+len - enddo - enddo - - else - - ! Gather non-local Router information - procindex = procindex+1 - temp_seg_starts(procindex,1:maxsegcount) = & - OutRearranger%SendRouter%seg_starts(i,1:maxsegcount) - temp_seg_lengths(procindex,1:maxsegcount) = & - OutRearranger%SendRouter%seg_lengths(i,1:maxsegcount) - temp_pe_list(procindex) = OutRearranger%SendRouter%pe_list(i) - temp_numsegs(procindex) = OutRearranger%SendRouter%num_segs(i) - temp_locsize(procindex) = OutRearranger%SendRouter%locsize(i) - temp_maxsize = max(temp_locsize(procindex),temp_maxsize) - - endif - - enddo - - ! Copy SendRouter components back in - - ! Deallocate existing SendRouter components - deallocate(OutRearranger%SendRouter%seg_starts,& - OutRearranger%SendRouter%seg_lengths, & - OutRearranger%SendRouter%pe_list, & - OutRearranger%SendRouter%num_segs, & - OutRearranger%SendRouter%locsize,stat=ier) - if(ier/=0) call die(myname_, & - 'deallocate(OutRearranger%SendRouter%seg_starts...)',ier) - - ! Re-allocate SendRouter components - allocate(OutRearranger%SendRouter%seg_starts(temp_nprocs,maxsegcount), & - OutRearranger%SendRouter%seg_lengths(temp_nprocs,maxsegcount), & - OutRearranger%SendRouter%pe_list(temp_nprocs), & - OutRearranger%SendRouter%num_segs(temp_nprocs), & - OutRearranger%SendRouter%locsize(temp_nprocs),stat=ier) - if(ier/=0) call die(myname_, & - 'allocate(OutRearranger%SendRouter%seg_starts...)',ier) - - ! Copy back in the spliced router information - OutRearranger%SendRouter%nprocs = temp_nprocs - OutRearranger%SendRouter%seg_starts(1:temp_nprocs,1:maxsegcount) = & - temp_seg_starts(1:temp_nprocs,1:maxsegcount) - OutRearranger%SendRouter%seg_lengths(1:temp_nprocs,1:maxsegcount) = & - temp_seg_lengths(1:temp_nprocs,1:maxsegcount) - OutRearranger%SendRouter%pe_list(1:temp_nprocs) = & - temp_pe_list(1:temp_nprocs) - OutRearranger%SendRouter%num_segs(1:temp_nprocs) = & - temp_numsegs(1:temp_nprocs) - OutRearranger%SendRouter%locsize(1:temp_nprocs) = & - temp_locsize(1:temp_nprocs) - OutRearranger%SendRouter%maxsize = temp_maxsize - - deallocate(temp_seg_starts,temp_seg_lengths,temp_pe_list, & - temp_numsegs,temp_locsize,stat=ier) - if(ier/=0) call die(myname_,'deallocate(temp_seg_starts...)',ier) - - - ! ::::::::::::::::::::::::::::::::::::::::::::::::::::::: - - - ! Operate on RecvRouter and create local copy structures. - - temp_nprocs = OutRearranger%RecvRouter%nprocs-1 - maxsegcount = SIZE(OutRearranger%RecvRouter%seg_starts,2) - - ! Allocate temporary Router structures to be used for modifying RecvRouter - nullify(temp_seg_starts,temp_seg_lengths,temp_pe_list, & - temp_numsegs,temp_locsize) - allocate(temp_seg_starts(temp_nprocs,maxsegcount), & - temp_seg_lengths(temp_nprocs,maxsegcount), & - temp_pe_list(temp_nprocs),temp_numsegs(temp_nprocs), & - temp_locsize(temp_nprocs),stat=ier) - if(ier/=0) call die(myname_,'allocate(temp_seg_starts...)',ier) - - temp_maxsize=0 - procindex = 0 - - ! Start assigning Rearranger copy structures and - ! non-local Router components - do i=1,OutRearranger%RecvRouter%nprocs - - ! Gather local copy information - if(OutRearranger%RecvRouter%pe_list(i) == myPid) then - - ! Senity Check for Router%locsize - if( (SIZE(OutRearranger%LocalPack,2) /= & - OutRearranger%RecvRouter%locsize(i)) ) then - call die(myname_, & - 'Router Error: Local RecvRouter%locsize(myPid) /= & - & Local SendRouter%locsize(myPid)') - endif - - OutRearranger%LocalSize = OutRearranger%RecvRouter%locsize(i) - - m=0 - do nseg = 1,OutRearranger%RecvRouter%num_segs(i) - trg_seg_start = OutRearranger%RecvRouter%seg_starts(i,nseg) - trg_seg_length = OutRearranger%RecvRouter%seg_lengths(i,nseg)-1 - do len=0,trg_seg_length - m=m+1 - OutRearranger%LocalPack(1,m) = trg_seg_start+len - enddo - enddo - - else - - ! Gather non-local Router information - procindex = procindex+1 - temp_seg_starts(procindex,1:maxsegcount) = & - OutRearranger%RecvRouter%seg_starts(i,1:maxsegcount) - temp_seg_lengths(procindex,1:maxsegcount) = & - OutRearranger%RecvRouter%seg_lengths(i,1:maxsegcount) - temp_pe_list(procindex) = OutRearranger%RecvRouter%pe_list(i) - temp_numsegs(procindex) = OutRearranger%RecvRouter%num_segs(i) - temp_locsize(procindex) = OutRearranger%RecvRouter%locsize(i) - temp_maxsize = max(temp_locsize(procindex),temp_maxsize) - - endif - - enddo - - ! Copy RecvRouter components back in - - ! Deallocate existing SendRouter components - deallocate(OutRearranger%RecvRouter%seg_starts, & - OutRearranger%RecvRouter%seg_lengths, & - OutRearranger%RecvRouter%pe_list, & - OutRearranger%RecvRouter%num_segs, & - OutRearranger%RecvRouter%locsize,stat=ier) - if(ier/=0) call die(myname_, & - 'deallocate(OutRearranger%RecvRouter%seg_starts...)',ier) - - ! Re-allocate RecvRouter components - allocate(OutRearranger%RecvRouter%seg_starts(temp_nprocs,maxsegcount), & - OutRearranger%RecvRouter%seg_lengths(temp_nprocs,maxsegcount), & - OutRearranger%RecvRouter%pe_list(temp_nprocs), & - OutRearranger%RecvRouter%num_segs(temp_nprocs), & - OutRearranger%RecvRouter%locsize(temp_nprocs),stat=ier) - if(ier/=0) call die(myname_, & - 'allocate(OutRearranger%RecvRouter%seg_starts...)',ier) - - ! Copy back in the spliced router information - OutRearranger%RecvRouter%nprocs = temp_nprocs - OutRearranger%RecvRouter%seg_starts(1:temp_nprocs,1:maxsegcount) = & - temp_seg_starts(1:temp_nprocs,1:maxsegcount) - OutRearranger%RecvRouter%seg_lengths(1:temp_nprocs,1:maxsegcount) = & - temp_seg_lengths(1:temp_nprocs,1:maxsegcount) - OutRearranger%RecvRouter%pe_list(1:temp_nprocs) = & - temp_pe_list(1:temp_nprocs) - OutRearranger%RecvRouter%num_segs(1:temp_nprocs) = & - temp_numsegs(1:temp_nprocs) - OutRearranger%RecvRouter%locsize(1:temp_nprocs) = & - temp_locsize(1:temp_nprocs) - OutRearranger%RecvRouter%maxsize = temp_maxsize - - deallocate(temp_seg_starts,temp_seg_lengths,temp_pe_list, & - temp_numsegs,temp_locsize,stat=ier) - if(ier/=0) call die(myname_,'deallocate(temp_seg_starts...)',ier) - - endif - - end subroutine init_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: clean_ - Clean a Rearranger -! -! !DESCRIPTION: -! This routine deallocates allocated memory associated with the -! input/output {\tt Rearranger} argument {\tt ReArr}. The success -! (failure) of this operation is reported in the zero (nonzero) value of -! the optional output {\tt INTEGER} argument {\tt status}. -! -! !INTERFACE: - - subroutine clean_(ReArr, status) - -! -! !USES: -! - use m_Router,only : Router - use m_Router,only : Router_clean => clean - use m_mpif90 - use m_die - use m_stdio - - implicit none - -! !INPUT/OUTPUT PARAMETERS: -! - type(Rearranger), intent(inout) :: ReArr - -! !OUTPUT PARAMETERS: -! - integer, optional, intent(out) :: status - -! !REVISION HISTORY: -! 31Jan02 - E.T. Ong - initial prototype -! 20Mar02 - E.T. Ong - working code -!EOP ___________________________________________________________________ - character(len=*),parameter :: myname_=myname//'::clean_' - integer :: ier - - ! Set output status flag (if present) to zero, which assumes - ! success. - - if(present(status)) status = 0 - - ! Clean up send and receive Routers: - - call Router_clean(ReArr%SendRouter,ier) - if(ier /= 0) then - if(present(status)) then - status = ier - return - else - write(stderr,'(2a,i8)') myname_, & - ':: ERROR--Router_clean(ReArr%SendRouter) failed with ier=',ier - endif - endif - - call Router_clean(ReArr%RecvRouter,ier) - if(ier /= 0) then - if(present(status)) then - status = ier - return - else - write(stderr,'(2a,i8)') myname_, & - ':: ERROR--Router_clean(ReArr%RecvRouter) failed with ier=',ier - endif - endif - - ! Clean up Local on-PE copy buffer: - - if(associated(ReArr%LocalPack)) then - deallocate(ReArr%LocalPack, stat=ier) - if(ier /= 0) then - if(present(status)) then - status=ier - else - write(stderr,'(2a,i8)') myname_, & - ':: ERROR--deallocate(ReArr%LocalPack) failed with stat=',ier - endif - endif - endif - - end subroutine clean_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: rearrange_ - Rearrange data between two Attribute Vectors -! -! !DESCRIPTION: -! This subroutine will take data in the {\tt SourceAv} Attribute -! Vector and rearrange it to match the GlobalSegMap used to define -! the {\tt TargetAv} Attribute Vector using the Rearrnger -! {\tt InRearranger}. -! -! The optional argument {\tt Tag} can be used to set the tag value used in -! the rearrangement. DefaultTag will be used otherwise. -! -! If the optional argument {\tt Sum} is present and true, data for the same -! physical point coming from two or more processes will be summed. -! Otherwise, data is overwritten. -! -! If the optional argument {\tt Vector} is present and true, -! vector architecture-friendly parts of this routine will be invoked. -! -! If the optional argument {\tt AlltoAll} is present and true, -! the communication will be done with an alltoall call instead of -! individual sends and receives. -! -! The size of the {\tt SourceAv} and {\tt TargetAv} -! argument must match those stored in the {\tt InRearranger} or -! and error will result. -! -! {\bf N.B.:} {\tt SourceAv} and {\tt TargetAv} are -! assumed to have exactly the same attributes -! in exactly the same order. -! -! !INTERFACE: - - subroutine rearrange_(SourceAVin,TargetAV,InRearranger,Tag,Sum,Vector,AlltoAll) - -! -! !USES: -! - - use m_MCTWorld,only :MCTWorld - use m_MCTWorld,only :ThisMCTWorld - use m_AttrVect, only : AttrVect - use m_AttrVect, only : AttrVect_init => init - use m_AttrVect, only : AttrVect_lsize => lsize - use m_AttrVect, only : AttrVect_copy => copy - use m_AttrVect, only : AttrVect_clean => clean - use m_AttrVect, only : AttrVect_zero => zero - use m_AttrVect, only : nIAttr,nRAttr - use m_AttrVect, only : Permute,Unpermute - use m_Router, only : Router - use m_realkinds, only : FP - use m_mpif90 - use m_die - use m_stdio - - implicit none - -! !INPUT/OUTPUT PARAMETERS: -! - type(AttrVect), intent(inout) :: TargetAV - -! !INPUT PARAMETERS: -! - type(AttrVect), target, intent(in) :: SourceAVin - type(Rearranger), target, intent(in) :: InRearranger - integer, optional, intent(in) :: Tag - logical, optional, intent(in) :: Sum - logical, optional, intent(in) :: Vector - logical, optional, intent(in) :: AlltoAll - -! !REVISION HISTORY: -! 31Jan02 - E.T. Ong - initial prototype -! 20Mar02 - E.T. Ong - working code -! 08Jul02 - E.T. Ong - change intent of Target,Source -! 29Oct03 - R. Jacob - add optional argument vector -! to control use of vector-friendly mods provided by Fujitsu. -! 30Mar06 - P. Worley - added alltoall option and -! reordered send/receive order to improve communication -! performance. Also remove replace allocated arrays with -! automatic. -! 14Oct06 - R. Jacob - check value of Sum argument. -! 25Jan08 - R. Jacob - Permute/unpermute if the internal -! routers permarr is defined. -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::Rearrange_' - integer :: numi,numr,i,j,k,ier - integer :: VectIndex,AttrIndex,seg_start,seg_end - integer :: localindex,SrcVectIndex,TrgVectIndex,IAttrIndex,RAttrIndex - integer :: proc,numprocs,nseg,pe,pe_shift,max_pe,myPid - integer :: mp_Type_rp - integer :: mytag - integer :: ISendSize, RSendSize, IRecvSize, RRecvSize - logical :: usevector, usealltoall - logical :: DoSum - logical :: Sendunordered - logical :: Recvunordered - real(FP) :: realtyp -!----------------------------------------------------------------------- - - ! DECLARE STRUCTURES FOR MPI ARGUMENTS. - - ! declare arrays mapping from all processes to those sending to - ! or receiving from - integer :: SendList(0:max_nprocs-1) - integer :: RecvList(0:max_nprocs-1) - - ! declare arrays to hold count and locations where data is to be sent from - integer :: ISendLoc(max_nprocs) - integer :: RSendLoc(max_nprocs) - - integer :: ISendCnts(0:max_nprocs-1) - integer :: RSendCnts(0:max_nprocs-1) - - integer :: ISdispls(0:max_nprocs-1) - integer :: RSdispls(0:max_nprocs-1) - - ! declare arrays to hold data to be sent - integer,dimension(:),allocatable :: ISendBuf - real(FP),dimension(:),allocatable :: RSendBuf - - ! declare arrays to hold count and locations where data is to be received into - integer :: IRecvLoc(max_nprocs) - integer :: RRecvLoc(max_nprocs) - - integer :: IRecvCnts(0:max_nprocs-1) - integer :: RRecvCnts(0:max_nprocs-1) - - integer :: IRdispls(0:max_nprocs-1) - integer :: RRdispls(0:max_nprocs-1) - - ! declare arrays to hold data to be received - integer,dimension(:),allocatable :: IRecvBuf - real(FP),dimension(:),allocatable :: RRecvBuf - - ! Structure to hold MPI request information for sends - integer :: send_ireqs(max_nprocs) - integer :: send_rreqs(max_nprocs) - - ! Structure to hold MPI request information for sends - integer :: recv_ireqs(max_nprocs) - integer :: recv_rreqs(max_nprocs) - - ! Structure to hold MPI status information for sends - integer :: send_istatus(MP_STATUS_SIZE,max_nprocs) - integer :: send_rstatus(MP_STATUS_SIZE,max_nprocs) - - ! Structure to hold MPI status information for sends - integer :: recv_istatus(MP_STATUS_SIZE,max_nprocs) - integer :: recv_rstatus(MP_STATUS_SIZE,max_nprocs) - - ! Pointer structure to make Router access simpler - type(Router), pointer :: SendRout, RecvRout - type(AttrVect),pointer :: SourceAv - type(AttrVect),target :: SourceAvtmp - -!:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: - - Sendunordered=associated(InRearranger%SendRouter%permarr) - Recvunordered=associated(InRearranger%RecvRouter%permarr) - - if(Sendunordered) then - call AttrVect_init(SourceAvtmp,SourceAvin,AttrVect_lsize(SourceAvin)) - call AttrVect_copy(SourceAvin, SourceAvtmp) - call Permute(SourceAvtmp,InRearranger%SendRouter%permarr) - SourceAv => SourceAvtmp - else - SourceAv => SourceAvin - endif - - if(Recvunordered) call Permute(TargetAv,InRearranger%RecvRouter%permarr) - - ! CHECK ARGUMENTS - - ! Check the size of the Source AttrVect - if(InRearranger%SendRouter%lAvsize /= AttrVect_lsize(SourceAV)) then - call warn(myname_,"SourceAV size is not appropriate for this Rearranger") - call die(myname_,"InRearranger%SendRouter%lAvsize",InRearranger%SendRouter%lAvsize, & - "AttrVect_lsize(SourceAV)", AttrVect_lsize(SourceAV)) - endif - - ! Check the size of the Target AttrVect - if(InRearranger%RecvRouter%lAvsize /= AttrVect_lsize(TargetAV)) then - call warn(myname_,"TargetAV size is not appropriate for this Rearranger") - call die(myname_,"InRearranger%RecvRouter%lAvsize",InRearranger%RecvRouter%lAvsize, & - "AttrVect_lsize(TargetAV)", AttrVect_lsize(TargetAV)) - endif - - ! Check the number of integer attributes - if(nIAttr(SourceAV) /= nIAttr(TargetAV)) then - call warn(myname_, & - "Number of attributes in SourceAV and TargetAV do not match") - call die(myname_,"nIAttr(SourceAV)", nIAttr(SourceAV), & - "nIAttr(TargetAV)", nIAttr(TargetAV)) - endif - - ! Check the number of real attributes - if(nRAttr(SourceAV) /= nRAttr(TargetAV)) then - call warn(myname_, & - "Number of attributes in SourceAV and TargetAV do not match") - call die(myname_,"nRAttr(SourceAV)", nRAttr(SourceAV), & - "nRAttr(TargetAV)", nRAttr(TargetAV)) - endif - - usevector=.false. - if(present(Vector)) then - if(Vector) usevector=.true. - endif - - usealltoall=.false. - if(present(Alltoall)) then - if(Alltoall) usealltoall=.true. - endif - - DoSum=.false. - if(present(Sum)) then - if(Sum) DoSum=.true. - endif - - ! ASSIGN VARIABLES - - - ! Get the number of integer and real attributes - numi = nIAttr(SourceAV) - numr = nRAttr(SourceAV) - - ! Assign the pointers - nullify(SendRout,RecvRout) - SendRout => InRearranger%SendRouter - RecvRout => InRearranger%RecvRouter - - mp_Type_rp=MP_Type(realtyp) - -!:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: - - ! ALLOCATE DATA STRUCTURES ! - - ! IF SENDING DATA - if(SendRout%nprocs > 0) then - - ! IF SENDING INTEGER DATA - if(numi .ge. 1) then - - ! allocate buffer to hold all outgoing data - ISendSize = 1 - do proc=1,SendRout%nprocs - ISendLoc(proc) = ISendSize - ISendSize = ISendSize + SendRout%locsize(proc)*numi - enddo - ISendSize = ISendSize - 1 - allocate(ISendBuf(ISendSize),stat=ier) - if(ier/=0) call die(myname_,'allocate(ISendBuf)',ier) - - endif - - ! IF SENDING REAL DATA - if(numr .ge. 1) then - - ! allocate buffer to hold all outgoing data - RSendSize = 1 - do proc=1,SendRout%nprocs - RSendLoc(proc) = RSendSize - RSendSize = RSendSize + SendRout%locsize(proc)*numr - enddo - RSendSize = RSendSize - 1 - allocate(RSendBuf(RSendSize),stat=ier) - if(ier/=0) call die(myname_,'allocate(RSendBuf)',ier) - - - endif - - endif - - ! IF RECEVING DATA - if(RecvRout%nprocs > 0) then - - ! IF RECEIVING INTEGER DATA - if(numi .ge. 1) then - - ! allocate buffer to hold all outgoing data - IRecvSize = 1 - do proc=1,RecvRout%nprocs - IRecvLoc(proc) = IRecvSize - IRecvSize = IRecvSize + RecvRout%locsize(proc)*numi - enddo - IRecvSize = IRecvSize - 1 - allocate(IRecvBuf(IRecvSize),stat=ier) - if(ier/=0) call die(myname_,'allocate(IRecvBuf)',ier) - - endif - - ! IF RECEIVING REAL DATA - if(numr .ge. 1) then - - ! allocate buffer to hold all outgoing data - RRecvSize = 1 - do proc=1,RecvRout%nprocs - RRecvLoc(proc) = RRecvSize - RRecvSize = RRecvSize + RecvRout%locsize(proc)*numr - enddo - RRecvSize = RRecvSize - 1 - allocate(RRecvBuf(RRecvSize),stat=ier) - if(ier/=0) call die(myname_,'allocate(RRecvBuf)',ier) - - - endif - - endif - -!:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: - - ! INVERT PE LIST ! - call MP_comm_rank(ThisMCTWorld%MCT_comm,myPid,ier) - if(ier/=0) call MP_perr_die(myname_,'MP_comm_rank',ier) - - call MP_comm_size(ThisMCTWorld%MCT_comm, max_pe, ier) - if(ier/=0) call MP_perr_die(myname_,'MP_comm_size',ier) - - SendList(:) = -1 - do proc = 1,SendRout%nprocs - SendList(SendRout%pe_list(proc)) = proc - enddo - - RecvList(:) = -1 - do proc = 1,RecvRout%nprocs - RecvList(RecvRout%pe_list(proc)) = proc - enddo - - if (usealltoall) then - ! CONSTRUCT CNTS AND DISPLS FOR ALLTOALLV ! - ISendCnts(:) = 0 - ISdispls(:) = 0 - RSendCnts(:) = 0 - RSdispls(:) = 0 - IRecvCnts(:) = 0 - IRdispls(:) = 0 - RRecvCnts(:) = 0 - RRdispls(:) = 0 - do pe = 0,max_pe-1 - proc = SendList(pe) - if (proc .ne. -1) then - ISendCnts(pe) = SendRout%locsize(proc)*numi - ISdispls(pe) = ISendLoc(proc) - 1 - - RSendCnts(pe) = SendRout%locsize(proc)*numr - RSdispls(pe) = RSendLoc(proc) - 1 - endif - - proc = RecvList(pe) - if (proc .ne. -1) then - IRecvCnts(pe) = RecvRout%locsize(proc)*numi - IRdispls(pe) = IRecvLoc(proc) - 1 - - RRecvCnts(pe) = RecvRout%locsize(proc)*numr - RRdispls(pe) = RRecvLoc(proc) - 1 - endif - enddo - endif - -!:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: -if (usealltoall) then - - ! Load data going to each processor - do proc = 1,SendRout%nprocs - j=0 - k=0 - - ! load the correct pieces of the integer and real vectors - do nseg = 1,SendRout%num_segs(proc) - seg_start = SendRout%seg_starts(proc,nseg) - seg_end = seg_start + SendRout%seg_lengths(proc,nseg)-1 - do VectIndex = seg_start,seg_end - do AttrIndex = 1,numi - ISendBuf(ISendLoc(proc)+j) = SourceAV%iAttr(AttrIndex,VectIndex) - j=j+1 - enddo - do AttrIndex = 1,numr - RSendBuf(RSendLoc(proc)+k) = SourceAV%rAttr(AttrIndex,VectIndex) - k=k+1 - enddo - enddo - enddo - enddo - -else - ! POST MPI_IRECV - - ! Load data coming from each processor - do pe_shift = 1,max_pe - proc = RecvList(mod(myPid+pe_shift,max_pe)) - if (proc .ne. -1) then - - ! receive the integer data - if(numi .ge. 1) then - - ! set tag - mytag = DefaultTag - if(present(Tag)) mytag=Tag - - if( (RecvRout%num_segs(proc) > 1) .or. DoSum ) then - - call MPI_IRECV(IRecvBuf(IRecvLoc(proc)), & - RecvRout%locsize(proc)*numi,MP_INTEGER, & - RecvRout%pe_list(proc),mytag, & - ThisMCTWorld%MCT_comm,recv_ireqs(proc),ier) - - else - - call MPI_IRECV(TargetAV%iAttr(1,RecvRout%seg_starts(proc,1)), & - RecvRout%locsize(proc)*numi,MP_INTEGER, & - RecvRout%pe_list(proc),mytag, & - ThisMCTWorld%MCT_comm,recv_ireqs(proc),ier) - - endif - - if(ier /= 0) call MP_perr_die(myname_,'MPI_IRECV(ints)',ier) - - endif - - ! receive the real data - if(numr .ge. 1) then - - ! set tag - mytag = DefaultTag + 1 - if(present(Tag)) mytag=Tag +1 - - if( (RecvRout%num_segs(proc) > 1) .or. DoSum ) then - - call MPI_IRECV(RRecvBuf(RRecvLoc(proc)), & - RecvRout%locsize(proc)*numr,mp_Type_rp, & - RecvRout%pe_list(proc),mytag, & - ThisMCTWorld%MCT_comm,recv_rreqs(proc),ier) - - else - - call MPI_IRECV(TargetAV%rAttr(1,RecvRout%seg_starts(proc,1)), & - RecvRout%locsize(proc)*numr,mp_Type_rp, & - RecvRout%pe_list(proc),mytag, & - ThisMCTWorld%MCT_comm,recv_rreqs(proc),ier) - - endif - - if(ier /= 0) call MP_perr_die(myname_,'MPI_IRECV(reals)',ier) - - endif - endif - enddo - -!:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: - - ! POST MPI_ISEND - - ! Load data going to each processor - do pe_shift = max_pe,1,-1 - proc = SendList(mod(myPid+pe_shift,max_pe)) - if (proc .ne. -1) then - - if( SendRout%num_segs(proc) > 1 ) then - - j=0 - k=0 - - ! load the correct pieces of the integer and real vectors - do nseg = 1,SendRout%num_segs(proc) - seg_start = SendRout%seg_starts(proc,nseg) - seg_end = seg_start + SendRout%seg_lengths(proc,nseg)-1 - do VectIndex = seg_start,seg_end - do AttrIndex = 1,numi - ISendBuf(ISendLoc(proc)+j) = SourceAV%iAttr(AttrIndex,VectIndex) - j=j+1 - enddo - do AttrIndex = 1,numr - RSendBuf(RSendLoc(proc)+k) = SourceAV%rAttr(AttrIndex,VectIndex) - k=k+1 - enddo - enddo - enddo - - endif - - ! send the integer data - if(numi .ge. 1) then - - ! set tag - mytag = DefaultTag - if(present(Tag)) mytag=Tag - - if( SendRout%num_segs(proc) > 1 ) then - - call MPI_ISEND(ISendBuf(ISendLoc(proc)), & - SendRout%locsize(proc)*numi,MP_INTEGER, & - SendRout%pe_list(proc),mytag, & - ThisMCTWorld%MCT_comm,send_ireqs(proc),ier) - - else - - call MPI_ISEND(SourceAV%iAttr(1,SendRout%seg_starts(proc,1)), & - SendRout%locsize(proc)*numi,MP_INTEGER, & - SendRout%pe_list(proc),mytag, & - ThisMCTWorld%MCT_comm,send_ireqs(proc),ier) - - endif - - if(ier /= 0) call MP_perr_die(myname_,'MPI_ISEND(ints)',ier) - - endif - - ! send the real data - if(numr .ge. 1) then - - ! set tag - mytag = DefaultTag +1 - if(present(Tag)) mytag=Tag +1 - - if( SendRout%num_segs(proc) > 1 ) then - - call MPI_ISEND(RSendBuf(RSendLoc(proc)), & - SendRout%locsize(proc)*numr,mp_Type_rp, & - SendRout%pe_list(proc),mytag, & - ThisMCTWorld%MCT_comm,send_rreqs(proc),ier) - - else - - call MPI_ISEND(SourceAV%rAttr(1,SendRout%seg_starts(proc,1)), & - SendRout%locsize(proc)*numr,mp_Type_rp, & - SendRout%pe_list(proc),mytag, & - ThisMCTWorld%MCT_comm,send_rreqs(proc),ier) - - endif - - if(ier /= 0) call MP_perr_die(myname_,'MPI_ISEND(reals)',ier) - - endif - endif - enddo -endif ! end of else for if(usealltoall) -!::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: - - ! ZERO TARGETAV WHILE WAITING FOR MESSAGES TO COMPLETE - - if(DoSum) call AttrVect_zero(TargetAV) - -!::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: - - ! LOAD THE LOCAL PIECES OF THE INTEGER AND REAL VECTOR - - if(usevector) then -!$OMP PARALLEL DO PRIVATE(IAttrIndex,localindex,TrgVectIndex,SrcVectIndex) - do IAttrIndex=1,numi -!CDIR SELECT(VECTOR) -!DIR$ CONCURRENT -!DIR$ PREFERVECTOR - do localindex=1,InRearranger%LocalSize - TrgVectIndex = InRearranger%LocalPack(1,localindex) - SrcVectIndex = InRearranger%LocalPack(2,localindex) - TargetAV%iAttr(IAttrIndex,TrgVectIndex) = & - SourceAV%iAttr(IAttrIndex,SrcVectIndex) - enddo - enddo -!$OMP PARALLEL DO PRIVATE(RAttrIndex,localindex,TrgVectIndex,SrcVectIndex) - do RAttrIndex=1,numr -!CDIR SELECT(VECTOR) -!DIR$ CONCURRENT -!DIR$ PREFERVECTOR - do localindex=1,InRearranger%LocalSize - TrgVectIndex = InRearranger%LocalPack(1,localindex) - SrcVectIndex = InRearranger%LocalPack(2,localindex) - TargetAV%rAttr(RAttrIndex,TrgVectIndex) = & - SourceAV%rAttr(RAttrIndex,SrcVectIndex) - enddo - enddo - - else -!$OMP PARALLEL DO PRIVATE(localindex,TrgVectIndex,SrcVectIndex,IAttrIndex,RAttrIndex) - do localindex=1,InRearranger%LocalSize - TrgVectIndex = InRearranger%LocalPack(1,localindex) - SrcVectIndex = InRearranger%LocalPack(2,localindex) - do IAttrIndex=1,numi - TargetAV%iAttr(IAttrIndex,TrgVectIndex) = & - SourceAV%iAttr(IAttrIndex,SrcVectIndex) - enddo - do RAttrIndex=1,numr - TargetAV%rAttr(RAttrIndex,TrgVectIndex) = & - SourceAV%rAttr(RAttrIndex,SrcVectIndex) - enddo - enddo - endif - -!::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: - -if (usealltoall) then - - if (numi .ge. 1) then - call MPI_Alltoallv(ISendBuf, ISendCnts, ISdispls, MP_INTEGER, & - IRecvBuf, IRecvCnts, IRdispls, MP_INTEGER, & - ThisMCTWorld%MCT_comm,ier) - endif - - if (numr .ge. 1) then - call MPI_Alltoallv(RSendBuf, RSendCnts, RSdispls, mp_Type_rp, & - RRecvBuf, RRecvCnts, RRdispls, mp_Type_rp, & - ThisMCTWorld%MCT_comm,ier) - endif - -else - - ! WAIT FOR THE NONBLOCKING SENDS TO COMPLETE - - if(SendRout%nprocs > 0) then - - if(numi .ge. 1) then - - call MPI_WAITALL(SendRout%nprocs,send_ireqs,send_istatus,ier) - if(ier /= 0) call MP_perr_die(myname_,'MPI_WAITALL(ints)',ier) - - endif - - if(numr .ge. 1) then - - call MPI_WAITALL(SendRout%nprocs,send_rreqs,send_rstatus,ier) - if(ier /= 0) call MP_perr_die(myname_,'MPI_WAITALL(reals)',ier) - - endif - - endif - -endif -!::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: - - ! WAIT FOR THE NONBLOCKING RECEIVES TO COMPLETE AND UNPACK BUFFER - - do numprocs = 1,RecvRout%nprocs - - if(numi .ge. 1) then - -if (usealltoall) then - proc = numprocs -else - if(DoSum) then - proc = numprocs - call MPI_WAIT(recv_ireqs(proc),recv_istatus,ier) - else - call MPI_WAITANY(RecvRout%nprocs,recv_ireqs,proc,recv_istatus,ier) - endif -endif - - if(DoSum) then - - ! load the correct pieces of the integer vectors - j=0 - do nseg = 1,RecvRout%num_segs(proc) - seg_start = RecvRout%seg_starts(proc,nseg) - seg_end = seg_start + RecvRout%seg_lengths(proc,nseg)-1 - do VectIndex = seg_start,seg_end - do AttrIndex = 1,numi - TargetAV%iAttr(AttrIndex,VectIndex)= & - TargetAV%iAttr(AttrIndex,VectIndex) + IRecvBuf(IRecvLoc(proc)+j) - j=j+1 - enddo - enddo - enddo - - else - - if (( RecvRout%num_segs(proc) > 1 ) .or. (usealltoall)) then - - ! load the correct pieces of the integer vectors - j=0 - do nseg = 1,RecvRout%num_segs(proc) - seg_start = RecvRout%seg_starts(proc,nseg) - seg_end = seg_start + RecvRout%seg_lengths(proc,nseg)-1 - do VectIndex = seg_start,seg_end - do AttrIndex = 1,numi - TargetAV%iAttr(AttrIndex,VectIndex)=IRecvBuf(IRecvLoc(proc)+j) - j=j+1 - enddo - enddo - enddo - - endif - - endif ! end of if DoSum - - endif ! end of in numi>1 - - if(numr .ge. 1) then - -if (usealltoall) then - proc = numprocs -else - if(DoSum) then - proc = numprocs - call MPI_WAIT(recv_rreqs(proc),recv_rstatus,ier) - else - call MPI_WAITANY(RecvRout%nprocs,recv_rreqs,proc,recv_rstatus,ier) - endif -endif - - if(DoSum) then - - ! load the correct pieces of the integer vectors - k=0 - do nseg = 1,RecvRout%num_segs(proc) - seg_start = RecvRout%seg_starts(proc,nseg) - seg_end = seg_start + RecvRout%seg_lengths(proc,nseg)-1 - do VectIndex = seg_start,seg_end - do AttrIndex = 1,numr - TargetAV%rAttr(AttrIndex,VectIndex) = & - TargetAV%rAttr(AttrIndex,VectIndex) + RRecvBuf(RRecvLoc(proc)+k) - k=k+1 - enddo - enddo - enddo - - else - - if (( RecvRout%num_segs(proc) > 1 ) .or. (usealltoall)) then - - ! load the correct pieces of the integer vectors - k=0 - do nseg = 1,RecvRout%num_segs(proc) - seg_start = RecvRout%seg_starts(proc,nseg) - seg_end = seg_start + RecvRout%seg_lengths(proc,nseg)-1 - do VectIndex = seg_start,seg_end - do AttrIndex = 1,numr - TargetAV%rAttr(AttrIndex,VectIndex)=RRecvBuf(RRecvLoc(proc)+k) - k=k+1 - enddo - enddo - enddo - - endif - - endif ! end if DoSum - - endif ! endif if numr>1 - - enddo - - if(Sendunordered) then - call AttrVect_clean(SourceAvtmp) - nullify(SourceAv) - else - nullify(SourceAv) - endif - - if(Recvunordered) call Unpermute(TargetAv,RecvRout%permarr) - -!:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: - - ! DEALLOCATE ALL STRUCTURES - - if(SendRout%nprocs > 0) then - - if(numi .ge. 1) then - - ! Deallocate the send buffer - deallocate(ISendBuf,stat=ier) - if(ier/=0) call die(myname_,'deallocate(ISendBuf)',ier) - - endif - - if(numr .ge. 1) then - - ! Deallocate the send buffer - deallocate(RSendBuf,stat=ier) - if(ier/=0) call die(myname_,'deallocate(RSendBuf)',ier) - - endif - - endif - - if(RecvRout%nprocs > 0) then - - if(numi .ge. 1) then - - ! Deallocate the receive buffer - deallocate(IRecvBuf,stat=ier) - if(ier/=0) call die(myname_,'deallocate(IRecvBuf)',ier) - - endif - - if(numr .ge. 1) then - - ! Deallocate the receive buffer - deallocate(RRecvBuf,stat=ier) - if(ier/=0) call die(myname_,'deallocate(RRecvBuf)',ier) - - endif - - endif - - nullify(SendRout,RecvRout) - - end subroutine rearrange_ - - - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: print_ - Print rearranger communication info -! -! !DESCRIPTION: -! Print out communication info for both routers in a -! rearranger. Print out on unit number 'lun' -! e.g. (source,destination,length) -! -! !INTERFACE: - - subroutine print_(rearr,mycomm,lun) -! -! !USES: -! - use m_die - use m_Router, only: router_print => print - - implicit none - -!INPUT/OUTPUT PARAMETERS: - type(Rearranger), intent(in) :: rearr - integer, intent(in) :: mycomm - integer, intent(in) :: lun - -! !REVISION HISTORY: -! 27Jul07 - R. Loy initial version -!EOP ___________________________________________________________________ - - - call router_print(rearr%SendRouter,mycomm,lun) - call router_print(rearr%RecvRouter,mycomm,lun) - - end subroutine print_ - - -end module m_Rearranger - - - - - diff --git a/cesm/models/utils/mct/mct/m_Router.F90 b/cesm/models/utils/mct/mct/m_Router.F90 deleted file mode 100644 index fdac762..0000000 --- a/cesm/models/utils/mct/mct/m_Router.F90 +++ /dev/null @@ -1,808 +0,0 @@ -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!----------------------------------------------------------------------- -! CVS $Id$ -! CVS $Name$ -!BOP ------------------------------------------------------------------- -! -! !MODULE: m_Router -- Router class -! -! !DESCRIPTION: -! The Router data type contains all the information needed -! to send an AttrVect between a component on M MPI-processes and a component -! on N MPI-processes. This module defines the Router datatype and provides -! methods to create and destroy one. -! -! !INTERFACE: - - module m_Router - - use m_realkinds, only : FP - use m_zeit - - implicit none - - private ! except - -! !declare a private pointer structure for the real data - type :: rptr -#ifdef SEQUENCE - sequence -#endif - real(FP),dimension(:),pointer :: pr - end type - -! !declare a private pointer structure for the integer data - type :: iptr -#ifdef SEQUENCE - sequence -#endif - integer,dimension(:),pointer :: pi - end type - -! !PUBLIC TYPES: - public :: Router ! The class data structure - - public :: rptr,iptr ! pointer types used in Router -!\end{verbatim} -!% On return, pe_list is the processor ranks of the other -!% component to receive from/send to. num_segs is the -!% number of segments out of my local AttrVect which must -!% be sent/received. (In general, these wont coincide exactly -!% with the segments used to define the GlobalMap) -!% seg_start is the start *in the local AttrVect* of each segment -!% (start goes from 1 to lsize(GSMap)) -!% and seg_lengths is the length. -!\begin{verbatim} - - type Router -#ifdef SEQUENCE - sequence -#endif - integer :: comp1id ! myid - integer :: comp2id ! id of second component - integer :: nprocs ! number of procs to talk to - integer :: maxsize ! maximum amount of data going to a processor - integer :: lAvsize ! The local size of AttrVect which can be - ! used with this Router in MCT_Send/MCT_Recv - integer :: numiatt ! Number of integer attributes currently in use - integer :: numratt ! Number of real attributes currently in use - integer,dimension(:),pointer :: pe_list ! processor ranks of send/receive in MCT_comm - integer,dimension(:),pointer :: num_segs ! number of segments to send/receive - integer,dimension(:),pointer :: locsize ! total of seg_lengths for a proc - integer,dimension(:),pointer :: permarr ! possible permutation array - integer,dimension(:,:),pointer :: seg_starts ! starting index - integer,dimension(:,:),pointer :: seg_lengths! total length - type(rptr),dimension(:),pointer :: rp1 ! buffer to hold real data - type(iptr),dimension(:),pointer :: ip1 ! buffer to hold integer data - integer,dimension(:),pointer :: ireqs,rreqs ! buffer for MPI_Requests - integer,dimension(:,:),pointer :: istatus,rstatus ! buffer for MPI_Status - end type Router - -! !PUBLIC MEMBER FUNCTIONS: - public :: init ! Create a Router - public :: clean ! Destroy a Router - public :: print ! Print info about a Router - - - interface init ; module procedure & - initd_, & ! initialize a Router between two seperate components - initp_ ! initialize a Router locally with two GSMaps - end interface - interface clean ; module procedure clean_ ; end interface - interface print ; module procedure print_ ; end interface - -! !REVISION HISTORY: -! 15Jan01 - R. Jacob - initial prototype -! 08Feb01 - R. Jacob add locsize and maxsize -! to Router type -! 25Sep02 - R. Jacob Remove type string. Add lAvsize -! 23Jul03 - R. Jacob Add status and reqs arrays used -! in send/recv to the Router datatype. -! 24Jul03 - R. Jacob Add real and integer buffers -! for send/recv to the Router datatype. -! 22Jan08 - R. Jacob Add ability to handle an unordered -! GSMap by creating a new, ordered one and building Router from -! that. Save permutation info in Router datatype. -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname='MCT::m_Router' - - contains - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: initd_ - initialize a Router between two seperate components -! -! !DESCRIPTION: -! The routine {\tt initd\_()} exchanges the {\tt GSMap} with the -! component identified by {\tt othercomp} and then calls {\tt initp\_()} -! to build a Router {\tt Rout} between them. -! -! {\bf N.B.} The {\tt GSMap} argument must be declared so that the index values -! on a processor are in ascending order. -! -! !INTERFACE: - - subroutine initd_(othercomp,GSMap,mycomm,Rout,name ) -! -! !USES: -! - use m_GlobalSegMap, only :GlobalSegMap - use m_ExchangeMaps,only: MCT_ExGSMap => ExchangeMap - use m_mpif90 - use m_die - - implicit none - -! !INPUT PARAMETERS: -! - integer, intent(in) :: othercomp - integer, intent(in) :: mycomm - type(GlobalSegMap),intent(in) :: GSMap ! of the calling comp - character(len=*), intent(in),optional :: name - -! !OUTPUT PARAMETERS: -! - type(Router), intent(out) :: Rout - -! !REVISION HISTORY: -! 15Jan01 - R. Jacob - initial prototype -! 06Feb01 - R. Jacob - Finish initialization -! of the Router. Router now works both ways. -! 25Apr01 - R. Jacob - Eliminate early -! custom code to exchange GSMap components and instead -! the more general purpose routine in m_ExchangeMaps. -! Use new subroutine OrderedPoints in m_GlobalSegMap -! to construct the vector of local and remote GSMaps. -! Clean-up code a little. -! 03May01 - R. Jacob - rename to initd and -! move most of code to new initp routine -! -!EOP ___________________________________________________________________ -! - character(len=*),parameter :: myname_=myname//'::initd_' - character(len=40) :: tagname - - type(GlobalSegMap) :: RGSMap ! the other GSMap - integer :: ier - -!--------------------------begin code----------------------- - -!!!!!!!!!!!!!!!!!Exchange of global map data - - if(present(name)) then - tagname='01'//name//'ExGSMap' - - call zeit_ci(trim(tagname)) - call MCT_ExGSMap(GSMap,mycomm,RGSMap,othercomp,ier) - if(ier /= 0) call die(myname_,'ExGSMap',ier) - call zeit_co(trim(tagname)) - -!!!!!!!!!!!!!!!!!Begin comparison of globalsegmaps - - call initp_(GSMap,RGSMap, mycomm, Rout,name) - else - call MCT_ExGSMap(GSMap,mycomm,RGSMap,othercomp,ier) - call initp_(GSMap,RGSMap, mycomm, Rout) - endif - - end subroutine initd_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: initp_ - initialize a Router from two GlobalSegMaps -! -! !DESCRIPTION: -! -! Given two GlobalSegmentMaps {\tt GSMap} and {\tt RGSMap}, intialize a -! Router {\tt Rout} between them. Use local communicator {\tt mycomm}. -! -! {\bf N.B.} The two {\tt GSMap} arguments must be declared so that the index values -! on a processor are in ascending order. -! -! !INTERFACE: - - subroutine initp_(inGSMap,inRGSMap,mycomm,Rout,name ) -! -! !USES: -! - use m_GlobalSegMap, only :GlobalSegMap - use m_GlobalSegMap, only :ProcessStorage - use m_GlobalSegMap, only :GSMap_comp_id => comp_id - use m_GlobalSegMap, only :GSMap_increasing => increasing - use m_GlobalSegMap, only :GlobalSegMap_copy => copy - use m_GlobalSegMap, only :GlobalSegMap_init => init - use m_GlobalSegMap, only :GlobalSegMap_clean => clean - use m_GlobalSegMap, only :GlobalSegMap_OPoints => OrderedPoints - use m_GlobalSegMap, only :GlobalSegMap_ngseg => ngseg ! rml - use m_GlobalSegMap, only :GlobalSegMap_nlseg => nlseg ! rml - use m_GlobalSegMap, only :GlobalSegMap_max_nlseg => max_nlseg ! rml - - use m_GlobalToLocal, only :GlobalToLocalIndex - use m_MCTWorld, only :MCTWorld - use m_MCTWorld, only :ThisMCTWorld - - use m_Permuter ,only:Permute - use m_MergeSorts ,only:IndexSet - use m_MergeSorts ,only:IndexSort - - use m_mpif90 - use m_die - -! use m_zeit - - - use m_stdio ! rml -! use shr_timer_mod ! rml timers - - implicit none - -! !INPUT PARAMETERS: -! - type(GlobalSegMap), intent(in) :: inGSMap - type(GlobalSegMap), intent(in) :: inRGSMap - integer , intent(in) :: mycomm - character(len=*), intent(in),optional :: name - -! !OUTPUT PARAMETERS: -! - type(Router), intent(out) :: Rout - -! !REVISION HISTORY: -! 03May01 - R.L. Jacob - Initial code brought -! in from old init routine. -! 31Jul01 - Jace A Mogill -! Rewrote to reduce number of loops and temp storage -! 26Apr06 - R. Loy - recode the search through -! the remote GSMap to improve efficiency -! 05Jan07 - R. Loy - improved bound on size of -! tmpsegcount and tmpsegstart -! 15May07 - R. Loy - improved bound on size of -! rgs_lb and rgs_ub -! 25Jan08 - R. Jacob - Dont die if GSMap is not -! increasing. Instead, permute it to increasing and proceed. -! 07Sep12 - T. Craig - Replace a double loop with a single -! to improve speed for large proc and segment counts. -!EOP ------------------------------------------------------------------- - - character(len=*),parameter :: myname_=myname//'::initp_' - integer :: ier,i,j,k,m,n - integer :: mysize,myPid,othercomp - integer :: lmaxsize,totallength - integer :: maxsegcount,count - logical, dimension(:), allocatable :: tmppe_list - integer, dimension(:,:), pointer :: tmpsegcount,tmpsegstart - - - integer :: my_left ! Left point in local segment (global memory) - integer :: my_right ! Right point in local segment (global memory) - integer :: r_left ! Left point in remote segment (global memory) - integer :: r_right ! Right point in remote segment (global memory) - integer :: nsegs_overlap ! Number of segments that overlap between two procs - - - integer :: ngseg, nlseg - integer :: myseg, rseg - integer :: prev_right ! Rightmost local point in previous overlapped segment - integer :: local_left, local_right - integer,allocatable :: mygs_lb(:),mygs_ub(:),mygs_len(:),mygs_lstart(:) - integer :: r_ngseg - integer :: r_max_nlseg ! max number of local segments in RGSMap - integer,allocatable :: rgs_count(:),rgs_lb(:,:),rgs_ub(:,:) - integer,allocatable :: nsegs_overlap_arr(:) - - integer :: overlap_left, overlap_right, overlap_diff - - integer :: proc, nprocs - - integer :: max_rgs_count, max_overlap_segs - type(GlobalSegMap) :: GSMap - type(GlobalSegMap) :: RGSMap - integer, dimension(:), pointer :: gpoints - integer, dimension(:), pointer :: permarr - integer, dimension(:), pointer :: rpermarr - integer :: gmapsize - character(len=40) :: tagname - - - integer,save :: t_initialized=0 ! rml timers - integer,save :: t_loop ! rml timers - integer,save :: t_loop2 ! rml timers - integer,save :: t_load ! rml timers - - call MP_comm_rank(mycomm,myPid,ier) - if(ier/=0) call MP_perr_die(myname_,'MP_comm_rank',ier) - - nullify(Rout%permarr) - - if(present(name)) then - tagname='02'//name//'incheck' - call zeit_ci(trim(tagname)) - endif - if (.not. GSMap_increasing(inGSMap)) then - if(myPid == 0) call warn(myname_,'GSMap indices not increasing...Will correct') - call GlobalSegMap_OPoints(inGSMap,myPid,gpoints) - gmapsize=ProcessStorage(inGSMap,myPid) - allocate(permarr(gmapsize), stat=ier) - if(ier/=0) call die(myname_,'allocate permarr',ier) - call IndexSet(permarr) - call IndexSort(permarr,gpoints) - call Permute(gpoints,permarr,gmapsize) - call GlobalSegMap_init(GSMap,gpoints,mycomm,inGSMap%comp_id,gsize=inGSMap%gsize) - - allocate(Rout%permarr(gmapsize),stat=ier) - if(ier/=0) call die(myname_,'allocate Router%permarr',ier) - Rout%permarr(:)=permarr(:) - - deallocate(gpoints,permarr, stat=ier) - if(ier/=0) call die(myname_,'deallocate gpoints,permarr',ier) - - else - call GlobalSegMap_copy(inGSMap,GSMap) - endif - - if (.not. GSMap_increasing(inRGSMap)) then - if(myPid == 0) call warn(myname_,'RGSMap indices not increasing...Will correct') - call GlobalSegMap_OPoints(inRGSMap,myPid,gpoints) - gmapsize=ProcessStorage(inRGSMap,myPid) - allocate(rpermarr(gmapsize), stat=ier) - if(ier/=0) call die(myname_,'allocate rpermarr',ier) - call IndexSet(rpermarr) - call IndexSort(rpermarr,gpoints) - call Permute(gpoints,rpermarr,gmapsize) - - call GlobalSegMap_init(RGSMap,gpoints,mycomm,inRGSMap%comp_id,gsize=inRGSMap%gsize) - - deallocate(gpoints,rpermarr, stat=ier) - if(ier/=0) call die(myname_,'deallocate gpoints,rpermarr',ier) - else - call GlobalSegMap_copy(inRGSMap,RGSMap) - endif - if(present(name)) then - call zeit_co(trim(tagname)) - endif - - - mysize = ProcessStorage(GSMap,myPid) - othercomp = GSMap_comp_id(RGSMap) - - -!. . . . . . . . . . . . . . . . . . . . . . . . - - - -!! -!! determine the global segments on this processor -!! just once, so the info be used repeatedly below -!! same code was used in m_GlobalToLocal - should make a subroutine... -!! - if(present(name)) then - tagname='03'//name//'lloop' - call zeit_ci(trim(tagname)) - endif - - ngseg = GlobalSegMap_ngseg(GSMap) - nlseg = GlobalSegMap_nlseg(GSMap, myPid) - - allocate( mygs_lb(nlseg), mygs_ub(nlseg), mygs_len(nlseg), & - mygs_lstart(nlseg), stat=ier ) - if(ier/=0) call die(myname_,'allocate mygs',ier) - - n = 0 - do i=1,ngseg - if (GSMap%pe_loc(i) == myPid ) then - n=n+1 - mygs_lb(n)=GSMap%start(i) - mygs_ub(n)=GSMap%start(i) + GSMap%length(i) -1 - mygs_len(n)=GSMap%length(i) - endif - enddo - - if (n .ne. nlseg) then - write(stderr,*) myname_,"mismatch nlseg",n,nlseg - call die(myname) - endif - - if (nlseg > 0) mygs_lstart(1)=1 - do i=2,nlseg - mygs_lstart(i)=mygs_lstart(i-1)+mygs_len(i-1) - enddo - if(present(name)) then - call zeit_co(trim(tagname)) - endif - - -!! -!! determine the segments in RGSMap that are local to each proc -!! - - nprocs=ThisMCTWorld%nprocspid(othercomp) - r_ngseg = GlobalSegMap_ngseg(RGSMap) - - !! original size of rgs_lb()/ub() was (r_ngseg,nprocs) - !! at the cost of looping to compute it (within GlobalSegMap_max_nlseg), - !! reduced size to (r_max_nlseg,nprocs) - !! further reduction could be made by flattening it to one dimension - !! of size (r_ngseg) and allocating another array to index into it. - !! would not improve overall mem use unless this were also done for - !! tmpsegstart()/count() and possibly seg_starts()/lengths (the - !! latter would be a major change). - - if(present(name)) then - tagname='04'//name//'rloop' - call zeit_ci(trim(tagname)) - endif - r_max_nlseg = GlobalSegMap_max_nlseg(RGSMap) - - allocate( rgs_count(nprocs) , & - rgs_lb(r_max_nlseg,nprocs), rgs_ub(r_max_nlseg,nprocs), & - nsegs_overlap_arr(nprocs), stat=ier ) - if(ier/=0) call die(myname_,'allocate rgs, nsegs',ier) - -! tcraig, updated loop - rgs_count = 0 !! number of segments in RGSMap local to proc - - do i=1,r_ngseg - proc = RGSMap%pe_loc(i) + 1 -! if (proc < 1 .or. proc > nprocs) then -! write(stderr,*) myname_,"proc pe_loc error",i,proc -! call die(myname_,'pe_loc error',0) -! endif - rgs_count(proc) = rgs_count(proc) +1 - rgs_lb( rgs_count(proc) , proc )=RGSMap%start(i) - rgs_ub( rgs_count(proc) , proc )=RGSMap%start(i) + RGSMap%length(i) -1 - enddo - - if(present(name)) then - call zeit_co(trim(tagname)) - endif - -!!! -!!! this is purely for error checking - - if(present(name)) then - tagname='05'//name//'erchck' - call zeit_ci(trim(tagname)) - endif - do proc = 1, nprocs - if (rgs_count(proc) > r_max_nlseg) then - write(stderr,*) myname_,"overflow on rgs array",proc,rgs_count(proc) - call die(myname_,'overflow on rgs',0) - endif - enddo - if(present(name)) then - call zeit_co(trim(tagname)) - endif - -!!! - - -!!!!!!!!!!!!!!!!!! - -! allocate space for searching -! overlap segments to a given remote proc cannot be more than -! the max of the local segments and the remote segments - - if(present(name)) then - tagname='06'//name//'loop2' - call zeit_ci(trim(tagname)) - endif - max_rgs_count=0 - do proc=1,nprocs - max_rgs_count = max( max_rgs_count, rgs_count(proc) ) - enddo - - max_overlap_segs = max(nlseg,max_rgs_count) - - allocate(tmpsegcount(ThisMCTWorld%nprocspid(othercomp), max_overlap_segs),& - tmpsegstart(ThisMCTWorld%nprocspid(othercomp), max_overlap_segs),& - tmppe_list(ThisMCTWorld%nprocspid(othercomp)),stat=ier) - if(ier/=0) & - call die( myname_,'allocate tmpsegcount etc. size ', & - ThisMCTWorld%nprocspid(othercomp), & - ' by ',max_overlap_segs) - - - tmpsegcount=0 - tmpsegstart=0 - count =0 - maxsegcount=0 - -!!!!!!!!!!!!!!!!!! - - - do proc = 1, nprocs - nsegs_overlap = 0 - tmppe_list(proc) = .FALSE. ! no overlaps with proc yet - - if ( rgs_count(proc) > 0 ) then - do myseg = 1, nlseg ! loop over local segs on 'myPID' - - my_left = mygs_lb(myseg) - my_right= mygs_ub(myseg) - - do rseg = 1, rgs_count(proc) ! loop over remote segs on 'proc' - - r_left = rgs_lb(rseg,proc) - r_right = rgs_ub(rseg,proc) - - if (.not. (my_right < r_left .or. & ! overlap - my_left > r_right) ) then - - if (nsegs_overlap == 0) then ! first overlap w/this proc - count = count + 1 - tmppe_list(proc) = .TRUE. - prev_right = -9999 - else - prev_right = local_right - endif - - overlap_left=max(my_left, r_left) - overlap_right=min(my_right, r_right) - overlap_diff= overlap_right - overlap_left - - local_left = mygs_lstart(myseg) + (overlap_left - my_left) - local_right = local_left + overlap_diff - - ! non-contiguous w/prev one - if (local_left /= (prev_right+1) ) then - nsegs_overlap = nsegs_overlap + 1 - tmpsegstart(count, nsegs_overlap) = local_left - endif - - tmpsegcount(count, nsegs_overlap) = & - tmpsegcount(count, nsegs_overlap) + overlap_diff + 1 - - endif - enddo - enddo - endif - - nsegs_overlap_arr(proc)=nsegs_overlap - enddo - - !! pull this out of the loop to vectorize - do proc=1,nprocs - maxsegcount=max(maxsegcount,nsegs_overlap_arr(proc)) - enddo - - - if (maxsegcount > max_overlap_segs) & - call die( myname_,'overran max_overlap_segs =', & - max_overlap_segs, ' count = ',maxsegcount) - -! write(stderr,*) 'max_overlap_segs =', max_overlap_segs, & -! 'maxsegcount =',maxsegcount, & -! 'mysize =',mysize - - - deallocate( mygs_lb, mygs_ub, mygs_len, mygs_lstart, & - rgs_count, rgs_lb, rgs_ub, & - nsegs_overlap_arr, stat=ier) - if(ier/=0) call die(myname_,'deallocate mygs,rgs,nsegs',ier) - - -! call shr_timer_stop(t_loop2) ! rml timers - if(present(name)) then - call zeit_co(trim(tagname)) - endif - - - -!. . . . . . . . . . . . . . . . . . . . . . . . - - -!!!!!!!!!!!!!!!!!!!!end of search through remote GSMap - -! start loading up the Router with data - - if(present(name)) then - tagname='07'//name//'load' - call zeit_ci(trim(tagname)) - endif - - Rout%comp1id = GSMap_comp_id(GSMap) - Rout%comp2id = othercomp - Rout%nprocs = count - Rout%numiatt = 0 - Rout%numratt = 0 - - allocate(Rout%pe_list(count),Rout%num_segs(count), & - Rout%seg_starts(count,maxsegcount), & - Rout%seg_lengths(count,maxsegcount), & - Rout%locsize(count),stat=ier) - if(ier/=0) call die(myname_,'allocate(Rout..)',ier) - - allocate(Rout%istatus(MP_STATUS_SIZE,count), & - Rout%rstatus(MP_STATUS_SIZE,count), & - Rout%rreqs(count),Rout%ireqs(count),stat=ier) - if(ier/=0) call die(myname_,'allocate(status,reqs,...)',ier) - -! allocate the number of pointers needed - allocate(Rout%ip1(count),stat=ier) - if(ier/=0) call die(myname_,'allocate(ip1)',ier) - -! allocate the number of pointers needed - allocate(Rout%rp1(count),stat=ier) - if(ier/=0) call die(myname_,'allocate(rp1)',ier) - - - - m=0 - do i=1,ThisMCTWorld%nprocspid(othercomp) - if(tmppe_list(i))then - m=m+1 - ! load processor rank in MCT_comm - Rout%pe_list(m)=ThisMCTWorld%idGprocid(othercomp,i-1) - endif - enddo - - lmaxsize=0 - do i=1,count - totallength=0 - do j=1,maxsegcount - if(tmpsegcount(i,j) /= 0) then - Rout%num_segs(i)=j - Rout%seg_starts(i,j)=tmpsegstart(i,j) - Rout%seg_lengths(i,j)=tmpsegcount(i,j) - totallength=totallength+Rout%seg_lengths(i,j) - endif - enddo - Rout%locsize(i)=totallength - lmaxsize=MAX(lmaxsize,totallength) - enddo - - Rout%maxsize=lmaxsize - Rout%lAvsize=mysize - - - deallocate(tmpsegstart,tmpsegcount,tmppe_list,stat=ier) - if(ier/=0) call die(myname_,'deallocate()',ier) - - call GlobalSegMap_clean(RGSMap) - call GlobalSegMap_clean(GSMap) - - - if(present(name)) then - call zeit_co(trim(tagname)) - endif - - end subroutine initp_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: clean_ - Destroy a Router -! -! !DESCRIPTION: -! Deallocate Router internal data structures and set integer parts to zero. -! -! !INTERFACE: - - subroutine clean_(Rout,stat) -! -! !USES: -! - use m_die - - implicit none - -!INPUT/OUTPUT PARAMETERS: - type(Router), intent(inout) :: Rout - -!OUTPUT PARAMETERS: - integer, optional, intent(out) :: stat - -! !REVISION HISTORY: -! 15Jan01 - R. Jacob - initial prototype -! 08Feb01 - R. Jacob - add code to clean -! the maxsize and locsize -! 01Mar02 - E.T. Ong removed the die to prevent -! crashes and added stat argument. -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::clean_' - integer :: ier - - deallocate(Rout%pe_list,Rout%num_segs,Rout%seg_starts, & - Rout%locsize,Rout%seg_lengths,stat=ier) - if(present(stat)) then - stat=ier - else - if(ier /= 0) call warn(myname_,'deallocate(Rout%pe_list,...)',ier) - endif - - deallocate(Rout%rreqs,Rout%ireqs,Rout%rstatus,& - Rout%istatus,stat=ier) - if(present(stat)) then - stat=ier - else - if(ier /= 0) call warn(myname_,'deallocate(Rout%rreqs,...)',ier) - endif - - deallocate(Rout%ip1,Rout%rp1,stat=ier) - if(present(stat)) then - stat=ier - else - if(ier /= 0) call warn(myname_,'deallocate(Rout%ip1,...)',ier) - endif - - if(associated(Rout%permarr)) then - deallocate(Rout%permarr,stat=ier) - if(present(stat)) then - stat=ier - else - if(ier /= 0) call warn(myname_,'deallocate(Rout%ip1,...)',ier) - endif - endif - - Rout%comp1id = 0 - Rout%comp2id = 0 - Rout%nprocs = 0 - Rout%maxsize = 0 - Rout%lAvsize = 0 - Rout%numiatt = 0 - Rout%numratt = 0 - - - end subroutine clean_ - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: print_ - Print router info -! -! !DESCRIPTION: -! Print out communication info about router on unit number 'lun' -! e.g. (source,destination,length) -! -! !INTERFACE: - - subroutine print_(rout,mycomm,lun) -! -! !USES: -! - use m_die - use m_mpif90 - - implicit none - -!INPUT/OUTPUT PARAMETERS: - type(Router), intent(in) :: Rout - integer, intent(in) :: mycomm - integer, intent(in) :: lun - -! !REVISION HISTORY: -! 27Jul07 - R. Loy initial version -!EOP ___________________________________________________________________ - - - integer iproc - integer myrank - integer ier - character(len=*),parameter :: myname_=myname//'::print_' - - call MP_comm_rank(mycomm,myrank,ier) - if(ier/=0) call MP_perr_die(myname_,'MP_comm_rank',ier) - - - do iproc=1,rout%nprocs - if (rout%num_segs(iproc) > 0) then - write(lun,*) myrank,rout%pe_list(iproc),rout%locsize(iproc) - endif - end do - - - end subroutine print_ - - - end module m_Router - diff --git a/cesm/models/utils/mct/mct/m_SparseMatrix.F90 b/cesm/models/utils/mct/mct/m_SparseMatrix.F90 deleted file mode 100644 index 1e32f5e..0000000 --- a/cesm/models/utils/mct/mct/m_SparseMatrix.F90 +++ /dev/null @@ -1,2767 +0,0 @@ -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!----------------------------------------------------------------------- -! CVS $Id$ -! CVS $Name$ -!BOP ------------------------------------------------------------------- -! -! !MODULE: m_SparseMatrix -- Sparse Matrix Object -! -! !DESCRIPTION: -! The {\tt SparseMatrix} data type is MCT's object for storing sparse -! matrices. In MCT, intergrid interpolation is implemented as a sparse -! matrix-vector multiplication, with the {\tt AttrVect} type playing the -! roles of the input and output vectors. The interpolation matrices tend -! to be {\em extremely} sparse. For ${\bf x} \in \Re^{N_x}$, and -! ${\bf y} \in \Re^{N_y}$, the interpolation matrix {\bf M} used to effect -! ${\bf y} = {\bf M} {\bf x}$ will typically have ${\cal O}({N_y})$ -! non-zero elements. For that reason, the {\tt SparseMatrix} type -! stores {\em only} information about non-zero matrix elements, along -! with the number of rows and columns in the full matrix. The nonzero -! matrix elements are stored in {\tt AttrVect} form (see the module -! {\tt m\_AttrVect} for more details), and the set of attributes are -! listed below: -! -!\begin{table}[htbp] -!\begin{center} -!\begin{tabular}{|l|l|l|} -!\hline -!{\bf Attribute Name} & {\bf Significance} & {\tt Type} \\ -!\hline -!{\tt grow} & Global Row Index & {\tt INTEGER} \\ -!\hline -!{\tt gcol} & Global Column Index & {\tt INTEGER} \\ -!\hline -!{\tt lrow} & Local Row Index & {\tt INTEGER} \\ -!\hline -!{\tt lcol} & Local Column Index & {\tt INTEGER} \\ -!\hline -!{\tt weight} & Matrix Element ${M_{ij}}$ & {\tt REAL} \\ -!\hline -!\end{tabular} -!\end{center} -!\end{table} -! -! The provision of both local and global column and row indices is -! made because this datatype can be used in either shared-memory or -! distributed-memory parallel matrix-vector products. -! -! This module contains the definition of the {\tt SparseMatrix} type, -! creation and destruction methods, a variety of accessor methods, -! routines for testing the suitability of the matrix for interpolation -! (i.e. the sum of each row is either zero or unity), and methods for -! sorting and permuting matrix entries. -! -! For better performance of the Matrix-Vector multiply on vector -! architectures, the {\tt SparseMatrix} object also contains arrays -! for holding the sparse matrix data in a more vector-friendly form. -! -! -! !INTERFACE: - - module m_SparseMatrix -! -! !USES: -! - use m_realkinds, only : FP - use m_AttrVect, only : AttrVect - - - private ! except - -! !PUBLIC TYPES: - - public :: SparseMatrix ! The class data structure - - Type SparseMatrix -#ifdef SEQUENCE - sequence -#endif - integer :: nrows - integer :: ncols - type(AttrVect) :: data - logical :: vecinit ! additional data for the vectorized sMat - integer,dimension(:),pointer :: row_s, row_e - integer, dimension(:,:), pointer :: tcol - real(FP), dimension(:,:), pointer :: twgt - integer :: row_max, row_min - integer :: tbl_end - End Type SparseMatrix - -! !PUBLIC MEMBER FUNCTIONS: - - public :: init ! Create a SparseMatrix - public :: vecinit ! Initialize the vector parts - public :: clean ! Destroy a SparseMatrix - public :: lsize ! Local number of elements - public :: indexIA ! Index integer attribute - public :: indexRA ! Index real attribute - public :: nRows ! Total number of rows - public :: nCols ! Total number of columns - - public :: exportGlobalRowIndices ! Return global row indices - ! for matrix elements - public :: exportGlobalColumnIndices ! Return global column indices - ! for matrix elements - public :: exportLocalRowIndices ! Return local row indices - ! for matrix elements - public :: exportLocalColumnIndices ! Return local column indices - ! for matrix elements - public :: exportMatrixElements ! Return matrix elements - - public :: importGlobalRowIndices ! Set global row indices - ! using - public :: importGlobalColumnIndices ! Return global column indices - ! for matrix elements - public :: importLocalRowIndices ! Return local row indices - ! for matrix elements - public :: importLocalColumnIndices ! Return local column indices - ! for matrix elements - public :: importMatrixElements ! Return matrix elements - public :: Copy ! Copy a SparseMatrix - - public :: GlobalNumElements ! Total number of nonzero elements - public :: ComputeSparsity ! Fraction of matrix that is nonzero - public :: local_row_range ! Local (on-process) row range - public :: global_row_range ! Local (on-process) row range - public :: local_col_range ! Local (on-process) column range - public :: global_col_range ! Local (on-process) column range - public :: CheckBounds ! Check row and column values - ! for out-of-bounds values - public :: row_sum ! Return SparseMatrix row sums - public :: row_sum_check ! Check SparseMatrix row sums against - ! input "valid" values - public :: Sort ! Sort matrix entries to generate an - ! index permutation (to be used by - ! Permute() - public :: Permute ! Permute matrix entries using index - ! permutation gernerated by Sort() - public :: SortPermute ! Sort/Permute matrix entries - - interface init ; module procedure init_ ; end interface - interface vecinit ; module procedure vecinit_ ; end interface - interface clean ; module procedure clean_ ; end interface - interface lsize ; module procedure lsize_ ; end interface - interface indexIA ; module procedure indexIA_ ; end interface - interface indexRA ; module procedure indexRA_ ; end interface - interface nRows ; module procedure nRows_ ; end interface - interface nCols ; module procedure nCols_ ; end interface - - interface exportGlobalRowIndices ; module procedure & - exportGlobalRowIndices_ - end interface - - interface exportGlobalColumnIndices ; module procedure & - exportGlobalColumnIndices_ - end interface - - interface exportLocalRowIndices ; module procedure & - exportLocalRowIndices_ - end interface - - interface exportLocalColumnIndices ; module procedure & - exportLocalColumnIndices_ - end interface - - interface exportMatrixElements ; module procedure & - exportMatrixElementsSP_, & - exportMatrixElementsDP_ - end interface - - interface importGlobalRowIndices ; module procedure & - importGlobalRowIndices_ - end interface - - interface importGlobalColumnIndices ; module procedure & - importGlobalColumnIndices_ - end interface - - interface importLocalRowIndices ; module procedure & - importLocalRowIndices_ - end interface - - interface importLocalColumnIndices ; module procedure & - importLocalColumnIndices_ - end interface - - interface importMatrixElements ; module procedure & - importMatrixElementsSP_, & - importMatrixElementsDP_ - end interface - - interface Copy ; module procedure Copy_ ; end interface - - interface GlobalNumElements ; module procedure & - GlobalNumElements_ - end interface - - interface ComputeSparsity ; module procedure & - ComputeSparsitySP_, & - ComputeSparsityDP_ - end interface - - interface local_row_range ; module procedure & - local_row_range_ - end interface - - interface global_row_range ; module procedure & - global_row_range_ - end interface - - interface local_col_range ; module procedure & - local_col_range_ - end interface - - interface global_col_range ; module procedure & - global_col_range_ - end interface - - interface CheckBounds; module procedure & - CheckBounds_ - end interface - - interface row_sum ; module procedure & - row_sumSP_, & - row_sumDP_ - end interface - - interface row_sum_check ; module procedure & - row_sum_checkSP_, & - row_sum_checkDP_ - end interface - - interface Sort ; module procedure Sort_ ; end interface - interface Permute ; module procedure Permute_ ; end interface - interface SortPermute ; module procedure SortPermute_ ; end interface - -! !REVISION HISTORY: -! 19Sep00 - J.W. Larson - initial prototype -! 15Jan01 - J.W. Larson - added numerous APIs -! 25Feb01 - J.W. Larson - changed from row/column -! attributes to global and local row and column attributes -! 23Apr01 - J.W. Larson - added number of rows -! and columns to the SparseMatrix type. This means the -! SparseMatrix is no longer a straight AttrVect type. This -! also made necessary the addition of lsize(), indexIA(), -! and indexRA(). -! 29Oct03 - R. Jacob - extend the SparseMatrix type -! to include mods from Fujitsu for a vector-friendly MatVecMul -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname='MCT::m_SparseMatrix' - -! SparseMatrix_iList components: - character(len=*),parameter :: SparseMatrix_iList='grow:gcol:lrow:lcol' - integer,parameter :: SparseMatrix_igrow=1 - integer,parameter :: SparseMatrix_igcol=2 - integer,parameter :: SparseMatrix_ilrow=3 - integer,parameter :: SparseMatrix_ilcol=4 - -! SparseMatrix_rList components: - character(len=*),parameter :: SparseMatrix_rList='weight' - integer,parameter :: SparseMatrix_iweight=1 - - contains - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: init_ - Initialize an Empty SparseMatrix -! -! !DESCRIPTION: This routine creates the storage space for the -! entries of a {\tt SparseMatrix}, and sets the number of rows and -! columns in it. The input {\tt INTEGER} arguments {\tt nrows} and -! {\tt ncols} specify the number of rows and columns respectively. -! The optional input argument {\tt lsize} specifies the number of -! nonzero entries in the {\tt SparseMatrix}. The initialized -! {\tt SparseMatrix} is returned in the output argument {\tt sMat}. -! -! {\bf N.B.}: This routine is allocating dynamical memory in the form -! of a {\tt SparseMatrix}. The user must deallocate this space when -! the {\tt SparseMatrix} is no longer needed by invoking the routine -! {\tt clean\_()}. -! -! !INTERFACE: - - subroutine init_(sMat, nrows, ncols, lsize) -! -! !USES: -! - use m_AttrVect, only : AttrVect_init => init - use m_die - - implicit none - -! !INPUT PARAMETERS: - - integer, intent(in) :: nrows - integer, intent(in) :: ncols - integer, optional, intent(in) :: lsize - -! !OUTPUT PARAMETERS: - - type(SparseMatrix), intent(out) :: sMat - -! !REVISION HISTORY: -! 19Sep00 - Jay Larson - initial prototype -! 23Apr01 - Jay Larson - added arguments -! nrows and ncols--number of rows and columns in the -! SparseMatrix -!EOP ___________________________________________________________________ -! - character(len=*),parameter :: myname_=myname//'::init_' - - integer :: n - - ! if lsize is present, use it to set n; if not, set n=0 - - n = 0 - if(present(lsize)) n=lsize - - ! Initialize number of rows and columns: - - sMat%nrows = nrows - sMat%ncols = ncols - - ! Initialize sMat%data using AttrVect_init - - call AttrVect_init(sMat%data, SparseMatrix_iList, & - SparseMatrix_rList, n) - - ! vecinit is off by default - sMat%vecinit = .FALSE. - - end subroutine init_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: vecinit_ - Initialize vector parts of a SparseMatrix -! -! !DESCRIPTION: This routine creates the storage space for -! and intializes the vector parts of a {\tt SparseMatrix}. -! -! {\bf N.B.}: This routine assumes the locally indexed parts of a -! {\tt SparseMatrix} have been initialized. This is -! accomplished by either importing the values directly with -! {\tt importLocalRowIndices} and {\tt importLocalColIndices} or by -! importing the Global Row and Col Indices and making two calls to -! {\tt GlobalToLocalMatrix}. -! -! {\bf N.B.}: The vector portion can use a large amount of -! memory so it is highly recommended that this routine only -! be called on a {\tt SparseMatrix} that has been scattered -! or otherwise sized locally. -! -! !INTERFACE: - - subroutine vecinit_(sMat) -! -! !USES: -! - use m_die - use m_stdio - - implicit none - -! !INPUT/OUTPUT PARAMETERS: - - type(SparseMatrix), intent(inout) :: sMat - -! !REVISION HISTORY: -! 27Oct03 - R. Jacob - initial version -! using code provided by Yoshi et. al. -!EOP ___________________________________________________________________ -! - character(len=*),parameter :: myname_=myname//'::vecinit_' - - integer :: irow,icol,iwgt - integer :: num_elements - integer :: row,col - integer :: ier,l,n - integer, dimension(:) , allocatable :: nr, rn - - if(sMat%vecinit) then - write(stderr,'(2a)') myname_, & - 'MCTERROR: sMat vector parts have already been initialized...Continuing' - RETURN - endif - - write(6,*) myname_,'Initializing vecMat' - irow = indexIA_(sMat,'lrow',dieWith=myname_) - icol = indexIA_(sMat,'lcol',dieWith=myname_) - iwgt = indexRA_(sMat,'weight',dieWith=myname_) - - num_elements = lsize_(sMat) - - sMat%row_min = sMat%data%iAttr(irow,1) - sMat%row_max = sMat%row_min - do n=1,num_elements - row = sMat%data%iAttr(irow,n) - if ( row > sMat%row_max ) sMat%row_max = row - if ( row < sMat%row_min ) sMat%row_min = row - enddo - - allocate( nr(sMat%row_max), rn(num_elements), stat=ier) - if(ier/=0) call die(myname_,'allocate(nr,rn)',ier) - - sMat%tbl_end = 0 - nr(:) = 0 - do n=1,num_elements - row = sMat%data%iAttr(irow,n) - nr(row) = nr(row)+1 - rn(n) = nr(row) - enddo - sMat%tbl_end = maxval(rn) - - allocate( sMat%tcol(sMat%row_max,sMat%tbl_end), & - sMat%twgt(sMat%row_max,sMat%tbl_end), stat=ier ) - if(ier/=0) call die(myname_,'allocate(tcol,twgt)',ier) - -!CDIR COLLAPSE - sMat%tcol(:,:) = -1 - do n=1,num_elements - row = sMat%data%iAttr(irow,n) - sMat%tcol(row,rn(n)) = sMat%data%iAttr(icol,n) - sMat%twgt(row,rn(n)) = sMat%data%rAttr(iwgt,n) - enddo - - allocate( sMat%row_s(sMat%tbl_end) , sMat%row_e(sMat%tbl_end), & - stat=ier ) - if(ier/=0) call die(myname_,'allocate(row_s,row_e',ier) - sMat%row_s = sMat%row_min - sMat%row_e = sMat%row_max - do l=1,sMat%tbl_end - do n=sMat%row_min,sMat%row_max - if (nr(n) >= l) then - sMat%row_s(l) = n - exit - endif - enddo - do n = sMat%row_max,sMat%row_min,-1 - if (nr(n) >= l) then - sMat%row_e(l) = n - exit - endif - enddo - enddo - - deallocate(nr,rn, stat=ier) - if(ier/=0) call die(myname_,'deallocate()',ier) - - sMat%vecinit = .TRUE. - - end subroutine vecinit_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: clean_ - Destroy a SparseMatrix. -! -! !DESCRIPTION: This routine deallocates dynamical memory held by the -! input {\tt SparseMatrix} argument {\tt sMat}. It also sets the number -! of rows and columns in the {\tt SparseMatrix} to zero. -! -! !INTERFACE: - - subroutine clean_(sMat,stat) -! -! !USES: -! - use m_AttrVect,only : AttrVect_clean => clean - use m_die - - implicit none - -! !INPUT/OUTPTU PARAMETERS: - - type(SparseMatrix), intent(inout) :: sMat - -! !OUTPUT PARAMETERS: - - integer, optional, intent(out) :: stat - -! !REVISION HISTORY: -! 19Sep00 - J.W. Larson - initial prototype -! 23Apr00 - J.W. Larson - added changes to -! accomodate clearing nrows and ncols. -! 01Mar02 - E.T. Ong Added stat argument. -! 03Oct03 - R. Jacob - clean vector parts -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::clean_' - integer :: ier - - ! Deallocate memory held by sMat: - - if(present(stat)) then - call AttrVect_clean(sMat%data,stat) - else - call AttrVect_clean(sMat%data) - endif - - ! Set the number of rows and columns in sMat to zero: - - sMat%nrows = 0 - sMat%ncols = 0 - - if(sMat%vecinit) then - sMat%row_max = 0 - sMat%row_min = 0 - sMat%tbl_end = 0 - deallocate(sMat%row_s,sMat%row_e,stat=ier) - if(ier/=0) then - if(present(stat)) then - stat=ier - else - call warn(myname_,'deallocate(row_s,row_e)',ier) - endif - endif - - deallocate(sMat%tcol,sMat%twgt,stat=ier) - if(ier/=0) then - if(present(stat)) then - stat=ier - else - call warn(myname_,'deallocate(tcol,twgt)',ier) - endif - endif - sMat%vecinit = .FALSE. - endif - - - end subroutine clean_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: lsize_ - Local Number Non-zero Elements -! -! !DESCRIPTION: This {\tt INTEGER} function reports on-processor storage -! of the number of nonzero elements in the input {\tt SparseMatrix} -! argument {\tt sMat}. -! -! !INTERFACE: - - integer function lsize_(sMat) -! -! !USES: -! - use m_AttrVect,only : AttrVect_lsize => lsize - - implicit none - -! !INPUT PARAMETERS: - - type(SparseMatrix), intent(in) :: sMat - -! !REVISION HISTORY: -! 23Apr00 - J.W. Larson - initial version. -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::lsize_' - - lsize_ = AttrVect_lsize(sMat%data) - - end function lsize_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: GlobalNumElements_ - Global Number of Non-zero Elements -! -! !DESCRIPTION: This routine computes the number of nonzero elements -! in a distributed {\tt SparseMatrix} variable {\tt sMat}. The input -! {\tt SparseMatrix} argument {\tt sMat} is examined on each process -! to determine the number of nonzero elements it holds, and this value -! is summed across the communicator associated with the input -! {\tt INTEGER} handle {\tt comm}, with the total returned {\em on each -! process on the communicator}. -! -! !INTERFACE: - - integer function GlobalNumElements_(sMat, comm) - -! -! !USES: -! - use m_die - use m_mpif90 - - implicit none - -! !INPUT PARAMETERS: - - type(SparseMatrix), intent(in) :: sMat - integer, optional, intent(in) :: comm - -! !REVISION HISTORY: -! 24Apr01 - Jay Larson - New routine. -! -!EOP ___________________________________________________________________ -! - character(len=*),parameter :: myname_=myname//':: GlobalNumElements_' - - integer :: MyNumElements, GNumElements, ierr - - ! Determine the number of locally held nonzero elements: - - MyNumElements = lsize_(sMat) - - call MPI_ALLREDUCE(MyNumElements, GNumElements, 1, MP_INTEGER, & - MP_SUM, comm, ierr) - if(ierr /= 0) then - call MP_perr_die(myname_,"MPI_ALLREDUCE(MyNumElements...",ierr) - endif - - GlobalNumElements_ = GNumElements - - end function GlobalNumElements_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: indexIA_ - Index an Integer Attribute -! -! !DESCRIPTION: This {\tt INTEGER} function reports the row index -! for a given {\tt INTEGER} attribute of the input {\tt SparseMatrix} -! argument {\tt sMat}. The attribute requested is represented by the -! input {\tt CHARACTER} variable {\tt attribute}. The list of integer -! attributes one can request is defined in the description block of the -! header of this module ({\tt m\_SparseMatrix}). -! -! Here is how {\tt indexIA\_} provides access to integer attribute data -! in a {\tt SparseMatrix} variable {\tt sMat}. Suppose we wish to access -! global row information. This attribute has associated with it the -! string tag {\tt grow}. The corresponding index returned ({\tt igrow}) -! is determined by invoking {\tt indexIA\_}: -! \begin{verbatim} -! igrow = indexIA_(sMat, 'grow') -! \end{verbatim} -! -! Access to the global row index data in {\tt sMat} is thus obtained by -! referencing {\tt sMat\%data\%iAttr(igrow,:)}. -! -! -! !INTERFACE: - - integer function indexIA_(sMat, item, perrWith, dieWith) -! -! !USES: -! - use m_String, only : String - use m_String, only : String_init => init - use m_String, only : String_clean => clean - use m_String, only : String_ToChar => ToChar - - use m_TraceBack, only : GenTraceBackString - - use m_AttrVect,only : AttrVect_indexIA => indexIA - - implicit none - -! !INPUT PARAMETERS: - - type(SparseMatrix), intent(in) :: sMat - character(len=*), intent(in) :: item - character(len=*), optional, intent(in) :: perrWith - character(len=*), optional, intent(in) :: dieWith - -! !REVISION HISTORY: -! 23Apr00 - J.W. Larson - initial version. -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::indexIA_' - type(String) :: myTrace - - ! Generate a traceback String - - if(present(dieWith)) then - call GenTraceBackString(myTrace, dieWith, myname_) - else - if(present(perrWith)) then - call GenTraceBackString(myTrace, perrWith, myname_) - else - call GenTraceBackString(myTrace, myname_) - endif - endif - - ! Call AttrVect_indexIA() accordingly: - - if( present(dieWith) .or. & - ((.not. present(dieWith)) .and. (.not. present(perrWith))) ) then - indexIA_ = AttrVect_indexIA(sMat%data, item, & - dieWith=String_ToChar(myTrace)) - else ! perrWith but no dieWith case - indexIA_ = AttrVect_indexIA(sMat%data, item, & - perrWith=String_ToChar(myTrace)) - endif - - call String_clean(myTrace) - - end function indexIA_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: indexRA_ - Index a Real Attribute -! -! !DESCRIPTION: This {\tt INTEGER} function reports the row index -! for a given {\tt REAL} attribute of the input {\tt SparseMatrix} -! argument {\tt sMat}. The attribute requested is represented by the -! input {\tt CHARACTER} variable {\tt attribute}. The list of real -! attributes one can request is defined in the description block of the -! header of this module ({\tt m\_SparseMatrix}). -! -! Here is how {\tt indexRA\_} provides access to integer attribute data -! in a {\tt SparseMatrix} variable {\tt sMat}. Suppose we wish to access -! matrix element values. This attribute has associated with it the -! string tag {\tt weight}. The corresponding index returned ({\tt iweight}) -! is determined by invoking {\tt indexRA\_}: -! \begin{verbatim} -! iweight = indexRA_(sMat, 'weight') -! \end{verbatim} -! -! Access to the matrix element data in {\tt sMat} is thus obtained by -! referencing {\tt sMat\%data\%rAttr(iweight,:)}. -! -! !INTERFACE: - - integer function indexRA_(sMat, item, perrWith, dieWith) -! -! !USES: -! - use m_String, only : String - use m_String, only : String_init => init - use m_String, only : String_clean => clean - use m_String, only : String_ToChar => ToChar - - use m_TraceBack, only : GenTraceBackString - - use m_AttrVect,only : AttrVect_indexRA => indexRA - - implicit none - -! !INPUT PARAMETERS: - - type(SparseMatrix), intent(in) :: sMat - character(len=*), intent(in) :: item - character(len=*), optional, intent(in) :: perrWith - character(len=*), optional, intent(in) :: dieWith - -! !REVISION HISTORY: -! 24Apr00 - J.W. Larson - initial version. -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::indexRA_' - - type(String) :: myTrace - - ! Generate a traceback String - - if(present(dieWith)) then ! append myname_ onto dieWith - call GenTraceBackString(myTrace, dieWith, myname_) - else - if(present(perrWith)) then ! append myname_ onto perrwith - call GenTraceBackString(myTrace, perrWith, myname_) - else ! Start a TraceBack String - call GenTraceBackString(myTrace, myname_) - endif - endif - - ! Call AttrVect_indexRA() accordingly: - - if( present(dieWith) .or. & - ((.not. present(dieWith)) .and. (.not. present(perrWith))) ) then - indexRA_ = AttrVect_indexRA(sMat%data, item, & - dieWith=String_ToChar(myTrace)) - else ! perrWith but no dieWith case - indexRA_ = AttrVect_indexRA(sMat%data, item, & - perrWith=String_ToChar(myTrace)) - endif - - call String_clean(myTrace) - - end function indexRA_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: nRows_ - Return the Number of Rows -! -! !DESCRIPTION: This routine returns the {\em total} number of rows -! in the input {\tt SparseMatrix} argument {\tt sMat}. This number of -! rows is a constant, and not dependent on the decomposition of the -! {\tt SparseMatrix}. -! -! !INTERFACE: - - integer function nRows_(sMat) -! -! !USES: -! - implicit none - -! !INPUT PARAMETERS: - - type(SparseMatrix), intent(in) :: sMat - -! !REVISION HISTORY: -! 19Apr01 - J.W. Larson - initial prototype -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::nRows_' - - nRows_ = sMat%nrows - - end function nRows_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: nCols_ - Return the Number of Columns -! -! !DESCRIPTION: This routine returns the {\em total} number of columns -! in the input {\tt SparseMatrix} argument {\tt sMat}. This number of -! columns is a constant, and not dependent on the decomposition of the -! {\tt SparseMatrix}. -! -! !INTERFACE: - - integer function nCols_(sMat) -! -! !USES: -! - implicit none - -! !INPUT PARAMETERS: - - type(SparseMatrix), intent(in) :: sMat - -! !REVISION HISTORY: -! 19Apr01 - J.W. Larson - initial prototype -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::nCols_' - - nCols_ = sMat%ncols - - end function nCols_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: exportGlobalRowIndices_ - Return Global Row Indices -! -! !DESCRIPTION: -! This routine extracts from the input {\tt SparseMatrix} argument -! {\tt sMat} its global row indices, and returns them in the {\tt INTEGER} -! output array {\tt GlobalRows}, and its length in the output {\tt INTEGER} -! argument {\tt length}. -! -! {\bf N.B.:} The flexibility of this routine regarding the pointer -! association status of the output argument {\tt GlobalRows} means the -! user must invoke this routine with care. If the user wishes this -! routine to fill a pre-allocated array, then obviously this array -! must be allocated prior to calling this routine. If the user wishes -! that the routine {\em create} the output argument array {\tt GlobalRows}, -! then the user must ensure this pointer is not allocated (i.e. the user -! must nullify this pointer) at the time this routine is invoked. -! -! {\bf N.B.:} If the user has relied on this routine to allocate memory -! associated with the pointer {\tt GlobalRows}, then the user is responsible -! for deallocating this array once it is no longer needed. Failure to -! do so will result in a memory leak. -! -! !INTERFACE: - - subroutine exportGlobalRowIndices_(sMat, GlobalRows, length) -! -! !USES: -! - use m_die - use m_stdio - - use m_AttrVect, only : AttrVect_exportIAttr => exportIAttr - - implicit none - -! !INPUT PARAMETERS: - - type(SparseMatrix), intent(in) :: sMat - -! !OUTPUT PARAMETERS: - - integer, dimension(:), pointer :: GlobalRows - integer, optional, intent(out) :: length - -! !REVISION HISTORY: -! 7May02 - J.W. Larson - initial version. -! -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::exportGlobalRowIndices_' - - ! Export the data (inheritance from AttrVect) - if(present(length)) then - call AttrVect_exportIAttr(sMat%data, 'grow', GlobalRows, length) - else - call AttrVect_exportIAttr(sMat%data, 'grow', GlobalRows) - endif - - end subroutine exportGlobalRowIndices_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: exportGlobalColumnIndices_ - Return Global Column Indices -! -! !DESCRIPTION: -! This routine extracts from the input {\tt SparseMatrix} argument -! {\tt sMat} its global column indices, and returns them in the {\tt INTEGER} -! output array {\tt GlobalColumns}, and its length in the output {\tt INTEGER} -! argument {\tt length}. -! -! {\bf N.B.:} The flexibility of this routine regarding the pointer -! association status of the output argument {\tt GlobalColumns} means the -! user must invoke this routine with care. If the user wishes this -! routine to fill a pre-allocated array, then obviously this array -! must be allocated prior to calling this routine. If the user wishes -! that the routine {\em create} the output argument array {\tt GlobalColumns}, -! then the user must ensure this pointer is not allocated (i.e. the user -! must nullify this pointer) at the time this routine is invoked. -! -! {\bf N.B.:} If the user has relied on this routine to allocate memory -! associated with the pointer {\tt GlobalColumns}, then the user is responsible -! for deallocating this array once it is no longer needed. Failure to -! do so will result in a memory leak. -! -! !INTERFACE: - - subroutine exportGlobalColumnIndices_(sMat, GlobalColumns, length) - -! -! !USES: -! - use m_die - use m_stdio - - use m_AttrVect, only : AttrVect_exportIAttr => exportIAttr - - implicit none - -! !INPUT PARAMETERS: - - type(SparseMatrix), intent(in) :: sMat - -! !OUTPUT PARAMETERS: - - integer, dimension(:), pointer :: GlobalColumns - integer, optional, intent(out) :: length - -! !REVISION HISTORY: -! 7May02 - J.W. Larson - initial version. -! -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::exportGlobalColumnIndices_' - - ! Export the data (inheritance from AttrVect) - if(present(length)) then - call AttrVect_exportIAttr(sMat%data, 'gcol', GlobalColumns, length) - else - call AttrVect_exportIAttr(sMat%data, 'gcol', GlobalColumns) - endif - - end subroutine exportGlobalColumnIndices_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: exportLocalRowIndices_ - Return Local Row Indices -! -! !DESCRIPTION: -! This routine extracts from the input {\tt SparseMatrix} argument -! {\tt sMat} its local row indices, and returns them in the {\tt INTEGER} -! output array {\tt LocalRows}, and its length in the output {\tt INTEGER} -! argument {\tt length}. -! -! {\bf N.B.:} The flexibility of this routine regarding the pointer -! association status of the output argument {\tt LocalRows} means the -! user must invoke this routine with care. If the user wishes this -! routine to fill a pre-allocated array, then obviously this array -! must be allocated prior to calling this routine. If the user wishes -! that the routine {\em create} the output argument array {\tt LocalRows}, -! then the user must ensure this pointer is not allocated (i.e. the user -! must nullify this pointer) at the time this routine is invoked. -! -! {\bf N.B.:} If the user has relied on this routine to allocate memory -! associated with the pointer {\tt LocalRows}, then the user is responsible -! for deallocating this array once it is no longer needed. Failure to -! do so will result in a memory leak. -! -! !INTERFACE: - - subroutine exportLocalRowIndices_(sMat, LocalRows, length) -! -! !USES: -! - use m_die - use m_stdio - - use m_AttrVect, only : AttrVect_exportIAttr => exportIAttr - - implicit none - -! !INPUT PARAMETERS: - - type(SparseMatrix), intent(in) :: sMat - -! !OUTPUT PARAMETERS: - - integer, dimension(:), pointer :: LocalRows - integer, optional, intent(out) :: length - -! !REVISION HISTORY: -! 7May02 - J.W. Larson - initial version. -! -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::exportLocalRowIndices_' - - ! Export the data (inheritance from AttrVect) - if(present(length)) then - call AttrVect_exportIAttr(sMat%data, 'lrow', LocalRows, length) - else - call AttrVect_exportIAttr(sMat%data, 'lrow', LocalRows) - endif - - end subroutine exportLocalRowIndices_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: exportLocalColumnIndices_ - Return Local Column Indices -! -! !DESCRIPTION: -! This routine extracts from the input {\tt SparseMatrix} argument -! {\tt sMat} its local column indices, and returns them in the {\tt INTEGER} -! output array {\tt LocalColumns}, and its length in the output {\tt INTEGER} -! argument {\tt length}. -! -! {\bf N.B.:} The flexibility of this routine regarding the pointer -! association status of the output argument {\tt LocalColumns} means the -! user must invoke this routine with care. If the user wishes this -! routine to fill a pre-allocated array, then obviously this array -! must be allocated prior to calling this routine. If the user wishes -! that the routine {\em create} the output argument array {\tt LocalColumns}, -! then the user must ensure this pointer is not allocated (i.e. the user -! must nullify this pointer) at the time this routine is invoked. -! -! {\bf N.B.:} If the user has relied on this routine to allocate memory -! associated with the pointer {\tt LocalColumns}, then the user is responsible -! for deallocating this array once it is no longer needed. Failure to -! do so will result in a memory leak. -! -! !INTERFACE: - - subroutine exportLocalColumnIndices_(sMat, LocalColumns, length) - -! -! !USES: -! - use m_die - use m_stdio - - use m_AttrVect, only : AttrVect_exportIAttr => exportIAttr - - implicit none - -! !INPUT PARAMETERS: - - type(SparseMatrix), intent(in) :: sMat - -! !OUTPUT PARAMETERS: - - integer, dimension(:), pointer :: LocalColumns - integer, optional, intent(out) :: length - -! !REVISION HISTORY: -! 7May02 - J.W. Larson - initial version. -! -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::exportLocalColumnIndices_' - - ! Export the data (inheritance from AttrVect) - if(present(length)) then - call AttrVect_exportIAttr(sMat%data, 'lcol', LocalColumns, length) - else - call AttrVect_exportIAttr(sMat%data, 'lcol', LocalColumns) - endif - - end subroutine exportLocalColumnIndices_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: exportMatrixElementsSP_ - Return Matrix Elements as Array -! -! !DESCRIPTION: -! This routine extracts the matrix elements from the input {\tt SparseMatrix} -! argument {\tt sMat}, and returns them in the {\tt REAL} output array -! {\tt MatrixElements}, and its length in the output {\tt INTEGER} -! argument {\tt length}. -! -! {\bf N.B.:} The flexibility of this routine regarding the pointer -! association status of the output argument {\tt MatrixElements} means the -! user must invoke this routine with care. If the user wishes this -! routine to fill a pre-allocated array, then obviously this array -! must be allocated prior to calling this routine. If the user wishes -! that the routine {\em create} the output argument array {\tt MatrixElements}, -! then the user must ensure this pointer is not allocated (i.e. the user -! must nullify this pointer) at the time this routine is invoked. -! -! {\bf N.B.:} If the user has relied on this routine to allocate memory -! associated with the pointer {\tt MatrixElements}, then the user is responsible -! for deallocating this array once it is no longer needed. Failure to -! do so will result in a memory leak. -! -! The native precision version is described here. A double precision version -! is also available. -! -! !INTERFACE: - - subroutine exportMatrixelementsSP_(sMat, MatrixElements, length) - -! -! !USES: -! - use m_die - use m_stdio - use m_realkinds, only : SP - - use m_AttrVect, only : AttrVect_exportRAttr => exportRAttr - - implicit none - -! !INPUT PARAMETERS: - - type(SparseMatrix), intent(in) :: sMat - -! !OUTPUT PARAMETERS: - - real(SP), dimension(:), pointer :: MatrixElements - integer, optional, intent(out) :: length - -! !REVISION HISTORY: -! 7May02 - J.W. Larson - initial version. -! 6Jan04 - R. Jacob - SP and DP versions -! -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::exportMatrixElementsSP_' - - ! Export the data (inheritance from AttrVect) - if(present(length)) then - call AttrVect_exportRAttr(sMat%data, 'weight', MatrixElements, length) - else - call AttrVect_exportRAttr(sMat%data, 'weight', MatrixElements) - endif - - end subroutine exportMatrixElementsSP_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -! ------------------------------------------------------------------- -! -! !IROUTINE: exportMatrixElementsDP_ - Return Matrix Elements as Array -! -! !DESCRIPTION: -! Double precision version of exportMatrixElementsSP_ -! -! !INTERFACE: - - subroutine exportMatrixelementsDP_(sMat, MatrixElements, length) - -! -! !USES: -! - use m_die - use m_stdio - use m_realkinds, only : DP - - use m_AttrVect, only : AttrVect_exportRAttr => exportRAttr - - implicit none - -! !INPUT PARAMETERS: - - type(SparseMatrix), intent(in) :: sMat - -! !OUTPUT PARAMETERS: - - real(DP), dimension(:), pointer :: MatrixElements - integer, optional, intent(out) :: length - -! !REVISION HISTORY: -! 7May02 - J.W. Larson - initial version. -! -! ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::exportMatrixElementsDP_' - - ! Export the data (inheritance from AttrVect) - if(present(length)) then - call AttrVect_exportRAttr(sMat%data, 'weight', MatrixElements, length) - else - call AttrVect_exportRAttr(sMat%data, 'weight', MatrixElements) - endif - - end subroutine exportMatrixElementsDP_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: importGlobalRowIndices_ - Set Global Row Indices of Elements -! -! !DESCRIPTION: -! This routine imports global row index data into the {\tt SparseMatrix} -! argument {\tt sMat}. The user provides the index data in the input -! {\tt INTEGER} vector {\tt inVect}. The input {\tt INTEGER} argument -! {\tt lsize} is used as a consistencey check to ensure the user is -! sufficient space in the {\tt SparseMatrix} to store the data. -! -! !INTERFACE: - - subroutine importGlobalRowIndices_(sMat, inVect, lsize) - -! -! !USES: -! - use m_die - use m_stdio - - use m_AttrVect, only : AttrVect_importIAttr => importIAttr - - implicit none - -! !INPUT PARAMETERS: - - integer, dimension(:), pointer :: inVect - integer, intent(in) :: lsize - -! !INPUT/OUTPUT PARAMETERS: - - type(SparseMatrix), intent(inout) :: sMat - -! !REVISION HISTORY: -! 7May02 - J.W. Larson - initial prototype. -! -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::importGlobalRowIndices_' - - ! Argument Check: - - if(lsize > lsize_(sMat)) then - write(stderr,*) myname_,':: ERROR, lsize > lsize_(sMat).', & - 'lsize = ',lsize,'lsize_(sMat) = ',lsize_(sMat) - call die(myname_) - endif - - ! Import the data (inheritance from AttrVect) - - call AttrVect_importIAttr(sMat%data, 'grow', inVect, lsize) - - end subroutine importGlobalRowIndices_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: importGlobalColumnIndices_ - Set Global Column Indices of Elements -! -! !DESCRIPTION: -! This routine imports global column index data into the {\tt SparseMatrix} -! argument {\tt sMat}. The user provides the index data in the input -! {\tt INTEGER} vector {\tt inVect}. The input {\tt INTEGER} argument -! {\tt lsize} is used as a consistencey check to ensure the user is -! sufficient space in the {\tt SparseMatrix} to store the data. -! -! !INTERFACE: - - subroutine importGlobalColumnIndices_(sMat, inVect, lsize) - -! -! !USES: -! - use m_die - use m_stdio - - use m_AttrVect, only : AttrVect_importIAttr => importIAttr - - implicit none - -! !INPUT PARAMETERS: - - integer, dimension(:), pointer :: inVect - integer, intent(in) :: lsize - -! !INPUT/OUTPUT PARAMETERS: - - type(SparseMatrix), intent(inout) :: sMat - -! !REVISION HISTORY: -! 7May02 - J.W. Larson - initial prototype. -! -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::importGlobalColumnIndices_' - - ! Argument Check: - - if(lsize > lsize_(sMat)) then - write(stderr,*) myname_,':: ERROR, lsize > lsize_(sMat).', & - 'lsize = ',lsize,'lsize_(sMat) = ',lsize_(sMat) - call die(myname_) - endif - - ! Import the data (inheritance from AttrVect) - - call AttrVect_importIAttr(sMat%data, 'gcol', inVect, lsize) - - end subroutine importGlobalColumnIndices_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: importLocalRowIndices_ - Set Local Row Indices of Elements -! -! !DESCRIPTION: -! This routine imports local row index data into the {\tt SparseMatrix} -! argument {\tt sMat}. The user provides the index data in the input -! {\tt INTEGER} vector {\tt inVect}. The input {\tt INTEGER} argument -! {\tt lsize} is used as a consistencey check to ensure the user is -! sufficient space in the {\tt SparseMatrix} to store the data. -! -! !INTERFACE: - - subroutine importLocalRowIndices_(sMat, inVect, lsize) - -! -! !USES: -! - use m_die - use m_stdio - - use m_AttrVect, only : AttrVect_importIAttr => importIAttr - - implicit none - -! !INPUT PARAMETERS: - - integer, dimension(:), pointer :: inVect - integer, intent(in) :: lsize - -! !INPUT/OUTPUT PARAMETERS: - - type(SparseMatrix), intent(inout) :: sMat - -! !REVISION HISTORY: -! 7May02 - J.W. Larson - initial prototype. -! -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::importLocalRowIndices_' - - ! Argument Check: - - if(lsize > lsize_(sMat)) then - write(stderr,*) myname_,':: ERROR, lsize > lsize_(sMat).', & - 'lsize = ',lsize,'lsize_(sMat) = ',lsize_(sMat) - call die(myname_) - endif - - ! Import the data (inheritance from AttrVect) - - call AttrVect_importIAttr(sMat%data, 'lrow', inVect, lsize) - - end subroutine importLocalRowIndices_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: importLocalColumnIndices_ - Set Local Column Indices of Elements -! -! !DESCRIPTION: -! This routine imports local column index data into the {\tt SparseMatrix} -! argument {\tt sMat}. The user provides the index data in the input -! {\tt INTEGER} vector {\tt inVect}. The input {\tt INTEGER} argument -! {\tt lsize} is used as a consistencey check to ensure the user is -! sufficient space in the {\tt SparseMatrix} to store the data. -! -! !INTERFACE: - - subroutine importLocalColumnIndices_(sMat, inVect, lsize) - -! -! !USES: -! - use m_die - use m_stdio - - use m_AttrVect, only : AttrVect_importIAttr => importIAttr - - implicit none - -! !INPUT PARAMETERS: - - integer, dimension(:), pointer :: inVect - integer, intent(in) :: lsize - -! !INPUT/OUTPUT PARAMETERS: - - type(SparseMatrix), intent(inout) :: sMat - -! !REVISION HISTORY: -! 7May02 - J.W. Larson - initial prototype. -! -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::importLocalColumnIndices_' - - ! Argument Check: - - if(lsize > lsize_(sMat)) then - write(stderr,*) myname_,':: ERROR, lsize > lsize_(sMat).', & - 'lsize = ',lsize,'lsize_(sMat) = ',lsize_(sMat) - call die(myname_) - endif - - ! Import the data (inheritance from AttrVect) - - call AttrVect_importIAttr(sMat%data, 'lcol', inVect, lsize) - - end subroutine importLocalColumnIndices_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: importMatrixElementsSP_ - Import Non-zero Matrix Elements -! -! !DESCRIPTION: -! This routine imports matrix elements index data into the -! {\tt SparseMatrix} argument {\tt sMat}. The user provides the index -! data in the input {\tt REAL} vector {\tt inVect}. The input -! {\tt INTEGER} argument {\tt lsize} is used as a consistencey check -! to ensure the user is sufficient space in the {\tt SparseMatrix} -! to store the data. -! -! !INTERFACE: - - subroutine importMatrixElementsSP_(sMat, inVect, lsize) - -! -! !USES: -! - use m_die - use m_stdio - use m_realkinds, only : SP - - use m_AttrVect, only : AttrVect_importRAttr => importRAttr - - implicit none - -! !INPUT PARAMETERS: - - real(SP), dimension(:), pointer :: inVect - integer, intent(in) :: lsize - -! !INPUT/OUTPUT PARAMETERS: - - type(SparseMatrix), intent(inout) :: sMat - -! !REVISION HISTORY: -! 7May02 - J.W. Larson - initial prototype. -! 6Jan04 - R. Jacob - Make SP and DP versions. -! -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::importMatrixElementsSP_' - - ! Argument Check: - - if(lsize > lsize_(sMat)) then - write(stderr,*) myname_,':: ERROR, lsize > lsize_(sMat).', & - 'lsize = ',lsize,'lsize_(sMat) = ',lsize_(sMat) - call die(myname_) - endif - - ! Import the data (inheritance from AttrVect) - - call AttrVect_importRAttr(sMat%data, 'weight', inVect, lsize) - - end subroutine importMatrixElementsSP_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -! ------------------------------------------------------------------- -! -! !IROUTINE: importMatrixElementsDP_ - Import Non-zero Matrix Elements -! -! !DESCRIPTION: -! Double precision version of importMatrixElementsSP_ -! -! !INTERFACE: - - subroutine importMatrixElementsDP_(sMat, inVect, lsize) - -! -! !USES: -! - use m_die - use m_stdio - use m_realkinds, only : DP - - use m_AttrVect, only : AttrVect_importRAttr => importRAttr - - implicit none - -! !INPUT PARAMETERS: - - real(DP), dimension(:), pointer :: inVect - integer, intent(in) :: lsize - -! !INPUT/OUTPUT PARAMETERS: - - type(SparseMatrix), intent(inout) :: sMat - -! !REVISION HISTORY: -! 7May02 - J.W. Larson - initial prototype. -! -! ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::importMatrixElementsDP_' - - ! Argument Check: - - if(lsize > lsize_(sMat)) then - write(stderr,*) myname_,':: ERROR, lsize > lsize_(sMat).', & - 'lsize = ',lsize,'lsize_(sMat) = ',lsize_(sMat) - call die(myname_) - endif - - ! Import the data (inheritance from AttrVect) - - call AttrVect_importRAttr(sMat%data, 'weight', inVect, lsize) - - end subroutine importMatrixElementsDP_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: Copy_ - Create a Copy of an Input SparseMatrix -! -! !DESCRIPTION: -! This routine creates a copy of the input {\tt SparseMatrix} argument -! {\tt sMat}, returning it as the output {\tt SparseMatrix} argument -! {\tt sMatCopy}. -! -! {\bf N.B.:} The output argument {\tt sMatCopy} represents allocated -! memory the user must deallocate when it is no longer needed. The -! MCT routine to use for this purpose is {\tt clean()} from this module. -! -! !INTERFACE: - - subroutine Copy_(sMat, sMatCopy) - -! -! !USES: -! - use m_die - use m_stdio - - use m_AttrVect, only : AttrVect - use m_AttrVect, only : AttrVect_init => init - use m_AttrVect, only : AttrVect_lsize => lsize - use m_AttrVect, only : AttrVect_Copy => Copy - - implicit none - -! !INPUT PARAMETERS: - - type(SparseMatrix), intent(in) :: sMat - -! !OUTPUT PARAMETERS: - - type(SparseMatrix), intent(out) :: sMatCopy - -! !REVISION HISTORY: -! 27Sep02 - J.W. Larson - initial prototype. -! -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::Copy_' - - ! Step one: copy the integer components of sMat: - - sMatCopy%nrows = sMat%nrows - sMatCopy%ncols = sMat%ncols - - sMatCopy%vecinit = .FALSE. - - ! Step two: Initialize the AttrVect sMatCopy%data off of sMat: - - call AttrVect_init(sMatCopy%data, sMat%data, AttrVect_lsize(sMat%data)) - - ! Step three: Copy sMat%data to sMatCopy%data: - - call AttrVect_Copy(sMat%data, aVout=sMatCopy%data) - - if(sMat%vecinit) call vecinit_(sMatCopy) - - end subroutine Copy_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: local_row_range_ - Local Row Extent of Non-zero Elements -! -! !DESCRIPTION: This routine examines the input distributed -! {\tt SparseMatrix} variable {\tt sMat}, and returns the range of local -! row values having nonzero elements. The first local row with -! nonzero elements is returned in the {\tt INTEGER} argument -! {\tt start\_row}, the last row in {\tt end\_row}. -! -! !INTERFACE: - - subroutine local_row_range_(sMat, start_row, end_row) -! -! !USES: -! - use m_die - - use m_AttrVect, only : AttrVect_lsize => lsize - use m_AttrVect, only : AttrVect_indexIA => indexIA - - implicit none - -! !INPUT PARAMETERS: - - type(SparseMatrix), intent(in) :: sMat - -! !OUTPUT PARAMETERS: - - integer, intent(out) :: start_row - integer, intent(out) :: end_row - -! !REVISION HISTORY: -! 15Jan01 - Jay Larson - API specification. -! 25Feb01 - Jay Larson - Initial prototype. -! 23Apr01 - Jay Larson - Modified to accomodate -! changes to the SparseMatrix type. -!EOP ___________________________________________________________________ -! - character(len=*),parameter :: myname_=myname//'::local_row_range_' - - integer :: i, ilrow, lsize - - ilrow = AttrVect_indexIA(sMat%data, 'lrow') - lsize = AttrVect_lsize(sMat%data) - - ! Initialize start_row and end_row: - - start_row = sMat%data%iAttr(ilrow,1) - end_row = sMat%data%iAttr(ilrow,1) - - do i=1,lsize - start_row = min(start_row, sMat%data%iAttr(ilrow,i)) - end_row = max(end_row, sMat%data%iAttr(ilrow,i)) - end do - - end subroutine local_row_range_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: global_row_range_ - Global Row Extent of Non-zero Elements -! -! !DESCRIPTION: This routine examines the input distributed -! {\tt SparseMatrix} variable {\tt sMat}, and returns the range of -! global row values having nonzero elements. The first local row with -! nonzero elements is returned in the {\tt INTEGER} argument -! {\tt start\_row}, the last row in {\tt end\_row}. -! -! !INTERFACE: - - subroutine global_row_range_(sMat, comm, start_row, end_row) -! -! !USES: -! - use m_die - - use m_AttrVect, only : AttrVect_lsize => lsize - use m_AttrVect, only : AttrVect_indexIA => indexIA - - implicit none - -! !INPUT PARAMETERS: - - type(SparseMatrix), intent(in) :: sMat - integer, intent(in) :: comm - -! !OUTPUT PARAMETERS: - - integer, intent(out) :: start_row - integer, intent(out) :: end_row - -! !REVISION HISTORY: -! 15Jan01 - Jay Larson - API specification. -! 25Feb01 - Jay Larson - Initial prototype. -! 23Apr01 - Jay Larson - Modified to accomodate -! changes to the SparseMatrix type. -!EOP ___________________________________________________________________ -! - character(len=*),parameter :: myname_=myname//'::global_row_range_' - - integer :: i, igrow, lsize - - igrow = AttrVect_indexIA(sMat%data, 'grow', dieWith=myname_) - lsize = AttrVect_lsize(sMat%data) - - ! Initialize start_row and end_row: - - start_row = sMat%data%iAttr(igrow,1) - end_row = sMat%data%iAttr(igrow,1) - - do i=1,lsize - start_row = min(start_row, sMat%data%iAttr(igrow,i)) - end_row = max(end_row, sMat%data%iAttr(igrow,i)) - end do - - end subroutine global_row_range_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: local_col_range_ - Local Column Extent of Non-zero Elements -! -! !DESCRIPTION: This routine examines the input distributed -! {\tt SparseMatrix} variable {\tt sMat}, and returns the range of -! local column values having nonzero elements. The first local column -! with nonzero elements is returned in the {\tt INTEGER} argument -! {\tt start\_col}, the last column in {\tt end\_col}. -! -! !INTERFACE: - - subroutine local_col_range_(sMat, start_col, end_col) -! -! !USES: -! - use m_die - - use m_AttrVect, only : AttrVect_lsize => lsize - use m_AttrVect, only : AttrVect_indexIA => indexIA - - implicit none - -! !INPUT PARAMETERS: - - type(SparseMatrix), intent(in) :: sMat - -! !OUTPUT PARAMETERS: - - integer, intent(out) :: start_col - integer, intent(out) :: end_col - -! !REVISION HISTORY: -! 15Jan01 - Jay Larson - API specification. -! 25Feb01 - Jay Larson - Initial prototype. -! 23Apr01 - Jay Larson - Modified to accomodate -! changes to the SparseMatrix type. -!EOP ___________________________________________________________________ -! - character(len=*),parameter :: myname_=myname//'::local_col_range_' - - integer :: i, ilcol, lsize - - ilcol = AttrVect_indexIA(sMat%data, 'lcol') - lsize = AttrVect_lsize(sMat%data) - - ! Initialize start_col and end_col: - - start_col = sMat%data%iAttr(ilcol,1) - end_col = sMat%data%iAttr(ilcol,1) - - do i=1,lsize - start_col = min(start_col, sMat%data%iAttr(ilcol,i)) - end_col = max(end_col, sMat%data%iAttr(ilcol,i)) - end do - - end subroutine local_col_range_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: global_col_range_ - Global Column Extent of Non-zero Elements -! -! !DESCRIPTION: This routine examines the input distributed -! {\tt SparseMatrix} variable {\tt sMat}, and returns the range of -! global column values having nonzero elements. The first global -! column with nonzero elements is returned in the {\tt INTEGER} argument -! {\tt start\_col}, the last column in {\tt end\_col}. -! -! !INTERFACE: - - subroutine global_col_range_(sMat, comm, start_col, end_col) -! -! !USES: -! - use m_die - - use m_AttrVect, only : AttrVect_lsize => lsize - use m_AttrVect, only : AttrVect_indexIA => indexIA - - implicit none - -! !INPUT PARAMETERS: - - type(SparseMatrix), intent(in) :: sMat - integer, intent(in) :: comm - -! !OUTPUT PARAMETERS: - - integer, intent(out) :: start_col - integer, intent(out) :: end_col - -! !REVISION HISTORY: -! 15Jan01 - Jay Larson - API specification. -! 25Feb01 - Jay Larson - Initial prototype. -! 23Apr01 - Jay Larson - Modified to accomodate -! changes to the SparseMatrix type. -!EOP ___________________________________________________________________ -! - character(len=*),parameter :: myname_=myname//'::global_col_range_' - - integer :: i, igcol, lsize - - igcol = AttrVect_indexIA(sMat%data, 'gcol') - lsize = AttrVect_lsize(sMat%data) - - ! Initialize start_col and end_col: - - start_col = sMat%data%iAttr(igcol,1) - end_col = sMat%data%iAttr(igcol,1) - - do i=1,lsize - start_col = min(start_col, sMat%data%iAttr(igcol,i)) - end_col = max(end_col, sMat%data%iAttr(igcol,i)) - end do - - end subroutine global_col_range_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: ComputeSparsitySP_ - Compute Matrix Sparsity -! -! !DESCRIPTION: This routine computes the sparsity of a consolidated -! (all on one process) or distributed {\tt SparseMatrix}. The input -! {\tt SparseMatrix} argument {\tt sMat} is examined to determine the -! number of nonzero elements it holds, and this value is divided by the -! product of the number of rows and columns in {\tt sMat}. If the -! optional input argument {\tt comm} is given, then the distributed -! elements are counted and the sparsity computed accordingly, and the -! resulting value of {\tt sparsity} is returned {\em to all processes}. -! -! Given the inherent problems with multiplying and dividing large integers, -! the work in this routine is performed using floating point arithmetic on -! the logarithms of the number of rows, columns, and nonzero elements. -! -! !INTERFACE: - - subroutine ComputeSparsitySP_(sMat, sparsity, comm) - -! -! !USES: -! - use m_die - use m_mpif90 - use m_realkinds, only : SP, FP - - use m_AttrVect, only : AttrVect_lsize => lsize - - implicit none - -! !INPUT PARAMETERS: - - type(SparseMatrix), intent(in) :: sMat - integer, optional, intent(in) :: comm - -! !OUTPUT PARAMETERS: - - real(SP), intent(out) :: sparsity - -! !REVISION HISTORY: -! 23Apr01 - Jay Larson - New routine. -! -!EOP ___________________________________________________________________ -! - character(len=*),parameter :: myname_=myname//'::ComputeSparsitySP_' - - integer :: num_elements, num_rows, num_cols - real(FP) :: Lnum_elements, Lnum_rows, Lnum_cols, LMySparsity - real(FP) :: MySparsity - integer :: ierr - - ! Extract number of nonzero elements and compute its logarithm - - num_elements = lsize_(sMat) - Lnum_elements = log(REAL(num_elements,FP)) - - ! Extract number of rows and compute its logarithm - - num_rows = nRows_(sMat) - Lnum_rows = log(REAL(num_rows,FP)) - - ! Extract number of columns and compute its logarithm - - num_cols = nCols_(sMat) - Lnum_cols = log(REAL(num_cols,FP)) - - ! Compute logarithm of the (local) sparsity - - LMySparsity = Lnum_elements - Lnum_rows - Lnum_cols - - ! Compute the (local) sparsity from its logarithm. - - MySparsity = exp(LMySparsity) - - ! If a communicator handle is present, sum up the - ! distributed sparsity values to all processes. If not, - ! return the value of MySparsity computed above. - - if(present(comm)) then - call MPI_ALLREDUCE(MySparsity, sparsity, 1, MP_INTEGER, & - MP_SUM, comm, ierr) - if(ierr /= 0) then - call MP_perr_die(myname_,"MPI_ALLREDUCE(MySparsity...",ierr) - endif - else - sparsity = MySparsity - endif - - end subroutine ComputeSparsitySP_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -! ---------------------------------------------------------------------- -! -! !IROUTINE: ComputeSparsityDP_ - Compute Matrix Sparsity -! -! !DESCRIPTION: -! Double precision version of ComputeSparsitySP_ -! -! !INTERFACE: - - subroutine ComputeSparsityDP_(sMat, sparsity, comm) - -! -! !USES: -! - use m_die - use m_mpif90 - use m_realkinds, only : DP, FP - - use m_AttrVect, only : AttrVect_lsize => lsize - - implicit none - -! !INPUT PARAMETERS: - - type(SparseMatrix), intent(in) :: sMat - integer, optional, intent(in) :: comm - -! !OUTPUT PARAMETERS: - - real(DP), intent(out) :: sparsity - -! !REVISION HISTORY: -! 23Apr01 - Jay Larson - New routine. -! -! ______________________________________________________________________ -! - character(len=*),parameter :: myname_=myname//'::ComputeSparsityDP_' - - integer :: num_elements, num_rows, num_cols - real(FP) :: Lnum_elements, Lnum_rows, Lnum_cols, LMySparsity - real(FP) :: MySparsity - integer :: ierr - - ! Extract number of nonzero elements and compute its logarithm - - num_elements = lsize_(sMat) - Lnum_elements = log(REAL(num_elements,FP)) - - ! Extract number of rows and compute its logarithm - - num_rows = nRows_(sMat) - Lnum_rows = log(REAL(num_rows,FP)) - - ! Extract number of columns and compute its logarithm - - num_cols = nCols_(sMat) - Lnum_cols = log(REAL(num_cols,FP)) - - ! Compute logarithm of the (local) sparsity - - LMySparsity = Lnum_elements - Lnum_rows - Lnum_cols - - ! Compute the (local) sparsity from its logarithm. - - MySparsity = exp(LMySparsity) - - ! If a communicator handle is present, sum up the - ! distributed sparsity values to all processes. If not, - ! return the value of MySparsity computed above. - - if(present(comm)) then - call MPI_ALLREDUCE(MySparsity, sparsity, 1, MP_INTEGER, & - MP_SUM, comm, ierr) - if(ierr /= 0) then - call MP_perr_die(myname_,"MPI_ALLREDUCE(MySparsity...",ierr) - endif - else - sparsity = MySparsity - endif - - end subroutine ComputeSparsityDP_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: CheckBounds_ - Check for Out-of-Bounds Row/Column Values -! -! !DESCRIPTION: This routine examines the input distributed -! {\tt SparseMatrix} variable {\tt sMat}, and examines the global row -! and column index for each element, comparing them with the known -! maximum values for each (as returned by the routines {\tt nRows\_()} -! and {\tt nCols\_()}, respectively). If global row or column entries -! are non-positive, or greater than the defined maximum values, this -! routine stops execution with an error message. If no out-of-bounds -! values are detected, the output {\tt INTEGER} status {\tt ierror} is -! set to zero. -! -! !INTERFACE: - - subroutine CheckBounds_(sMat, ierror) -! -! !USES: -! - use m_die - - use m_AttrVect, only : AttrVect_lsize => lsize - use m_AttrVect, only : AttrVect_indexIA => indexIA - - implicit none - -! !INPUT PARAMETERS: - - type(SparseMatrix), intent(in) :: sMat - -! !OUTPUT PARAMETERS: - - integer, intent(out) :: ierror - -! !REVISION HISTORY: -! 24Apr01 - Jay Larson - Initial prototype. -!EOP ___________________________________________________________________ -! - character(len=*),parameter :: myname_=myname//'::CheckBounds_' - - integer :: MaxRow, MaxCol, NumElements - integer :: igrow, igcol - integer :: i - - ! Initially, set ierror to zero (success): - - ierror = 0 - - ! Query sMat to find the number of rows and columns: - - MaxRow = nRows_(sMat) - MaxCol = nCols_(sMat) - - ! Query sMat for the number of nonzero elements: - - NumElements = lsize_(sMat) - - ! Query sMat to index global row and column storage indices: - - igrow = indexIA_(sMat=sMat,item='grow',dieWith=myname_) - igcol = indexIA_(sMat=sMat,item='gcol',dieWith=myname_) - - ! Scan the entries of sMat for row or column elements that - ! are out-of-bounds. Here, out-of-bounds means: 1) non- - ! positive row or column indices; 2) row or column indices - ! exceeding the stated number of rows or columns. - - do i=1,NumElements - - ! Row index out of bounds? - - if((sMat%data%iAttr(igrow,i) > MaxRow) .or. & - (sMat%data%iAttr(igrow,i) <= 0)) then - ierror = 1 - call die(myname_,"Row index out of bounds",ierror) - endif - - ! Column index out of bounds? - - if((sMat%data%iAttr(igcol,i) > MaxCol) .or. & - (sMat%data%iAttr(igcol,i) <= 0)) then - ierror = 2 - call die(myname_,"Column index out of bounds",ierror) - endif - - end do - - end subroutine CheckBounds_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: row_sumSP_ - Sum Elements in Each Row -! -! !DESCRIPTION: -! Given an input {\tt SparseMatrix} argument {\tt sMat}, {\tt row\_sum\_()} -! returns the number of the rows {\tt num\_rows} in the sparse matrix and -! the sum of the elements in each row in the array {\tt sums}. The input -! argument {\tt comm} is the Fortran 90 MPI communicator handle used to -! determine the number of rows and perform the sums. The output arguments -! {\tt num\_rows} and {\tt sums} are valid on all processes. -! -! {\bf N.B.: } This routine allocates an array {\tt sums}. The user is -! responsible for deallocating this array when it is no longer needed. -! Failure to do so will cause a memory leak. -! -! !INTERFACE: - - subroutine row_sumSP_(sMat, num_rows, sums, comm) - -! -! !USES: -! - use m_die - use m_mpif90 - use m_realkinds, only : SP, FP - - use m_AttrVect, only : AttrVect_lsize => lsize - use m_AttrVect, only : AttrVect_indexIA => indexIA - use m_AttrVect, only : AttrVect_indexRA => indexRA - - implicit none - -! !INPUT PARAMETERS: - - type(SparseMatrix), intent(in) :: sMat - integer, intent(in) :: comm - -! !OUTPUT PARAMETERS: - - integer, intent(out) :: num_rows - real(SP), dimension(:), pointer :: sums - - - -! !REVISION HISTORY: -! 15Jan01 - Jay Larson - API specification. -! 25Jan01 - Jay Larson - Prototype code. -! 23Apr01 - Jay Larson - Modified to accomodate -! changes to the SparseMatrix type. -! 18May01 - R. Jacob - Use MP_TYPE function -! to set type in the mpi_allreduce -!EOP ___________________________________________________________________ -! - character(len=*),parameter :: myname_=myname//'::row_sumSP_' - - integer :: i, igrow, ierr, iwgt, lsize, myID - integer :: start_row, end_row - integer :: mp_Type_lsums - real(FP), dimension(:), allocatable :: lsums - real(FP), dimension(:), allocatable :: gsums - - ! Determine local rank - - call MP_COMM_RANK(comm, myID, ierr) - - ! Determine on each process the row of global row indices: - - call global_row_range_(sMat, comm, start_row, end_row) - - ! Determine across the communicator the _maximum_ value of - ! end_row, which will be assigned to num_rows on each process: - - call MPI_ALLREDUCE(end_row, num_rows, 1, MP_INTEGER, MP_MAX, & - comm, ierr) - if(ierr /= 0) then - call MP_perr_die(myname_,"MPI_ALLREDUCE(end_row...",ierr) - endif - - ! Allocate storage for the sums on each process. - - allocate(lsums(num_rows), gsums(num_rows), sums(num_rows), stat=ierr) - - if(ierr /= 0) then - call die(myname_,"allocate(lsums(...",ierr) - endif - - ! Compute the local entries to lsum(1:num_rows) for each process: - - lsize = AttrVect_lsize(sMat%data) - igrow = AttrVect_indexIA(aV=sMat%data,item='grow',dieWith=myname_) - iwgt = AttrVect_indexRA(aV=sMat%data,item='weight',dieWith=myname_) - - lsums = 0._FP - do i=1,lsize - lsums(sMat%data%iAttr(igrow,i)) = lsums(sMat%data%iAttr(igrow,i)) + & - sMat%data%rAttr(iwgt,i) - end do - - ! Compute the global sum of the entries of lsums so that all - ! processes own the global sums. - - mp_Type_lsums=MP_Type(lsums) - call MPI_ALLREDUCE(lsums, gsums, num_rows, mp_Type_lsums, MP_SUM, comm, ierr) - if(ierr /= 0) then - call MP_perr_die(myname_,"MPI_ALLREDUCE(lsums...",ierr) - endif - - ! Copy our temporary array gsums into the output pointer sums - ! This was done so that lsums and gsums have the same precision (FP) - ! Precision conversion occurs here from FP to (SP or DP) - - sums = gsums - - ! Clean up... - - deallocate(lsums, gsums, stat=ierr) - if(ierr /= 0) then - call die(myname_,"deallocate(lsums...",ierr) - endif - - end subroutine row_sumSP_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -! ---------------------------------------------------------------------- -! -! !IROUTINE: row_sumDP_ - Sum Elements in Each Row -! -! !DESCRIPTION: -! Double precision version of row_sumSP_ -! -! {\bf N.B.: } This routine allocates an array {\tt sums}. The user is -! responsible for deallocating this array when it is no longer needed. -! Failure to do so will cause a memory leak. -! -! !INTERFACE: - - subroutine row_sumDP_(sMat, num_rows, sums, comm) - -! -! !USES: -! - use m_die - use m_mpif90 - - use m_realkinds, only : DP, FP - - use m_AttrVect, only : AttrVect_lsize => lsize - use m_AttrVect, only : AttrVect_indexIA => indexIA - use m_AttrVect, only : AttrVect_indexRA => indexRA - - implicit none - -! !INPUT PARAMETERS: - - type(SparseMatrix), intent(in) :: sMat - integer, intent(in) :: comm - -! !OUTPUT PARAMETERS: - - integer, intent(out) :: num_rows - real(DP), dimension(:), pointer :: sums - - - -! !REVISION HISTORY: -! 15Jan01 - Jay Larson - API specification. -! 25Jan01 - Jay Larson - Prototype code. -! 23Apr01 - Jay Larson - Modified to accomodate -! changes to the SparseMatrix type. -! 18May01 - R. Jacob - Use MP_TYPE function -! to set type in the mpi_allreduce -! ______________________________________________________________________ -! - character(len=*),parameter :: myname_=myname//'::row_sumDP_' - - integer :: i, igrow, ierr, iwgt, lsize, myID - integer :: start_row, end_row - integer :: mp_Type_lsums - real(FP), dimension(:), allocatable :: lsums - real(FP), dimension(:), allocatable :: gsums - - ! Determine local rank - - call MP_COMM_RANK(comm, myID, ierr) - - ! Determine on each process the row of global row indices: - - call global_row_range_(sMat, comm, start_row, end_row) - - ! Determine across the communicator the _maximum_ value of - ! end_row, which will be assigned to num_rows on each process: - - call MPI_ALLREDUCE(end_row, num_rows, 1, MP_INTEGER, MP_MAX, & - comm, ierr) - if(ierr /= 0) then - call MP_perr_die(myname_,"MPI_ALLREDUCE(end_row...",ierr) - endif - - ! Allocate storage for the sums on each process. - - allocate(lsums(num_rows), gsums(num_rows), sums(num_rows), stat=ierr) - - if(ierr /= 0) then - call die(myname_,"allocate(lsums(...",ierr) - endif - - ! Compute the local entries to lsum(1:num_rows) for each process: - - lsize = AttrVect_lsize(sMat%data) - igrow = AttrVect_indexIA(aV=sMat%data,item='grow',dieWith=myname_) - iwgt = AttrVect_indexRA(aV=sMat%data,item='weight',dieWith=myname_) - - lsums = 0._FP - do i=1,lsize - lsums(sMat%data%iAttr(igrow,i)) = lsums(sMat%data%iAttr(igrow,i)) + & - sMat%data%rAttr(iwgt,i) - end do - - ! Compute the global sum of the entries of lsums so that all - ! processes own the global sums. - - mp_Type_lsums=MP_Type(lsums) - call MPI_ALLREDUCE(lsums, gsums, num_rows, mp_Type_lsums, MP_SUM, comm, ierr) - if(ierr /= 0) then - call MP_perr_die(myname_,"MPI_ALLREDUCE(lsums...",ierr) - endif - - ! Copy our temporary array gsums into the output pointer sums - ! This was done so that lsums and gsums have the same precision (FP) - ! Precision conversion occurs here from FP to (SP or DP) - - sums = gsums - - ! Clean up... - - deallocate(lsums, gsums, stat=ierr) - if(ierr /= 0) then - call die(myname_,"deallocate(lsums...",ierr) - endif - - end subroutine row_sumDP_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: row_sum_checkSP_ - Check Row Sums vs. Valid Values -! -! !DESCRIPTION: The routine {\tt row\_sum\_check()} sums the rows of -! the input distributed (across the communicator identified by {\tt comm}) -! {\tt SparseMatrix} variable {\tt sMat}. It then compares these sums -! with the {\tt num\_valid} input "valid" values stored in the array -! {\tt valid\_sums}. If all of the sums are within the absolute tolerence -! specified by the input argument {\tt abs\_tol} of any of the valid values, -! the output {\tt LOGICAL} flag {\tt valid} is set to {\tt .TRUE}. -! Otherwise, this flag is returned with value {\tt .FALSE}. -! -! !INTERFACE: - - subroutine row_sum_checkSP_(sMat, comm, num_valid, valid_sums, abs_tol, valid) - -! -! !USES: -! - use m_die - use m_realkinds, only : SP, FP - - implicit none - -! !INPUT PARAMETERS: - - type(SparseMatrix), intent(in) :: sMat - integer, intent(in) :: comm - integer, intent(in) :: num_valid - real(SP), intent(in) :: valid_sums(num_valid) - real(SP), intent(in) :: abs_tol - -! !OUTPUT PARAMETERS: - - logical, intent(out) :: valid - -! !REVISION HISTORY: -! 15Jan01 - Jay Larson - API specification. -! 25Feb01 - Jay Larson - Prototype code. -! 06Jan03 - R. Jacob - create DP and SP versions -!EOP ___________________________________________________________________ -! - character(len=*),parameter :: myname_=myname//'::row_sum_checkSP_' - - integer :: i, j, num_invalid, num_rows - real(FP), dimension(:), pointer :: sums - - ! Compute row sums: - - call row_sum(sMat, num_rows, sums, comm) - - ! Initialize for the scanning loop (assume the matrix row - ! sums are valid): - - valid = .TRUE. - i = 1 - - SCAN_LOOP: do - - ! Count the number of elements in valid_sums(:) that - ! are separated from sums(i) by more than abs_tol - - num_invalid = 0 - - do j=1,num_valid - if(abs(sums(i) - valid_sums(j)) > abs_tol) then - num_invalid = num_invalid + 1 - endif - end do - - ! If num_invalid = num_valid, then we have failed to - ! find a valid sum value within abs_tol of sums(i). This - ! one failure is enough to halt the process. - - if(num_invalid == num_valid) then - valid = .FALSE. - EXIT - endif - - ! Prepare index i for the next element of sums(:) - - i = i + 1 - if( i > num_rows) EXIT - - end do SCAN_LOOP - - end subroutine row_sum_checkSP_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -! ---------------------------------------------------------------------- -! -! !IROUTINE: row_sum_checkDP_ - Check Row Sums vs. Valid Values -! -! !DESCRIPTION: -! Double precision version of row_sum_checkSP -! -! !INTERFACE: - - subroutine row_sum_checkDP_(sMat, comm, num_valid, valid_sums, abs_tol, valid) - -! -! !USES: -! - use m_die - use m_realkinds, only : DP, FP - - implicit none - -! !INPUT PARAMETERS: - - type(SparseMatrix), intent(in) :: sMat - integer, intent(in) :: comm - integer, intent(in) :: num_valid - real(DP), intent(in) :: valid_sums(num_valid) - real(DP), intent(in) :: abs_tol - -! !OUTPUT PARAMETERS: - - logical, intent(out) :: valid - -! !REVISION HISTORY: -! 15Jan01 - Jay Larson - API specification. -! 25Feb01 - Jay Larson - Prototype code. -! 06Jan03 - R. Jacob - create DP and SP versions -! ______________________________________________________________________ -! - character(len=*),parameter :: myname_=myname//'::row_sum_checkDP_' - - integer :: i, j, num_invalid, num_rows - real(FP), dimension(:), pointer :: sums - - ! Compute row sums: - - call row_sum(sMat, num_rows, sums, comm) - - ! Initialize for the scanning loop (assume the matrix row - ! sums are valid): - - valid = .TRUE. - i = 1 - - SCAN_LOOP: do - - ! Count the number of elements in valid_sums(:) that - ! are separated from sums(i) by more than abs_tol - - num_invalid = 0 - - do j=1,num_valid - if(abs(sums(i) - valid_sums(j)) > abs_tol) then - num_invalid = num_invalid + 1 - endif - end do - - ! If num_invalid = num_valid, then we have failed to - ! find a valid sum value within abs_tol of sums(i). This - ! one failure is enough to halt the process. - - if(num_invalid == num_valid) then - valid = .FALSE. - EXIT - endif - - ! Prepare index i for the next element of sums(:) - - i = i + 1 - if( i > num_rows) EXIT - - end do SCAN_LOOP - - end subroutine row_sum_checkDP_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: Sort_ - Generate Index Permutation -! -! !DESCRIPTION: -! The subroutine {\tt Sort\_()} uses a list of sorting keys defined by -! the input {\tt List} argument {\tt key\_list}, searches for the appropriate -! integer or real attributes referenced by the items in {\tt key\_list} -! ( that is, it identifies the appropriate entries in {sMat\%data\%iList} -! and {\tt sMat\%data\%rList}), and then uses these keys to generate an index -! permutation {\tt perm} that will put the nonzero matrix entries of stored -! in {\tt sMat\%data} in lexicographic order as defined by {\tt key\_ist} -! (the ordering in {\tt key\_list} being from left to right. The optional -! {\tt LOGICAL} array input argument {\tt descend} specifies whether or -! not to sort by each key in {\em descending} order or {\em ascending} -! order. Entries in {\tt descend} that have value {\tt .TRUE.} correspond -! to a sort by the corresponding key in descending order. If the argument -! {\tt descend} is not present, the sort is performed for all keys in -! ascending order. -! -! !INTERFACE: - - subroutine Sort_(sMat, key_list, perm, descend) - -! -! !USES: -! - use m_die , only : die - use m_stdio , only : stderr - - use m_List , only : List - - use m_AttrVect, only: AttrVect_Sort => Sort - - implicit none -! -! !INPUT PARAMETERS: - - type(SparseMatrix), intent(in) :: sMat - type(List), intent(in) :: key_list - logical, dimension(:), optional, intent(in) :: descend -! -! !OUTPUT PARAMETERS: - - integer, dimension(:), pointer :: perm - - -! !REVISION HISTORY: -! 24Apr01 - J.W. Larson - initial prototype -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::Sort_' - - if(present(descend)) then - call AttrVect_Sort(sMat%data, key_list, perm, descend) - else - call AttrVect_Sort(sMat%data, key_list, perm) - endif - - end Subroutine Sort_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: Permute_ - Permute Matrix Elements using Supplied Index Permutation -! -! !DESCRIPTION: -! The subroutine {\tt Permute\_()} uses an input index permutation -! {\tt perm} to re-order the entries of the {\tt SparseMatrix} argument -! {\tt sMat}. The index permutation {\tt perm} is generated using the -! routine {\tt Sort\_()} (in this module). -! -! !INTERFACE: - - subroutine Permute_(sMat, perm) - -! -! !USES: -! - use m_die , only : die - use m_stdio , only : stderr - - use m_AttrVect, only: AttrVect_Permute => Permute - - implicit none -! -! !INPUT PARAMETERS: - - - integer, dimension(:), pointer :: perm -! -! !INPUT/OUTPUT PARAMETERS: - - type(SparseMatrix), intent(inout) :: sMat - - -! !REVISION HISTORY: -! 24Apr01 - J.W. Larson - initial prototype -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::Permute_' - - call AttrVect_Permute(sMat%data, perm) - - end Subroutine Permute_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: SortPermute_ - Sort and Permute Matrix Elements -! -! !DESCRIPTION: -! The subroutine {\tt SortPermute\_()} uses a list of sorting keys defined -! by the input {\tt List} argument {\tt key\_list}, searches for the -! appropriate integer or real attributes referenced by the items in -! {\tt key\_ist} ( that is, it identifies the appropriate entries in -! {sMat\%data\%iList} and {\tt sMat\%data\%rList}), and then uses these -! keys to generate an index permutation that will put the nonzero matrix -! entries of stored in {\tt sMat\%data} in lexicographic order as defined -! by {\tt key\_list} (the ordering in {\tt key\_list} being from left to -! right. The optional {\tt LOGICAL} array input argument {\tt descend} -! specifies whether or not to sort by each key in {\em descending} order -! or {\em ascending} order. Entries in {\tt descend} that have value -! {\tt .TRUE.} correspond to a sort by the corresponding key in descending -! order. If the argument {\tt descend} is not present, the sort is -! performed for all keys in ascending order. -! -! Once this index permutation is created, it is applied to re-order the -! entries of the {\tt SparseMatrix} argument {\tt sMat} accordingly. -! -! !INTERFACE: - - subroutine SortPermute_(sMat, key_list, descend) - -! -! !USES: -! - use m_die , only : die - use m_stdio , only : stderr - - use m_List , only : List - - implicit none -! -! !INPUT PARAMETERS: - - type(List), intent(in) :: key_list - logical, dimension(:), optional, intent(in) :: descend -! -! !INPUT/OUTPUT PARAMETERS: - - type(SparseMatrix), intent(inout) :: sMat - -! !REVISION HISTORY: -! 24Apr01 - J.W. Larson - initial prototype -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::SortPermute_' - - integer :: ier - integer, dimension(:), pointer :: perm - - ! Create index permutation perm(:) - - if(present(descend)) then - call Sort_(sMat, key_list, perm, descend) - else - call Sort_(sMat, key_list, perm) - endif - - ! Apply index permutation perm(:) to re-order sMat: - - call Permute_(sMat, perm) - - ! Clean up - - deallocate(perm, stat=ier) - if(ier/=0) call die(myname_, "deallocate(perm)", ier) - - end subroutine SortPermute_ - - end module m_SparseMatrix - - - diff --git a/cesm/models/utils/mct/mct/m_SparseMatrixComms.F90 b/cesm/models/utils/mct/mct/m_SparseMatrixComms.F90 deleted file mode 100644 index 3fd489b..0000000 --- a/cesm/models/utils/mct/mct/m_SparseMatrixComms.F90 +++ /dev/null @@ -1,699 +0,0 @@ -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!----------------------------------------------------------------------- -! CVS $Id$ -! CVS $Name$ -!BOP ------------------------------------------------------------------- -! -! !MODULE: m_SparseMatrixComms -- sparse matrix communications methods. -! -! !DESCRIPTION: -! The {\tt SparseMatrix} datatype provides sparse matrix storage for -! the parallel matrix-vector multiplication ${\bf y} = {\bf M} {\bf x}$. -! This module provides communications services for the {\tt SparseMatrix} -! type. These services include scattering matrix elements based on row or -! column decompositions, gathering of matrix elements to the root, and -! broadcasting from the root. -! -! {\bf N.B.:} These routines will not communicate the vector portion -! of a {\tt SparseMatrix}, if it has been initialized. A WARNING will -! be issued in most cases. In general, do communication first, then -! call {\tt vecinit}. -! -! !INTERFACE: - - module m_SparseMatrixComms - - private ! except - -! !PUBLIC MEMBER FUNCTIONS: -! - public :: ScatterByColumn - public :: ScatterByRow - public :: Gather - public :: Bcast - - interface ScatterByColumn ; module procedure & - ScatterByColumnGSMap_ - end interface - - interface ScatterByRow ; module procedure & - ScatterByRowGSMap_ - end interface - - interface Gather ; module procedure & - GM_gather_, & - GSM_gather_ - end interface - - interface Bcast ; module procedure Bcast_ ; end interface - -! !REVISION HISTORY: -! 13Apr01 - J.W. Larson - initial prototype -! and API specifications. -! 10May01 - J.W. Larson - added GM_gather_ -! and cleaned up prologues. -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname='MCT::m_SparseMatrixComms' - - contains - -!------------------------------------------------------------------------- -! Math + Computer Science Division / Argonne National Laboratory ! -!------------------------------------------------------------------------- -!BOP -! -! !IROUTINE: ScatterByColumnGSMap_ - Column-based scatter for SparseMatrix. -! -! !DESCRIPTION: This routine scatters the input {\tt SparseMatrix} -! argument {\tt GsMat} (valid only on the root) to a distributed -! {\tt SparseMatrix} variable {\tt LsMat} across all the processes -! present on the communicator associated with the integer handle -! {\tt comm}. The decomposition defining the scatter is supplied by the -! input {\tt GlobalSegMap} argument {\tt columnGSMap}. The optional -! output {\tt INTEGER} flag {\tt stat} signifies a successful (failed) -! operation if it is returned with value zero (nonzero). -! -! {\bf N.B.:} This routine returns an allocated {\tt SparseMatrix} -! variable {\tt LsMat}. The user must destroy this variable when it -! is no longer needed by invoking {\tt SparseMatrix\_Clean()}. -! -! !INTERFACE: - - subroutine ScatterByColumnGSMap_(columnGSMap, GsMat, LsMat, root, comm, stat) -! -! !USES: -! - - use m_die, only : MP_perr_die,die - use m_stdio - use m_mpif90 - - use m_List, only: List - use m_List, only: List_init => init - use m_List, only: List_clean => clean - - use m_GlobalSegMap, only : GlobalSegMap - use m_GlobalSegMap, only : GlobalSegMap_clean => clean - - use m_SparseMatrix, only : SparseMatrix - use m_SparseMatrix, only : SparseMatrix_nRows => nRows - use m_SparseMatrix, only : SparseMatrix_nCols => nCols - use m_SparseMatrix, only : SparseMatrix_SortPermute => SortPermute - - use m_SparseMatrixDecomp, only : SparseMatrixDecompByColumn => ByColumn - - use m_AttrVectComms, only : AttrVect_Scatter => scatter - - implicit none - -! !INPUT PARAMETERS: -! - type(GlobalSegMap), intent(in) :: columnGSMap - integer, intent(in) :: root - integer, intent(in) :: comm - -! !INPUT/OUTPUT PARAMETERS: -! - type(SparseMatrix), intent(inout) :: GsMat - -! !OUTPUT PARAMETERS: -! - type(SparseMatrix), intent(out) :: LsMat - integer, optional, intent(out) :: stat - -! !REVISION HISTORY: -! -! 13Apr01 - J.W. Larson - initial API spec. -! 10May01 - J.W. Larson - cleaned up prologue. -! 13Jun01 - J.W. Larson - Made status flag stat -! optional, and ititilaze it to zero if it is present. -! 09Jul03 - E.T. Ong - added sorting to distributed -! matrix elements -!EOP -!------------------------------------------------------------------------- - - character(len=*),parameter :: myname_=myname//'ScatterByColumnGSMap_' -! GlobalSegMap used to create column decomposition of GsMat - type(GlobalSegMap) :: MatGSMap -! Storage for the number of rows and columns in the SparseMatrix - integer :: NumRowsColumns(2) -! List storage for sorting keys - type(List) :: sort_keys -! Process ID - integer :: myID -! Error flag - integer :: ierr - - ! Initialize stat if present - - if(present(stat)) stat = 0 - - ! Which process am I? - - call MPI_COMM_RANK(comm, myID, ierr) - if(ierr /= 0) then - call MP_perr_die(myname_,"MPI_COMM_RANK() failed",ierr) - endif - - ! can't scatter vector parts. - if((myID.eq.root) .and. GsMat%vecinit) then - write(stderr,*) myname_,& - "WARNING: will not scatter vector parts of GsMat" - endif - - ! Create from columnGSMap the corresponding GlobalSegMap - ! that will decompose GsMat by column the same way. - - call SparseMatrixDecompByColumn(columnGSMap, GsMat, MatGSMap, root, comm) - - ! Broadcast the resulting GlobalSegMap across the communicator - - ! Scatter the matrix element data GsMat%data accordingly - - call AttrVect_Scatter(GsMat%data, LsMat%data, MatGSMap, root, comm, ierr) - - if(ierr /= 0) then - if(present(stat)) then - write(stderr,*) myname_,":: AttrVect_Scatter(GsMat%data) failed--stat=", & - ierr - stat = ierr - return - else - call die(myname_,"call AttrVect_Scatter(GsMat%data,..",ierr) - endif - endif - - ! Now, distribute to all the processes the number of Rows and - ! columns in GsMat (which are valid on the root only at this point) - - if(myID == root) then - NumRowsColumns(1) = SparseMatrix_nRows(GsMat) - NumRowsColumns(2) = SparseMatrix_nCols(GsMat) - endif - - call MPI_Bcast(NumRowsColumns, 2, MP_INTEGER, root, comm, ierr) - - if(ierr /= 0) then - call MP_perr_die(myname_,"MPI_Bcast(NumRowsColumns...",ierr) - endif - - ! Unpack NumRowsColumns - - LsMat%nrows = NumRowsColumns(1) - LsMat%ncols = NumRowsColumns(2) - - ! Set the value of vecinit - LsMat%vecinit = .FALSE. - - ! Finally, lets sort the distributed local matrix elements - - ! Sort the matrix entries in sMat by column, then row. - ! First, create the key list... - - call List_init(sort_keys,'gcol:grow') - - ! Now perform the sort/permute... - call SparseMatrix_SortPermute(LsMat, sort_keys) - - ! Cleanup - - call List_clean(sort_keys) - call GlobalSegMap_clean(MatGSMap) - - end subroutine ScatterByColumnGSMap_ - -!------------------------------------------------------------------------- -! Math + Computer Science Division / Argonne National Laboratory ! -!------------------------------------------------------------------------- -!BOP -! -! !IROUTINE: ScatterByRowGSMap_ -Row-based scatter for SparseMatrix. -! -! !DESCRIPTION: This routine scatters the input {\tt SparseMatrix} -! argument {\tt GsMat} (valid only on the root) to a distributed -! {\tt SparseMatrix} variable {\tt LsMat} across all the processes -! present on the communicator associated with the integer handle -! {\tt comm}. The decomposition defining the scatter is supplied by the -! input {\tt GlobalSegMap} argument {\tt rowGSMap}. The output integer -! flag {\tt stat} signifies a successful (failed) operation if it is -! returned with value zero (nonzero). -! -! {\bf N.B.:} This routine returns an allocated {\tt SparseMatrix} -! variable {\tt LsMat}. The user must destroy this variable when it -! is no longer needed by invoking {\tt SparseMatrix\_Clean()}. -! -! !INTERFACE: - - subroutine ScatterByRowGSMap_(rowGSMap, GsMat, LsMat, root, comm, stat) -! -! !USES: -! - use m_die, only : MP_perr_die,die - use m_stdio - use m_mpif90 - - use m_List, only: List - use m_List, only: List_init => init - use m_List, only: List_clean => clean - - use m_GlobalSegMap, only : GlobalSegMap - use m_GlobalSegMap, only : GlobalSegMap_clean => clean - - use m_SparseMatrix, only : SparseMatrix - use m_SparseMatrix, only : SparseMatrix_nRows => nRows - use m_SparseMatrix, only : SparseMatrix_nCols => nCols - use m_SparseMatrix, only : SparseMatrix_SortPermute => SortPermute - - use m_SparseMatrixDecomp, only : SparseMatrixDecompByRow => ByRow - - use m_AttrVectComms, only : AttrVect_Scatter => scatter - - implicit none - -! !INPUT PARAMETERS: -! - type(GlobalSegMap), intent(in) :: rowGSMap - integer, intent(in) :: root - integer, intent(in) :: comm - -! !INPUT/OUTPUT PARAMETERS: -! - type(SparseMatrix), intent(inout) :: GsMat - -! !OUTPUT PARAMETERS: -! - type(SparseMatrix), intent(out) :: LsMat - integer, optional, intent(out) :: stat - -! !REVISION HISTORY: -! -! 13Apr01 - J.W. Larson - initial API spec. -! 26Apr01 - R.L. Jacob - fix use statement -! from SMDecomp so it points to ByRow -! 13Jun01 - J.W. Larson - Made status flag stat -! optional, and initialize it to zero if it is present. -! 09Jul03 - E.T. Ong - Added sorting to distributed -! matrix elements. -!EOP -!------------------------------------------------------------------------- - - character(len=*),parameter :: myname_=myname//'ScatterByRowGSMap_' -! GlobalSegMap used to create row decomposition of GsMat - type(GlobalSegMap) :: MatGSMap -! Storage for the number of rows and columns in the SparseMatrix - integer :: NumRowsColumns(2) -! List storage for sorting keys - type(List) :: sort_keys -! Process ID - integer :: myID -! Error flag - integer :: ierr - - ! Initialize stat to zero (if present) - - if(present(stat)) stat = 0 - - ! Which process are we? - - call MPI_COMM_RANK(comm, myID, ierr) - if(ierr /= 0) then - call MP_perr_die(myname_,"MPI_COMM_RANK() failed",ierr) - endif - - ! can't scatter vector parts. - if((myID.eq.root) .and. GsMat%vecinit) then - write(stderr,*) myname_,& - "WARNING: will not scatter vector parts of GsMat." - endif - - ! Create from rowGSMap the corresponding GlobalSegMap - ! that will decompose GsMat by row the same way. - - call SparseMatrixDecompByRow(rowGSMap, GsMat, MatGSMap, root, comm) - - ! Scatter the matrix element data GsMat%data accordingly - - call AttrVect_Scatter(GsMat%data, LsMat%data, MatGSMap, root, comm, ierr) - if(ierr /= 0) then - if(present(stat)) then - write(stderr,*) myname_,":: AttrVect_Scatter(GsMat%data) failed--stat=", & - ierr - stat = ierr - return - else - call die(myname_,"call AttrVect_Scatter(GsMat%data,..",ierr) - endif - endif - - ! Now, distribute to all the processes the number of rows and - ! columns in GsMat (which are valid on the root only at this point) - - if(myID == root) then - NumRowsColumns(1) = SparseMatrix_nRows(GsMat) - NumRowsColumns(2) = SparseMatrix_nCols(GsMat) - endif - - call MPI_Bcast(NumRowsColumns, 2, MP_INTEGER, root, comm, ierr) - if(ierr /= 0) then - call MP_perr_die(myname_,"MPI_Bcast(NumRowsColumns...",ierr) - endif - - ! Unpack NumRowsColumns - - LsMat%nrows = NumRowsColumns(1) - LsMat%ncols = NumRowsColumns(2) - - ! Set the value of vecinit - LsMat%vecinit = .FALSE. - - ! Sort the matrix entries in sMat by row, then column. - ! First, create the key list... - - call List_init(sort_keys,'grow:gcol') - - ! Now perform the sort/permute... - call SparseMatrix_SortPermute(LsMat, sort_keys) - - ! Cleanup - - call List_clean(sort_keys) - call GlobalSegMap_clean(MatGSMap) - - end subroutine ScatterByRowGSMap_ - -!------------------------------------------------------------------------- -! Math + Computer Science Division / Argonne National Laboratory ! -!------------------------------------------------------------------------- -!BOP -! -! !IROUTINE: GM_gather_ - Gather a distributed SparseMatrix to the root. -! -! !DESCRIPTION: This routine gathers the input distributed -! {\tt SparseMatrix} argument {\tt LsMat} to the {\tt SparseMatrix} -! variable {\tt GsMat} on the root. The decomposition defining the gather -! is supplied by the input {\tt GlobalMap} argument {\tt GMap}. The -! status flag {\tt stat} has value zero (nonzero) if the operation has -! succeeded (failed). -! -! {\bf N.B.:} This routine returns an allocated {\tt SparseMatrix} -! variable {\tt GsMat}. The user must destroy this variable when it -! is no longer needed by invoking {\tt SparseMatrix\_Clean()}. -! -! !INTERFACE: - - subroutine GM_gather_(LsMat, GsMat, GMap, root, comm, stat) -! -! !USES: -! - use m_stdio - use m_die, only : die - - use m_GlobalMap, only: GlobalMap - - use m_SparseMatrix, only: SparseMatrix - use m_SparseMatrix, only: SparseMatrix_nRows => nRows - use m_SparseMatrix, only: SparseMatrix_nCols => nCols - - use m_AttrVectComms, only : AttrVect_gather => gather - - implicit none - -! !INPUT PARAMETERS: -! - type(SparseMatrix), intent(in) :: LsMat - type(GlobalMap), intent(in) :: GMap - integer, intent(in) :: root - integer, intent(in) :: comm - -! !OUTPUT PARAMETERS: -! - type(SparseMatrix), intent(out) :: GsMat - integer, optional, intent(out) :: stat - -! !REVISION HISTORY: -! -! 13Apr01 - J.W. Larson - initial API spec. -! 10May01 - J.W. Larson - initial routine and -! prologue -! 13Jun01 - J.W. Larson - Made status flag stat -! optional, and ititilaze it to zero if it is present. -!EOP -!------------------------------------------------------------------------- - - character(len=*),parameter :: myname_=myname//'GM_gather_' - integer :: ierr - - ! if stat is present, initialize its value to zero (success) - - if(present(stat)) stat = 0 - - if(LsMat%vecinit) then - write(stderr,*) myname_,& - "WARNING: will not gather vector parts of LsMat." - endif - - call AttrVect_gather(LsMat%data, GsMat%data, GMap, root, comm, ierr) - if(ierr /= 0) then - if(present(stat)) then - write(stderr,*) myname_,":: AttrVect_Gather(LsMat%data...) failed--stat=", & - ierr - stat = ierr - return - else - call die(myname_,"call AttrVect_Scatter(LsMat%data...) failed",ierr) - endif - endif - - ! For now, the GsMat inherits the number of rows and columns from - ! the corresponding values of LsMat on the root (this should be - ! checked in future versions). - - GsMat%nrows = SparseMatrix_nRows(LsMat) - GsMat%ncols = SparseMatrix_nCols(LsMat) - - GsMat%vecinit = .FALSE. - - end subroutine GM_gather_ - -!------------------------------------------------------------------------- -! Math + Computer Science Division / Argonne National Laboratory ! -!------------------------------------------------------------------------- -!BOP -! -! !IROUTINE: GSM_gather_ - Gather a distributed SparseMatrix to the root. -! -! !DESCRIPTION: This routine gathers the input distributed -! {\tt SparseMatrix} argument {\tt LsMat} to the {\tt SparseMatrix} -! variable {\tt GsMat} on the root. The decomposition defining the gather -! is supplied by the input {\tt GlobalSegMap} argument {\tt GSMap}. The -! status flag {\tt stat} has value zero (nonzero) if the operation has -! succeeded (failed). -! -! {\bf N.B.:} This routine returns an allocated {\tt SparseMatrix} -! variable {\tt GsMat}. The user must destroy this variable when it -! is no longer needed by invoking {\tt SparseMatrix\_Clean()}. -! -! !INTERFACE: - - subroutine GSM_gather_(LsMat, GsMat, GSMap, root, comm, stat) -! -! !USES: -! - use m_stdio - use m_die, only : die - - use m_GlobalSegMap, only: GlobalSegMap - - use m_SparseMatrix, only: SparseMatrix - use m_SparseMatrix, only: SparseMatrix_nRows => nRows - use m_SparseMatrix, only: SparseMatrix_nCols => nCols - - use m_AttrVectComms, only : AttrVect_gather => gather - - implicit none - -! !INPUT PARAMETERS: -! - type(SparseMatrix), intent(in) :: LsMat - type(GlobalSegMap), intent(in) :: GSMap - integer, intent(in) :: root - integer, intent(in) :: comm - -! !OUTPUT PARAMETERS: -! - type(SparseMatrix), intent(out) :: GsMat - integer, optional, intent(out) :: stat - -! !REVISION HISTORY: -! -! 13Apr01 - J.W. Larson - initial API spec. -! 13Jun01 - J.W. Larson - Made status flag stat -! optional, and ititilaze it to zero if it is present. -!EOP -!------------------------------------------------------------------------- - - character(len=*),parameter :: myname_=myname//'GSM_gather_' - integer :: ierr - - ! if stat is present, initialize its value to zero (success) - - if(present(stat)) stat = 0 - - if(LsMat%vecinit) then - write(stderr,*) myname_,& - "WARNING: will not gather vector parts of LsMat." - endif - - ! Gather the AttrVect component of LsMat to GsMat... - - call AttrVect_gather(LsMat%data, GsMat%data, GSMap, root, comm, ierr) - if(ierr /= 0) then - if(present(stat)) then - write(stderr,*) myname_,":: AttrVect_Gather(LsMat%data...) failed--stat=", & - ierr - stat = ierr - return - else - call die(myname_,"call AttrVect_Gather(LsMat%data...)",ierr) - endif - endif - - ! For now, the GsMat inherits the number of rows and columns from - ! the corresponding values of LsMat on the root (this should be - ! checked in future versions). - - GsMat%nrows = SparseMatrix_nRows(LsMat) - GsMat%ncols = SparseMatrix_nCols(LsMat) - - GsMat%vecinit = .FALSE. - - end subroutine GSM_gather_ - -!------------------------------------------------------------------------- -! Math + Computer Science Division / Argonne National Laboratory ! -!------------------------------------------------------------------------- -!BOP -! -! !IROUTINE: Bcast_ - Broadcast a SparseMatrix. -! -! !DESCRIPTION: This routine broadcasts the {\tt SparseMatrix} argument -! {\tt sMat} from the root to all processes on the communicator associated -! with the communicator handle {\tt comm}. The status flag {\tt stat} -! has value zero if the operation has succeeded. -! -! {\bf N.B.:} This routine returns an allocated {\tt SparseMatrix} -! variable {\tt sMat}. The user must destroy this variable when it -! is no longer needed by invoking {\tt SparseMatrix\_Clean()}. -! -! {\bf N.B.:} This routine will exit with an error if the vector portion -! of {\tt sMat} has been initialized prior to broadcast. -! -! !INTERFACE: - - subroutine Bcast_(sMat, root, comm, stat) - -! -! !USES: -! - - use m_die, only : MP_perr_die,die - use m_stdio - use m_mpif90 - - use m_GlobalSegMap, only: GlobalSegMap - - use m_AttrVectComms, only : AttrVect_bcast => bcast - - use m_SparseMatrix, only: SparseMatrix - use m_SparseMatrix, only: SparseMatrix_nRows => nRows - use m_SparseMatrix, only: SparseMatrix_nCols => nCols - - implicit none - -! !INPUT PARAMETERS: -! - integer, intent(in) :: root - integer, intent(in) :: comm - -! !INPUT/OUTPUT PARAMETERS: -! - type(SparseMatrix), intent(inout) :: sMat - -! !OUTPUT PARAMETERS: -! - integer, optional, intent(out) :: stat - -! !REVISION HISTORY: -! -! 13Apr01 - J.W. Larson - initial API spec/code -! 13Jun01 - J.W. Larson - Made status flag stat -! optional, and ititilaze it to zero if it is present. -! 17Jul02 - J.W. Larson - Bug fix--local -! process ID myID was uninitialized. -!EOP -!------------------------------------------------------------------------- - - character(len=*),parameter :: myname_=myname//'Bcast_' - -! Storage for the number of rows and columns in the SparseMatrix - integer :: NumRowsColumns(2) -! Process ID number - integer :: myID -! Error flag - integer :: ierr - - ! Initialize stat if present - - if(present(stat)) stat = 0 - - ! Determine local process ID myID: - - call MPI_COMM_RANK(comm, myID, ierr) - if(ierr /= 0) then - call MP_perr_die(myname_,"MPI_COMM_RANK() failed",ierr) - endif - - if((myID.eq.root) .and. sMat%vecinit) then - write(stderr,*) myname_,& - "Cannot broadcast SparseMatrix with initialized vector parts." - call die(myname_,"Gather SparseMatrix with vecinit TRUE.") - endif - - ! Broadcast sMat%data from the root - - call AttrVect_bcast(sMat%data, root, comm, ierr) - if(ierr /= 0) then - if(present(stat)) then - write(stderr,*) myname_,":: AttrVect_bcast(sMat%data...failed--stat=", & - ierr - stat = ierr - return - else - call die(myname_,"call AttrVect_bcast(sMat%data...) failed",ierr) - endif - endif - - if(myID == root) then - NumRowsColumns(1) = SparseMatrix_nRows(sMat) - NumRowsColumns(2) = SparseMatrix_nCols(sMat) - endif - - call MPI_Bcast(NumRowsColumns, 2, MP_INTEGER, root, comm, ierr) - if(ierr /= 0) then - call MP_perr_die(myname_,"MPI_Bcast(NumRowsColumns...",ierr) - endif - - ! Unpack NumRowsColumns on broadcast destination processes - - if(myID /= root) then - sMat%nrows = NumRowsColumns(1) - sMat%ncols = NumRowsColumns(2) - endif - - sMat%vecinit = .FALSE. - - end subroutine Bcast_ - - end module m_SparseMatrixComms diff --git a/cesm/models/utils/mct/mct/m_SparseMatrixDecomp.F90 b/cesm/models/utils/mct/mct/m_SparseMatrixDecomp.F90 deleted file mode 100644 index e34baac..0000000 --- a/cesm/models/utils/mct/mct/m_SparseMatrixDecomp.F90 +++ /dev/null @@ -1,756 +0,0 @@ -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!----------------------------------------------------------------------- -! CVS $Id$ -! CVS $Name$ -!BOP ------------------------------------------------------------------- -! -! !MODULE: m_SparseMatrixDecomp -- Parallel sparse matrix decomposition. -! -! !DESCRIPTION: -! The {\tt SparseMatrix} datatype provides sparse matrix storage for -! the parallel matrix-vector multiplication ${\bf y} = {\bf M} {\bf x}$. -! This module provides services to create decompositions for the -! {\tt SparseMatrix}. The matrix decompositions available are row -! and column decompositions. They are generated by invoking the -! appropriate routine in this module, and passing the corresponding -! {\em vector} decomposition. For a row (column) decomposition, one -! invokes the routine {\tt ByRow()} ({\tt ByColumn()}), passing the -! domain decomposition for the vector {\bf y} ({\bf x}). -! -! !INTERFACE: - - module m_SparseMatrixDecomp - - private ! except - -! !PUBLIC MEMBER FUNCTIONS: -! - public :: ByColumn - public :: ByRow - - - interface ByColumn ; module procedure & - ByColumnGSMap_ - end interface - - interface ByRow ; module procedure & - ByRowGSMap_ - end interface - -! !REVISION HISTORY: -! 13Apr01 - J.W. Larson - initial prototype -! and API specifications. -! 03Aug01 - E. Ong - in ByRowGSMap and ByColumnGSMap, -! call GlobalSegMap_init on non-root processes with actual -! shaped arguments to satisfy Fortran 90 standard. See -! comments in ByRowGSMap/ByColumnGSMap. -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname='MCT::m_SparseMatrixDecomp' - - contains - -!------------------------------------------------------------------------- -! Math + Computer Science Division / Argonne National Laboratory ! -!------------------------------------------------------------------------- -!BOP -! -! !IROUTINE: ByColumnGSMap_ - Generate Row-based GlobalSegMap for SparseMatrix -! -! !INTERFACE: - - subroutine ByColumnGSMap_(xGSMap, sMat, sMGSMap, root, comm) -! -! !USES: -! - use m_die, only: MP_perr_die,die - - use m_List, only: List - use m_List, only: List_init => init - use m_List, only: List_clean => clean - - use m_AttrVect, only: AttrVect - use m_AttrVect, only: AttrVect_init => init - use m_AttrVect, only: AttrVect_zero => zero - use m_AttrVect, only: AttrVect_lsize => lsize - use m_AttrVect, only: AttrVect_indexIA => indexIA - use m_AttrVect, only: AttrVect_copy => copy - use m_AttrVect, only: AttrVect_clean => clean - - use m_AttrVectComms, only: AttrVect_scatter => scatter - use m_AttrVectComms, only: AttrVect_gather => gather - - use m_GlobalMap, only : GlobalMap - use m_GlobalMap, only : GlobalMap_init => init - use m_GlobalMap, only : GlobalMap_clean => clean - - use m_GlobalSegMap, only: GlobalSegMap - use m_GlobalSegMap, only: GlobalSegMap_init => init - use m_GlobalSegMap, only: GlobalSegMap_peLocs => peLocs - use m_GlobalSegMap, only: GlobalSegMap_comp_id => comp_id - - use m_SparseMatrix, only: SparseMatrix - use m_SparseMatrix, only: SparseMatrix_lsize => lsize - use m_SparseMatrix, only: SparseMatrix_SortPermute => SortPermute - - implicit none - -! !INPUT PARAMETERS: -! - type(GlobalSegMap), intent(in) :: xGSMap - integer, intent(in) :: root - integer, intent(in) :: comm - -! !INPUT/OUTPUT PARAMETERS: -! - type(SparseMatrix), intent(inout) :: sMat - -! !OUTPUT PARAMETERS: -! - type(GlobalSegMap), intent(out) :: sMGSMap - -! !DESCRIPTION: This routine is invoked from all processes on the -! communicator {\tt comm} to create from an input {\tt SparseMatrix} -! {\tt sMat} (valid only on the {\tt root} process) and an input -! {\bf x}-vector decomposition described by the {\tt GlobalSegMap} -! argument {\tt xGSMap} (valid at least on the {\tt root}) to create -! an output {\tt GlobalSegMap} decomposition of the matrix elements -! {\tt sMGSMap}, which is valid on all processes on the communicator. -! This matrix {\tt GlobalSegMap} describes the corresponding column -! decomposition of {\tt sMat}. -! -! {\bf N.B.}: The argument {\tt sMat} is returned sorted in lexicographic -! order by column and row. -! -! !REVISION HISTORY: -! -! 13Apr01 - J.W. Larson - initial API spec. -! 26Apr01 - R.L. Jacob - add use statements for -! GlobalSegMap_init and GSMap_peLocs. -! Add gsize argument required to GSMap_peLocs. -! Add underscore to ComputeSegments call so it matches -! the subroutine decleration. -! change attribute on starts,lengths, and pe_locs to -! pointer to match GSMap_init. -! add use m_die statement -! 26Apr01 - J.W. Larson - fixed major logic bug -! that had all processes executing some operations that -! should only occur on the root. -! 09Jul03 - E.T. Ong - call pe_locs in parallel. -! reduce the serial sort from gcol:grow to just gcol. -!EOP -!------------------------------------------------------------------------- - - character(len=*),parameter :: myname_=myname//'ByColumnGSMap_' -! Process ID number - integer :: myID, mySIZE -! Attributes for the output GlobalSegMap - integer :: gsize, comp_id, ngseg -! Temporary array for identifying each matrix element column and -! process ID destination - type(AttrVect) :: gcol - type(AttrVect) :: dist_gcol - type(AttrVect) :: element_pe_locs - type(AttrVect) :: dist_element_pe_locs -! Index variables for the AttrVects - integer :: dist_gsize - integer :: gcol_index - integer :: element_pe_locs_index -! Temporary array for initializing GlobalMap Decomposition - integer,dimension(:), allocatable :: counts -! GlobalMap for setting up decomposition to call pe_locs - type(GlobalMap) :: dist_GMap -! Temporary arrays for matrix GlobalSegMap attributes - integer, dimension(:), pointer :: starts, lengths, pe_locs -! List storage for sorting keys - type(List) :: sort_keys -! Error flag - integer :: ierr -! Loop index - integer :: i - - ! Determine process id number myID - - call MPI_COMM_RANK(comm, myID, ierr) - if(ierr /= 0) then - call MP_perr_die(myname_,'call MPI_COMM_RANK(...',ierr) - endif - - ! Determine the number of processors in communicator - - call MPI_COMM_SIZE(comm, mySIZE, ierr) - if(ierr /= 0) then - call MP_perr_die(myname_,'call MPI_COMM_SIZE(...',ierr) - endif - - ! Allocate space for GlobalMap length information - - allocate(counts(0:mySIZE-1),stat=ierr) - if(ierr/=0) call die(myname_,"allocate(counts)",ierr) - - ! First step: a lot of prep work on the root only: - - if(myID == root) then - - ! Sort the matrix entries in sMat by column. - ! First, create the key list... - - call List_init(sort_keys,'gcol') - - ! Now perform the sort/permute... - - call SparseMatrix_SortPermute(sMat, sort_keys) - - call List_clean(sort_keys) - - ! The global size of matrix GlobalSegMap is the number nonzero - ! elements in sMat. - - gsize = SparseMatrix_lsize(sMat) - - ! Allocate storage space for matrix element column indices and - ! process ID destinations - - call AttrVect_init(aV=gcol, iList="gcol", lsize=gsize) - - ! Extract global column information and place in array gCol - - call AttrVect_copy(aVin=sMat%data, aVout=gcol, iList="gcol") - - ! Setup GlobalMap decomposition lengths: - - do i=0,mySIZE-1 - counts(i) = gsize/mySIZE - enddo - counts(mySIZE-1) = counts(mySIZE-1) + mod(gsize,mySIZE) - - endif - - ! Initialize GlobalMap so that we can scatter the global row - ! information. The GlobalMap will inherit the component ID - ! from xGSMap - - comp_id = GlobalSegMap_comp_id(xGSMap) - - call GlobalMap_init(GMap=dist_GMap, comp_id=comp_id, lns=counts, & - root=root, comm=comm) - - call AttrVect_scatter(iV=gcol, oV=dist_gcol, GMap=dist_GMap, & - root=root, comm=comm) - - ! Similarly, we want to scatter the element_pe_locs using the - ! same decomposition - - dist_gsize = AttrVect_lsize(dist_gcol) - - call AttrVect_init(aV=dist_element_pe_locs, iList="element_pe_locs", & - lsize=dist_gsize) - call AttrVect_zero(dist_element_pe_locs) - - ! Compute process ID destination for each matrix element, - ! and store in the AttrVect element_pe_locs - - gcol_index = AttrVect_indexIA(dist_gcol,"gcol", dieWith=myname_) - element_pe_locs_index = AttrVect_indexIA(dist_element_pe_locs, & - "element_pe_locs", dieWith=myname_) - - call GlobalSegMap_peLocs(xGSMap, dist_gsize, & - dist_gcol%iAttr(gcol_index,1:dist_gsize), & - dist_element_pe_locs%iAttr(element_pe_locs_index,1:dist_gsize)) - - call AttrVect_gather(iV=dist_element_pe_locs, oV=element_pe_locs, & - GMap=dist_GMap, root=root, comm=comm) - - ! Back to the root operations - - if(myID == root) then - - ! Sanity check: Is the globalsize of sMat the same as the - ! gathered size of element_pe_locs? - - if(gsize /= AttrVect_lsize(element_pe_locs)) then - call die(myname_,"gsize /= AttrVect_lsize(element_pe_locs) & - & on root process") - endif - - ! Using the entries of gCol and element_pe_locs, build the - ! output GlobalSegMap attribute arrays starts(:), lengths(:), - ! and pe_locs(:) - - gcol_index = AttrVect_indexIA(gcol,"gcol", dieWith=myname_) - element_pe_locs_index = AttrVect_indexIA(element_pe_locs, & - "element_pe_locs", dieWith=myname_) - - call ComputeSegments_(element_pe_locs%iAttr(element_pe_locs_index, & - 1:gsize), & - gcol%iAttr(gcol_index,1:gsize), & - gsize, ngseg, starts, lengths, pe_locs) - ! Clean up on the root - - call AttrVect_clean(gcol) - call AttrVect_clean(element_pe_locs) - - endif ! if(myID == root) - - ! Non-root processes call GlobalSegMap_init with root_start, - ! root_length, and root_pe_loc, although these arguments are - ! not used in the subroutine. Since these correspond to dummy - ! shaped array arguments in initr_, the Fortran 90 standard - ! dictates that the actual arguments must contain complete shape - ! information. Therefore, these array arguments must be - ! allocated on all processes. - - if(myID /= root) then - allocate(starts(0),lengths(0),pe_locs(0),stat=ierr) - if(ierr /= 0) then - call die(myname_,'non-root allocate(starts...',ierr) - endif - endif - - ! Using this local data on the root, create the SparseMatrix - ! GlobalSegMap sMGSMap (which will be valid on all processes - ! on the communicator: - - call GlobalSegMap_init(sMGSMap, ngseg, starts, lengths, pe_locs, & - root, comm, comp_id, gsize) - - ! Clean up - - call GlobalMap_clean(dist_GMap) - call AttrVect_clean(dist_gcol) - call AttrVect_clean(dist_element_pe_locs) - - deallocate(starts, lengths, pe_locs, counts, stat=ierr) - if(ierr /= 0) then - call die(myname_,'deallocate(starts...',ierr) - endif - - - end subroutine ByColumnGSMap_ - -!------------------------------------------------------------------------- -! Math + Computer Science Division / Argonne National Laboratory ! -!------------------------------------------------------------------------- -!BOP -! -! !IROUTINE: ByRowGSMap_ - Generate Row-based GlobalSegMap for SparseMatrix -! -! !INTERFACE: - - subroutine ByRowGSMap_(yGSMap, sMat, sMGSMap, root, comm) -! -! !USES: -! - - use m_die, only: MP_perr_die,die - - use m_List, only: List - use m_List, only: List_init => init - use m_List, only: List_clean => clean - - use m_AttrVect, only: AttrVect - use m_AttrVect, only: AttrVect_init => init - use m_AttrVect, only: AttrVect_lsize => lsize - use m_AttrVect, only: AttrVect_indexIA => indexIA - use m_AttrVect, only: AttrVect_copy => copy - use m_AttrVect, only: AttrVect_clean => clean - use m_AttrVect, only: AttrVect_zero => zero - - use m_AttrVectComms, only: AttrVect_scatter => scatter - use m_AttrVectComms, only: AttrVect_gather => gather - - use m_GlobalMap, only : GlobalMap - use m_GlobalMap, only : GlobalMap_init => init - use m_GlobalMap, only : GlobalMap_clean => clean - - use m_GlobalSegMap, only: GlobalSegMap - use m_GlobalSegMap, only: GlobalSegMap_init => init - use m_GlobalSegMap, only: GlobalSegMap_peLocs => peLocs - use m_GlobalSegMap, only: GlobalSegMap_comp_id => comp_id - - use m_SparseMatrix, only: SparseMatrix - use m_SparseMatrix, only: SparseMatrix_lsize => lsize - use m_SparseMatrix, only: SparseMatrix_SortPermute => SortPermute - - implicit none - -! !INPUT PARAMETERS: -! - type(GlobalSegMap), intent(in) :: yGSMap - integer, intent(in) :: root - integer, intent(in) :: comm - -! !INPUT/OUTPUT PARAMETERS: -! - type(SparseMatrix), intent(inout) :: sMat - -! !OUTPUT PARAMETERS: -! - type(GlobalSegMap), intent(out) :: sMGSMap - -! !DESCRIPTION: This routine is invoked from all processes on the -! communicator {\tt comm} to create from an input {\tt SparseMatrix} -! {\tt sMat} (valid only on the {\tt root} process) and an input -! {\bf y}-vector decomposition described by the {\tt GlobalSegMap} -! argument {\tt yGSMap} (valid at least on the {\tt root}) to create -! an output {\tt GlobalSegMap} decomposition of the matrix elements -! {\tt sMGSMap}, which is valid on all processes on the communicator. -! This matrix {\tt GlobalSegMap} describes the corresponding row -! decomposition of {\tt sMat}. -! -! {\bf N.B.}: The argument {\tt sMat} is returned sorted in lexicographic -! order by row and column. -! -! !REVISION HISTORY: -! -! 13Apr01 - J.W. Larson - initial API spec. -! 26Apr01 - R.L. Jacob - add use statements for -! GlobalSegMap_init and GSMap_peLocs. -! Add gsize argument required to GSMap_peLocs. -! Add underscore to ComputeSegments call so it matches -! the subroutine decleration. -! change attribute on starts,lengths, and pe_locs to -! pointer to match GSMap_init. -! 26Apr01 - J.W. Larson - fixed major logic bug -! that had all processes executing some operations that -! should only occur on the root. -! 09Jun03 - E.T. Ong - call peLocs in parallel. -! reduce the serial sort from grow:gcol to just grow. -!EOP -!------------------------------------------------------------------------- - - character(len=*),parameter :: myname_=myname//'ByRowGSMap_' -! Process ID number and communicator size - integer :: myID, mySIZE -! Attributes for the output GlobalSegMap - integer :: gsize, comp_id, ngseg -! Temporary array for identifying each matrix element row and -! process ID destination - type(AttrVect) :: grow - type(AttrVect) :: dist_grow - type(AttrVect) :: element_pe_locs - type(AttrVect) :: dist_element_pe_locs -! Index variables for AttrVects - integer :: dist_gsize - integer :: grow_index - integer :: element_pe_locs_index -! Temporary array for initializing GlobalMap Decomposition - integer,dimension(:), allocatable :: counts -! GlobalMap for setting up decomposition to call pe_locs - type(GlobalMap) :: dist_GMap -! Temporary arrays for matrix GlobalSegMap attributes - integer, dimension(:), pointer :: starts, lengths, pe_locs -! List storage for sorting keys - type(List) :: sort_keys -! Error flag - integer :: ierr -! Loop index - integer :: i - - ! Determine process id number myID - - call MPI_COMM_RANK(comm, myID, ierr) - if(ierr /= 0) then - call MP_perr_die(myname_,'call MPI_COMM_RANK(...',ierr) - endif - - ! Determine the number of processors in communicator - - call MPI_COMM_SIZE(comm, mySIZE, ierr) - if(ierr /= 0) then - call MP_perr_die(myname_,'call MPI_COMM_SIZE(...',ierr) - endif - - ! Allocate space for GlobalMap length information - - allocate(counts(0:mySIZE-1),stat=ierr) - if(ierr/=0) call die(myname_,"allocate(counts)",ierr) - - ! First step: a lot of prep work on the root only: - - if(myID == root) then - - ! Sort the matrix entries in sMat by row. - ! First, create the key list... - - call List_init(sort_keys,'grow') - - ! Now perform the sort/permute... - - call SparseMatrix_SortPermute(sMat, sort_keys) - - call List_clean(sort_keys) - - ! The global size of matrix GlobalSegMap is the number of rows. - - gsize = SparseMatrix_lsize(sMat) - - ! Allocate storage space for matrix element row indices and - ! process ID destinations - - call AttrVect_init(aV=grow, iList="grow", lsize=gsize) - - ! Extract global row information and place in AttrVect grow - - call AttrVect_copy(aVin=sMat%data, aVout=grow, iList="grow") - - ! Setup GlobalMap decomposition lengths: - ! Give any extra points to the last process - - do i=0,mySIZE-1 - counts(i) = gsize/mySIZE - enddo - counts(mySIZE-1) = counts(mySIZE-1) + mod(gsize,mySIZE) - - endif - - ! Initialize GlobalMap and scatter the global row information. - ! The GlobalMap will inherit the component ID from yGSMap - - comp_id = GlobalSegMap_comp_id(yGSMap) - - call GlobalMap_init(GMap=dist_GMap, comp_id=comp_id, lns=counts, & - root=root, comm=comm) - - call AttrVect_scatter(iV=grow, oV=dist_grow, GMap=dist_GMap, & - root=root, comm=comm) - - ! Similarly, we want to scatter the element_pe_locs using the - ! same decomposition - - dist_gsize = AttrVect_lsize(dist_grow) - - call AttrVect_init(aV=dist_element_pe_locs, iList="element_pe_locs", & - lsize=dist_gsize) - call AttrVect_zero(dist_element_pe_locs) - - ! Compute process ID destination for each matrix element, - ! and store in the AttrVect element_pe_locs - - grow_index = AttrVect_indexIA(dist_grow,"grow", dieWith=myname_) - element_pe_locs_index = AttrVect_indexIA(dist_element_pe_locs, & - "element_pe_locs", dieWith=myname_) - - call GlobalSegMap_peLocs(yGSMap, dist_gsize, & - dist_grow%iAttr(grow_index,1:dist_gsize), & - dist_element_pe_locs%iAttr(element_pe_locs_index,1:dist_gsize)) - - ! Gather element_pe_locs on root so that we can call compute_segments - - call AttrVect_gather(iV=dist_element_pe_locs, oV=element_pe_locs, & - GMap=dist_GMap, root=root, comm=comm) - - ! Back to the root operations - - if(myID == root) then - - ! Sanity check: Is the globalsize of sMat the same as the - ! gathered size of element_pe_locs? - - if(gsize /= AttrVect_lsize(element_pe_locs)) then - call die(myname_,"gsize /= AttrVect_lsize(element_pe_locs) & - & on root process") - endif - - ! Using the entries of grow and element_pe_locs, build the - ! output GlobalSegMap attribute arrays starts(:), lengths(:), - ! and pe_locs(:) - - grow_index = AttrVect_indexIA(grow,"grow", dieWith=myname_) - element_pe_locs_index = AttrVect_indexIA(element_pe_locs, & - "element_pe_locs", dieWith=myname_) - - call ComputeSegments_(element_pe_locs%iAttr(element_pe_locs_index, & - 1:gsize), & - grow%iAttr(grow_index,1:gsize), & - gsize, ngseg, starts, lengths, pe_locs) - - ! Clean up on the root - - call AttrVect_clean(grow) - call AttrVect_clean(element_pe_locs) - - endif ! if(myID == root) - - ! Non-root processes call GlobalSegMap_init with root_start, - ! root_length, and root_pe_loc, although these arguments are - ! not used in the subroutine. Since these correspond to dummy - ! shaped array arguments in initr_, the Fortran 90 standard - ! dictates that the actual arguments must contain complete shape - ! information. Therefore, these array arguments must be - ! allocated on all processes. - - if(myID /= root) then - allocate(starts(0),lengths(0),pe_locs(0),stat=ierr) - if(ierr /= 0) then - call die(myname_,'non-root allocate(starts...',ierr) - endif - endif - - ! Using this local data on the root, create the SparseMatrix - ! GlobalSegMap sMGSMap (which will be valid on all processes - ! on the communicator. The GlobalSegMap will inherit the - ! component ID from yGSMap - - call GlobalSegMap_init(sMGSMap, ngseg, starts, lengths, pe_locs, & - root, comm, comp_id, gsize) - - ! Clean up: - - call GlobalMap_clean(dist_GMap) - call AttrVect_clean(dist_grow) - call AttrVect_clean(dist_element_pe_locs) - - deallocate(starts, lengths, pe_locs, counts, stat=ierr) - if(ierr /= 0) then - call die(myname_,'deallocate(starts...',ierr) - endif - - - end subroutine ByRowGSMap_ - -!------------------------------------------------------------------------- -! Math + Computer Science Division / Argonne National Laboratory ! -!------------------------------------------------------------------------- -!BOP -! -! !IROUTINE: ComputeSegments_ - Create segments from list data. -! -! !INTERFACE: - - subroutine ComputeSegments_(element_pe_locs, elements, num_elements, & - nsegs, seg_starts, seg_lengths, seg_pe_locs) -! -! !USES: -! - - use m_die, only: die - - implicit none - -! !INPUT PARAMETERS: -! - integer, dimension(:), intent(in) :: element_pe_locs - integer, dimension(:), intent(in) :: elements - integer, intent(in) :: num_elements - -! !OUTPUT PARAMETERS: -! - integer, intent(out) :: nsegs - integer, dimension(:), pointer :: seg_starts - integer, dimension(:), pointer :: seg_lengths - integer, dimension(:), pointer :: seg_pe_locs - -! !DESCRIPTION: This routine examins an input list of {\tt num\_elements} -! process ID locations stored in the array {\tt element\_pe\_locs}, counts -! the number of contiguous segments {\tt nsegs}, and returns the segment -! start index, length, and process ID location in the arrays {\tt seg\_starts(:)}, -! {\tt seg\_lengths(:)}, and {\tt seg\_pe\_locs(:)}, respectively. -! -! {\bf N.B.}: The argument {\tt sMat} is returned sorted in lexicographic -! order by row and column. -! -! !REVISION HISTORY: -! -! 18Apr01 - J.W. Larson - initial version. -! 28Aug01 - M.J. Zavislak -! Changed first sanity check to get size(element_pe_locs) -! instead of size(elements) -!EOP -!------------------------------------------------------------------------- - character(len=*),parameter :: myname_=myname//'ComputeSegments_' - - integer :: i, ierr, iseg - - ! Input argument sanity checks: - - if(size(element_pe_locs) < num_elements) then - call die(myname_,'input argument array element_pe_locs too small', & - num_elements-size(element_pe_locs)) - endif - - if(size(elements) < num_elements) then - call die(myname_,'input argument array elements too small', & - num_elements-size(elements)) - endif - - ! First pass: how many segments? - - do i=1,num_elements - - if(i == 1) then ! bootstrap segment count - - nsegs = 1 - - else ! usual point/segment processing - - ! New segment? If so, increment nsegs. - - if((elements(i) > elements(i-1) + 1) .or. & - (element_pe_locs(i) /= element_pe_locs(i-1))) then ! new segment - nsegs = nsegs + 1 - endif - - endif ! if(i == 1) block - - end do ! do i=1,num_elements - - allocate(seg_starts(nsegs), seg_lengths(nsegs), seg_pe_locs(nsegs), & - stat=ierr) - - if(ierr /= 0) then - call die(myname_,'allocate(seg_starts...',ierr) - endif - - ! Second pass: fill in segment data. - - ! NOTE: Structure of this loop was changed from a for loop - ! to avoid a faulty vectorization on the SUPER-UX compiler - - i=1 - ASSIGN_LOOP: do - - if(i == 1) then ! bootstrap first segment info. - - iseg = 1 - seg_starts(iseg) = 1 - seg_lengths(iseg) = 1 - seg_pe_locs(iseg) = element_pe_locs(iseg) - - else ! do usual point/segment processing - - ! New segment? This happens if 1) elements(i) > elements(i-1) + 1, or - ! 2) element_pe_locs(i) /= element_pe_locs(i-1). - - if((elements(i) > elements(i-1) + 1) .or. & - (element_pe_locs(i) /= element_pe_locs(i-1))) then ! new segment - - ! Initialize new segment - iseg = iseg + 1 - seg_starts(iseg) = i - seg_lengths(iseg) = 1 - seg_pe_locs(iseg) = element_pe_locs(i) - - else - - ! Increment current segment length - seg_lengths(iseg) = seg_lengths(iseg) + 1 - - endif ! If new segment block - - endif ! if(i == 1) block - - ! Prepare index i for the next loop around; - if(i>=num_elements) EXIT - i = i + 1 - - end do ASSIGN_LOOP - - if(iseg /= nsegs) then - call die(myname_,'segment number difference',iseg-nsegs) - endif - - end subroutine ComputeSegments_ - - end module m_SparseMatrixDecomp diff --git a/cesm/models/utils/mct/mct/m_SparseMatrixPlus.F90 b/cesm/models/utils/mct/mct/m_SparseMatrixPlus.F90 deleted file mode 100644 index 9443eb1..0000000 --- a/cesm/models/utils/mct/mct/m_SparseMatrixPlus.F90 +++ /dev/null @@ -1,871 +0,0 @@ -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !MODULE: m_SparseMatrixPlus -- Class Parallel for Matrix-Vector Multiplication -! -! !DESCRIPTION: -! Matrix-vector multiplication is one of the MCT's core services, and is -! used primarily for the interpolation of data fields from one physical -! grid to another. Let ${\bf x} \in \Re^{N_x}$ and -! ${\bf y} \in \Re^{N_y}$ represent data fields on physical grids $A$ -! and $B$, respectively. Field data is interpolated from grid $A$ to grid -! $B$ by -! $$ {\bf y} = {\bf M} {\bf x} , $$ -! where {\bf M} is aa ${N_y} \times {N_x}$ matrix. -! -! Within MCT, the {\tt SparseMatrix} data type is MCT's object for -! storing sparse matrices such as {\bf M} , and the {\tt AttrVect} data -! type is MCT's field data storage object. That is, {\bf x} and {\bf y} -! are each stored in {\tt AttrVect} form, and {\bf M} is stored as a -! {\tt SparseMatrix}. -! -! For global address spaces (uniprocessor or shared-memory parallel), this -! picture of matrix-vector multiplication is sufficient. If one wishes -! to perform {\em distributed-memory parallel} matrix-vector multiplication, -! however, in addition to computation, one must consider {\em communication}. -! -! There are three basic message-passing parallel strategies for computing -! ${\bf y} = {\bf M} {\bf x}$: -! -!\begin{enumerate} -! \item Decompose {\bf M} based on its {\em rows}, and corresponding to the -! decomposition for the vector {\bf y}. That is, if a given process owns -! the $i^{\rm th}$ element of {\bf y}, then all the elements of row $i$ of -! {\bf M} also reside on this process. Then ${\bf y} = {\bf M} {\bf x}$ is -! implemented as follows: -! \begin{enumerate} -! \item Create an {\em intermediate vector} {\bf x'} that is the pre-image of -! the elements of {\bf y} owned locally. -! \item Comunnicate with the appropriate processes on the local communicator to -! gather from {\bf x} the elements of {\bf x'}. -! \item Compute ${\bf y} = {\bf M} {\bf x'}$. -! \item Destroy the data structure holding {\bf x'}. -! \end{enumerate} -! \item Decompose {\bf M} based on its {\em columns}, and corresponding to the -! decomposition for the vector {\bf x}. That is, if a given process owns -! the $j^{\rm th}$ element of {\bf x}, then all the elements of column $j$ of -! {\bf M} also reside on this process. Then ${\bf y} = {\bf M} {\bf x}$ is -! implemented as follows: -! \begin{enumerate} -! \item Create an {\em intermediate vector} {\bf y'} that holds {\em partial sums} -! of elements of {\bf y} computed from {\bf x} and {\bf M}. -! \item Compute ${\bf y'} = {\bf M} {\bf x}$. -! \item Perform communications to route elements of {\bf y'} to their eventual -! destinations in {\bf y}, where they will be summed, resulting in the distributed -! vector {\bf y}. -! \item Destroy the data structure holding {\bf y'}. -! \end{enumerate} -! \item Decompose {\bf M} based on some arbitrary, user-supplied scheme. This will -! necessitate two intermediate vectors {\bf x'} and {\bf y'}. Then -! ${\bf y} = {\bf M} {\bf x}$ is implemented as follows: -! \begin{enumerate} -! \item Create {\em intermediate vectors} {\bf x'} and {\bf y'}. The numbers of -! elements in {\bf x'} and {\bf y'} are based {\bf M}, specifically its numbers of -! {\em distinct} row and column index values, respectively. -! \item Comunnicate with the appropriate processes on the local communicator to -! gather from {\bf x} the elements of {\bf x'}. -! \item Compute ${\bf y'} = {\bf M} {\bf x'}$. -! \item Perform communications to route elements of {\bf y'} to their eventual -! destinations in {\bf y}, where they will be summed, resulting in the distributed -! vector {\bf y}. -! \item Destroy the data structures holding {\bf x'} and {\bf y'}. -! \end{enumerate} -! \end{enumerate} -! -! These operations require information about many aspects of the multiplication -! process. These data are: -! \begin{itemize} -! \item The matrix-vector parallelization strategy, which is one of the following: -! \begin{enumerate} -! \item Distributed in {\bf x}, purely data local in {\bf y}, labeled by the -! public data member {\tt Xonly} -! \item Purely data local {\bf x}, distributed in {\bf y}, labeled by the -! public data member {\tt Yonly} -! \item Distributed in both {\bf x} and {\bf y}, labeled by the public data -! member {\tt XandY} -! \end{enumerate} -! \item A communications scheduler to create {\bf x'} from {\bf x}; -! \item A communications scheduler to deliver partial sums contained in {\bf y'} to -! {\bf y}. -! \item Lengths of the intermediate vectors {\bf x'} and {\bf y'}. -! \end{itemize} -! -! In MCT, the above data are stored in a {\em master} class for {\tt SparseMatrix}- -! {\tt AttrVect} multiplication. This master class is called a -! {\tt SparseMatrixPlus}. -! -! This module contains the definition of the {\tt SparseMatrixPlus}, and a variety -! of methods to support it. These include initialization, destruction, query, and -! data import/export. -! -! !INTERFACE: - - module m_SparseMatrixPlus - -! !USES: - - use m_String, only : String - use m_SparseMatrix, only : SparseMatrix - use m_Rearranger, only : Rearranger - -! !PUBLIC TYPES: - - public :: SparseMatrixPlus - - Type SparseMatrixPlus -#ifdef SEQUENCE - sequence -#endif - type(String) :: Strategy - integer :: XPrimeLength - type(Rearranger) :: XToXPrime - integer :: YPrimeLength - type(Rearranger) :: YPrimeToY - type(SparseMatrix) :: Matrix - integer :: Tag - End Type SparseMatrixPlus - -! !PUBLIC MEMBER FUNCTIONS: - - public :: init - public :: vecinit - public :: clean - public :: initialized - public :: exportStrategyToChar - - interface init ; module procedure & - initFromRoot_, & - initDistributed_ - end interface - interface vecinit ; module procedure vecinit_ ; end interface - interface clean ; module procedure clean_ ; end interface - interface initialized ; module procedure initialized_ ; end interface - interface exportStrategyToChar ; module procedure & - exportStrategyToChar_ - end interface - -! !PUBLIC DATA MEMBERS: - - public :: Xonly ! Matrix decomposed only by ROW (i.e., based - ! on the decomposition of y); comms x->x' - public :: Yonly ! Matrix decomposed only by COLUMN (i.e., based - ! on the decomposition of x); comms y'->y - public :: XandY ! Matrix has complex ROW/COLUMN decomposed - -! !DEFINED PARAMETERS: - - integer,parameter :: DefaultTag = 700 - - -! !SEE ALSO: -! The MCT module m_SparseMatrix for more information about Sparse Matrices. -! The MCT module m_Rearranger for deatailed information about Communications -! scheduling. -! The MCT module m_AttrVect for details regarding the Attribute Vector. -! The MCT module m_MatAttrVectMult for documentation of API's that use -! the SparseMatrixPlus. -! -! !REVISION HISTORY: -! 29August 2002 - J. Larson - API specification. -!EOP ------------------------------------------------------------------- - - character(len=*), parameter :: Xonly = 'Xonly' - character(len=*), parameter :: Yonly = 'Yonly' - character(len=*), parameter :: XandY = 'XandY' - - character(len=*), parameter :: myname = 'MCT::m_SparseMatrixPlus' - - contains - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: initFromRoot_ - Creation and Initializtion from the Root -! -! !DESCRIPTION: -! This routine creates an {\tt SparseMatrixPlus} {\tt sMatPlus} using -! the following elements: -! \begin{itemize} -! \item A {\tt SparseMatrix} (the input argument {\tt sMat}), whose -! elements all reside only on the {\tt root} process of the MPI -! communicator with an integer handle defined by the input {\tt INTEGER} -! argument {\tt comm}; -! \item A {\tt GlobalSegMap} (the input argument {\tt xGSMap}) describing -! the domain decomposition of the vector {\bf x} on the communicator -! {\tt comm}; -! \item A {\tt GlobalSegMap} (the input argument {\tt yGSMap}) describing -! the domain decomposition of the vector {\bf y} on the communicator -! {\tt comm}; -! \item The matrix-vector multiplication parallelization strategy. This -! is set by the input {\tt CHARACTER} argument {\tt strategy}, which must -! have value corresponding to one of the following public data members -! defined in the declaration section of this module. Acceptable values -! for use in this routine are: {\tt Xonly} and {\tt Yonly}. -! \end{itemize} -! The optional argument {\tt Tag} can be used to set the tag value used in -! the call to {\tt Rearranger}. DefaultTag will be used otherwise. -! -! !INTERFACE: - - subroutine initFromRoot_(sMatPlus, sMat, xGSMap, yGSMap, strategy, & - root, comm, ComponentID, Tag) - -! !USES: - - use m_die - use m_stdio - use m_mpif90 - - use m_String, only : String - use m_String, only : String_init => init - - use m_GlobalSegMap, only : GlobalSegMap - use m_GlobalSegMap, only : GlobalSegMap_gsize => gsize - use m_GlobalSegMap, only : GlobalSegMap_lsize => lsize - use m_GlobalSegMap, only : GlobalSegMap_clean => clean - - use m_SparseMatrix, only : SparseMatrix - use m_SparseMatrix, only : SparseMatrix_nRows => nRows - use m_SparseMatrix, only : SparseMatrix_nCols => nCols - - use m_SparseMatrixComms, only : SparseMatrix_ScatterByRow => ScatterByRow - use m_SparseMatrixComms, only : SparseMatrix_ScatterByColumn => & - ScatterByColumn - - use m_SparseMatrixToMaps, only : SparseMatrixToXGlobalSegMap - use m_SparseMatrixToMaps, only : SparseMatrixToYGlobalSegMap - - use m_GlobalToLocal, only : GlobalToLocalMatrix - - use m_Rearranger, only : Rearranger - use m_Rearranger, only : Rearranger_init => init - - implicit none - -! !INPUT PARAMETERS: - - type(GlobalSegMap), intent(in) :: xGSMap - type(GlobalSegMap), intent(in) :: yGSMap - character(len=*), intent(in) :: strategy - integer, intent(in) :: root - integer, intent(in) :: comm - integer, intent(in) :: ComponentID - integer,optional, intent(in) :: Tag - -! !INPUT/OUTPUT PARAMETERS: - - type(SparseMatrix), intent(inout) :: sMat - -! !OUTPUT PARAMETERS: - - type(SparseMatrixPlus), intent(out) :: SMatPlus - -! !REVISION HISTORY: -! 30Aug02 - Jay Larson - API Specification -!EOP ___________________________________________________________________ -! - character(len=*),parameter :: myname_=myname//'::initFromRoot_' - - type(GlobalSegMap) :: xPrimeGSMap, yPrimeGSMap - - integer :: myID, ierr - - ! Set tag used in Rearranger call - - SMatPlus%Tag = DefaultTag - if(present(Tag)) SMatPlus%Tag = Tag - - ! set vector flag - SMatPlus%Matrix%vecinit = .FALSE. - - ! Get local process ID number - - call MPI_COMM_RANK(comm, myID, ierr) - if(ierr /= 0) then - call MP_perr_die(myname_,'MPI_COMM_RANK() failed',ierr) - endif - - ! Basic Input Argument Checks: - - ! On the root, where the matrix is stored, do its number of - ! rows and columns match the global lengths ofthe vectors y - ! and x, respectively? - - if(myID == root) then - - if(GlobalSegMap_gsize(yGSMap) /= SparseMatrix_nRows(sMat)) then - write(stderr,'(3a,i8,2a,i8)') myname_, & - ':: FATAL--length of vector y different from row count of sMat.', & - 'Length of y = ',GlobalSegMap_gsize(yGSMap),' Number of rows in ',& - 'sMat = ',SparseMatrix_nRows(sMat) - call die(myname_) - endif - - if(GlobalSegMap_gsize(xGSMap) /= SparseMatrix_nCols(sMat)) then - write(stderr,'(3a,i8,2a,i8)') myname_, & - ':: FATAL--length of vector x different from column count of sMat.', & - 'Length of x = ',GlobalSegMap_gsize(xGSMap),' Number of columns in ',& - 'sMat = ',SparseMatrix_nCols(sMat) - call die(myname_) - endif - - endif ! if(myID == root) then... - - ! Check desired parallelization strategy name for validity. - ! If either of the strategies supported by this routine are - ! provided, initialize the appropriate component of sMatPlus. - - select case(strategy) - case(Xonly) ! decompose sMat by rows following decomposition of y - call String_init(sMatPlus%Strategy, strategy) - case(Yonly) ! decompose sMat by columns following decomposition of x - call String_init(sMatPlus%Strategy, strategy) - case(XandY) ! User has called the wrong routine. Try initDistributed() - ! instead. - write(stderr,'(4a)') myname_, & - ':: ERROR--Strategy name = ',strategy,' not supported by this routine.' - case default ! strategy name not recognized. - write(stderr,'(5a)') myname_, & - ':: ERROR--Invalid parallelization strategy name = ',strategy,' not ', & - 'recognized by this module.' - call die(myname_) - end select - - ! End Argument Sanity Checks. - - ! Based on the parallelization strategy, scatter sMat into - ! sMatPlus%Matrix accordingly. - - select case(strategy) - case(Xonly) - ! Scatter sMat by Row - call SparseMatrix_ScatterByRow(yGSMap, sMat, sMatPlus%Matrix, root, & - comm, ierr) - ! Compute GlobalSegMap associated with intermediate vector x' - call SparseMatrixToXGlobalSegMap(sMatPlus%Matrix, xPrimeGSMap, & - root, comm, ComponentID) - ! Determine length of x' from xPrimeGSMap: - sMatPlus%XPrimeLength = GlobalSegMap_lsize(xPrimeGSMap, comm) - ! Create Rearranger to assemble x' from x - call Rearranger_init(xGSMap, xPrimeGSMap, comm, sMatPlus%XToXPrime) - ! Create local column indices based on xPrimeGSMap - call GlobalToLocalMatrix(sMatPlus%Matrix, xPrimeGSMap, 'column', comm) - ! Create local row indices based on yGSMap - call GlobalToLocalMatrix(sMatPlus%Matrix, yGSMap, 'row', comm) - ! Destroy intermediate GlobalSegMap for x' - call GlobalSegMap_clean(xPrimeGSMap) - case(Yonly) - ! Scatter sMat by Column - call SparseMatrix_ScatterByColumn(xGSMap, sMat, sMatPlus%Matrix, root, & - comm, ierr) - ! Compute GlobalSegMap associated with intermediate vector y' - call SparseMatrixToYGlobalSegMap(sMatPlus%Matrix, yPrimeGSMap, & - root, comm, ComponentID) - ! Determine length of y' from yPrimeGSMap: - sMatPlus%YPrimeLength = GlobalSegMap_lsize(yPrimeGSMap, comm) - ! Create Rearranger to assemble y from partial sums in y' - call Rearranger_init(yPrimeGSMap, yGSMap, comm, sMatPlus%YPrimeToY) - ! Create local row indices based on yPrimeGSMap - call GlobalToLocalMatrix(sMatPlus%Matrix, yPrimeGSMap, 'row', comm) - ! Create local column indices based on xGSMap - call GlobalToLocalMatrix(sMatPlus%Matrix, xGSMap, 'column', comm) - ! Destroy intermediate GlobalSegMap for y' - call GlobalSegMap_clean(yPrimeGSMap) - case default ! do nothing - end select - - end subroutine initFromRoot_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: initDistributed_ - Distributed Creation and Initializtion -! -! !DESCRIPTION: -! This routine creates an {\tt SparseMatrixPlus} {\tt sMatPlus} using -! the following elements: -! \begin{itemize} -! \item A {\tt SparseMatrix} (the input argument {\tt sMat}), whose -! elements have previously been destributed across the MPI communicator -! with an integer handle defined by the input {\tt INTEGER} argument -! {\tt comm}; -! \item A {\tt GlobalSegMap} (the input argument {\tt xGSMap}) describing -! the domain decomposition of the vector {\bf x} on the communicator -! {\tt comm}; and -! \item A {\tt GlobalSegMap} (the input argument {\tt yGSMap}) describing -! the domain decomposition of the vector {\bf y} on the communicator -! {\tt comm}; -! \end{itemize} -! The other input arguments required by this routine are the {\tt INTEGER} -! arguments {\tt root} and {\tt ComponentID}, which define the communicator -! root ID and MCT component ID, respectively. -! -! !INTERFACE: - - subroutine initDistributed_(sMatPlus, sMat, xGSMap, yGSMap, root, comm, & - ComponentID, Tag) - -! !USES: - - use m_die - use m_stdio - use m_mpif90 - - use m_String, only : String - use m_String, only : String_init => init - - use m_GlobalSegMap, only : GlobalSegMap - use m_GlobalSegMap, only : GlobalSegMap_gsize => gsize - use m_GlobalSegMap, only : GlobalSegMap_lsize => lsize - use m_GlobalSegMap, only : GlobalSegMap_clean => clean - - use m_SparseMatrix, only : SparseMatrix - use m_SparseMatrix, only : SparseMatrix_nRows => nRows - use m_SparseMatrix, only : SparseMatrix_nCols => nCols - use m_SparseMatrix, only : SparseMatrix_Copy => Copy - - use m_SparseMatrixComms, only : SparseMatrix_ScatterByRow => ScatterByRow - use m_SparseMatrixComms, only : SparseMatrix_ScatterByColumn => & - ScatterByColumn - - use m_SparseMatrixToMaps, only : SparseMatrixToXGlobalSegMap - use m_SparseMatrixToMaps, only : SparseMatrixToYGlobalSegMap - - use m_GlobalToLocal, only : GlobalToLocalMatrix - - use m_Rearranger, only : Rearranger - use m_Rearranger, only : Rearranger_init => init - - implicit none - -! !INPUT PARAMETERS: - - type(GlobalSegMap), intent(in) :: xGSMap - type(GlobalSegMap), intent(in) :: yGSMap - integer, intent(in) :: root - integer, intent(in) :: comm - integer, intent(in) :: ComponentID - integer,optional, intent(in) :: Tag - -! !INPUT/OUTPUT PARAMETERS: - - type(SparseMatrix), intent(inout) :: sMat - -! !OUTPUT PARAMETERS: - - type(SparseMatrixPlus), intent(out) :: SMatPlus - -! !REVISION HISTORY: -! 30Aug02 - Jay Larson - API Specification -!EOP ___________________________________________________________________ -! - character(len=*),parameter :: myname_=myname//'::initDistributed_' - - type(GlobalSegMap) :: xPrimeGSMap, yPrimeGSMap - - integer :: myID, ierr - - ! Set tag used in Rearranger call - - SMatPlus%Tag = DefaultTag - if(present(Tag)) SMatPlus%Tag = Tag - - ! Get local process ID number - - call MPI_COMM_RANK(comm, myID, ierr) - if(ierr /= 0) then - call MP_perr_die(myname_,'MPI_COMM_RANK() failed',ierr) - endif - ! Basic Input Argument Checks: - - ! A portion of sMat (even if there are no nonzero elements in - ! this local chunk) on each PE. We must check to ensure the - ! number rows and columns match the global lengths ofthe - ! vectors y and x, respectively. - - if(GlobalSegMap_gsize(yGSMap) /= SparseMatrix_nRows(sMat)) then - write(stderr,'(3a,i8,2a,i8)') myname, & - ':: FATAL--length of vector y different from row count of sMat.', & - 'Length of y = ',GlobalSegMap_gsize(yGSMap),' Number of rows in ',& - 'sMat = ',SparseMatrix_nRows(sMat) - call die(myname_) - endif - - if(GlobalSegMap_gsize(xGSMap) /= SparseMatrix_nCols(sMat)) then - write(stderr,'(3a,i8,2a,i8)') myname, & - ':: FATAL--length of vector x different from column count of sMat.', & - 'Length of x = ',GlobalSegMap_gsize(xGSMap),' Number of columns in ',& - 'sMat = ',SparseMatrix_nCols(sMat) - call die(myname_) - endif - - ! End Argument Sanity Checks. - - ! Set parallelization strategy to XandY, since the work distribution - ! was previously determined and in principle can be *anything* - - call String_init(sMatPlus%Strategy, XandY) - - ! Based on the XandY parallelization strategy, build SMatPlus - ! First, copy Internals of sMat into sMatPlus%Matrix: - call SparseMatrix_Copy(sMat, sMatPlus%Matrix) - ! Compute GlobalSegMap associated with intermediate vector x' - call SparseMatrixToXGlobalSegMap(sMatPlus%Matrix, xPrimeGSMap, & - root, comm, ComponentID) - ! Determine length of x' from xPrimeGSMap: - sMatPlus%XPrimeLength = GlobalSegMap_lsize(xPrimeGSMap, comm) - ! Create Rearranger to assemble x' from x - call Rearranger_init(xGSMap, xPrimeGSMap, comm, sMatPlus%XToXPrime) - ! Create local column indices based on xPrimeGSMap - call GlobalToLocalMatrix(sMatPlus%Matrix, xPrimeGSMap, 'column', comm) - ! Destroy intermediate GlobalSegMap for x' - call GlobalSegMap_clean(xPrimeGSMap) - ! Compute GlobalSegMap associated with intermediate vector y' - call SparseMatrixToYGlobalSegMap(sMatPlus%Matrix, yPrimeGSMap, & - root, comm, ComponentID) - ! Determine length of y' from yPrimeGSMap: - sMatPlus%YPrimeLength = GlobalSegMap_lsize(yPrimeGSMap, comm) - ! Create Rearranger to assemble y from partial sums in y' - call Rearranger_init(yPrimeGSMap, yGSMap, comm, sMatPlus%YPrimeToY) - ! Create local row indices based on yPrimeGSMap - call GlobalToLocalMatrix(sMatPlus%Matrix, yPrimeGSMap, 'row', comm) - ! Destroy intermediate GlobalSegMap for y' - call GlobalSegMap_clean(yPrimeGSMap) - - end subroutine initDistributed_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: vecinit_ - Initialize vector parts of a SparseMatrixPlus -! -! !DESCRIPTION: -! This routine will initialize the parts of the SparseMatrix in -! the SparseMatrixPlus object that are used in the vector-friendly -! version of the sparse matrix multiply. -! -! !INTERFACE: - - subroutine vecinit_(SMatP) -! -! !USES: -! - use m_die - use m_SparseMatrix, only : SparseMatrix_vecinit => vecinit - - implicit none - -! !INPUT/OUTPUT PARAMETERS: - - type(SparseMatrixPlus), intent(inout) :: SMatP - -! !REVISION HISTORY: -! 29Oct03 - R. Jacob - initial prototype -!EOP ___________________________________________________________________ -! - character(len=*),parameter :: myname_=myname//'::vecinit_' - - call SparseMatrix_vecinit(SMatP%Matrix) - - end subroutine vecinit_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: clean_ - Destruction of a SparseMatrixPlus Object -! -! !DESCRIPTION: -! This routine deallocates all allocated memory belonging to the -! input/output {\tt SparseMatrixPlus} argument {\tt SMatP}, and sets -! to zero its integer components describing intermediate vector length, -! and sets its {\tt LOGICAL} flag signifying initialization to -! {\tt .FALSE.} The success (failure) of this operation is signified -! by the zero (non-zero) value of the optional {\tt INTEGER} output -! argument {\tt status}. If the user does supply {\tt status} when -! invoking this routine, failure of {\tt clean\_()} will lead to -! termination of execution with an error message. -! -! !INTERFACE: - - subroutine clean_(SMatP, status) - -! !USES: - - use m_die - use m_stdio - - use m_String, only : String - use m_String, only : String_init => init - use m_String, only : String_ToChar => toChar - use m_String, only : String_clean => clean - - use m_SparseMatrix, only : SparseMatrix - use m_SparseMatrix, only : SparseMatrix_clean => clean - - use m_Rearranger, only : Rearranger - use m_Rearranger, only : Rearranger_clean => clean - - implicit none - -! !INPUT/OUTPUT PARAMETERS: - - type(SparseMatrixPlus), intent(inout) :: SMatP - -! !OUTPUT PARAMETERS: - - integer, optional, intent(out) :: status - -! !REVISION HISTORY: -! 30Aug02 - Jay Larson - API Specification -!EOP ___________________________________________________________________ -! - character(len=*),parameter :: myname_=myname//'::clean_' - - integer :: myStatus - type(String) :: dummyStrategy ! SGI IR->WHIRL work-around - character(len=5) :: myStrategy - - ! If status was supplied, set it to zero (success) - - if(present(status)) status = 0 - - ! The following string copy is superfluous. It is placed here - ! to outwit a compiler bug in the SGI and SunOS compilers. - ! It occurs when a component of a derived type is used as an - ! argument to String_ToChar. This bug crashes the compiler - ! with the error message: - ! Error: Signal Segmentation fault in phase IR->WHIRL Conversion - - call String_init(dummyStrategy, SMatP%Strategy) - myStrategy = String_ToChar(dummyStrategy) - - ! Use SMatP%Strategy to determine which Rearranger(s) need - ! to be destroyed. The CHARACTER parameters Xonly, Yonly, - ! and XandY are inherited from the declaration section of - ! this module. - - - select case(myStrategy) - case(Xonly) ! destroy X-rearranger only - - call Rearranger_clean(SMatP%XToXprime, myStatus) - if(myStatus /= 0) then ! something went wrong - if(present(status)) then - status = myStatus - return - else - write(stderr,'(3a,i8)') myname_, & - ':: ERROR - call to Rearranger_clean(SMatP%XToXprime) failed.', & - ' stat = ',myStatus - endif - endif - - case(Yonly) ! destroy Y-rearranger only - - call Rearranger_clean(SMatP%YprimeToY, myStatus) - if(myStatus /= 0) then ! something went wrong - if(present(status)) then - status = myStatus - return - else - write(stderr,'(3a,i8)') myname_, & - ':: ERROR - call to Rearranger_clean(SMatP%YPrimeToY) failed.', & - ' stat = ',myStatus - endif - endif - - case(XandY) ! destroy both X- and Y-rearrangers - - call Rearranger_clean(SMatP%XToXprime, myStatus) - if(myStatus /= 0) then ! something went wrong - if(present(status)) then - status = myStatus - return - else - write(stderr,'(3a,i8)') myname_, & - ':: ERROR - call to Rearranger_clean(SMatP%XToXprime) failed.', & - ' stat = ',myStatus - endif - endif - - call Rearranger_clean(SMatP%YprimeToY, myStatus) - if(myStatus /= 0) then ! something went wrong - if(present(status)) then - status = myStatus - return - else - write(stderr,'(3a,i8)') myname_, & - ':: ERROR - call to Rearranger_clean(SMatP%YPrimeToY) failed.', & - ' stat = ',myStatus - endif - endif - - case default ! do nothing--corresponds to purely data local case - end select - - ! Zero out XPrimeLength and YPrimeLength - - SMatP%XPrimeLength = 0 - SMatP%YPrimeLength = 0 - - ! Destroy the SparseMatrix component SMatP%Matrix - - call SparseMatrix_clean(SMatP%Matrix, myStatus) - if(myStatus /= 0) then ! something went wrong - if(present(status)) then - status = myStatus - return - else - write(stderr,'(2a,i8)') myname_, & - ':: ERROR - call to SparseMatrix_clean() failed with stat=',myStatus - endif - endif - - ! Destroy the String SMatP%Strategy and its copy - - call String_clean(SMatP%Strategy) - call String_clean(dummyStrategy) - - end subroutine clean_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: initialized_ - Confirmation of Initialization -! -! !DESCRIPTION: -! This {\tt LOGICAL} query function tells the user if the input -! {\tt SparseMatrixPlus} argument {\tt sMatPlus} has been initialized. -! The return value of {\tt initialized\_} is {\tt .TRUE.} if -! {\tt sMatPlus} has been previously initialized, {\tt .FALSE.} if it -! has not. -! -! !INTERFACE: - - logical function initialized_(sMatPlus) -! -! !USES: -! -! No external modules are used by this function. - - use m_String, only : String_len - use m_List, only : List - use m_List, only : List_init => init - use m_List, only : List_identical => identical - use m_List, only : List_clean => clean - - use m_die - - implicit none - -! !INPUT PARAMETERS: -! - type(SparseMatrixPlus), intent(in) :: sMatPlus - -! !REVISION HISTORY: -! 26Sep02 - Jay Larson - Implementation -!EOP ___________________________________________________________________ -! - character(len=*),parameter :: myname_=myname//'::initialized_' - - integer :: XonlyLen, YonlyLen, XandYLen - type(List) :: XonlyList, YonlyList, XandYList, stratList - - initialized_ = .FALSE. - - XonlyLen = len(trim(Xonly)) - YonlyLen = len(trim(Yonly)) - XandYLen = len(trim(XandY)) - - if( (XonlyLen /= YonlyLen) .or. (XonlyLen /= XandYLen) ) then - call die(myname_,"The length of the strategies are unequal. & - &This routine needs to be rewritten.") - endif - - if(associated(sMatPlus%strategy%c)) then - if(String_len(sMatPlus%strategy) == XonlyLen) then - call List_init(XonlyList,Xonly) - call List_init(YonlyList,Yonly) - call List_init(XandYList,XandY) - call List_init(stratList,sMatPlus%strategy) - if(List_identical(stratList,XonlyList)) initialized_ = .TRUE. - if(List_identical(stratList,YonlyList)) initialized_ = .TRUE. - if(List_identical(stratList,XandYList)) initialized_ = .TRUE. - call List_clean(XonlyList) - call List_clean(YonlyList) - call List_clean(XandYList) - call List_clean(stratList) - endif - endif - - end function initialized_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: exportStrategyToChar - Return Parallelization Strategy -! -! !DESCRIPTION: -! This query subroutine returns the parallelization strategy set in -! the input {\tt SparseMatrixPlus} argument {\tt sMatPlus}. The result -! is returned in the output {\tt CHARACTER} argument {\tt StratChars}. -! -! !INTERFACE: - - function exportStrategyToChar_(sMatPlus) -! -! !USES: -! - use m_stdio - use m_die - - use m_String, only : String_ToChar => toChar - use m_String, only : String_init => init - use m_String, only : String_clean => clean - use m_String, only : String - - implicit none - -! !INPUT PARAMETERS: -! - type(SparseMatrixPlus), intent(in) :: sMatPlus - -! !OUTPUT PARAMETERS: -! - character(len=size(sMatPlus%Strategy%c)) :: exportStrategyToChar_ - -! !REVISION HISTORY: -! 01Aug07 - Jay Larson - Implementation -!EOP ___________________________________________________________________ -! - character(len=*),parameter :: myname_=myname//'::exportStrategyToChar_' - type(String) :: dummyStrategy ! SGI IR->WHIRL work-around - - ! Check input argument to ensure it has been initialized. If not, - ! signal an error and terminate execution. - - if( .not. initialized_(sMatPlus) ) then - write(stderr,'(3a)') myname_,':: Warning, input argument not initialized, ', & - 'returning empty character field for parallelization strategy.' - exportStrategyToChar_ = ' ' - return - endif - - ! Return in character form the parallelizaiton strategy - call String_init(dummyStrategy, SMatPlus%Strategy) - - exportStrategyToChar_ = String_ToChar(dummyStrategy) - - call String_clean(dummyStrategy) - - end function exportStrategyToChar_ - - end module m_SparseMatrixPlus - diff --git a/cesm/models/utils/mct/mct/m_SparseMatrixToMaps.F90 b/cesm/models/utils/mct/mct/m_SparseMatrixToMaps.F90 deleted file mode 100644 index 9ed0e8d..0000000 --- a/cesm/models/utils/mct/mct/m_SparseMatrixToMaps.F90 +++ /dev/null @@ -1,456 +0,0 @@ -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!----------------------------------------------------------------------- -! CVS $Id$ -! CVS $Name$ -!BOP ------------------------------------------------------------------- -! -! !MODULE: m_SparseMatrixToMaps -- Maps from the Sparse Matrix -! -! !DESCRIPTION: -! The {\tt SparseMatrix} provides consolidated (on one process) or -! distributed sparse matrix storage for the operation -! ${\bf y} = {\bf M} {\bf x}$, where {\bf x} and {\bf y} are vectors, -! and {\bf M} is a matrix. In performing parallel matrix-vector -! multiplication, one has numerous options regarding the decomposition -! of the matrix {\bf M}, and the vectors {\bf y} and {\bf x}. -! This module provides services to generate mct mapping components---the -! {\tt GlobalMap} and {\tt GlobalSegMap} for the vectors {\bf y} and/or -! {\bf x} based on the decomposition of the sparse matrix {\bf M}. -! -! !INTERFACE: - - module m_SparseMatrixToMaps -! -! !USES: -! - use m_SparseMatrix, only : SparseMatrix - - implicit none - - private ! except - - public :: SparseMatrixToXGlobalSegMap - public :: SparseMatrixToYGlobalSegMap - - interface SparseMatrixToXGlobalSegMap ; module procedure & - SparseMatrixToXGlobalSegMap_ - end interface - - interface SparseMatrixToYGlobalSegMap ; module procedure & - SparseMatrixToYGlobalSegMap_ - end interface - -! !REVISION HISTORY: -! 13Apr01 - J.W. Larson - initial prototype -! and API specifications. -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname='MCT::m_SparseMatrixToMaps' - - contains - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: SparseMatrixToXGlobalSegMap_ - Generate X GlobalSegmap. -! -! !DESCRIPTION: Given an input {\tt SparseMatrix} argument {\tt sMat}, -! this routine generates an output {\tt GlobalSegMap} variable -! {\tt xGSMap}, which describes the domain decomposition of the vector -! {\bf x} in the distributed matrix-vector multiplication -! $${\bf y} = {\bf M} {\bf x}.$$ -! -! !INTERFACE: - - subroutine SparseMatrixToXGlobalSegMap_(sMat, xGSMap, root, comm, comp_id) -! -! !USES: -! - use m_stdio, only : stderr - use m_die, only : die - use m_mpif90 - - use m_List, only : List - use m_List, only : List_init => init - use m_List, only : List_clean => clean - - use m_SparseMatrix, only : SparseMatrix - use m_SparseMatrix, only : SparseMatrix_nCols => nCols - use m_SparseMatrix, only : SparseMatrix_lsize => lsize - use m_SparseMatrix, only : SparseMatrix_indexIA => indexIA - use m_SparseMatrix, only : SparseMatrix_SortPermute => SortPermute - - use m_GlobalSegMap, only : GlobalSegMap - use m_GlobalSegMap, only : GlobalSegMap_init => init - - implicit none - -! !INPUT PARAMETERS: -! - integer, intent(in) :: root ! communicator root - integer, intent(in) :: comm ! communicator handle - integer, intent(in) :: comp_id ! component id - -! !INPUT/OUTPUT PARAMETERS: -! - type(SparseMatrix), intent(inout) :: sMat ! input SparseMatrix - -! !OUTPUT PARAMETERS: -! - type(GlobalSegMap), intent(out) :: xGSMap ! segmented decomposition - ! for x -! !REVISION HISTORY: -! 13Apr01 - J.W. Larson - API specification. -! 25Apr01 - J.W. Larson - First version. -! 27Apr01 - J.W. Larson - Bug fix--intent of -! argument sMat changed from (IN) to (INOUT) -! 27Apr01 - R.L. Jacob - bug fix-- add use -! statement for SortPermute -! 01May01 - R.L. Jacob - make comp_id an -! input argument -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::SparseMatrixToXGlobalSegMap_' - -! SparseMatrix attributes: - integer :: lsize -! GlobalSegMap input attributes: - integer :: gsize, ngseg - integer, dimension(:), pointer :: starts, lengths -! Temporary array for identifying each matrix element column and -! process ID destination - integer, dimension(:), allocatable :: gCol, element_pe_locs -! Index to identify the gcol attribute in sMat: - integer :: igCol -! Matrix element sorting keys list: - type(List) :: sort_keys -! Loop index and error flag: - integer :: i, ierr - - ! Determine he local number of matrix elements lsize - - lsize = SparseMatrix_lsize(sMat) - - ! The value of gsize is taken from the number of columns in sMat: - - gsize = SparseMatrix_nCols(sMat) - - ! Sort SparseMatrix entries by global column index gcol, then - ! global row index. - - ! Create Sort keys list - - call List_init(sort_keys,'gcol:grow') - - ! Sort and permute the entries of sMat into lexicographic order - ! by global column, then global row. - - call SparseMatrix_SortPermute(sMat, sort_keys) - - ! Clean up sort keys list - - call List_clean(sort_keys) - - ! Allocate storage space for matrix element column indices and - ! process ID destinations - - allocate(gCol(lsize), stat=ierr) - - if(ierr /= 0) then - call die(myname_,'allocate(gCol...',ierr) - endif - - ! Extract global column information and place in array gCol - - igCol = SparseMatrix_indexIA(sMat, 'gcol', dieWith=myname_) - - do i=1, lsize - gCol(i) = sMat%data%iAttr(igCol,i) - end do - - ! Scan sorted entries of gCol to count segments (ngseg), and - ! their starting indices and lengths (returned in the arrays - ! starts(:) and lengths(:), respectively) - - call ComputeSegments_(gCol, lsize, ngseg, starts, lengths) - - ! Now we have sufficient data to call the GlobalSegMap - ! initialization using distributed data: - - call GlobalSegMap_init(xGSMap, starts, lengths, root, comm, & - comp_id, gsize=gsize) - - ! clean up temporary arrays gCol(:), starts(:) and lengths(:), - ! (the latter two were allocated in the call to the routine - ! ComputeSegments_()) - - deallocate(gCol, starts, lengths, stat=ierr) - - if(ierr /= 0) then - call die(myname_,'deallocate(gCol...',ierr) - endif - - end subroutine SparseMatrixToXGlobalSegMap_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: SparseMatrixToYGlobalSegMap_ - Generate Y GlobalSegmap. -! -! !DESCRIPTION: Given an input {\tt SparseMatrix} argument {\tt sMat}, -! this routine generates an output {\tt GlobalSegMap} variable -! {\tt yGSMap}, which describes the domain decomposition of the vector -! {\bf y} in the distributed matrix-vector multiplication -! ${\bf y} = {\bf M} {\bf x}$. -! -! !INTERFACE: - - subroutine SparseMatrixToYGlobalSegMap_(sMat, yGSMap, root, comm, comp_id) -! -! !USES: -! - use m_stdio, only : stderr - use m_die, only : die - - use m_List, only : List - use m_List, only : List_init => init - use m_List, only : List_clean => clean - - use m_SparseMatrix, only : SparseMatrix - use m_SparseMatrix, only : SparseMatrix_nRows => nRows - use m_SparseMatrix, only : SparseMatrix_lsize => lsize - use m_SparseMatrix, only : SparseMatrix_indexIA => indexIA - use m_SparseMatrix, only : SparseMatrix_SortPermute => SortPermute - - use m_GlobalSegMap, only : GlobalSegMap - use m_GlobalSegMap, only : GlobalSegMap_init => init - - implicit none - -! !INPUT PARAMETERS: -! - integer, intent(in) :: root ! communicator root - integer, intent(in) :: comm ! communicator handle - integer, intent(in) :: comp_id ! component id - -! !INPUT/OUTPUT PARAMETERS: -! - type(SparseMatrix), intent(inout) :: sMat ! input SparseMatrix - -! !OUTPUT PARAMETERS: -! - type(GlobalSegMap), intent(out) :: yGSMap ! segmented decomposition - ! for y -! !REVISION HISTORY: -! 13Apr01 - J.W. Larson - API specification. -! 25Apr01 - J.W. Larson - initial code. -! 27Apr01 - J.W. Larson - Bug fix--intent of -! argument sMat changed from (IN) to (INOUT) -! 27Apr01 - R.L. Jacob - bug fix-- add use -! statement for SortPermute -! 01May01 - R.L. Jacob - make comp_id an -! input argument -! 07May02 - J.W. Larson - Changed interface to -! make it consistent with SparseMatrixToXGlobalSegMap_(). -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::SparseMatrixToYGlobalSegMap_' - -! SparseMatrix attributes: - integer :: lsize -! GlobalSegMap input attributes: - integer :: gsize, ngseg - integer, dimension(:), pointer :: starts, lengths -! Temporary array for identifying each matrix element column and -! process ID destination - integer, dimension(:), allocatable :: gRow, element_pe_locs -! Index to identify the gRow attribute in sMat: - integer :: igRow -! Matrix element sorting keys list: - type(List) :: sort_keys -! Loop index and error flag: - integer :: i, ierr - - ! Determine he local number of matrix elements lsize - - lsize = SparseMatrix_lsize(sMat) - - ! The value of gsize is taken from the number of columns in sMat: - - gsize = SparseMatrix_nRows(sMat) - - ! Sort SparseMatrix entries by global column index grow, then - ! global row index. - - ! Create Sort keys list - - call List_init(sort_keys,'grow:gcol') - - ! Sort and permute the entries of sMat into lexicographic order - ! by global column, then global row. - - call SparseMatrix_SortPermute(sMat, sort_keys) - - ! Clean up sort keys list - - call List_clean(sort_keys) - - ! Allocate storage space for matrix element column indices and - ! process ID destinations - - allocate(gRow(lsize), stat=ierr) - - if(ierr /= 0) then - call die(myname_,'allocate(gRow...',ierr) - endif - - ! Extract global column information and place in array gRow - - igRow = SparseMatrix_indexIA(sMat,'grow', dieWith=myname_) - - do i=1, lsize - gRow(i) = sMat%data%iAttr(igRow,i) - end do - - ! Scan sorted entries of gRow to count segments (ngseg), and - ! their starting indices and lengths (returned in the arrays - ! starts(:) and lengths(:), respectively) - - call ComputeSegments_(gRow, lsize, ngseg, starts, lengths) - - ! Now we have sufficient data to call the GlobalSegMap - ! initialization using distributed data: - - call GlobalSegMap_init(yGSMap, starts, lengths, root, comm, & - comp_id, gsize=gsize) - - ! clean up temporary arrays gRow(:), starts(:) and lengths(:), - ! (the latter two were allocated in the call to the routine - ! ComputeSegments_()) - - deallocate(gRow, starts, lengths, stat=ierr) - - if(ierr /= 0) then - call die(myname_,'deallocate(gRow...',ierr) - endif - - end subroutine SparseMatrixToYGlobalSegMap_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: CreateSegments_ - Generate segment information. -! -! !DESCRIPTION: This routine examines an input {\tt INTEGER} list of -! numbers {\tt indices} (of length {\tt num\_indices}), determines the -! number of segments of consecutive numbers (or runs) {\tt nsegs}. The -! starting indices for each run, and their lengths are returned in the -! {\tt INTEGER} arrays {\tt starts(:)} and {\tt lengths(:)}, respectively. -! -! !INTERFACE: - - subroutine ComputeSegments_(indices, num_indices, nsegs, starts, lengths) - -! -! !USES: -! - use m_stdio, only : stderr - use m_die, only : die - - implicit none -! -! !INPUT PARAMETERS: -! - - integer, dimension(:), intent(in) :: indices - integer, intent(in) :: num_indices -! -! !OUTPUT PARAMETERS: -! - integer, intent(out) :: nsegs - integer, dimension(:), pointer :: starts - integer, dimension(:), pointer :: lengths - - -! !REVISION HISTORY: -! 19Apr01 - J.W. Larson - API specification. -! 25Apr01 - J.W. Larson - Initial code. -! 27Apr01 - J.W. Larson - Bug fix--error in -! computation of segment starts/lengths. -! 27Nov01 - E.T. Ong - Bug fix--initialize -! nsegs=0 in case num_indices=0. -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::ComputeSegments_' - - integer :: i, ierr - - ! First pass: count the segments - - nsegs = 0 - - do i=1,num_indices - - if(i == 1) then ! bootstrap segment counting process - - nsegs = 1 - - else - - if(indices(i) > indices(i-1) + 1) then ! new segment - nsegs = nsegs + 1 - endif - - endif ! if(i==1) - - end do ! do i=1, num_indices - - ! Allocate storage space for starts(:) and lengths(:) - - allocate(starts(nsegs), lengths(nsegs), stat=ierr) - - if(ierr /= 0) then - call die(myname_,'allocate(starts...',ierr) - endif - - ! Second pass: compute segment start/length info - - do i=1,num_indices - - select case(i) - case(1) ! bootstrap segment counting process - nsegs = 1 - starts(nsegs) = indices(i) -! rml patch - lengths(nsegs) = 1 - case default - - if(i == num_indices) then ! last point - if(indices(i) > indices(i-1) + 1) then ! new segment with 1 pt. - ! first, close the books on the penultimate segment: - lengths(nsegs) = indices(i-1) - starts(nsegs) + 1 - nsegs = nsegs + 1 - starts(nsegs) = indices(i) - lengths(nsegs) = 1 ! (just one point) - else - lengths(nsegs) = indices(i) - starts(nsegs) + 1 - endif - else - if(indices(i) > indices(i-1) + 1) then ! new segment - lengths(nsegs) = indices(i-1) - starts(nsegs) + 1 - nsegs = nsegs + 1 - starts(nsegs) = indices(i) - endif - endif - - end select ! select case(i) - - end do ! do i=1, num_indices - - end subroutine ComputeSegments_ - - end module m_SparseMatrixToMaps diff --git a/cesm/models/utils/mct/mct/m_SpatialIntegral.F90 b/cesm/models/utils/mct/mct/m_SpatialIntegral.F90 deleted file mode 100644 index 228fea5..0000000 --- a/cesm/models/utils/mct/mct/m_SpatialIntegral.F90 +++ /dev/null @@ -1,2034 +0,0 @@ -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!----------------------------------------------------------------------- -! CVS $Id$ -! CVS $Name$ -!BOP ------------------------------------------------------------------- -! -! !MODULE: m_SpatialIntegral - Spatial Integrals and Averages using a GeneralGrid -! -! !DESCRIPTION: This module provides spatial integration and averaging -! services for the MCT. For a field $\Phi$ sampled at a point ${\bf x}$ -! in some multidimensional domain $\Omega$, the integral $I$ of -! $\Phi({\bf x})$ is -! $$ I = \int_{\Omega} \Phi ({\bf x}) d\Omega .$$ -! The spatial average $A$ of $\Phi({\bf x})$ over $\Omega$ is -! $$ A = {{ \int_{\Omega} \Phi ({\bf x}) d\Omega} \over -! { \int_{\Omega} d\Omega} }. $$ -! Since the {\tt AttrVect} represents a discretized field, the integrals -! above are implemented as: -! $$ I = \sum_{i=1}^N \Phi_i \Delta \Omega_i $$ -! and -! $$ A = {{\sum_{i=1}^N \Phi_i \Delta \Omega_i } \over -!{\sum_{i=1}^N \Delta \Omega_i } }, $$ -! where $N$ is the number of physical locations, $\Phi_i$ is the value -! of the field $\Phi$ at location $i$, and $\Delta \Omega_i$ is the spatial -! weight (lenghth element, cross-sectional area element, volume element, -! {\em et cetera}) at location $i$. -! -! MCT extends the concept of integrals and area/volume averages to include -! {\em masked} integrals and averages. MCT recognizes both {\em integer} -! and {\em real} masks. An integer mask $M$ is a vector of integers (one -! corresponding to each physical location) with each element having value -! either zero or one. Integer masks are used to include/exclude data from -! averages or integrals. For example, if one were to compute globally -! averaged cloud amount over land (but not ocean nor sea-ice), one would -! assign a $1$ to each location on the land and a $0$ to each non-land -! location. A {\em real} mask $F$ is a vector of real numbers (one corresponding -! to each physical location) with each element having value within the -! closed interval $[0,1]$. .Real masks are used to represent fractional -! area/volume coverage at a location by a given component model. For -! example, if one wishes to compute area averages over sea-ice, one must -! include the ice fraction present at each point. Masked Integrals and -! averages are represented in the MCT by: -! $$ I = \sum_{i=1}^N {\prod_{j=1}^J M_i} {\prod_{k=1}^K F_i} -! \Phi_i \Delta \Omega_i $$ -! and -! $$ A = {{\sum_{i=1}^N \bigg({\prod_{j=1}^J M_i}\bigg) \bigg( {\prod_{k=1}^K F_i} -! \bigg) \Phi_i -! \Delta \Omega_i } \over -!{\sum_{i=1}^N \bigg({\prod_{j=1}^J M_i}\bigg) \bigg( {\prod_{k=1}^K F_i} \bigg) -! \Delta \Omega_i } }, $$ -! where $J$ is the number of integer masks and $K$ is the number of real masks. -! -! All of the routines in this module assume field data is stored in an -! attribute vector ({\tt AttrVect}), and the integration/averaging is performed -! only on the {\tt REAL} attributes. Physical coordinate grid and mask -! information is assumed to be stored as attributes in either a -! {\tt GeneralGrid}, or pre-combined into a single integer mask and a single -! real mask. -! -! !INTERFACE: - - module m_SpatialIntegral - - implicit none - - private ! except - -! !PUBLIC MEMBER FUNCTIONS: - - public :: SpatialIntegral ! Spatial Integral - public :: SpatialAverage ! Spatial Area Average - - public :: MaskedSpatialIntegral ! Masked Spatial Integral - public :: MaskedSpatialAverage ! MaskedSpatial Area Average - - public :: PairedSpatialIntegrals ! A Pair of Spatial - ! Integrals - - public :: PairedSpatialAverages ! A Pair of Spatial - ! Area Averages - - public :: PairedMaskedSpatialIntegrals ! A Pair of Masked - ! Spatial Integrals - - public :: PairedMaskedSpatialAverages ! A Pair of Masked - ! Spatial Area Averages - - interface SpatialIntegral ; module procedure & - SpatialIntegralRAttrGG_ - end interface - interface SpatialAverage ; module procedure & - SpatialAverageRAttrGG_ - end interface - interface MaskedSpatialIntegral ; module procedure & - MaskedSpatialIntegralRAttrGG_ - end interface - interface MaskedSpatialAverage ; module procedure & - MaskedSpatialAverageRAttrGG_ - end interface - interface PairedSpatialIntegrals ; module procedure & - PairedSpatialIntegralRAttrGG_ - end interface - interface PairedSpatialAverages ; module procedure & - PairedSpatialAverageRAttrGG_ - end interface - interface PairedMaskedSpatialIntegrals ; module procedure & - PairedMaskedIntegralRAttrGG_ - end interface - interface PairedMaskedSpatialAverages ; module procedure & - PairedMaskedAverageRAttrGG_ - end interface - -! !REVISION HISTORY: -! 25Oct01 - J.W. Larson - Initial version -! 9May02 - J.W. Larson - Massive Refactoring. -! 10-14Jun02 - J.W. Larson - Added Masked methods. -! 17-18Jun02 - J.W. Larson - Added Paired/Masked -! methods. -! 18Jun02 - J.W. Larson - Renamed module from -! m_GlobalIntegral to m_SpatialIntegral. -! 15Jan03 - E.T. Ong - Initialized real-only -! AttrVects using nullfied integer lists. This circuitous -! hack was required because the compaq compiler does not -! compile the function AttrVectExportListToChar. -! -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname='MCT::m_SpatialIntegral' - - contains - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: SpatialIntegralRAttrGG_ - Compute spatial integral. -! -! !DESCRIPTION: -! This routine computes spatial integrals of the {\tt REAL} attributes -! of the {\tt REAL} attributes of the input {\tt AttrVect} argument -! {\tt inAv}. {\tt SpatialIntegralRAttrGG\_()} takes the input -! {\tt AttrVect} argument {\tt inAv} and computes the spatial -! integral using weights stored in the {\tt GeneralGrid} argument -! {\tt GGrid} and identified by the {\tt CHARACTER} tag {\tt WeightTag}. -! The integral of each {\tt REAL} attribute is returned in the output -! {\tt AttrVect} argument {\tt outAv}. If {\tt SpatialIntegralRAttrGG\_()} -! is invoked with the optional {\tt LOGICAL} input argument -! {\tt SumWeights} set as {\tt .TRUE.}, then the weights are also summed -! and stored in {\tt outAv} (and can be referenced with the attribute -! tag defined by the argument{\tt WeightTag}. If -! {\tt SpatialIntegralRAttrGG\_()} is invoked with the optional {\tt INTEGER} -! argument {\tt comm} (a Fortran MPI communicator handle), the summation -! operations for the integral are completed on the local process, then -! reduced across the communicator, with all processes receiving the result. -! -! {\bf N.B.: } The local lengths of the {\tt AttrVect} argument {\tt inAv} -! and the {\tt GeneralGrid} {\tt GGrid} must be equal. That is, there -! must be a one-to-one correspondence between the field point values stored -! in {\tt inAv} and the point weights stored in {\tt GGrid}. -! -! {\bf N.B.: } If {\tt SpatialIntegralRAttrGG\_()} is invoked with the -! optional {\tt LOGICAL} input argument {\tt SumWeights} set as {\tt .TRUE.}, -! then the value of {\tt WeightTag} must not conflict with any of the -! {\tt REAL} attribute tags in {\tt inAv}. -! -! {\bf N.B.: } The output {\tt AttrVect} argument {\tt outAv} is an -! allocated data structure. The user must deallocate it using the routine -! {\tt AttrVect\_clean()} when it is no longer needed. Failure to do so -! will result in a memory leak. -! -! !INTERFACE: - - subroutine SpatialIntegralRAttrGG_(inAv, outAv, GGrid, WeightTag, & - SumWeights, comm) -! ! USES: - - use m_stdio - use m_die - use m_mpif90 - - use m_realkinds, only : FP - - use m_AttrVect, only : AttrVect - use m_AttrVect, only : AttrVect_lsize => lsize - - use m_GeneralGrid, only : GeneralGrid - use m_GeneralGrid, only : GeneralGrid_lsize => lsize - use m_GeneralGrid, only : GeneralGrid_indexRA => indexRA - use m_GeneralGrid, only : GeneralGrid_exportRAttr => exportRAttr - - use m_SpatialIntegralV, only: SpatialIntegralV - - implicit none - -! !INPUT PARAMETERS: - - type(AttrVect), intent(IN) :: inAv - type(GeneralGrid), intent(IN) :: GGrid - character(len=*), intent(IN) :: WeightTag - logical, optional, intent(IN) :: SumWeights - integer, optional, intent(IN) :: comm - -! !OUTPUT PARAMETERS: - - type(AttrVect), intent(OUT) :: outAv - -! !REVISION HISTORY: -! 06Feb02 - J.W. Larson - initial version -! 09May02 - J.W. Larson - Refactored and -! renamed SpatialIntegralRAttrGG_(). -! 07Jun02 - J.W. Larson - Bug fix and further -! refactoring. -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::SpatialIntegralRAttrGG_' - - integer :: ierr, length - logical :: mySumWeights - real(FP), dimension(:), pointer :: gridWeights - - ! Argument Validity Checks - - if(AttrVect_lsize(inAv) /= GeneralGrid_lsize(GGrid)) then - ierr = AttrVect_lsize(inAv) - GeneralGrid_lsize(GGrid) - write(stderr,'(3a,i8,a,i8)') myname_, & - ':: inAv / GGrid length mismatch: ', & - ' AttrVect_lsize(inAv) = ',AttrVect_lsize(inAv), & - ' GeneralGrid_lsize(GGrid) = ',GeneralGrid_lsize(GGrid) - call die(myname_) - endif - - if(present(SumWeights)) then - mySumWeights = SumWeights - else - mySumWeights = .FALSE. - endif - - ! ensure unambiguous pointer association status for gridWeights - - nullify(gridWeights) - - ! Extract Grid Weights - - call GeneralGrid_exportRAttr(GGrid, WeightTag, gridWeights, length) - - ! - - if(present(comm)) then ! do a distributed AllReduce-style integral: - call SpatialIntegralV(inAv, outAv, gridWeights, mySumWeights, & - WeightTag, comm) - else - call SpatialIntegralV(inAv, outAv, gridWeights, mySumWeights, & - WeightTag) - endif - - ! Clean up temporary allocated space - - deallocate(gridWeights, stat=ierr) - if(ierr /= 0) then - write(stderr,'(2a,i8)') myname_, & - ':: deallocate(gridWeights...failed. ierr=', ierr - call die(myname_) - endif - - end subroutine SpatialIntegralRAttrGG_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: SpatialAverageRAttrGG_ - Compute spatial average. -! -! !DESCRIPTION: -! This routine computes spatial averages of the {\tt REAL} attributes -! of the input {\tt AttrVect} argument {\tt inAv}. -! {\tt SpatialAverageRAttrGG\_()} takes the input {\tt AttrVect} argument -! {\tt inAv} and computes the spatial average using weights -! stored in the {\tt GeneralGrid} argument {\tt GGrid} and identified by -! the {\tt CHARACTER} tag {\tt WeightTag}. The average of each {\tt REAL} -! attribute is returned in the output {\tt AttrVect} argument {\tt outAv}. -! If {\tt SpatialAverageRAttrGG\_()} is invoked with the optional {\tt INTEGER} -! argument {\tt comm} (a Fortran MPI communicator handle), the summation -! operations for the average are completed on the local process, then -! reduced across the communicator, with all processes receiving the result. -! -! {\bf N.B.: } The local lengths of the {\tt AttrVect} argument {\tt inAv} -! and the {\tt GeneralGrid} {\tt GGrid} must be equal. That is, there -! must be a one-to-one correspondence between the field point values stored -! in {\tt inAv} and the point weights stored in {\tt GGrid}. -! -! {\bf N.B.: } The output {\tt AttrVect} argument {\tt outAv} is an -! allocated data structure. The user must deallocate it using the routine -! {\tt AttrVect\_clean()} when it is no longer needed. Failure to do so -! will result in a memory leak. -! -! !INTERFACE: - - subroutine SpatialAverageRAttrGG_(inAv, outAv, GGrid, WeightTag, comm) - -! ! USES: - - use m_realkinds, only : FP - - use m_stdio - use m_die - use m_mpif90 - - use m_AttrVect, only : AttrVect - use m_AttrVect, only : AttrVect_init => init - use m_AttrVect, only : AttrVect_zero => zero - use m_AttrVect, only : AttrVect_clean => clean - use m_AttrVect, only : AttrVect_nRAttr => nRAttr - use m_AttrVect, only : AttrVect_indexRA => indexRA - - use m_GeneralGrid, only : GeneralGrid - - use m_List, only : List - use m_List, only : List_nullify => nullify - - implicit none - -! !INPUT PARAMETERS: - - type(AttrVect), intent(IN) :: inAv - type(GeneralGrid), intent(IN) :: GGrid - character(len=*), intent(IN) :: WeightTag - integer, optional, intent(IN) :: comm - -! !OUTPUT PARAMETERS: - - type(AttrVect), intent(OUT) :: outAv - -! !REVISION HISTORY: -! 08Feb02 - J.W. Larson - initial version -! 08May02 - J.W. Larson - minor modifications: -! 1) renamed the routine to GlobalAverageRAttrGG_ -! 2) changed calls to reflect new routine name -! GlobalIntegralRAttrGG_(). -! 18Jun02 - J.W. Larson - Renamed routine to -! SpatialAverageRAttrGG_(). -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::SpatialAverageRAtttrGG_' - - type(AttrVect) :: integratedAv - type(List) :: nullIList - integer :: i, ierr, iweight - - ! Compute the spatial integral: - - if(present(comm)) then - call SpatialIntegralRAttrGG_(inAv, integratedAv, GGrid, WeightTag, & - .TRUE., comm) - else - call SpatialIntegralRAttrGG_(inAv, integratedAv, GGrid, WeightTag, & - .TRUE.) - endif - - ! Check value of summed weights (to avoid division by zero): - - iweight = AttrVect_indexRA(integratedAv, WeightTag) - if(integratedAv%rAttr(iweight, 1) == 0._FP) then - write(stderr,'(2a)') myname_, & - '::ERROR--Global sum of grid weights is zero.' - call die(myname_) - endif - - ! Initialize output AttrVect outAv: - - call List_nullify(nullIList) - call AttrVect_init(outAv, iList=nullIList, rList=inAv%rList, lsize=1) - call AttrVect_zero(outAv) - - ! Divide by global weight sum to compute spatial averages from - ! spatial integrals. - - do i=1,AttrVect_nRAttr(outAv) - outAv%rAttr(i,1) = integratedAv%rAttr(i,1) & - / integratedAv%rAttr(iweight,1) - end do - - ! Clean up temporary AttrVect: - - call AttrVect_clean(integratedAv) - - end subroutine SpatialAverageRAttrGG_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: MaskedSpatialIntegralRAttrGG_ - Masked spatial integral. -! -! !DESCRIPTION: -! This routine computes masked spatial integrals of the {\tt REAL} -! attributes of the input {\tt AttrVect} argument {\tt inAv}, returning -! the masked integrals in the output {\tt AttrVect} {\tt outAv}. All of -! the masking data are assumed stored in the input {\tt GeneralGrid} -! argument {\tt GGrid}. If integer masks are to be used, their integer -! attribute names in {\tt GGrid} are named as a colon-delimited list -! in the optional {\tt CHARACTER} input argument {\tt iMaskTags}. Real -! masks (if desired) are referenced by their real attribute names in -! {\tt GGrid} are named as a colon-delimited list in the optional -! {\tt CHARACTER} input argument {\tt rMaskTags}. The user specifies -! a choice of mask combination method with the input {\tt LOGICAL} argument -! {\tt UseFastMethod}. If ${\tt UseFastMethod} = {\tt .FALSE.}$ this -! routine checks each mask entry to ensure that the integer masks contain -! only ones and zeroes, and that entries in the real masks are all in -! the closed interval $[0,1]$. If ${\tt UseFastMethod} = {\tt .TRUE.}$, -! this routine performs direct products of the masks, assuming that the -! user has validated them in advance. The optional {\tt LOGICAL} input -! argument {\tt SumWeights} determines whether the masked sum of the spatial -! weights is computed and returned in {\tt outAv} with the real attribute -! name supplied in the optional {\tt CHARACTER} input argument -! {\tt WeightSumTag}. This integral can either be a local (i.e. a global -! memory space operation), or a global distributed integral. The latter -! is the case if the optional input {\tt INTEGER} argument {\tt comm} is -! supplied (which corresponds to a Fortran MPI communicatior handle). -! -! {\bf N.B.: } The local lengths of the {\tt AttrVect} argument {\tt inAv} -! and the input {\tt GeneralGrid} {\tt GGrid} must be equal. That is, there -! must be a one-to-one correspondence between the field point values stored -! in {\tt inAv} and the point weights stored in {\tt GGrid}. -! -! {\bf N.B.: } If {\tt SpatialIntegralRAttrV\_()} is invoked with the -! optional {\tt LOGICAL} input argument {\tt SumWeights} set as {\tt .TRUE.}. -! In this case, the none of {\tt REAL} attribute tags in {\tt inAv} may be -! named the same as the string contained in {\tt WeightSumTag}, which is an -! attribute name reserved for the sum of the weights in the output {\tt AttrVect} -! {\tt outAv}. -! -! {\bf N.B.: } The output {\tt AttrVect} argument {\tt outAv} is an -! allocated data structure. The user must deallocate it using the routine -! {\tt AttrVect\_clean()} when it is no longer needed. Failure to do so -! will result in a memory leak. -! -! !INTERFACE: - - subroutine MaskedSpatialIntegralRAttrGG_(inAv, outAv, GGrid, SpatialWeightTag, & - iMaskTags, rMaskTags, UseFastMethod, & - SumWeights, WeightSumTag, comm) - -! ! USES: - - use m_stdio - use m_die - use m_mpif90 - - use m_realkinds, only : FP - - use m_String, only : String - use m_String, only : String_toChar => toChar - use m_String, only : String_clean => clean - - use m_List, only : List - use m_List, only : List_init => init - use m_List, only : List_clean => clean - use m_List, only : List_nitem => nitem - use m_List, only : List_get => get - - use m_AttrVect, only : AttrVect - use m_AttrVect, only : AttrVect_lsize => lsize - - use m_GeneralGrid, only : GeneralGrid - use m_GeneralGrid, only : GeneralGrid_lsize => lsize - use m_GeneralGrid, only : GeneralGrid_indexRA => indexRA - use m_GeneralGrid, only : GeneralGrid_exportIAttr => exportIAttr - use m_GeneralGrid, only : GeneralGrid_exportRAttr => exportRAttr - - use m_AttrVectReduce, only : AttrVect_GlobalWeightedSumRAttr => & - GlobalWeightedSumRAttr - use m_AttrVectReduce, only : AttrVect_LocalWeightedSumRAttr => & - LocalWeightedSumRAttr - - use m_SpatialIntegralV, only : MaskedSpatialIntegralV - - implicit none - -! !INPUT PARAMETERS: - - type(AttrVect), intent(IN) :: inAv - type(GeneralGrid), intent(IN) :: GGrid - character(len=*), intent(IN) :: SpatialWeightTag - character(len=*), optional, intent(IN) :: iMaskTags - character(len=*), optional, intent(IN) :: rMaskTags - logical, intent(IN) :: UseFastMethod - logical, optional, intent(IN) :: SumWeights - character(len=*), optional, intent(IN) :: WeightSumTag - integer, optional, intent(IN) :: comm - -! !OUTPUT PARAMETERS: - - type(AttrVect), intent(OUT) :: outAv - -! !REVISION HISTORY: -! 11Jun02 - J.W. Larson - initial version -! -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::MaskedSpatialIntegralRAttrGG_' - - integer :: i, ierr, j, length - logical :: mySumWeights - - type(List) :: iMaskList, rMaskList - type(String) :: DummStr - - integer, dimension(:), pointer :: iMask, iMaskTemp - real(FP), dimension(:), pointer :: rMask, rMaskTemp - integer :: TempMaskLength - - real(FP), dimension(:), pointer :: SpatialWeights - - integer :: niM, nrM ! Number of iMasks and rMasks, respectively - - ! Argument Validity Checks - - if(AttrVect_lsize(inAv) /= GeneralGrid_lsize(GGrid)) then - ierr = AttrVect_lsize(inAv) - GeneralGrid_lsize(GGrid) - write(stderr,'(3a,i8,a,i8)') myname_, & - ':: inAv / GGrid length mismatch: ', & - ' AttrVect_lsize(inAv) = ',AttrVect_lsize(inAv), & - ' GeneralGrid_lsize(GGrid) = ',GeneralGrid_lsize(GGrid) - call die(myname_) - endif - - if(present(SumWeights)) then - mySumWeights = SumWeights - if(.not. present(WeightSumTag)) then - write(stderr,'(3a)') myname_,':: FATAL--If the input argument SumWeights=.TRUE.,', & - ' then the argument WeightSumTag must be provided.' - call die(myname_) - endif - else - mySumWeights = .FALSE. - endif - - if(present(iMaskTags)) then - call List_init(iMaskList, iMaskTags) - if(List_nitem(iMaskList) == 0) then - write(stderr,'(3a)') myname_,':: ERROR--an INTEGER mask list with', & - 'no valid items was provided.' - call die(myname_) - endif - endif - - if(present(rMaskTags)) then - call List_init(rMaskList, rMaskTags) - if(List_nitem(iMaskList) == 0) then - write(stderr,'(3a)') myname_,':: ERROR--an REAL mask list with', & - 'no valid items was provided.' - call die(myname_) - endif - endif - - ! Determine the on-processor vector length for use throughout - ! this routine: - - length = AttrVect_lsize(inAv) - - !========================================================== - ! Extract Spatial Weights from GGrid using SpatialWeightTag - !========================================================== - - nullify(SpatialWeights) - call GeneralGrid_exportRAttr(GGrid, SpatialWeightTag, SpatialWeights, & - TempMaskLength) - if(TempMaskLength /= length) then - write(stderr,'(3a,i8,a,i8)') myname_,& - ':: error on return from GeneralGrid_exportRAttr().' , & - 'Returned with SpatialWeights(:) length = ',TempMaskLength, & - ',which conflicts with AttrVect_lsize(inAv) = ',length - call die(myname_) - endif - - !========================================================== - ! If the argument iMaskTags is present, create the combined - ! iMask array: - !========================================================== - - if(present(iMaskTags)) then ! assemble iMask(:) from all the integer - ! mask attributes stored in GGrid(:) - - allocate(iMask(length), iMaskTemp(length), stat=ierr) - if(ierr /= 0) then - write(stderr,'(3a,i8)') myname_,':: allocate(iMask(...) failed,', & - ' ierr=',ierr - call die(myname_) - endif - - niM = List_nitem(iMaskList) - - do i=1,niM - - ! Retrieve current iMask tag, and get this attribute from GGrid: - call List_get(DummStr, i, iMaskList) - call GeneralGrid_exportIAttr(GGrid, String_toChar(DummStr), & - iMaskTemp, TempMaskLength) - call String_clean(DummStr) - if(TempMaskLength /= length) then - write(stderr,'(3a,i8,a,i8)') myname_,& - ':: error on return from GeneralGrid_exportIAttr().' , & - 'Returned with TempMaskLength = ',TempMaskLength, & - ',which conflicts with AttrVect_lsize(inAv) = ',length - call die(myname_) - endif - - if(i == 1) then ! first pass--examine iMaskTemp(:) only - - if(UseFastMethod) then ! straight copy of iMaskTemp(:) - do j=1,length - iMask(j) = iMaskTemp(j) - end do - else ! go through the entries of iMaskTemp(:) one-by-one - do j=1,length - select case(iMaskTemp(j)) - case(0) - iMask(j) = 0 - case(1) - iMask(j) = 1 - case default - write(stderr,'(3a,i8,a,i8)') myname_, & - ':: FATAL--illegal INTEGER mask entry. Integer mask ', & - 'entries must be 0 or 1. iMask(',j,') = ', iMask(j) - call die(myname_) - end select ! select case(iMaskTemp(j))... - end do ! do j=1,length - endif ! if(UseFastMethod)... - - else ! That is, i /= 1 ... - - if(UseFastMethod) then ! straight product of iMask(:) - ! and iMaskTemp(:) - do j=1,length - iMask(j) = iMask(j) * iMaskTemp(j) - end do - else ! go through the entries of iMaskTemp(:) one-by-one - do j=1,length - select case(iMaskTemp(j)) - case(0) ! zero out iMask(j) - iMask(j) = 0 - case(1) ! do nothing - case default - write(stderr,'(3a,i8,a,i8)') myname_, & - ':: FATAL--illegal INTEGER mask entry. Integer mask ', & - 'entries must be 0 or 1. iMask(',j,') = ', iMask(j) - call die(myname_) - end select ! select case(iMaskTemp(j))... - end do ! do j=1,length - endif ! if(UseFastMethod)... - - endif ! if(i == 1)... - - end do ! do i=1,niM...iMask retrievals - - endif ! if(present(iMaskTags))... - - !========================================================== - ! If the argument rMaskTags is present, create the combined - ! REAL mask rMask array: - !========================================================== - - if(present(rMaskTags)) then ! assemble rMask(:) from all the integer - ! mask attributes stored in GGrid(:) - - allocate(rMask(length), rMaskTemp(length), stat=ierr) - if(ierr /= 0) then - write(stderr,'(3a,i8)') myname_,':: allocate(rMask(...) failed,', & - ' ierr=',ierr - call die(myname_) - endif - - nrM = List_nitem(rMaskList) - - do i=1,nrM - - ! Retrieve current rMask tag, and get this attribute from GGrid: - call List_get(DummStr, i, rMaskList) - call GeneralGrid_exportRAttr(GGrid, String_toChar(DummStr), & - rMaskTemp, TempMaskLength) - call String_clean(DummStr) - if(TempMaskLength /= length) then - write(stderr,'(3a,i8,a,i8)') myname_,& - ':: error on return from GeneralGrid_exportRAttr().' , & - 'Returned with TempMaskLength = ',TempMaskLength, & - ',which conflicts with AttrVect_lsize(inAv) = ',length - call die(myname_) - endif - - if(i == 1) then ! first pass--examine rMaskTemp(:) only - - if(UseFastMethod) then ! straight copy of rMaskTemp(:) - do j=1,length - rMask(j) = rMaskTemp(j) - end do - else ! go through the entries of rMaskTemp(:) one-by-one - ! to ensure they are in the range [0.,1.] - do j=1,length - if((rMaskTemp(j) >= 0.) .or. (rMaskTemp(j) <=1.)) then - rMask(j) = rMaskTemp(j) - else - write(stderr,'(3a,i8,a,i8)') myname_, & - ':: FATAL--illegal REAL mask entry. Real mask ', & - 'entries must be in [0.,1.] rMask(',j,') = ', rMask(j) - call die(myname_) - endif ! if((rMaskTemp(j) >= 0.) .or. (rMaskTemp(j) <=1.))... - end do ! do j=1,length - endif ! if(UseFastMethod)... - - else ! That is, i /= 1 ... - - if(UseFastMethod) then ! straight product of rMask(:) - ! and rMaskTemp(:) - do j=1,length - rMask(j) = rMask(j) * rMaskTemp(j) - end do - else ! go through the entries of rMaskTemp(:) one-by-one - ! to ensure they are in the range [0.,1.] - do j=1,length - if((rMaskTemp(j) >= 0.) .or. (rMaskTemp(j) <=1.)) then - rMask(j) = rMask(j) * rMaskTemp(j) - else - write(stderr,'(3a,i8,a,i8)') myname_, & - ':: FATAL--illegal REAL mask entry. Real mask ', & - 'entries must be in [0.,1.] rMask(',j,') = ', rMask(j) - call die(myname_) - endif ! if((rMaskTemp(j) >= 0.) .or. (rMaskTemp(j) <=1.))... - end do ! do j=1,length - endif ! if(UseFastMethod)... - - endif ! if(i == 1)... - - end do ! do i=1,niM...rMask retrievals - - endif ! if(present(rMaskTags))... - - !========================================================== - ! Now that we have produced single INTEGER and REAL masks, - ! compute the masked weighted sum. - !========================================================== - - if(present(rMaskTags)) then ! We have a REAL Mask - - if(present(iMaskTags)) then ! and an INTEGER Mask - - if(present(comm)) then ! compute distributed AllReduce-style sum: - - if(mySumWeights) then ! return the global masked sum of the - ! weights in outAV - call MaskedSpatialIntegralV(inAv, outAv, SpatialWeights, & - iMask, rMask, UseFastMethod, & - SumWeights, WeightSumTag, comm) - else ! Do not return the masked sum of the weights - call MaskedSpatialIntegralV(inAv, outAv, SpatialWeights, & - iMask, rMask, UseFastMethod, & - comm=comm) - endif ! if(mySumWeights)... - - else ! compute local sum: - - if(mySumWeights) then ! return the global masked sum of the - ! weights in outAV - call MaskedSpatialIntegralV(inAv, outAv, SpatialWeights, & - iMask, rMask, UseFastMethod, & - SumWeights, WeightSumTag) - else ! Do not return the masked sum of the weights - call MaskedSpatialIntegralV(inAv, outAv, SpatialWeights, & - iMask, rMask, UseFastMethod) - endif ! if(mySumWeights)... - - endif ! if(present(comm))... - - else ! REAL Mask Only Case... - - if(present(comm)) then ! compute distributed AllReduce-style sum: - - if(mySumWeights) then ! return the global masked sum of the - ! weights in outAV - call MaskedSpatialIntegralV(inAv, outAv, SpatialWeights, & - rMask=rMask, & - UseFastMethod=UseFastMethod, & - SumWeights=SumWeights, & - WeightSumTag=WeightSumTag, & - comm=comm) - else ! Do not return the masked sum of the weights - call MaskedSpatialIntegralV(inAv, outAv, SpatialWeights, & - rMask=rMask, & - UseFastMethod=UseFastMethod, & - comm=comm) - endif ! if(mySumWeights)... - - else ! compute local sum: - - if(mySumWeights) then ! return the global masked sum of the - ! weights in outAV - call MaskedSpatialIntegralV(inAv, outAv, SpatialWeights, & - rMask=rMask, & - UseFastMethod=UseFastMethod, & - SumWeights=SumWeights, & - WeightSumTag=WeightSumTag) - else ! Do not return the masked sum of the weights - call MaskedSpatialIntegralV(inAv, outAv, SpatialWeights, & - rMask=rMask, & - UseFastMethod=UseFastMethod) - endif ! if(mySumWeights)... - - endif ! if(present(comm))... - - endif - else ! no REAL Mask... - - if(present(iMaskTags)) then ! INTEGER Mask Only Case... - - if(present(comm)) then ! compute distributed AllReduce-style sum: - - if(mySumWeights) then ! return the global masked sum of the - ! weights in outAV - call MaskedSpatialIntegralV(inAv, outAv, SpatialWeights, & - iMask=iMask, & - UseFastMethod=UseFastMethod, & - SumWeights=SumWeights, & - WeightSumTag=WeightSumTag, & - comm=comm) - else ! Do not return the masked sum of the weights - call MaskedSpatialIntegralV(inAv, outAv, SpatialWeights, & - iMask=iMask, & - UseFastMethod=UseFastMethod, & - comm=comm) - endif ! if(mySumWeights)... - - else ! compute local sum: - - if(mySumWeights) then ! return the global masked sum of the - ! weights in outAV - call MaskedSpatialIntegralV(inAv, outAv, SpatialWeights, & - iMask=iMask, & - UseFastMethod=UseFastMethod, & - SumWeights=SumWeights, & - WeightSumTag=WeightSumTag) - else ! Do not return the masked sum of the weights - call MaskedSpatialIntegralV(inAv, outAv, SpatialWeights, & - iMask=iMask, & - UseFastMethod=UseFastMethod) - endif ! if(mySumWeights)... - - endif ! if(present(comm))... - - else ! no INTEGER Mask / no REAL Mask Case... - - if(present(comm)) then ! compute distributed AllReduce-style sum: - - if(mySumWeights) then ! return the global masked sum of the - ! weights in outAV - call MaskedSpatialIntegralV(inAv, outAv, SpatialWeights, & - UseFastMethod=UseFastMethod, & - SumWeights=SumWeights, & - WeightSumTag=WeightSumTag, & - comm=comm) - else ! Do not return the masked sum of the weights - call MaskedSpatialIntegralV(inAv, outAv, SpatialWeights, & - UseFastMethod=UseFastMethod, & - comm=comm) - endif ! if(mySumWeights)... - - else ! compute local sum: - - if(mySumWeights) then ! return the global masked sum of the - ! weights in outAV - call MaskedSpatialIntegralV(inAv, outAv, SpatialWeights, & - UseFastMethod=UseFastMethod, & - SumWeights=SumWeights, & - WeightSumTag=WeightSumTag) - else ! Do not return the masked sum of the weights - call MaskedSpatialIntegralV(inAv, outAv, SpatialWeights, & - UseFastMethod=UseFastMethod) - endif ! if(mySumWeights)... - - endif ! if(present(comm))... - - endif ! if(present(iMaskTags)... - - endif ! if(present(rMaskTags)... - - !========================================================== - ! The masked spatial integral is now completed. - ! Clean up the the various allocated mask structures. - !========================================================== - - if(present(iMaskTags)) then ! clean up iMask and friends... - call List_clean(iMaskList) - deallocate(iMask, iMaskTemp, stat=ierr) - if(ierr /= 0) then - write(stderr,'(3a,i8)') myname_,':: deallocate(iMask(...) failed,', & - ' ierr=',ierr - call die(myname_) - endif - endif - - if(present(rMaskTags)) then ! clean up rMask and co... - call List_clean(rMaskList) - deallocate(rMask, rMaskTemp, stat=ierr) - if(ierr /= 0) then - write(stderr,'(3a,i8)') myname_,':: deallocate(rMask(...) failed,', & - ' ierr=',ierr - call die(myname_) - endif - endif - - ! Clean up SpatialWeights(:) - - deallocate(SpatialWeights, stat=ierr) - if(ierr /= 0) then - write(stderr,'(3a,i8)') myname_,':: deallocate(SpatialWeights(...) failed,', & - ' ierr=',ierr - call die(myname_) - endif - - end subroutine MaskedSpatialIntegralRAttrGG_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: MaskedSpatialAverageRAttrGG_ - Masked spatial average. -! -! !DESCRIPTION: -! This routine computes masked spatial averages of the {\tt REAL} -! attributes of the input {\tt AttrVect} argument {\tt inAv}, returning -! the masked averages in the output {\tt AttrVect} {\tt outAv}. All of -! the masking data are assumed stored in the input {\tt GeneralGrid} -! argument {\tt GGrid}. If integer masks are to be used, their integer -! attribute names in {\tt GGrid} are named as a colon-delimited list -! in the optional {\tt CHARACTER} input argument {\tt iMaskTags}. Real -! masks (if desired) are referenced by their real attribute names in -! {\tt GGrid} are named as a colon-delimited list in the optional -! {\tt CHARACTER} input argument {\tt rMaskTags}. The user specifies -! a choice of mask combination method with the input {\tt LOGICAL} argument -! {\tt UseFastMethod}. If ${\tt UseFastMethod} = {\tt .FALSE.}$ this -! routine checks each mask entry to ensure that the integer masks contain -! only ones and zeroes, and that entries in the real masks are all in -! the closed interval $[0,1]$. If ${\tt UseFastMethod} = {\tt .TRUE.}$, -! this routine performs direct products of the masks, assuming that the -! user has validated them in advance. This averaging can either be a -! local (equivalent to a global memory space operation), or a global -! distributed integral. The latter is the case if the optional input -! {\tt INTEGER} argument {\tt comm} is supplied (which corresponds to a -! Fortran MPI communicatior handle). -! -! {\bf N.B.: } The local lengths of the {\tt AttrVect} argument {\tt inAv} -! and the input {\tt GeneralGrid} {\tt GGrid} must be equal. That is, -! there must be a one-to-one correspondence between the field point values -! stored in {\tt inAv} and the point weights stored in {\tt GGrid}. -! -! {\bf N.B.: } The output {\tt AttrVect} argument {\tt outAv} is an -! allocated data structure. The user must deallocate it using the routine -! {\tt AttrVect\_clean()} when it is no longer needed. Failure to do so -! will result in a memory leak. -! -! !INTERFACE: - - subroutine MaskedSpatialAverageRAttrGG_(inAv, outAv, GGrid, SpatialWeightTag, & - iMaskTags, rMaskTags, UseFastMethod, & - comm) - -! ! USES: - - use m_realkinds, only : FP - - use m_stdio - use m_die - use m_mpif90 - - use m_AttrVect, only : AttrVect - use m_AttrVect, only : AttrVect_init => init - use m_AttrVect, only : AttrVect_zero => zero - use m_AttrVect, only : AttrVect_clean => clean - use m_AttrVect, only : AttrVect_lsize => lsize - use m_AttrVect, only : AttrVect_indexRA => indexRA - use m_AttrVect, only : AttrVect_nRAttr => nRAttr - - use m_GeneralGrid, only : GeneralGrid - use m_GeneralGrid, only : GeneralGrid_lsize => lsize - use m_GeneralGrid, only : GeneralGrid_indexRA => indexRA - - use m_List, only : List - use m_List, only : List_nullify => nullify - - implicit none - -! !INPUT PARAMETERS: - - type(AttrVect), intent(IN) :: inAv - type(GeneralGrid), intent(IN) :: GGrid - character(len=*), intent(IN) :: SpatialWeightTag - character(len=*), optional, intent(IN) :: iMaskTags - character(len=*), optional, intent(IN) :: rMaskTags - logical, intent(IN) :: UseFastMethod - integer, optional, intent(IN) :: comm - -! !OUTPUT PARAMETERS: - - type(AttrVect), intent(OUT) :: outAv - -! !REVISION HISTORY: -! 12Jun02 - J.W. Larson - initial version -! -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::MaskedSpatialAverageRAttrGG_' - - type(AttrVect) :: integratedAv - type(List) :: nullIList - character*9, parameter :: WeightSumTag = 'WeightSum' - - integer :: i, iweight - - !================================================================ - ! Do the integration using MaskedSpatialIntegralRAttrGG_(), which - ! returns the intermediate integrals (including the masked weight - ! sum) in the AttrVect integratedAv. - !================================================================ - - if(present(iMaskTags)) then - - if(present(rMaskTags)) then ! have both iMasks and rMasks - - if(present(comm)) then ! a distributed parallel sum - call MaskedSpatialIntegralRAttrGG_(inAv, integratedAv, GGrid, & - SpatialWeightTag, iMaskTags, & - rMaskTags, UseFastMethod, & - .TRUE., WeightSumTag, comm) - else ! a purely local sum - call MaskedSpatialIntegralRAttrGG_(inAv, integratedAv, GGrid, & - SpatialWeightTag, iMaskTags, & - rMaskTags, UseFastMethod, & - .TRUE., WeightSumTag) - endif ! if(present(comm))... - - else ! Only iMasks are in use - - if(present(comm)) then ! a distributed parallel sum - call MaskedSpatialIntegralRAttrGG_(inAv, integratedAv, GGrid, & - SpatialWeightTag, iMaskTags, & - UseFastMethod=UseFastMethod, & - SumWeights=.TRUE., & - WeightSumTag=WeightSumTag, & - comm=comm) - - else ! a purely local sum - call MaskedSpatialIntegralRAttrGG_(inAv, integratedAv, GGrid, & - SpatialWeightTag, iMaskTags, & - UseFastMethod=UseFastMethod, & - SumWeights=.TRUE., & - WeightSumTag=WeightSumTag) - endif ! if(present(comm))... - - endif ! if(present(rMaskTags)... - - else ! no iMasks - - if(present(rMaskTags)) then ! Only rMasks are in use - - if(present(comm)) then ! a distributed parallel sum - call MaskedSpatialIntegralRAttrGG_(inAv, integratedAv, GGrid, & - SpatialWeightTag, & - rMaskTags=rMaskTags, & - UseFastMethod=UseFastMethod, & - SumWeights=.TRUE., & - WeightSumTag=WeightSumTag, & - comm=comm) - else ! a purely local sum - call MaskedSpatialIntegralRAttrGG_(inAv, integratedAv, GGrid, & - SpatialWeightTag, & - rMaskTags=rMaskTags, & - UseFastMethod=UseFastMethod, & - SumWeights=.TRUE., & - WeightSumTag=WeightSumTag) - endif - - else ! Neither iMasks nor rMasks are in use - - if(present(comm)) then ! a distributed parallel sum - call MaskedSpatialIntegralRAttrGG_(inAv, integratedAv, GGrid, & - SpatialWeightTag, & - UseFastMethod=UseFastMethod, & - SumWeights=.TRUE., & - WeightSumTag=WeightSumTag, & - comm=comm) - else ! a purely local sum - call MaskedSpatialIntegralRAttrGG_(inAv, integratedAv, GGrid, & - SpatialWeightTag, & - UseFastMethod=UseFastMethod, & - SumWeights=.TRUE., & - WeightSumTag=WeightSumTag) - endif ! if(present(comm))... - - endif ! if(present(rMaskTags))... - - endif ! if(present(iMaskTags))... - - !================================================================ - ! The masked integrals and masked weight sum now reside in - ! in the AttrVect integratedAv. We now wish to compute the - ! averages by dividing the integtrals by the masked weight sum. - !================================================================ - - ! Check value of summed weights (to avoid division by zero): - - iweight = AttrVect_indexRA(integratedAv, WeightSumTag) - if(integratedAv%rAttr(iweight, 1) == 0._FP) then - write(stderr,'(2a)') myname_, & - '::ERROR--Global sum of grid weights is zero.' - call die(myname_) - endif - - ! Initialize output AttrVect outAv: - call List_nullify(nullIList) - call AttrVect_init(outAv, iList=nullIList, rList=inAv%rList, lsize=1) - call AttrVect_zero(outAv) - - ! Divide by global weight sum to compute spatial averages from - ! spatial integrals. - - do i=1,AttrVect_nRAttr(outAv) - outAv%rAttr(i,1) = integratedAv%rAttr(i,1) & - / integratedAv%rAttr(iweight,1) - end do - - ! Clean up temporary AttrVect: - - call AttrVect_clean(integratedAv) - - end subroutine MaskedSpatialAverageRAttrGG_ - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: PairedSpatialIntegralRAttrGG_ - Do two spatial integrals at once. -! -! !DESCRIPTION: -! This routine computes spatial integrals of the {\tt REAL} attributes -! of the {\tt REAL} attributes of the input {\tt AttrVect} arguments -! {\tt inAv1} and {\tt inAv2}, returning the integrals in the output -! {\tt AttrVect} arguments {\tt outAv1} and {\tt outAv2}, respectively . -! The integrals of {\tt inAv1} and {\tt inAv2} are computed using -! spatial weights stored in the input {\tt GeneralGrid} arguments -! {\tt GGrid1} and {\tt GGrid2}, respectively. The spatial weights in -! in {\tt GGrid1} and {\tt GGrid2} are identified by the input {\tt CHARACTER} -! arguments {\tt WeightTag1} and {\tt WeightTag2}, respectively. -! If {\tt SpatialIntegralRAttrGG\_()} is invoked with the optional -! {\tt LOGICAL} input argument -! {\tt SumWeights} set as {\tt .TRUE.}, then the weights are also summed -! and stored in {\tt outAv1} and {\tt outAv2}, and can be referenced with -! the attribute tags defined by the arguments {\tt WeightTag1} and -! {\tt WeightTag2}, respectively. This paired integral is implicitly a -! distributed operation (the whole motivation for pairing the integrals is -! to reduce communication latency costs), and the Fortran MPI communicator -! handle is defined by the input {\tt INTEGER} argument {\tt comm}. The -! summation is an AllReduce operation, with all processes receiving the -! global sum. -! -! {\bf N.B.: } The local lengths of the {\tt AttrVect} argument {\tt inAv1} -! and the {\tt GeneralGrid} {\tt GGrid1} must be equal. That is, there -! must be a one-to-one correspondence between the field point values stored -! in {\tt inAv1} and the point weights stored in {\tt GGrid1}. The same -! relationship must apply between {\tt inAv2} and {\tt GGrid2}. -! -! {\bf N.B.: } If {\tt SpatialIntegralRAttrGG\_()} is invoked with the -! optional {\tt LOGICAL} input argument {\tt SumWeights} set as {\tt .TRUE.}, -! then the value of {\tt WeightTag1} must not conflict with any of the -! {\tt REAL} attribute tags in {\tt inAv1} and the value of {\tt WeightTag2} -! must not conflict with any of the {\tt REAL} attribute tags in {\tt inAv2}. -! -! {\bf N.B.: } The output {\tt AttrVect} arguments {\tt outAv1} and -! {\tt outAv2} are allocated data structures. The user must deallocate them -! using the routine {\tt AttrVect\_clean()} when they are no longer needed. -! Failure to do so will result in a memory leak. -! -! !INTERFACE: - - subroutine PairedSpatialIntegralRAttrGG_(inAv1, outAv1, GGrid1, WeightTag1, & - inAv2, outAv2, GGrid2, WeightTag2, & - SumWeights, comm) -! ! USES: - - use m_stdio - use m_die - use m_mpif90 - - use m_realkinds, only : FP - - use m_AttrVect, only : AttrVect - use m_AttrVect, only : AttrVect_lsize => lsize - use m_AttrVect, only : AttrVect_nRAttr => nRAttr - - use m_GeneralGrid, only : GeneralGrid - use m_GeneralGrid, only : GeneralGrid_lsize => lsize - use m_GeneralGrid, only : GeneralGrid_indexRA => indexRA - use m_GeneralGrid, only : GeneralGrid_exportRAttr => exportRAttr - - use m_AttrVectReduce, only : AttrVect_LocalWeightedSumRAttr => & - LocalWeightedSumRAttr - - use m_SpatialIntegralV, only : PairedSpatialIntegralsV - - implicit none - -! !INPUT PARAMETERS: - - type(AttrVect), intent(IN) :: inAv1 - type(GeneralGrid), intent(IN) :: GGrid1 - character(len=*), intent(IN) :: WeightTag1 - type(AttrVect), intent(IN) :: inAv2 - type(GeneralGrid), intent(IN) :: GGrid2 - character(len=*), intent(IN) :: WeightTag2 - logical, optional, intent(IN) :: SumWeights - integer, intent(IN) :: comm - -! !OUTPUT PARAMETERS: - - type(AttrVect), intent(OUT) :: outAv1 - type(AttrVect), intent(OUT) :: outAv2 - -! !REVISION HISTORY: -! 09May02 - J.W. Larson - Initial version. -! 10Jun02 - J.W. Larson - Refactored--now -! built on top of PairedIntegralRAttrV_(). -! -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::PairedSpatialIntegralRAttrGG_' - - ! Argument Sanity Checks: - - integer :: ierr, length1, length2 - logical :: mySumWeights - real(FP), dimension(:), pointer :: gridWeights1, gridWeights2 - - ! Argument Validity Checks - - if(AttrVect_lsize(inAv1) /= GeneralGrid_lsize(GGrid1)) then - ierr = AttrVect_lsize(inAv1) - GeneralGrid_lsize(GGrid1) - write(stderr,'(3a,i8,a,i8)') myname_, & - ':: inAv1 / GGrid1 length mismatch: ', & - ' AttrVect_lsize(inAv1) = ',AttrVect_lsize(inAv1), & - ' GeneralGrid_lsize(GGrid1) = ',GeneralGrid_lsize(GGrid1) - call die(myname_) - endif - - if(AttrVect_lsize(inAv2) /= GeneralGrid_lsize(GGrid2)) then - ierr = AttrVect_lsize(inAv2) - GeneralGrid_lsize(GGrid2) - write(stderr,'(3a,i8,a,i8)') myname_, & - ':: inAv2 / GGrid2 length mismatch: ', & - ' AttrVect_lsize(inAv2) = ',AttrVect_lsize(inAv2), & - ' GeneralGrid_lsize(GGrid2) = ',GeneralGrid_lsize(GGrid2) - call die(myname_) - endif - - ! Are we summing the integration weights for either input - ! GeneralGrid? - - if(present(SumWeights)) then - mySumWeights = SumWeights - else - mySumWeights = .FALSE. - endif - - ! ensure unambiguous pointer association status for gridWeights1 - ! and gridWeights2 - - nullify(gridWeights1) - nullify(gridWeights2) - - ! Extract Grid Weights - - call GeneralGrid_exportRAttr(GGrid1, WeightTag1, gridWeights1, length1) - call GeneralGrid_exportRAttr(GGrid2, WeightTag2, gridWeights2, length2) - - - call PairedSpatialIntegralsV(inAv1, outAv1, gridweights1, WeightTag1, & - inAv2, outAv2, gridweights2, WeightTag2, & - mySumWeights, comm) - - ! Clean up allocated arrays: - - deallocate(gridWeights1, gridWeights2, stat=ierr) - if(ierr /= 0) then - write(stderr,'(2a,i8)') myname_, & - 'ERROR--deallocate(gridWeights1,...) failed, ierr = ',ierr - call die(myname_) - endif - - end subroutine PairedSpatialIntegralRAttrGG_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: PairedSpatialAverageRAttrGG_ - Do two spatial averages at once. -! -! !DESCRIPTION: -! This routine computes spatial averages of the {\tt REAL} attributes -! of the {\tt REAL} attributes of the input {\tt AttrVect} arguments -! {\tt inAv1} and {\tt inAv2}, returning the integrals in the output -! {\tt AttrVect} arguments {\tt outAv1} and {\tt outAv2}, respectively . -! The integrals of {\tt inAv1} and {\tt inAv2} are computed using -! spatial weights stored in the input {\tt GeneralGrid} arguments -! {\tt GGrid1} and {\tt GGrid2}, respectively. The spatial weights in -! in {\tt GGrid1} and {\tt GGrid2} are identified by the input {\tt CHARACTER} -! arguments {\tt WeightTag1} and {\tt WeightTag2}, respectively. -! This paired average is implicitly a -! distributed operation (the whole motivation for pairing the averages is -! to reduce communication latency costs), and the Fortran MPI communicator -! handle is defined by the input {\tt INTEGER} argument {\tt comm}. The -! summation is an AllReduce operation, with all processes receiving the -! global sum. -! -! {\bf N.B.: } The local lengths of the {\tt AttrVect} argument {\tt inAv1} -! and the {\tt GeneralGrid} {\tt GGrid1} must be equal. That is, there -! must be a one-to-one correspondence between the field point values stored -! in {\tt inAv1} and the point weights stored in {\tt GGrid1}. The same -! relationship must apply between {\tt inAv2} and {\tt GGrid2}. -! -! {\bf N.B.: } The output {\tt AttrVect} arguments {\tt outAv1} and -! {\tt outAv2} are allocated data structures. The user must deallocate them -! using the routine {\tt AttrVect\_clean()} when they are no longer needed. -! Failure to do so will result in a memory leak. -! -! !INTERFACE: - - subroutine PairedSpatialAverageRAttrGG_(inAv1, outAv1, GGrid1, WeightTag1, & - inAv2, outAv2, GGrid2, WeightTag2, & - comm) -! ! USES: - - use m_realkinds, only : FP - - use m_stdio - use m_die - use m_mpif90 - - use m_AttrVect, only : AttrVect - use m_AttrVect, only : AttrVect_init => init - use m_AttrVect, only : AttrVect_zero => zero - use m_AttrVect, only : AttrVect_clean => clean - use m_AttrVect, only : AttrVect_lsize => lsize - use m_AttrVect, only : AttrVect_nRAttr => nRAttr - use m_AttrVect, only : AttrVect_indexRA => indexRA - - use m_GeneralGrid, only : GeneralGrid - use m_GeneralGrid, only : GeneralGrid_lsize => lsize - use m_GeneralGrid, only : GeneralGrid_indexRA => indexRA - use m_GeneralGrid, only : GeneralGrid_exportRAttr => exportRAttr - - use m_AttrVectReduce, only : AttrVect_LocalWeightedSumRAttr => & - LocalWeightedSumRAttr - - use m_List, only : List - use m_List, only : List_nullify => nullify - - implicit none - -! !INPUT PARAMETERS: - - type(AttrVect), intent(IN) :: inAv1 - type(GeneralGrid), intent(IN) :: GGrid1 - character(len=*), intent(IN) :: WeightTag1 - type(AttrVect), intent(IN) :: inAv2 - type(GeneralGrid), intent(IN) :: GGrid2 - character(len=*), intent(IN) :: WeightTag2 - integer, intent(IN) :: comm - -! !OUTPUT PARAMETERS: - - type(AttrVect), intent(OUT) :: outAv1 - type(AttrVect), intent(OUT) :: outAv2 - -! !REVISION HISTORY: -! 09May02 - J.W. Larson - Initial version. -! 14Jun02 - J.W. Larson - Bug fix to reflect -! new interface to PairedSpatialIntegralRAttrGG_(). -! -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::PairedSpatialAverageRAttrGG_' - - type(AttrVect) :: integratedAv1, integratedAv2 - type(List) :: nullIList - integer :: i, ierr, iweight1, iweight2 - - ! Compute the spatial integral: - - call PairedSpatialIntegralRAttrGG_(inAv1, integratedAv1, GGrid1, WeightTag1, & - inAv2, integratedAv2, GGrid2, & - WeightTag2, .TRUE., comm) - - - ! Check value of summed weights (to avoid division by zero): - - iweight1 = AttrVect_indexRA(integratedAv1, WeightTag1) - if(integratedAv1%rAttr(iweight1, 1) == 0._FP) then - write(stderr,'(2a)') myname_, & - '::ERROR--Global sum of grid weights in first integral is zero.' - call die(myname_) - endif - - iweight2 = AttrVect_indexRA(integratedAv2, WeightTag2) - if(integratedAv2%rAttr(iweight2, 1) == 0._FP) then - write(stderr,'(2a)') myname_, & - '::ERROR--Global sum of grid weights in second integral is zero.' - call die(myname_) - endif - - ! Initialize output AttrVects outAv1 and outAv2: - - call List_nullify(nullIList) - - call AttrVect_init(outAv1, iList=nullIList, rList=inAv1%rList, lsize=1) - call AttrVect_zero(outAv1) - call AttrVect_init(outAv2, iList=nullIList, rList=InAv2%rList, lsize=1) - call AttrVect_zero(outAv2) - - ! Divide by global weight sum to compute spatial averages from - ! spatial integrals. - - do i=1,AttrVect_nRAttr(outAv1) - outAv1%rAttr(i,1) = integratedAv1%rAttr(i,1) & - / integratedAv1%rAttr(iweight1,1) - end do - - do i=1,AttrVect_nRAttr(outAv2) - outAv2%rAttr(i,1) = integratedAv2%rAttr(i,1) & - / integratedAv2%rAttr(iweight2,1) - end do - - ! Clean up temporary AttrVects: - - call AttrVect_clean(integratedAv1) - call AttrVect_clean(integratedAv2) - - end subroutine PairedSpatialAverageRAttrGG_ - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: PairedMaskedIntegralRAttrGG_ - Do two masked integrals at once. -! -! !DESCRIPTION: -! This routine computes a pair of masked spatial integrals of the {\tt REAL} -! attributes of the input {\tt AttrVect} arguments {\tt inAv} and -! {\tt inAv2}, returning the masked integrals in the output {\tt AttrVect} -! {\tt outAv1} and {\tt outAv2}, respectively. All of the spatial weighting -! and masking data for each set of integrals are assumed stored in the input -! {\tt GeneralGrid} arguments {\tt GGrid} and {\tt GGrid2}. If integer -! masks are to be used, their integer attribute names in {\tt GGrid1} -! and {\tt GGrid2} are named as a colon-delimited lists in the optional -! {\tt CHARACTER} input arguments {\tt iMaskTags1} and {\tt iMaskTags2}, -! respectively. Real masks (if desired) are referenced by their real -! attribute names in {\tt GGrid1} and {\tt GGrid2} are named as -! colon-delimited lists in the optional {\tt CHARACTER} input arguments -! {\tt rMaskTags1} and {\tt rMaskTags2}, respectively. The user specifies -! a choice of mask combination method with the input {\tt LOGICAL} argument -! {\tt UseFastMethod}. If ${\tt UseFastMethod} = {\tt .FALSE.}$ this -! routine checks each mask entry to ensure that the integer masks contain -! only ones and zeroes, and that entries in the real masks are all in -! the closed interval $[0,1]$. If ${\tt UseFastMethod} = {\tt .TRUE.}$, -! this routine performs direct products of the masks, assuming that the -! user has validated them in advance. The optional {\tt LOGICAL} input -! argument {\tt SumWeights} determines whether the masked sum of the spatial -! weights is computed and returned in {\tt outAv1} and {\tt outAv2} with the -! real attribute names supplied in the {\tt CHARACTER} input arguments -! {\tt SpatialWeightTag1}, and {\tt SpatialWeightTag2}, respectively. -! This paired integral is implicitly a distributed operation (the whole -! motivation for pairing the averages is to reduce communication latency -! costs), and the Fortran MPI communicator handle is defined by the input -! {\tt INTEGER} argument {\tt comm}. The -! summation is an AllReduce operation, with all processes receiving the -! global sum. -! -! {\bf N.B.: } The local lengths of the {\tt AttrVect} argument {\tt inAv1} -! and the {\tt GeneralGrid} {\tt GGrid1} must be equal. That is, there -! must be a one-to-one correspondence between the field point values stored -! in {\tt inAv1} and the point weights stored in {\tt GGrid1}. The same -! relationship must apply between {\tt inAv2} and {\tt GGrid2}. -! -! {\bf N.B.: } If {\tt PairedMaskedIntegralRAttrGG\_()} is invoked with the -! optional {\tt LOGICAL} input argument {\tt SumWeights} set as {\tt .TRUE.}, -! then the value of {\tt SpatialWeightTag1} must not conflict with any of the -! {\tt REAL} attribute tags in {\tt inAv1} and the value of -! {\tt SpatialWeightTag2} must not conflict with any of the {\tt REAL} -! attribute tags in {\tt inAv2}. -! -! {\bf N.B.: } The output {\tt AttrVect} arguments {\tt outAv1} and -! {\tt outAv2} are allocated data structures. The user must deallocate them -! using the routine {\tt AttrVect\_clean()} when they are no longer needed. -! Failure to do so will result in a memory leak. -! -! !INTERFACE: - - subroutine PairedMaskedIntegralRAttrGG_(inAv1, outAv1, GGrid1, & - SpatialWeightTag1, rMaskTags1, & - iMaskTags1, inAv2, outAv2, GGrid2, & - SpatialWeightTag2, rMaskTags2, & - iMaskTags2, UseFastMethod, & - SumWeights, comm) -! ! USES: - - use m_stdio - use m_die - use m_mpif90 - - use m_realkinds, only : FP - - use m_AttrVect, only : AttrVect - use m_AttrVect, only : AttrVect_lsize => lsize - use m_AttrVect, only : AttrVect_nRAttr => nRAttr - - use m_GeneralGrid, only : GeneralGrid - use m_GeneralGrid, only : GeneralGrid_lsize => lsize - use m_GeneralGrid, only : GeneralGrid_indexRA => indexRA - use m_GeneralGrid, only : GeneralGrid_exportRAttr => exportRAttr - - use m_AttrVectReduce, only : AttrVect_LocalWeightedSumRAttr => & - LocalWeightedSumRAttr - - implicit none - -! !INPUT PARAMETERS: - - type(AttrVect), intent(IN) :: inAv1 - type(GeneralGrid), intent(IN) :: GGrid1 - character(len=*), intent(IN) :: SpatialWeightTag1 - character(len=*), optional, intent(IN) :: iMaskTags1 - character(len=*), optional, intent(IN) :: rMaskTags1 - type(AttrVect), intent(IN) :: inAv2 - type(GeneralGrid), intent(IN) :: GGrid2 - character(len=*), intent(IN) :: SpatialWeightTag2 - character(len=*), optional, intent(IN) :: iMaskTags2 - character(len=*), optional, intent(IN) :: rMaskTags2 - logical, intent(IN) :: UseFastMethod - logical, optional, intent(IN) :: SumWeights - integer, intent(IN) :: comm - -! !OUTPUT PARAMETERS: - - type(AttrVect), intent(OUT) :: outAv1 - type(AttrVect), intent(OUT) :: outAv2 - -! !REVISION HISTORY: -! 17Jun02 - J.W. Larson - Initial version. -! 19Jun02 - J.W. Larson - Shortened the name -! for compatibility with the Portland Group f90 compiler -! -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_ = & - myname//'::PairedMaskedIntegralRAttrGG_' - - logical :: mySumWeights - real(FP), dimension(:), pointer :: PairedBuffer, OutPairedBuffer - integer :: ierr, nRA1, nRA2, PairedBufferLength - - ! Basic Argument Validity Checks: - - if(AttrVect_lsize(inAv1) /= GeneralGrid_lsize(GGrid1)) then - ierr = AttrVect_lsize(inAv1) - GeneralGrid_lsize(GGrid1) - write(stderr,'(3a,i8,a,i8)') myname_, & - ':: inAv1 / GGrid1 length mismatch: ', & - ' AttrVect_lsize(inAv1) = ',AttrVect_lsize(inAv1), & - ' GeneralGrid_lsize(GGrid1) = ',GeneralGrid_lsize(GGrid1) - call die(myname_) - endif - - if(AttrVect_lsize(inAv2) /= GeneralGrid_lsize(GGrid2)) then - ierr = AttrVect_lsize(inAv2) - GeneralGrid_lsize(GGrid2) - write(stderr,'(3a,i8,a,i8)') myname_, & - ':: inAv2 / GGrid2 length mismatch: ', & - ' AttrVect_lsize(inAv2) = ',AttrVect_lsize(inAv2), & - ' GeneralGrid_lsize(GGrid2) = ',GeneralGrid_lsize(GGrid2) - call die(myname_) - endif - - ! Are we summing the integration weights for the input - ! GeneralGrids? - - if(present(SumWeights)) then - mySumWeights = SumWeights - else - mySumWeights = .FALSE. - endif - - ! Begin by invoking MaskedSpatialIntegralRAttrGG_() for each - ! AttrVect/GeneralGrid pair. This is done LOCALLY to create - ! integratedAv1 and integratedAv2, respectively. - - ! Local Masked Integral #1: - - if(present(iMaskTags1)) then - - if(present(rMaskTags1)) then ! both Integer and Real Masking - call MaskedSpatialIntegralRAttrGG_(inAv1, outAv1, GGrid1, & - SpatialWeightTag1, iMaskTags1, & - rMaskTags1, UseFastMethod, & - mySumWeights, SpatialWeightTag1) - else ! Integer Masking Only - call MaskedSpatialIntegralRAttrGG_(inAv1, outAv1, GGrid1, & - SpatialWeightTag1, & - iMaskTags=iMaskTags1, & - UseFastMethod=UseFastMethod, & - SumWeights=mySumWeights, & - WeightSumTag=SpatialWeightTag1) - endif ! if(present(rMaskTags1))... - - else ! No Integer Masking - - if(present(rMaskTags1)) then ! Real Masking Only - call MaskedSpatialIntegralRAttrGG_(inAv1, outAv1, GGrid1, & - SpatialWeightTag=SpatialWeightTag1, & - rMaskTags=rMaskTags1, & - UseFastMethod=UseFastMethod, & - SumWeights=mySumWeights, & - WeightSumTag=SpatialWeightTag1) - else ! Neither Integer nor Real Masking - call MaskedSpatialIntegralRAttrGG_(inAv1, outAv1, GGrid1, & - SpatialWeightTag=SpatialWeightTag1, & - UseFastMethod=UseFastMethod, & - SumWeights=mySumWeights, & - WeightSumTag=SpatialWeightTag1) - - endif ! if(present(rMaskTags1))... - - endif ! if(present(iMaskTags1))... - - ! Local Masked Integral #2: - - if(present(iMaskTags2)) then - - if(present(rMaskTags2)) then ! both Integer and Real Masking - call MaskedSpatialIntegralRAttrGG_(inAv2, outAv2, GGrid2, & - SpatialWeightTag2, iMaskTags2, & - rMaskTags2, UseFastMethod, & - mySumWeights, SpatialWeightTag2) - else ! Integer Masking Only - call MaskedSpatialIntegralRAttrGG_(inAv2, outAv2, GGrid2, & - SpatialWeightTag2, & - iMaskTags=iMaskTags2, & - UseFastMethod=UseFastMethod, & - SumWeights=mySumWeights, & - WeightSumTag=SpatialWeightTag2) - endif ! if(present(rMaskTags2))... - - else ! No Integer Masking - - if(present(rMaskTags2)) then ! Real Masking Only - call MaskedSpatialIntegralRAttrGG_(inAv2, outAv2, GGrid2, & - SpatialWeightTag=SpatialWeightTag2, & - rMaskTags=rMaskTags2, & - UseFastMethod=UseFastMethod, & - SumWeights=mySumWeights, & - WeightSumTag=SpatialWeightTag2) - else ! Neither Integer nor Real Masking - call MaskedSpatialIntegralRAttrGG_(inAv2, outAv2, GGrid2, & - SpatialWeightTag=SpatialWeightTag2, & - UseFastMethod=UseFastMethod, & - SumWeights=mySumWeights, & - WeightSumTag=SpatialWeightTag2) - - endif ! if(present(rMaskTags2))... - - endif ! if(present(iMaskTags2))... - - ! Create the paired buffer for the Global Sum - - nRA1 = AttrVect_nRAttr(outAv1) - nRA2 = AttrVect_nRAttr(outAv2) - - PairedBufferLength = nRA1 + nRA2 - allocate(PairedBuffer(PairedBufferLength), OutPairedBuffer(PairedBufferLength), & - stat=ierr) - if(ierr /= 0) then - write(stderr,'(2a,i8)') myname_, & - ':: Fatal error--allocate(PairedBuffer...failed, ierr = ',ierr - call die(myname_) - endif - - ! Load the paired buffer - - PairedBuffer(1:nRA1) = outAv1%rAttr(1:nRA1,1) - PairedBuffer(nRA1+1:PairedBufferLength) = outAv2%rAttr(1:nRA2,1) - - ! Perform the global sum on the paired buffer - - call MPI_AllReduce(PairedBuffer, OutPairedBuffer, PairedBufferLength, & - MP_Type(PairedBuffer(1)), MP_SUM, comm, ierr) - if(ierr /= 0) then - write(stderr,'(2a,i8)') myname_, & - ':: Fatal Error--MPI_ALLREDUCE() failed with ierror = ',ierr - call MP_perr_die(myname_,'MPI_ALLREDUCE() failed',ierr) - endif - - ! Unload OutPairedBuffer into outAv1 and outAv2: - - outAv1%rAttr(1:nRA1,1) = OutPairedBuffer(1:nRA1) - outAv2%rAttr(1:nRA2,1) = OutPairedBuffer(nRA1+1:PairedBufferLength) - - deallocate(PairedBuffer, OutPairedBuffer, stat=ierr) - if(ierr /= 0) then - write(stderr,'(2a,i8)') myname_, & - ':: Fatal error--deallocate(PairedBuffer...failed, ierr = ',ierr - call die(myname_) - endif - - end subroutine PairedMaskedIntegralRAttrGG_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: PairedMaskedAverageRAttrGG_ - Do two masked averages at once. -! -! !DESCRIPTION: -! This routine computes a pair of masked spatial averages of the {\tt REAL} -! attributes of the input {\tt AttrVect} arguments {\tt inAv} and -! {\tt inAv2}, returning the masked averagess in the output {\tt AttrVect} -! {\tt outAv1} and {\tt outAv2}, respectively. All of the spatial weighting -! and masking data for each set of averages are assumed stored in the input -! {\tt GeneralGrid} arguments {\tt GGrid} and {\tt GGrid2}. If integer -! masks are to be used, their integer attribute names in {\tt GGrid1} -! and {\tt GGrid2} are named as a colon-delimited lists in the optional -! {\tt CHARACTER} input arguments {\tt iMaskTags1} and {\tt iMaskTags2}, -! respectively. Real masks (if desired) are referenced by their real -! attribute names in {\tt GGrid1} and {\tt GGrid2} are named as -! colon-delimited lists in the optional {\tt CHARACTER} input arguments -! {\tt rMaskTags1} and {\tt rMaskTags2}, respectively. The user specifies -! a choice of mask combination method with the input {\tt LOGICAL} argument -! {\tt UseFastMethod}. If ${\tt UseFastMethod} = {\tt .FALSE.}$ this -! routine checks each mask entry to ensure that the integer masks contain -! only ones and zeroes, and that entries in the real masks are all in -! the closed interval $[0,1]$. If ${\tt UseFastMethod} = {\tt .TRUE.}$, -! this routine performs direct products of the masks, assuming that the -! user has validated them in advance. This paired average is implicitly -! a distributed operation (the whole motivation for pairing the averages -! is to reduce communication latency costs), and the Fortran MPI communicator -! handle is defined by the input {\tt INTEGER} argument {\tt comm}. The -! summation is an AllReduce operation, with all processes receiving the -! global sum. -! -! {\bf N.B.: } The local lengths of the {\tt AttrVect} argument {\tt inAv1} -! and the {\tt GeneralGrid} {\tt GGrid1} must be equal. That is, there -! must be a one-to-one correspondence between the field point values stored -! in {\tt inAv1} and the point weights stored in {\tt GGrid1}. The same -! relationship must apply between {\tt inAv2} and {\tt GGrid2}. -! -! {\bf N.B.: } The output {\tt AttrVect} arguments {\tt outAv1} and -! {\tt outAv2} are allocated data structures. The user must deallocate them -! using the routine {\tt AttrVect\_clean()} when they are no longer needed. -! Failure to do so will result in a memory leak. -! -! !INTERFACE: - - subroutine PairedMaskedAverageRAttrGG_(inAv1, outAv1, GGrid1, & - SpatialWeightTag1, rMaskTags1, & - iMaskTags1, inAv2, outAv2, GGrid2, & - SpatialWeightTag2, rMaskTags2, & - iMaskTags2, UseFastMethod, & - comm) -! ! USES: - - use m_stdio - use m_die - use m_mpif90 - - use m_realkinds, only : FP - - use m_AttrVect, only : AttrVect - use m_AttrVect, only : AttrVect_init => init - use m_AttrVect, only : AttrVect_zero => zero - use m_AttrVect, only : AttrVect_clean => clean - use m_AttrVect, only : AttrVect_lsize => lsize - use m_AttrVect, only : AttrVect_nRAttr => nRAttr - - use m_GeneralGrid, only : GeneralGrid - use m_GeneralGrid, only : GeneralGrid_lsize => lsize - use m_GeneralGrid, only : GeneralGrid_indexRA => indexRA - use m_GeneralGrid, only : GeneralGrid_exportRAttr => exportRAttr - - use m_AttrVectReduce, only : AttrVect_LocalWeightedSumRAttr => & - LocalWeightedSumRAttr - - use m_List, only : List - use m_List, only : List_nullify => nullify - - implicit none - -! !INPUT PARAMETERS: - - type(AttrVect), intent(IN) :: inAv1 - type(GeneralGrid), intent(IN) :: GGrid1 - character(len=*), intent(IN) :: SpatialWeightTag1 - character(len=*), optional, intent(IN) :: iMaskTags1 - character(len=*), optional, intent(IN) :: rMaskTags1 - type(AttrVect), intent(IN) :: inAv2 - type(GeneralGrid), intent(IN) :: GGrid2 - character(len=*), intent(IN) :: SpatialWeightTag2 - character(len=*), optional, intent(IN) :: iMaskTags2 - character(len=*), optional, intent(IN) :: rMaskTags2 - logical, intent(IN) :: UseFastMethod - integer, intent(IN) :: comm - -! !OUTPUT PARAMETERS: - - type(AttrVect), intent(OUT) :: outAv1 - type(AttrVect), intent(OUT) :: outAv2 - -! !REVISION HISTORY: -! 17Jun02 - J.W. Larson - Initial version. -! 19Jun02 - J.W. Larson - Shortened the name -! for compatibility with the Portland Group f90 compiler -! 25Jul02 - J.W. Larson E.T. Ong - Bug fix. This routine was -! previously doing integrals rather than area averages. -! -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_ = & - myname//'::PairedMaskedAverageRAttrGG_' - - type(AttrVect) :: LocalIntegral1, LocalIntegral2 - type(List) :: nullIList - real(FP), dimension(:), pointer :: PairedBuffer, OutPairedBuffer - integer :: i, ierr, nRA1, nRA2, PairedBufferLength - real(FP) :: WeightSumInv - - ! Basic Argument Validity Checks: - - if(AttrVect_lsize(inAv1) /= GeneralGrid_lsize(GGrid1)) then - ierr = AttrVect_lsize(inAv1) - GeneralGrid_lsize(GGrid1) - write(stderr,'(3a,i8,a,i8)') myname_, & - ':: inAv1 / GGrid1 length mismatch: ', & - ' AttrVect_lsize(inAv1) = ',AttrVect_lsize(inAv1), & - ' GeneralGrid_lsize(GGrid1) = ',GeneralGrid_lsize(GGrid1) - call die(myname_) - endif - - if(AttrVect_lsize(inAv2) /= GeneralGrid_lsize(GGrid2)) then - ierr = AttrVect_lsize(inAv2) - GeneralGrid_lsize(GGrid2) - write(stderr,'(3a,i8,a,i8)') myname_, & - ':: inAv2 / GGrid2 length mismatch: ', & - ' AttrVect_lsize(inAv2) = ',AttrVect_lsize(inAv2), & - ' GeneralGrid_lsize(GGrid2) = ',GeneralGrid_lsize(GGrid2) - call die(myname_) - endif - - ! Begin by invoking MaskedSpatialIntegralRAttrGG_() for each - ! AttrVect/GeneralGrid pair. This is done LOCALLY to create - ! LocalIntegral1 and LocalIntegral2, respectively. - - ! Local Masked Integral #1: - - if(present(iMaskTags1)) then - - if(present(rMaskTags1)) then ! both Integer and Real Masking - call MaskedSpatialIntegralRAttrGG_(inAv1, LocalIntegral1, GGrid1, & - SpatialWeightTag1, iMaskTags1, & - rMaskTags1, UseFastMethod, & - .TRUE., SpatialWeightTag1) - else ! Integer Masking Only - call MaskedSpatialIntegralRAttrGG_(inAv1, LocalIntegral1, GGrid1, & - SpatialWeightTag1, & - iMaskTags=iMaskTags1, & - UseFastMethod=UseFastMethod, & - SumWeights=.TRUE., & - WeightSumTag=SpatialWeightTag1) - endif ! if(present(rMaskTags1))... - - else ! No Integer Masking - - if(present(rMaskTags1)) then ! Real Masking Only - call MaskedSpatialIntegralRAttrGG_(inAv1, LocalIntegral1, GGrid1, & - SpatialWeightTag=SpatialWeightTag1, & - rMaskTags=rMaskTags1, & - UseFastMethod=UseFastMethod, & - SumWeights=.TRUE., & - WeightSumTag=SpatialWeightTag1) - else ! Neither Integer nor Real Masking - call MaskedSpatialIntegralRAttrGG_(inAv1, LocalIntegral1, GGrid1, & - SpatialWeightTag=SpatialWeightTag1, & - UseFastMethod=UseFastMethod, & - SumWeights=.TRUE., & - WeightSumTag=SpatialWeightTag1) - - endif ! if(present(rMaskTags1))... - - endif ! if(present(iMaskTags1))... - - ! Local Masked Integral #2: - - if(present(iMaskTags2)) then - - if(present(rMaskTags2)) then ! both Integer and Real Masking - call MaskedSpatialIntegralRAttrGG_(inAv2, LocalIntegral2, GGrid2, & - SpatialWeightTag2, iMaskTags2, & - rMaskTags2, UseFastMethod, & - .TRUE., SpatialWeightTag2) - else ! Integer Masking Only - call MaskedSpatialIntegralRAttrGG_(inAv2, LocalIntegral2, GGrid2, & - SpatialWeightTag2, & - iMaskTags=iMaskTags2, & - UseFastMethod=UseFastMethod, & - SumWeights=.TRUE., & - WeightSumTag=SpatialWeightTag2) - endif ! if(present(rMaskTags2))... - - else ! No Integer Masking - - if(present(rMaskTags2)) then ! Real Masking Only - call MaskedSpatialIntegralRAttrGG_(inAv2, LocalIntegral2, GGrid2, & - SpatialWeightTag=SpatialWeightTag2, & - rMaskTags=rMaskTags2, & - UseFastMethod=UseFastMethod, & - SumWeights=.TRUE., & - WeightSumTag=SpatialWeightTag2) - else ! Neither Integer nor Real Masking - call MaskedSpatialIntegralRAttrGG_(inAv2, LocalIntegral2, GGrid2, & - SpatialWeightTag=SpatialWeightTag2, & - UseFastMethod=UseFastMethod, & - SumWeights=.TRUE., & - WeightSumTag=SpatialWeightTag2) - - endif ! if(present(rMaskTags2))... - - endif ! if(present(iMaskTags2))... - - ! Create the paired buffer for the Global Sum - - nRA1 = AttrVect_nRAttr(LocalIntegral1) - nRA2 = AttrVect_nRAttr(LocalIntegral2) - - PairedBufferLength = nRA1 + nRA2 - allocate(PairedBuffer(PairedBufferLength), OutPairedBuffer(PairedBufferLength), & - stat=ierr) - if(ierr /= 0) then - write(stderr,'(2a,i8)') myname_, & - ':: Fatal error--allocate(PairedBuffer...failed, ierr = ',ierr - call die(myname_) - endif - - ! Load the paired buffer - - PairedBuffer(1:nRA1) = LocalIntegral1%rAttr(1:nRA1,1) - PairedBuffer(nRA1+1:PairedBufferLength) = LocalIntegral2%rAttr(1:nRA2,1) - - ! Perform the global sum on the paired buffer - - call MPI_AllReduce(PairedBuffer, OutPairedBuffer, PairedBufferLength, & - MP_Type(PairedBuffer(1)), MP_SUM, comm, ierr) - if(ierr /= 0) then - write(stderr,'(2a,i8)') myname_, & - ':: Fatal Error--MPI_ALLREDUCE() failed with ierror = ',ierr - call MP_perr_die(myname_,'MPI_ALLREDUCE() failed',ierr) - endif - - ! Create outAv1 and outAv2 from inAv1 and inAv2, respectively: - - call List_nullify(nullIList) - - call AttrVect_init(outAv1, iList=nullIList, rList=inAv1%rList, lsize=1) - call AttrVect_zero(outAv1) - call AttrVect_init(outAv2, iList=nullIList, rList=inAv2%rList, lsize=1) - call AttrVect_zero(outAv2) - - ! Unload/rescale OutPairedBuffer into outAv1 and outAv2: - - nRA1 = AttrVect_nRAttr(outAv1) - nRA2 = AttrVect_nRAttr(outAv2) - - ! First outAv1: - - if(OutPairedBuffer(nRA1+1) /= 0.) then - WeightSumInv = 1._FP / OutPairedBuffer(nRA1+1) ! Sum of weights on grid1 - ! is the nRA1+1th element in - ! the paired buffer. - else - write(stderr,'(2a)') myname_, & - ':: FATAL ERROR--Sum of the Weights for integral #1 is zero! Terminating...' - call die(myname_) - endif - - ! Rescale global integral to get global average: - - do i=1,nRA1 - outAv1%rAttr(i,1) = WeightSumInv * OutPairedBuffer(i) - end do - - ! And then outAv2: - - if(OutPairedBuffer(PairedBufferLength) /= 0.) then - WeightSumInv = 1._FP / OutPairedBuffer(PairedBufferLength) ! Sum of weights on grid2 - ! is the last element in - ! the paired buffer. - else - write(stderr,'(2a)') myname_, & - ':: FATAL ERROR--Sum of the Weights for integral #2 is zero! Terminating...' - call die(myname_) - endif - - ! Rescale global integral to get global average: - - do i=1,nRA2 - outAv2%rAttr(i,1) = WeightSumInv * OutPairedBuffer(i+nRA1+1) - end do - - ! Clean up allocated structures - - call AttrVect_clean(LocalIntegral1) - call AttrVect_clean(LocalIntegral2) - - deallocate(PairedBuffer, OutPairedBuffer, stat=ierr) - if(ierr /= 0) then - write(stderr,'(2a,i8)') myname_, & - ':: Fatal error--deallocate(PairedBuffer...failed, ierr = ',ierr - call die(myname_) - endif - - end subroutine PairedMaskedAverageRAttrGG_ - - end module m_SpatialIntegral - - - diff --git a/cesm/models/utils/mct/mct/m_SpatialIntegralV.F90 b/cesm/models/utils/mct/mct/m_SpatialIntegralV.F90 deleted file mode 100644 index 2cc9f3a..0000000 --- a/cesm/models/utils/mct/mct/m_SpatialIntegralV.F90 +++ /dev/null @@ -1,2017 +0,0 @@ -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!----------------------------------------------------------------------- -! CVS $Id$ -! CVS $Name$ -!BOP ------------------------------------------------------------------- -! -! !MODULE: m_SpatialIntegralV - Spatial Integrals and Averages using vectors of weights -! -! !DESCRIPTION: This module provides spatial integration and averaging -! services for the MCT similar to those in {\tt m\_SpatialIntegral} except -! the weights are provided by an input vector instead of through a -! {\tt GeneralGrid}. See the description for {\tt m\_SpatialIntegral} for -! more information -! -! -! Paired masked spatial integrals and averages have not yet been implemented in -! vector form. -! -! !INTERFACE: - - module m_SpatialIntegralV - - implicit none - - private ! except - -! !PUBLIC MEMBER FUNCTIONS: - - public :: SpatialIntegralV ! Spatial Integral - public :: SpatialAverageV ! Spatial Area Average - - public :: MaskedSpatialIntegralV ! Masked Spatial Integral - public :: MaskedSpatialAverageV ! MaskedSpatial Area Average - - public :: PairedSpatialIntegralsV ! A Pair of Spatial - ! Integrals - - public :: PairedSpatialAveragesV ! A Pair of Spatial - ! Area Averages - - interface SpatialIntegralV ; module procedure & - SpatialIntegralRAttrVSP_, & - SpatialIntegralRAttrVDP_ - end interface - interface SpatialAverageV ; module procedure & - SpatialAverageRAttrVSP_, & - SpatialAverageRAttrVDP_ - end interface - interface MaskedSpatialIntegralV ; module procedure & - MaskedSpatialIntegralRAttrVSP_, & - MaskedSpatialIntegralRAttrVDP_ - end interface - interface MaskedSpatialAverageV ; module procedure & - MaskedSpatialAverageRAttrVSP_, & - MaskedSpatialAverageRAttrVDP_ - end interface - interface PairedSpatialIntegralsV ; module procedure & - PairedSpatialIntegralRAttrVSP_, & - PairedSpatialIntegralRAttrVDP_ - end interface - interface PairedSpatialAveragesV ; module procedure & - PairedSpatialAverageRAttrVSP_, & - PairedSpatialAverageRAttrVDP_ - end interface - -! !REVISION HISTORY: -! 4Jan04 - R.Jacob - move Vector versions of routines -! from m_SpatialIntegral to this file. -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname='MCT::m_SpatialIntegralV' - - contains - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: SpatialIntegralRAttrVSP_ - Compute spatial integral. -! -! !DESCRIPTION: -! This routine computes spatial integrals of the {\tt REAL} attributes -! of the {\tt REAL} attributes of the input {\tt AttrVect} argument -! {\tt inAv}. {\tt SpatialIntegralRAttrV\_()} takes the input -! {\tt AttrVect} argument {\tt inAv} and computes the spatial -! integral using weights stored in the input {\tt REAL} array argument -! {\tt Weights}. The integral of each {\tt REAL} attribute is returned -! in the output {\tt AttrVect} argument {\tt outAv}. If -! {\tt SpatialIntegralRAttrV\_()} is invoked with the optional {\tt LOGICAL} -! input argument {\tt SumWeights} set as {\tt .TRUE.}, then the weights -! are also summed and stored in {\tt outAv} (and can be referenced with -! the attribute name {\tt WeightTag}. If {\tt SpatialIntegralRAttrV\_()} is -! invoked with the optional {\tt INTEGER} argument {\tt comm} (a Fortran -! MPI communicator handle), the summation operations for the integral are -! completed on the local process, then reduced across the communicator, -! with all processes receiving the result. -! -! {\bf N.B.: } The local lengths of the {\tt AttrVect} argument {\tt inAv} -! and the input array {\tt Weights} must be equal. That is, there must be -! a one-to-one correspondence between the field point values stored -! in {\tt inAv} and the point weights stored in {\tt Weights}. -! -! {\bf N.B.: } If {\tt SpatialIntegralRAttrV\_()} is invoked with the -! optional {\tt LOGICAL} input argument {\tt SumWeights} set as {\tt .TRUE.}. -! In this case, the none of {\tt REAL} attribute tags in {\tt inAv} may be -! named the same as the string contained in {\tt WeightTag}, which is an -! attribute name reserved for the sum of the weights in the output {\tt AttrVect} -! {\tt outAv}. -! -! {\bf N.B.: } The output {\tt AttrVect} argument {\tt outAv} is an -! allocated data structure. The user must deallocate it using the routine -! {\tt AttrVect\_clean()} when it is no longer needed. Failure to do so -! will result in a memory leak. -! -! !INTERFACE: - - subroutine SpatialIntegralRAttrVSP_(inAv, outAv, Weights, SumWeights, & - WeightTag, comm) - -! ! USES: - - use m_stdio - use m_die - use m_mpif90 - use m_realkinds, only : SP - - use m_AttrVect, only : AttrVect - use m_AttrVect, only : AttrVect_lsize => lsize - - use m_AttrVectReduce, only : AttrVect_GlobalWeightedSumRAttr => & - GlobalWeightedSumRAttr - use m_AttrVectReduce, only : AttrVect_LocalWeightedSumRAttr => & - LocalWeightedSumRAttr - - implicit none - -! !INPUT PARAMETERS: - - type(AttrVect), intent(IN) :: inAv - real(SP), dimension(:), pointer :: Weights - logical, optional, intent(IN) :: SumWeights - character(len=*), optional, intent(IN) :: WeightTag - integer, optional, intent(IN) :: comm - -! !OUTPUT PARAMETERS: - - type(AttrVect), intent(OUT) :: outAv - -! !REVISION HISTORY: -! 07Jun02 - J.W. Larson - initial version -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::SpatialIntegralRAttrVSP_' - - integer :: ierr, length - logical :: mySumWeights - - ! Argument Validity Checks - - if(AttrVect_lsize(inAv) /= size(Weights)) then - ierr = AttrVect_lsize(inAv) - size(Weights) - write(stderr,'(3a,i8,a,i8)') myname_, & - ':: inAv / Weights array length mismatch: ', & - ' AttrVect_lsize(inAv) = ',AttrVect_lsize(inAv), & - ' size(Weights) = ',size(Weights) - call die(myname_) - endif - - if(present(SumWeights)) then - mySumWeights = SumWeights - if(.not. present(WeightTag)) then - write(stderr,'(3a)') myname_,':: FATAL--If the input argument SumWeights=.TRUE.,', & - ' then the argument WeightTag must be provided.' - call die(myname_) - endif - else - mySumWeights = .FALSE. - endif - - ! Compute the sum - - if(present(comm)) then ! compute distributed AllReduce-style sum: - - if(mySumWeights) then ! return the spatial sum of the weights in outAV - call AttrVect_GlobalWeightedSumRAttr(inAV, outAV, Weights, & - comm, WeightTag) - else - call AttrVect_GlobalWeightedSumRAttr(inAV, outAV, Weights, comm) - endif - - else ! compute local sum: - - if(mySumWeights) then ! return the spatial sum of the weights in outAV - call AttrVect_LocalWeightedSumRAttr(inAV, outAV, Weights, & - WeightTag) - else - call AttrVect_LocalWeightedSumRAttr(inAV, outAV, Weights) - endif - - endif ! if(present(comm))... - - end subroutine SpatialIntegralRAttrVSP_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -! ------------------------------------------------------------------- -! -! !IROUTINE: SpatialIntegralRAttrVDP_ - Compute spatial integral. -! -! !DESCRIPTION: -! Double precision version of SpatialIntegralRAttrVSP_ -! -! !INTERFACE: - - subroutine SpatialIntegralRAttrVDP_(inAv, outAv, Weights, SumWeights, & - WeightTag, comm) - -! ! USES: - - use m_stdio - use m_die - use m_mpif90 - use m_realkinds, only : DP - - use m_AttrVect, only : AttrVect - use m_AttrVect, only : AttrVect_lsize => lsize - - use m_AttrVectReduce, only : AttrVect_GlobalWeightedSumRAttr => & - GlobalWeightedSumRAttr - use m_AttrVectReduce, only : AttrVect_LocalWeightedSumRAttr => & - LocalWeightedSumRAttr - - implicit none - -! !INPUT PARAMETERS: - - type(AttrVect), intent(IN) :: inAv - real(DP), dimension(:), pointer :: Weights - logical, optional, intent(IN) :: SumWeights - character(len=*), optional, intent(IN) :: WeightTag - integer, optional, intent(IN) :: comm - -! !OUTPUT PARAMETERS: - - type(AttrVect), intent(OUT) :: outAv - -! !REVISION HISTORY: -! 07Jun02 - J.W. Larson - initial version -! ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::SpatialIntegralRAttrVDP_' - - integer :: ierr, length - logical :: mySumWeights - - ! Argument Validity Checks - - if(AttrVect_lsize(inAv) /= size(Weights)) then - ierr = AttrVect_lsize(inAv) - size(Weights) - write(stderr,'(3a,i8,a,i8)') myname_, & - ':: inAv / Weights array length mismatch: ', & - ' AttrVect_lsize(inAv) = ',AttrVect_lsize(inAv), & - ' size(Weights) = ',size(Weights) - call die(myname_) - endif - - if(present(SumWeights)) then - mySumWeights = SumWeights - if(.not. present(WeightTag)) then - write(stderr,'(3a)') myname_,':: FATAL--If the input argument SumWeights=.TRUE.,', & - ' then the argument WeightTag must be provided.' - call die(myname_) - endif - else - mySumWeights = .FALSE. - endif - - ! Compute the sum - - if(present(comm)) then ! compute distributed AllReduce-style sum: - - if(mySumWeights) then ! return the spatial sum of the weights in outAV - call AttrVect_GlobalWeightedSumRAttr(inAV, outAV, Weights, & - comm, WeightTag) - else - call AttrVect_GlobalWeightedSumRAttr(inAV, outAV, Weights, comm) - endif - - else ! compute local sum: - - if(mySumWeights) then ! return the spatial sum of the weights in outAV - call AttrVect_LocalWeightedSumRAttr(inAV, outAV, Weights, & - WeightTag) - else - call AttrVect_LocalWeightedSumRAttr(inAV, outAV, Weights) - endif - - endif ! if(present(comm))... - - end subroutine SpatialIntegralRAttrVDP_ - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: SpatialAverageRAttrVSP_ - Compute spatial average. -! -! !DESCRIPTION: -! This routine computes spatial averages of the {\tt REAL} attributes -! of the input {\tt AttrVect} argument {\tt inAv}. -! {\tt SpatialAverageRAttrV\_()} takes the input {\tt AttrVect} argument -! {\tt inAv} and computes the spatial average using weights -! stored in the {\tt REAL} array {\tt Weights}. The average of each -! {\tt REAL} attribute is returned in the output {\tt AttrVect} argument -! {\tt outAv}. If {\tt SpatialAverageRAttrV\_()} is invoked with the -! optional {\tt INTEGER} argument {\tt comm} (a Fortran MPI communicator -! handle), the summation operations for the average are completed on the -! local process, then reduced across the communicator, with all processes -! receiving the result. -! -! {\bf N.B.: } The local lengths of the {\tt AttrVect} argument {\tt inAv} -! and the input array {\tt Weights} must be equal. That is, there must -! be a one-to-one correspondence between the field point values stored -! in {\tt inAv} and the point weights stored in {\tt Weights}. -! -! {\bf N.B.: } The output {\tt AttrVect} argument {\tt outAv} is an -! allocated data structure. The user must deallocate it using the routine -! {\tt AttrVect\_clean()} when it is no longer needed. Failure to do so -! will result in a memory leak. -! -! !INTERFACE: - - subroutine SpatialAverageRAttrVSP_(inAv, outAv, Weights, comm) - -! ! USES: - - use m_stdio - use m_die - use m_mpif90 - use m_realkinds, only : SP, FP - - use m_AttrVect, only : AttrVect - use m_AttrVect, only : AttrVect_init => init - use m_AttrVect, only : AttrVect_zero => zero - use m_AttrVect, only : AttrVect_clean => clean - use m_AttrVect, only : AttrVect_nRAttr => nRAttr - use m_AttrVect, only : AttrVect_indexRA => indexRA - - use m_List, only : List - use m_List, only : List_nullify => nullify - - implicit none - -! !INPUT PARAMETERS: - - type(AttrVect), intent(IN) :: inAv - real(SP), dimension(:), pointer :: Weights - integer, optional, intent(IN) :: comm - -! !OUTPUT PARAMETERS: - - type(AttrVect), intent(OUT) :: outAv - -! !REVISION HISTORY: -! 10Jun02 - J.W. Larson - initial version -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::SpatialAverageRAtttrVSP_' - - type(AttrVect) :: integratedAv - type(List) :: nullIList - integer :: i, ierr, iweight - - ! Compute the spatial integral: - - if(present(comm)) then - call SpatialIntegralV(inAv, integratedAv, Weights, & - .TRUE., 'weights', comm) - else - call SpatialIntegralV(inAv, integratedAv, Weights, .TRUE., 'weights') - endif - - ! Check value of summed weights (to avoid division by zero): - - iweight = AttrVect_indexRA(integratedAv, 'weights') - if(integratedAv%rAttr(iweight, 1) == 0._FP) then - write(stderr,'(2a)') myname_, & - '::ERROR--Global sum of grid weights is zero.' - call die(myname_) - endif - - ! Initialize output AttrVect outAv: - - call List_nullify(nullIList) - call AttrVect_init(outAv, iList=nullIList, rList=inAv%rList, lsize=1) - call AttrVect_zero(outAv) - - ! Divide by global weight sum to compute spatial averages from - ! spatial integrals. - - do i=1,AttrVect_nRAttr(outAv) - outAv%rAttr(i,1) = integratedAv%rAttr(i,1) & - / integratedAv%rAttr(iweight,1) - end do - - ! Clean up temporary AttrVect: - - call AttrVect_clean(integratedAv) - - end subroutine SpatialAverageRAttrVSP_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -! ------------------------------------------------------------------- -! -! !IROUTINE: SpatialAverageRAttrVDP_ - Compute spatial average. -! -! !DESCRIPTION: -! Double pecision version of SpatialAverageRAttrVSP -! -! !INTERFACE: - - subroutine SpatialAverageRAttrVDP_(inAv, outAv, Weights, comm) - -! ! USES: - - use m_stdio - use m_die - use m_mpif90 - use m_realkinds, only : DP, FP - - use m_AttrVect, only : AttrVect - use m_AttrVect, only : AttrVect_init => init - use m_AttrVect, only : AttrVect_zero => zero - use m_AttrVect, only : AttrVect_clean => clean - use m_AttrVect, only : AttrVect_nRAttr => nRAttr - use m_AttrVect, only : AttrVect_indexRA => indexRA - - use m_List, only : List - use m_List, only : List_nullify => nullify - - implicit none - -! !INPUT PARAMETERS: - - type(AttrVect), intent(IN) :: inAv - real(DP), dimension(:), pointer :: Weights - integer, optional, intent(IN) :: comm - -! !OUTPUT PARAMETERS: - - type(AttrVect), intent(OUT) :: outAv - -! !REVISION HISTORY: -! 10Jun02 - J.W. Larson - initial version -! ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::SpatialAverageRAtttrVDP_' - - type(AttrVect) :: integratedAv - type(List) :: nullIList - integer :: i, ierr, iweight - - ! Compute the spatial integral: - - if(present(comm)) then - call SpatialIntegralV(inAv, integratedAv, Weights, & - .TRUE., 'weights', comm) - else - call SpatialIntegralV(inAv, integratedAv, Weights, .TRUE., 'weights') - endif - - ! Check value of summed weights (to avoid division by zero): - - iweight = AttrVect_indexRA(integratedAv, 'weights') - if(integratedAv%rAttr(iweight, 1) == 0._FP) then - write(stderr,'(2a)') myname_, & - '::ERROR--Global sum of grid weights is zero.' - call die(myname_) - endif - - ! Initialize output AttrVect outAv: - - call List_nullify(nullIList) - call AttrVect_init(outAv, iList=nullIList, rList=inAv%rList, lsize=1) - call AttrVect_zero(outAv) - - ! Divide by global weight sum to compute spatial averages from - ! spatial integrals. - - do i=1,AttrVect_nRAttr(outAv) - outAv%rAttr(i,1) = integratedAv%rAttr(i,1) & - / integratedAv%rAttr(iweight,1) - end do - - ! Clean up temporary AttrVect: - - call AttrVect_clean(integratedAv) - - end subroutine SpatialAverageRAttrVDP_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: MaskedSpatialIntegralRAttrVSP_ - Masked spatial integral. -! -! !DESCRIPTION: -! This routine computes masked spatial integrals of the {\tt REAL} -! attributes of the input {\tt AttrVect} argument {\tt inAv}, returning -! the masked integrals in the output {\tt AttrVect} argument {\tt outAv}. -! The masked integral is computed using weights stored in the input -! {\tt REAL} array argument {\tt SpatialWeights}. Integer masking (if -! desired) is provided in the optional input {\tt INTEGER} array {\tt iMask}, -! and real masking (if desired) is provided in the optional input {\tt REAL} -! array {\tt rMask}. If {\tt SpatialIntegralRAttrV\_()} is invoked with the -! optional {\tt LOGICAL} input argument {\tt SumWeights} set as {\tt .TRUE.}, -! then the weights are also summed and stored in {\tt outAv} (and can be -! referenced with the attribute name defined by the optional input -! {\tt CHARACTER} argument {\tt WeightSumTag}. If -! {\tt SpatialIntegralRAttrV\_()} is invoked with the optional {\tt INTEGER} -! argument {\tt comm} (a Fortran MPI communicator handle), the summation -! operations for the integral are completed on the local process, then -! reduced across the communicator, with all processes receiving the result. -! Otherwise, the integral is assumed to be local (or equivalent to a global -! address space). -! -! {\bf N.B.: } The local lengths of the {\tt AttrVect} argument {\tt inAv} -! and the input array {\tt Weights} must be equal. That is, there must be -! a one-to-one correspondence between the field point values stored -! in {\tt inAv} and the point weights stored in {\tt SpatialWeights}. -! -! {\bf N.B.: } If {\tt SpatialIntegralRAttrV\_()} is invoked with the -! optional {\tt LOGICAL} input argument {\tt SumWeights} set as {\tt .TRUE.}. -! In this case, the none of {\tt REAL} attribute tags in {\tt inAv} may be -! named the same as the string contained in {\tt WeightSumTag}, which is an -! attribute name reserved for the sum of the weights in the output {\tt AttrVect} -! {\tt outAv}. -! -! {\bf N.B.: } The output {\tt AttrVect} argument {\tt outAv} is an -! allocated data structure. The user must deallocate it using the routine -! {\tt AttrVect\_clean()} when it is no longer needed. Failure to do so -! will result in a memory leak. -! -! !INTERFACE: - - subroutine MaskedSpatialIntegralRAttrVSP_(inAv, outAv, SpatialWeights, iMask, & - rMask, UseFastMethod, SumWeights, & - WeightSumTag, comm) - -! ! USES: - - use m_stdio - use m_die - use m_mpif90 - use m_realkinds, only : SP, FP - - use m_AttrVect, only : AttrVect - use m_AttrVect, only : AttrVect_lsize => lsize - - use m_AttrVectReduce, only : AttrVect_GlobalWeightedSumRAttr => & - GlobalWeightedSumRAttr - use m_AttrVectReduce, only : AttrVect_LocalWeightedSumRAttr => & - LocalWeightedSumRAttr - implicit none - -! !INPUT PARAMETERS: - - type(AttrVect), intent(IN) :: inAv - real(SP),dimension(:), pointer :: SpatialWeights - integer, dimension(:), optional, pointer :: iMask - real(SP),dimension(:), optional, pointer :: rMask - logical, intent(IN) :: UseFastMethod - logical, optional, intent(IN) :: SumWeights - character(len=*), optional, intent(IN) :: WeightSumTag - integer, optional, intent(IN) :: comm - -! !OUTPUT PARAMETERS: - - type(AttrVect), intent(OUT) :: outAv - -! !REVISION HISTORY: -! 10Jun02 - J.W. Larson - initial version -! -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::MaskedSpatialIntegralRAttrVSP_' - - integer :: i, ierr, length - logical :: mySumWeights - real(FP), dimension(:), pointer :: Weights - - ! Argument Validity Checks - - if(AttrVect_lsize(inAv) /= size(SpatialWeights)) then - ierr = AttrVect_lsize(inAv) - size(SpatialWeights) - write(stderr,'(3a,i8,a,i8)') myname_, & - ':: inAv / SpatialWeights array length mismatch: ', & - ' AttrVect_lsize(inAv) = ',AttrVect_lsize(inAv), & - ' size(SpatialWeights) = ',size(SpatialWeights) - call die(myname_) - endif - - if(present(iMask)) then ! make sure it is the right length - if(AttrVect_lsize(inAv) /= size(iMask)) then - ierr = AttrVect_lsize(inAv) - size(iMask) - write(stderr,'(3a,i8,a,i8)') myname_, & - ':: inAv / iMask array length mismatch: ', & - ' AttrVect_lsize(inAv) = ',AttrVect_lsize(inAv), & - ' size(iMask) = ',size(iMask) - call die(myname_) - endif - endif - - if(present(rMask)) then ! make sure it is the right length - if(AttrVect_lsize(inAv) /= size(rMask)) then - ierr = AttrVect_lsize(inAv) - size(rMask) - write(stderr,'(3a,i8,a,i8)') myname_, & - ':: inAv / rMask array length mismatch: ', & - ' AttrVect_lsize(inAv) = ',AttrVect_lsize(inAv), & - ' size(rMask) = ',size(rMask) - call die(myname_) - endif - endif - - if(present(SumWeights)) then - mySumWeights = SumWeights - if(.not. present(WeightSumTag)) then - write(stderr,'(3a)') myname_,':: FATAL--If the input argument SumWeights=.TRUE.,', & - ' then the argument WeightSumTag must be provided.' - call die(myname_) - endif - else - mySumWeights = .FALSE. - endif - - ! Create a common Weights(:) array... - - length = AttrVect_lsize(inAv) - - allocate(Weights(length), stat=ierr) - if(ierr /= 0) then - write(stderr,'(3a,i8)') myname_,':: allocate(Weights(...) failed,', & - ' ierr=',ierr - call die(myname_) - endif - - ! Combine weights and masks into a common Weights(:) array... - - if(UseFastMethod) then ! form the product of iMask, rMask, and SpatialWeights - - if(present(rMask)) then ! use it to form Weights(:) - if(present(iMask)) then ! use it and rMask to form Weights(:) - do i=1,length - Weights(i) = rMask(i) * SpatialWeights(i) * iMask(i) - end do - else - do i=1,length - Weights(i) = rMask(i) * SpatialWeights(i) - end do - endif ! if(present(iMask))... - else - if(present(iMask)) then - do i=1,length - Weights(i) = SpatialWeights(i) * iMask(i) - end do - else - do i=1,length - Weights(i) = SpatialWeights(i) - end do - endif ! if(present(iMask))... - endif ! if(present(rMask))... - - - else ! Scan iMask and rMask carefully and set Weights(i) to zero - ! when iMask(i) or rMask(i) is zero. This avoids round-off - ! effects from products and promotion of integers to reals. - - if(present(rMask)) then ! use it to form Weights(:) - if(present(iMask)) then ! use it and rMask to form Weights(:) - do i=1,length - select case(iMask(i)) - case(0) - Weights(i) = 0._FP - case(1) - if(rMask(i) == 1._FP) then - Weights(i) = SpatialWeights(i) - elseif(rMask(i) == 0._FP) then - Weights(i) = 0._FP - elseif((rMask(i) > 0._FP) .and. (rMask(i) < 1._FP)) then - Weights(i) = rMask(i) * SpatialWeights(i) - else ! rMask(i) < 0. or rMask(i) > 1. - write(stderr,'(3a,i8,a,f10.7)') myname_, & - ':: invalid value for real', & - 'mask entry rMask(',i,') = ',rMask(i) - call die(myname_) - endif - case default - write(stderr,'(3a,i8,a,i8)') myname_, & - ':: invalid value for integer', & - 'mask entry iMask(',i,') = ',iMask(i) - call die(myname_) - end select - end do - else - do i=1,length - if(rMask(i) == 1._FP) then - Weights(i) = SpatialWeights(i) - elseif(rMask(i) == 0._FP) then - Weights(i) = 0._FP - elseif((rMask(i) > 0._FP) .and. (rMask(i) < 1._FP)) then - Weights(i) = rMask(i) * SpatialWeights(i) - else ! rMask(i) < 0. or rMask(i) > 1. - write(stderr,'(3a,i8,a,e10.6)') myname_, & - ':: invalid value for real', & - 'mask entry rMask(',i,') = ',rMask(i) - call die(myname_) - endif - end do - endif ! if(present(iMask))... - else ! no rMask present... - if(present(iMask)) then ! check iMask entries... - do i=1,length - select case(iMask(i)) - case(0) - Weights(i) = 0._FP - case(1) - Weights(i) = SpatialWeights(i) - case default - write(stderr,'(3a,i8,a,i8)') myname_, & - ':: invalid value for integer', & - 'mask entry iMask(',i,') = ',iMask(i) - call die(myname_) - end select - end do - else ! straight assignment of SpatialWeights(:) - do i=1,length - Weights(i) = SpatialWeights(i) - end do - endif ! if(present(iMask))... - endif ! if(present(rMask))... - - - endif ! if(UseFastMethod) - - ! Now that the weights are combined into a common Weights(:), - ! compute the masked weighted sum: - - if(present(comm)) then ! compute distributed AllReduce-style sum: - - if(mySumWeights) then ! return the global sum of the weights in outAV - call AttrVect_GlobalWeightedSumRAttr(inAV, outAV, Weights, & - comm, WeightSumTag) - else - call AttrVect_GlobalWeightedSumRAttr(inAV, outAV, Weights, comm) - endif - - else ! compute local sum: - - if(mySumWeights) then ! return the global sum of the weights in outAV - call AttrVect_LocalWeightedSumRAttr(inAV, outAV, Weights, & - WeightSumAttr=WeightSumTag) - else - call AttrVect_LocalWeightedSumRAttr(inAV, outAV, Weights) - endif - - endif ! if(present(comm))... - - ! Clean up the allocated Weights(:) array - - deallocate(Weights, stat=ierr) - if(ierr /= 0) then - write(stderr,'(3a,i8)') myname_,':: deallocate(Weights(...) failed,', & - ' ierr=',ierr - call die(myname_) - endif - - end subroutine MaskedSpatialIntegralRAttrVSP_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -! ------------------------------------------------------------------- -! -! !IROUTINE: MaskedSpatialIntegralRAttrVDP_ - Masked spatial integral. -! -! !DESCRIPTION: -! Double precision version of MaskedSpatialIntegralRAttrVSP_ -! -! !INTERFACE: - - subroutine MaskedSpatialIntegralRAttrVDP_(inAv, outAv, SpatialWeights, iMask, & - rMask, UseFastMethod, SumWeights, & - WeightSumTag, comm) - -! ! USES: - - use m_stdio - use m_die - use m_mpif90 - use m_realkinds, only : DP, FP - - use m_AttrVect, only : AttrVect - use m_AttrVect, only : AttrVect_lsize => lsize - - use m_AttrVectReduce, only : AttrVect_GlobalWeightedSumRAttr => & - GlobalWeightedSumRAttr - use m_AttrVectReduce, only : AttrVect_LocalWeightedSumRAttr => & - LocalWeightedSumRAttr - implicit none - -! !INPUT PARAMETERS: - - type(AttrVect), intent(IN) :: inAv - real(DP),dimension(:), pointer :: SpatialWeights - integer, dimension(:), optional, pointer :: iMask - real(DP),dimension(:), optional, pointer :: rMask - logical, intent(IN) :: UseFastMethod - logical, optional, intent(IN) :: SumWeights - character(len=*), optional, intent(IN) :: WeightSumTag - integer, optional, intent(IN) :: comm - -! !OUTPUT PARAMETERS: - - type(AttrVect), intent(OUT) :: outAv - -! !REVISION HISTORY: -! 10Jun02 - J.W. Larson - initial version -! ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::MaskedSpatialIntegralRAttrVDP_' - - integer :: i, ierr, length - logical :: mySumWeights - real(FP), dimension(:), pointer :: Weights - - ! Argument Validity Checks - - if(AttrVect_lsize(inAv) /= size(SpatialWeights)) then - ierr = AttrVect_lsize(inAv) - size(SpatialWeights) - write(stderr,'(3a,i8,a,i8)') myname_, & - ':: inAv / SpatialWeights array length mismatch: ', & - ' AttrVect_lsize(inAv) = ',AttrVect_lsize(inAv), & - ' size(SpatialWeights) = ',size(SpatialWeights) - call die(myname_) - endif - - if(present(iMask)) then ! make sure it is the right length - if(AttrVect_lsize(inAv) /= size(iMask)) then - ierr = AttrVect_lsize(inAv) - size(iMask) - write(stderr,'(3a,i8,a,i8)') myname_, & - ':: inAv / iMask array length mismatch: ', & - ' AttrVect_lsize(inAv) = ',AttrVect_lsize(inAv), & - ' size(iMask) = ',size(iMask) - call die(myname_) - endif - endif - - if(present(rMask)) then ! make sure it is the right length - if(AttrVect_lsize(inAv) /= size(rMask)) then - ierr = AttrVect_lsize(inAv) - size(rMask) - write(stderr,'(3a,i8,a,i8)') myname_, & - ':: inAv / rMask array length mismatch: ', & - ' AttrVect_lsize(inAv) = ',AttrVect_lsize(inAv), & - ' size(rMask) = ',size(rMask) - call die(myname_) - endif - endif - - if(present(SumWeights)) then - mySumWeights = SumWeights - if(.not. present(WeightSumTag)) then - write(stderr,'(3a)') myname_,':: FATAL--If the input argument SumWeights=.TRUE.,', & - ' then the argument WeightSumTag must be provided.' - call die(myname_) - endif - else - mySumWeights = .FALSE. - endif - - ! Create a common Weights(:) array... - - length = AttrVect_lsize(inAv) - - allocate(Weights(length), stat=ierr) - if(ierr /= 0) then - write(stderr,'(3a,i8)') myname_,':: allocate(Weights(...) failed,', & - ' ierr=',ierr - call die(myname_) - endif - - ! Combine weights and masks into a common Weights(:) array... - - if(UseFastMethod) then ! form the product of iMask, rMask, and SpatialWeights - - if(present(rMask)) then ! use it to form Weights(:) - if(present(iMask)) then ! use it and rMask to form Weights(:) - do i=1,length - Weights(i) = rMask(i) * SpatialWeights(i) * iMask(i) - end do - else - do i=1,length - Weights(i) = rMask(i) * SpatialWeights(i) - end do - endif ! if(present(iMask))... - else - if(present(iMask)) then - do i=1,length - Weights(i) = SpatialWeights(i) * iMask(i) - end do - else - do i=1,length - Weights(i) = SpatialWeights(i) - end do - endif ! if(present(iMask))... - endif ! if(present(rMask))... - - - else ! Scan iMask and rMask carefully and set Weights(i) to zero - ! when iMask(i) or rMask(i) is zero. This avoids round-off - ! effects from products and promotion of integers to reals. - - if(present(rMask)) then ! use it to form Weights(:) - if(present(iMask)) then ! use it and rMask to form Weights(:) - do i=1,length - select case(iMask(i)) - case(0) - Weights(i) = 0._FP - case(1) - if(rMask(i) == 1._FP) then - Weights(i) = SpatialWeights(i) - elseif(rMask(i) == 0._FP) then - Weights(i) = 0._FP - elseif((rMask(i) > 0._FP) .and. (rMask(i) < 1._FP)) then - Weights(i) = rMask(i) * SpatialWeights(i) - else ! rMask(i) < 0. or rMask(i) > 1. - write(stderr,'(3a,i8,a,f10.7)') myname_, & - ':: invalid value for real', & - 'mask entry rMask(',i,') = ',rMask(i) - call die(myname_) - endif - case default - write(stderr,'(3a,i8,a,i8)') myname_, & - ':: invalid value for integer', & - 'mask entry iMask(',i,') = ',iMask(i) - call die(myname_) - end select - end do - else - do i=1,length - if(rMask(i) == 1._FP) then - Weights(i) = SpatialWeights(i) - elseif(rMask(i) == 0._FP) then - Weights(i) = 0._FP - elseif((rMask(i) > 0._FP) .and. (rMask(i) < 1._FP)) then - Weights(i) = rMask(i) * SpatialWeights(i) - else ! rMask(i) < 0. or rMask(i) > 1. - write(stderr,'(3a,i8,a,e10.6)') myname_, & - ':: invalid value for real', & - 'mask entry rMask(',i,') = ',rMask(i) - call die(myname_) - endif - end do - endif ! if(present(iMask))... - else ! no rMask present... - if(present(iMask)) then ! check iMask entries... - do i=1,length - select case(iMask(i)) - case(0) - Weights(i) = 0._FP - case(1) - Weights(i) = SpatialWeights(i) - case default - write(stderr,'(3a,i8,a,i8)') myname_, & - ':: invalid value for integer', & - 'mask entry iMask(',i,') = ',iMask(i) - call die(myname_) - end select - end do - else ! straight assignment of SpatialWeights(:) - do i=1,length - Weights(i) = SpatialWeights(i) - end do - endif ! if(present(iMask))... - endif ! if(present(rMask))... - - - endif ! if(UseFastMethod) - - ! Now that the weights are combined into a common Weights(:), - ! compute the masked weighted sum: - - if(present(comm)) then ! compute distributed AllReduce-style sum: - - if(mySumWeights) then ! return the global sum of the weights in outAV - call AttrVect_GlobalWeightedSumRAttr(inAV, outAV, Weights, & - comm, WeightSumTag) - else - call AttrVect_GlobalWeightedSumRAttr(inAV, outAV, Weights, comm) - endif - - else ! compute local sum: - - if(mySumWeights) then ! return the global sum of the weights in outAV - call AttrVect_LocalWeightedSumRAttr(inAV, outAV, Weights, & - WeightSumAttr=WeightSumTag) - else - call AttrVect_LocalWeightedSumRAttr(inAV, outAV, Weights) - endif - - endif ! if(present(comm))... - - ! Clean up the allocated Weights(:) array - - deallocate(Weights, stat=ierr) - if(ierr /= 0) then - write(stderr,'(3a,i8)') myname_,':: deallocate(Weights(...) failed,', & - ' ierr=',ierr - call die(myname_) - endif - - end subroutine MaskedSpatialIntegralRAttrVDP_ - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: MaskedSpatialAverageRAttrVSP_ - Masked spatial average. -! -! !DESCRIPTION: [NEEDS **LOTS** of work...] -! This routine computes spatial integrals of the {\tt REAL} attributes -! of the {\tt REAL} attributes of the input {\tt AttrVect} argument -! {\tt inAv}. {\tt SpatialIntegralRAttrV\_()} takes the input -! {\tt AttrVect} argument {\tt inAv} and computes the spatial -! integral using weights stored in the input {\tt REAL} array argument -! {\tt Weights}. The integral of each {\tt REAL} attribute is returned -! in the output {\tt AttrVect} argument {\tt outAv}. If -! {\tt SpatialIntegralRAttrV\_()} is invoked with the optional {\tt LOGICAL} -! input argument {\tt SumWeights} set as {\tt .TRUE.}, then the weights -! are also summed and stored in {\tt outAv} (and can be referenced with -! the attribute name {\tt WeightTag}. If {\tt SpatialIntegralRAttrV\_()} is -! invoked with the optional {\tt INTEGER} argument {\tt comm} (a Fortran -! MPI communicator handle), the summation operations for the integral are -! completed on the local process, then reduced across the communicator, -! with all processes receiving the result. -! -! {\bf N.B.: } The local lengths of the {\tt AttrVect} argument {\tt inAv} -! and the input array {\tt Weights} must be equal. That is, there must be -! a one-to-one correspondence between the field point values stored -! in {\tt inAv} and the point weights stored in {\tt Weights}. -! -! {\bf N.B.: } If {\tt SpatialIntegralRAttrV\_()} is invoked with the -! optional {\tt LOGICAL} input argument {\tt SumWeights} set as {\tt .TRUE.}. -! In this case, the none of {\tt REAL} attribute tags in {\tt inAv} may be -! named the same as the string contained in {\tt WeightTag}, which is an -! attribute name reserved for the sum of the weights in the output {\tt AttrVect} -! {\tt outAv}. -! -! {\bf N.B.: } The output {\tt AttrVect} argument {\tt outAv} is an -! allocated data structure. The user must deallocate it using the routine -! {\tt AttrVect\_clean()} when it is no longer needed. Failure to do so -! will result in a memory leak. -! -! !INTERFACE: - - subroutine MaskedSpatialAverageRAttrVSP_(inAv, outAv, SpatialWeights, iMask, & - rMask, UseFastMethod, comm) - -! ! USES: - - use m_stdio - use m_die - use m_mpif90 - use m_realkinds, only : SP, FP - - use m_AttrVect, only : AttrVect - use m_AttrVect, only : AttrVect_init => init - use m_AttrVect, only : AttrVect_zero => zero - use m_AttrVect, only : AttrVect_clean => clean - use m_AttrVect, only : AttrVect_lsize => lsize - use m_AttrVect, only : AttrVect_nRAttr => nRAttr - use m_AttrVect, only : AttrVect_indexRA => indexRA - - use m_List, only : List - use m_List, only : List_nullify => nullify - - implicit none - -! !INPUT PARAMETERS: - - type(AttrVect), intent(IN) :: inAv - real(SP), dimension(:), pointer :: SpatialWeights - integer, dimension(:), optional, pointer :: iMask - real(SP),dimension(:), optional, pointer :: rMask - logical, intent(IN) :: UseFastMethod - integer, optional, intent(IN) :: comm - -! !OUTPUT PARAMETERS: - - type(AttrVect), intent(OUT) :: outAv - -! !REVISION HISTORY: -! 11Jun02 - J.W. Larson - initial version -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::MaskedSpatialAverageRAttrVSP_' - - type(AttrVect) :: integratedAv - type(List) :: nullIList - - integer :: i, ierr, length, iweight - logical :: mySumWeights - - ! Argument Validity Checks - - if(AttrVect_lsize(inAv) /= size(SpatialWeights)) then - ierr = AttrVect_lsize(inAv) - size(SpatialWeights) - write(stderr,'(3a,i8,a,i8)') myname_, & - ':: inAv / SpatialWeights array length mismatch: ', & - ' AttrVect_lsize(inAv) = ',AttrVect_lsize(inAv), & - ' size(SpatialWeights) = ',size(SpatialWeights) - call die(myname_) - endif - - if(present(iMask)) then ! make sure it is the right length - if(AttrVect_lsize(inAv) /= size(iMask)) then - ierr = AttrVect_lsize(inAv) - size(iMask) - write(stderr,'(3a,i8,a,i8)') myname_, & - ':: inAv / iMask array length mismatch: ', & - ' AttrVect_lsize(inAv) = ',AttrVect_lsize(inAv), & - ' size(iMask) = ',size(iMask) - call die(myname_) - endif - endif - - if(present(rMask)) then ! make sure it is the right length - if(AttrVect_lsize(inAv) /= size(rMask)) then - ierr = AttrVect_lsize(inAv) - size(rMask) - write(stderr,'(3a,i8,a,i8)') myname_, & - ':: inAv / rMask array length mismatch: ', & - ' AttrVect_lsize(inAv) = ',AttrVect_lsize(inAv), & - ' size(rMask) = ',size(rMask) - call die(myname_) - endif - endif - - ! Compute the masked weighted sum, including the sum of the - ! masked weights. - - if(present(comm)) then ! communicator handle present - - if(present(iMask)) then - - if(present(rMask)) then - call MaskedSpatialIntegralV(inAv, integratedAv, SpatialWeights, & - iMask, rMask, UseFastMethod, .TRUE., & - 'MaskedWeightsSum', comm) - else ! no rMask - call MaskedSpatialIntegralV(inAv, integratedAv, SpatialWeights, & - iMask=iMask, UseFastMethod=UseFastMethod, & - SumWeights=.TRUE., & - WeightSumTag='MaskedWeightsSum', & - comm=comm) - endif ! if(present(rMask))... - - else ! no iMask present... - - if(present(rMask)) then - call MaskedSpatialIntegralV(inAv, integratedAv, SpatialWeights, & - rMask=rMask, UseFastMethod=UseFastMethod, & - SumWeights=.TRUE., & - WeightSumTag='MaskedWeightsSum', & - comm=comm) - else ! neither rMask nor iMask present: - call MaskedSpatialIntegralV(inAv, integratedAv, SpatialWeights, & - UseFastMethod=UseFastMethod, & - SumWeights=.TRUE., & - WeightSumTag='MaskedWeightsSum', & - comm=comm) - endif ! if(present(rMask))... - - endif ! if(present(iMask))... - - else ! no communicator handle present - - if(present(iMask)) then - - if(present(rMask)) then - call MaskedSpatialIntegralV(inAv, integratedAv, SpatialWeights, & - iMask, rMask, UseFastMethod, .TRUE., & - 'MaskedWeightsSum') - else ! no rMask - call MaskedSpatialIntegralV(inAv, integratedAv, SpatialWeights, & - iMask=iMask, UseFastMethod=UseFastMethod, & - SumWeights=.TRUE., & - WeightSumTag='MaskedWeightsSum') - endif ! if(present(rMask))... - - else ! no iMask present... - - if(present(rMask)) then - call MaskedSpatialIntegralV(inAv, integratedAv, SpatialWeights, & - rMask=rMask, UseFastMethod=UseFastMethod, & - SumWeights=.TRUE., & - WeightSumTag='MaskedWeightsSum') - else ! neither rMask nor iMask present: - call MaskedSpatialIntegralV(inAv, integratedAv, SpatialWeights, & - UseFastMethod=UseFastMethod, & - SumWeights=.TRUE., & - WeightSumTag='MaskedWeightsSum') - endif ! if(present(rMask))... - - endif ! if(present(iMask))... - - endif ! if(present(comm))... - - ! At this point, integratedAv containes the masked spatial integrals - ! of the REAL attributes of inAv, along with the sum of the weights. - ! to compute the masked spatial average - - ! Check value of summed weights (to avoid division by zero): - - iweight = AttrVect_indexRA(integratedAv, 'MaskedWeightsSum') - if(integratedAv%rAttr(iweight, 1) == 0._FP) then - write(stderr,'(2a)') myname_, & - '::ERROR--Global sum of grid weights is zero.' - call die(myname_) - endif - - ! Initialize output AttrVect outAv: - - call List_nullify(nullIList) - call AttrVect_init(outAv, iList=nullIList, rList=inAv%rList, lsize=1) - call AttrVect_zero(outAv) - - ! Divide by global weight sum to compute spatial averages from - ! spatial integrals. - - do i=1,AttrVect_nRAttr(outAv) - outAv%rAttr(i,1) = integratedAv%rAttr(i,1) & - / integratedAv%rAttr(iweight,1) - end do - - ! Clean up temporary AttrVect: - - call AttrVect_clean(integratedAv) - - end subroutine MaskedSpatialAverageRAttrVSP_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -! ------------------------------------------------------------------- -! -! !IROUTINE: MaskedSpatialAverageRAttrVDP_ - Masked spatial average. -! -! !DESCRIPTION: [NEEDS **LOTS** of work...] -! Double precision interface version of MaskedSpatialAverageRAttrVSP_. -! -! !INTERFACE: - - subroutine MaskedSpatialAverageRAttrVDP_(inAv, outAv, SpatialWeights, iMask, & - rMask, UseFastMethod, comm) - -! ! USES: - - use m_stdio - use m_die - use m_mpif90 - use m_realkinds, only : DP, FP - - use m_AttrVect, only : AttrVect - use m_AttrVect, only : AttrVect_init => init - use m_AttrVect, only : AttrVect_zero => zero - use m_AttrVect, only : AttrVect_clean => clean - use m_AttrVect, only : AttrVect_lsize => lsize - use m_AttrVect, only : AttrVect_nRAttr => nRAttr - use m_AttrVect, only : AttrVect_indexRA => indexRA - - use m_List, only : List - use m_List, only : List_nullify => nullify - - implicit none - -! !INPUT PARAMETERS: - - type(AttrVect), intent(IN) :: inAv - real(DP), dimension(:), pointer :: SpatialWeights - integer, dimension(:), optional, pointer :: iMask - real(DP),dimension(:), optional, pointer :: rMask - logical, intent(IN) :: UseFastMethod - integer, optional, intent(IN) :: comm - -! !OUTPUT PARAMETERS: - - type(AttrVect), intent(OUT) :: outAv - -! !REVISION HISTORY: -! 11Jun02 - J.W. Larson - initial version -! ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::MaskedSpatialAverageRAttrVDP_' - - type(AttrVect) :: integratedAv - type(List) :: nullIList - - integer :: i, ierr, length, iweight - logical :: mySumWeights - - ! Argument Validity Checks - - if(AttrVect_lsize(inAv) /= size(SpatialWeights)) then - ierr = AttrVect_lsize(inAv) - size(SpatialWeights) - write(stderr,'(3a,i8,a,i8)') myname_, & - ':: inAv / SpatialWeights array length mismatch: ', & - ' AttrVect_lsize(inAv) = ',AttrVect_lsize(inAv), & - ' size(SpatialWeights) = ',size(SpatialWeights) - call die(myname_) - endif - - if(present(iMask)) then ! make sure it is the right length - if(AttrVect_lsize(inAv) /= size(iMask)) then - ierr = AttrVect_lsize(inAv) - size(iMask) - write(stderr,'(3a,i8,a,i8)') myname_, & - ':: inAv / iMask array length mismatch: ', & - ' AttrVect_lsize(inAv) = ',AttrVect_lsize(inAv), & - ' size(iMask) = ',size(iMask) - call die(myname_) - endif - endif - - if(present(rMask)) then ! make sure it is the right length - if(AttrVect_lsize(inAv) /= size(rMask)) then - ierr = AttrVect_lsize(inAv) - size(rMask) - write(stderr,'(3a,i8,a,i8)') myname_, & - ':: inAv / rMask array length mismatch: ', & - ' AttrVect_lsize(inAv) = ',AttrVect_lsize(inAv), & - ' size(rMask) = ',size(rMask) - call die(myname_) - endif - endif - - ! Compute the masked weighted sum, including the sum of the - ! masked weights. - - if(present(comm)) then ! communicator handle present - - if(present(iMask)) then - - if(present(rMask)) then - call MaskedSpatialIntegralV(inAv, integratedAv, SpatialWeights, & - iMask, rMask, UseFastMethod, .TRUE., & - 'MaskedWeightsSum', comm) - else ! no rMask - call MaskedSpatialIntegralV(inAv, integratedAv, SpatialWeights, & - iMask=iMask, UseFastMethod=UseFastMethod, & - SumWeights=.TRUE., & - WeightSumTag='MaskedWeightsSum', & - comm=comm) - endif ! if(present(rMask))... - - else ! no iMask present... - - if(present(rMask)) then - call MaskedSpatialIntegralV(inAv, integratedAv, SpatialWeights, & - rMask=rMask, UseFastMethod=UseFastMethod, & - SumWeights=.TRUE., & - WeightSumTag='MaskedWeightsSum', & - comm=comm) - else ! neither rMask nor iMask present: - call MaskedSpatialIntegralV(inAv, integratedAv, SpatialWeights, & - UseFastMethod=UseFastMethod, & - SumWeights=.TRUE., & - WeightSumTag='MaskedWeightsSum', & - comm=comm) - endif ! if(present(rMask))... - - endif ! if(present(iMask))... - - else ! no communicator handle present - - if(present(iMask)) then - - if(present(rMask)) then - call MaskedSpatialIntegralV(inAv, integratedAv, SpatialWeights, & - iMask, rMask, UseFastMethod, .TRUE., & - 'MaskedWeightsSum') - else ! no rMask - call MaskedSpatialIntegralV(inAv, integratedAv, SpatialWeights, & - iMask=iMask, UseFastMethod=UseFastMethod, & - SumWeights=.TRUE., & - WeightSumTag='MaskedWeightsSum') - endif ! if(present(rMask))... - - else ! no iMask present... - - if(present(rMask)) then - call MaskedSpatialIntegralV(inAv, integratedAv, SpatialWeights, & - rMask=rMask, UseFastMethod=UseFastMethod, & - SumWeights=.TRUE., & - WeightSumTag='MaskedWeightsSum') - else ! neither rMask nor iMask present: - call MaskedSpatialIntegralV(inAv, integratedAv, SpatialWeights, & - UseFastMethod=UseFastMethod, & - SumWeights=.TRUE., & - WeightSumTag='MaskedWeightsSum') - endif ! if(present(rMask))... - - endif ! if(present(iMask))... - - endif ! if(present(comm))... - - ! At this point, integratedAv containes the masked spatial integrals - ! of the REAL attributes of inAv, along with the sum of the weights. - ! to compute the masked spatial average - - ! Check value of summed weights (to avoid division by zero): - - iweight = AttrVect_indexRA(integratedAv, 'MaskedWeightsSum') - if(integratedAv%rAttr(iweight, 1) == 0._FP) then - write(stderr,'(2a)') myname_, & - '::ERROR--Global sum of grid weights is zero.' - call die(myname_) - endif - - ! Initialize output AttrVect outAv: - - call List_nullify(nullIList) - call AttrVect_init(outAv, iList=nullIList, rList=inAv%rList, lsize=1) - call AttrVect_zero(outAv) - - ! Divide by global weight sum to compute spatial averages from - ! spatial integrals. - - do i=1,AttrVect_nRAttr(outAv) - outAv%rAttr(i,1) = integratedAv%rAttr(i,1) & - / integratedAv%rAttr(iweight,1) - end do - - ! Clean up temporary AttrVect: - - call AttrVect_clean(integratedAv) - - end subroutine MaskedSpatialAverageRAttrVDP_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: PairedSpatialIntegralRAttrVSP_ - Do two spatial integrals at once. -! -! !DESCRIPTION: -! This routine computes spatial integrals of the {\tt REAL} attributes -! of the {\tt REAL} attributes of the input {\tt AttrVect} arguments -! {\tt inAv1} and {\tt inAv2}, returning the integrals in the output -! {\tt AttrVect} arguments {\tt outAv1} and {\tt outAv2}, respectively . -! The integrals of {\tt inAv1} and {\tt inAv2} are computed using -! spatial weights stored in the input {\tt REAL} array arguments -! {\tt Weights1} and {\tt Weights2}, respectively. -! If {\tt SpatialIntegralRAttrV\_()} is invoked with the optional -! {\tt LOGICAL} input argument -! {\tt SumWeights} set as {\tt .TRUE.}, then the weights are also summed -! and stored in {\tt outAv1} and {\tt outAv2}, and can be referenced with -! the attribute tags defined by the arguments {\tt WeightName1} and -! {\tt WeightName2}, respectively. This paired integral is implicitly a -! distributed operation (the whole motivation for pairing the integrals is -! to reduce communication latency costs), and the Fortran MPI communicator -! handle is defined by the input {\tt INTEGER} argument {\tt comm}. The -! summation is an AllReduce operation, with all processes receiving the -! global sum. -! -! {\bf N.B.: } The local lengths of the {\tt AttrVect} argument {\tt inAv1} -! and the input {\tt REAL} array {\tt Weights1} must be equal. That is, there -! must be a one-to-one correspondence between the field point values stored -! in {\tt inAv1} and the point weights stored in {\tt Weights}. The same -! relationship must apply between {\tt inAv2} and {\tt Weights2}. -! -! {\bf N.B.: } If {\tt SpatialIntegralRAttrV\_()} is invoked with the -! optional {\tt LOGICAL} input argument {\tt SumWeights} set as {\tt .TRUE.}, -! then the value of {\tt WeightName1} must not conflict with any of the -! {\tt REAL} attribute tags in {\tt inAv1} and the value of {\tt WeightName2} -! must not conflict with any of the {\tt REAL} attribute tags in {\tt inAv2}. -! -! {\bf N.B.: } The output {\tt AttrVect} arguments {\tt outAv1} and -! {\tt outAv2} are allocated data structures. The user must deallocate them -! using the routine {\tt AttrVect\_clean()} when they are no longer needed. -! Failure to do so will result in a memory leak. -! -! !INTERFACE: - - subroutine PairedSpatialIntegralRAttrVSP_(inAv1, outAv1, Weights1, WeightName1, & - inAv2, outAv2, Weights2, WeightName2, & - SumWeights, comm) -! ! USES: - - use m_stdio - use m_die - use m_mpif90 - use m_realkinds, only : SP, FP - - use m_AttrVect, only : AttrVect - use m_AttrVect, only : AttrVect_lsize => lsize - use m_AttrVect, only : AttrVect_nRAttr => nRAttr - - use m_AttrVectReduce, only : AttrVect_LocalWeightedSumRAttr => & - LocalWeightedSumRAttr - - implicit none - -! !INPUT PARAMETERS: - - type(AttrVect), intent(IN) :: inAv1 - real(SP),dimension(:),pointer :: Weights1 - character(len=*), intent(IN) :: WeightName1 - type(AttrVect), intent(IN) :: inAv2 - real(SP),dimension(:),pointer :: Weights2 - character(len=*), intent(IN) :: WeightName2 - logical, optional, intent(IN) :: SumWeights - integer, intent(IN) :: comm - -! !OUTPUT PARAMETERS: - - type(AttrVect), intent(OUT) :: outAv1 - type(AttrVect), intent(OUT) :: outAv2 - -! !REVISION HISTORY: -! 10Jun02 - J.W. Larson - Initial version. -! -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::PairedSpatialIntegralRAttrVSP_' - - ! Argument Sanity Checks: - - integer :: ierr, length1, length2, PairedBufferLength - integer :: nRA1, nRA2 - logical :: mySumWeights - real(FP), dimension(:), pointer :: PairedBuffer, OutPairedBuffer - - ! Argument Validity Checks - - if(AttrVect_lsize(inAv1) /= size(Weights1)) then - ierr = AttrVect_lsize(inAv1) - size(Weights1) - write(stderr,'(3a,i8,a,i8)') myname_, & - ':: inAv1 / Weights1 length mismatch: ', & - ' AttrVect_lsize(inAv1) = ',AttrVect_lsize(inAv1), & - ' size(Weights1) = ',size(Weights1) - call die(myname_) - endif - - if(AttrVect_lsize(inAv2) /= size(Weights2)) then - ierr = AttrVect_lsize(inAv2) - size(Weights2) - write(stderr,'(3a,i8,a,i8)') myname_, & - ':: inAv2 / Weights2 length mismatch: ', & - ' AttrVect_lsize(inAv2) = ',AttrVect_lsize(inAv2), & - ' size(Weights2) = ',size(Weights2) - call die(myname_) - endif - - ! Are we summing the integration weights? - - if(present(SumWeights)) then - mySumWeights = SumWeights - else - mySumWeights = .FALSE. - endif - - ! Compute the local contributions to the two integrals: - - if(mySumWeights) then - call AttrVect_LocalWeightedSumRAttr(inAv1, outAv1, Weights1, WeightName1) - call AttrVect_LocalWeightedSumRAttr(inAv2, outAv2, Weights2, WeightName2) - else - call AttrVect_LocalWeightedSumRAttr(inAv1, outAv1, Weights1) - call AttrVect_LocalWeightedSumRAttr(inAv2, outAv2, Weights2) - endif - - ! Create the paired buffer for the Global Sum - - nRA1 = AttrVect_nRAttr(outAv1) - nRA2 = AttrVect_nRAttr(outAv2) - - PairedBufferLength = nRA1 + nRA2 - allocate(PairedBuffer(PairedBufferLength), OutPairedBuffer(PairedBufferLength), & - stat=ierr) - if(ierr /= 0) then - write(stderr,'(2a,i8)') myname_, & - ':: Fatal error--allocate(PairedBuffer...failed, ierr = ',ierr - call die(myname_) - endif - - ! Load the paired buffer - - PairedBuffer(1:nRA1) = outAv1%rAttr(1:nRA1,1) - PairedBuffer(nRA1+1:PairedBufferLength) = outAv2%rAttr(1:nRA2,1) - - ! Perform the global sum on the paired buffer - - call MPI_AllReduce(PairedBuffer, OutPairedBuffer, PairedBufferLength, & - MP_Type(PairedBuffer(1)), MP_SUM, comm, ierr) - if(ierr /= 0) then - write(stderr,'(2a,i8)') myname_, & - ':: Fatal Error--MPI_ALLREDUCE() failed with ierror = ',ierr - call MP_perr_die(myname_,'MPI_ALLREDUCE() failed',ierr) - endif - - ! Unload OutPairedBuffer into outAv1 and outAv2: - - outAv1%rAttr(1:nRA1,1) = OutPairedBuffer(1:nRA1) - outAv2%rAttr(1:nRA2,1) = OutPairedBuffer(nRA1+1:PairedBufferLength) - - ! Clean up allocated arrays: - - deallocate(PairedBuffer, OutPairedBuffer, stat=ierr) - if(ierr /= 0) then - write(stderr,'(2a,i8)') myname_, & - 'ERROR--deallocate(PairedBuffer,...) failed, ierr = ',ierr - call die(myname_) - endif - - end subroutine PairedSpatialIntegralRAttrVSP_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -! ------------------------------------------------------------------- -! -! !IROUTINE: PairedSpatialIntegralRAttrVDP_ - Two spatial integrals. -! -! !DESCRIPTION: -! Double precision interface version of PairedSpatialIntegralRAttrVSP_. -! -! !INTERFACE: - - subroutine PairedSpatialIntegralRAttrVDP_(inAv1, outAv1, Weights1, WeightName1, & - inAv2, outAv2, Weights2, WeightName2, & - SumWeights, comm) -! ! USES: - - use m_stdio - use m_die - use m_mpif90 - use m_realkinds, only : DP, FP - - use m_AttrVect, only : AttrVect - use m_AttrVect, only : AttrVect_lsize => lsize - use m_AttrVect, only : AttrVect_nRAttr => nRAttr - - use m_AttrVectReduce, only : AttrVect_LocalWeightedSumRAttr => & - LocalWeightedSumRAttr - - implicit none - -! !INPUT PARAMETERS: - - type(AttrVect), intent(IN) :: inAv1 - real(DP),dimension(:),pointer :: Weights1 - character(len=*), intent(IN) :: WeightName1 - type(AttrVect), intent(IN) :: inAv2 - real(DP),dimension(:),pointer :: Weights2 - character(len=*), intent(IN) :: WeightName2 - logical, optional, intent(IN) :: SumWeights - integer, intent(IN) :: comm - -! !OUTPUT PARAMETERS: - - type(AttrVect), intent(OUT) :: outAv1 - type(AttrVect), intent(OUT) :: outAv2 - -! !REVISION HISTORY: -! 10Jun02 - J.W. Larson - Initial version. -! -! ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::PairedSpatialIntegralRAttrVDP_' - - ! Argument Sanity Checks: - - integer :: ierr, length1, length2, PairedBufferLength - integer :: nRA1, nRA2 - logical :: mySumWeights - real(FP), dimension(:), pointer :: PairedBuffer, OutPairedBuffer - - ! Argument Validity Checks - - if(AttrVect_lsize(inAv1) /= size(Weights1)) then - ierr = AttrVect_lsize(inAv1) - size(Weights1) - write(stderr,'(3a,i8,a,i8)') myname_, & - ':: inAv1 / Weights1 length mismatch: ', & - ' AttrVect_lsize(inAv1) = ',AttrVect_lsize(inAv1), & - ' size(Weights1) = ',size(Weights1) - call die(myname_) - endif - - if(AttrVect_lsize(inAv2) /= size(Weights2)) then - ierr = AttrVect_lsize(inAv2) - size(Weights2) - write(stderr,'(3a,i8,a,i8)') myname_, & - ':: inAv2 / Weights2 length mismatch: ', & - ' AttrVect_lsize(inAv2) = ',AttrVect_lsize(inAv2), & - ' size(Weights2) = ',size(Weights2) - call die(myname_) - endif - - ! Are we summing the integration weights? - - if(present(SumWeights)) then - mySumWeights = SumWeights - else - mySumWeights = .FALSE. - endif - - ! Compute the local contributions to the two integrals: - - if(mySumWeights) then - call AttrVect_LocalWeightedSumRAttr(inAv1, outAv1, Weights1, WeightName1) - call AttrVect_LocalWeightedSumRAttr(inAv2, outAv2, Weights2, WeightName2) - else - call AttrVect_LocalWeightedSumRAttr(inAv1, outAv1, Weights1) - call AttrVect_LocalWeightedSumRAttr(inAv2, outAv2, Weights2) - endif - - ! Create the paired buffer for the Global Sum - - nRA1 = AttrVect_nRAttr(outAv1) - nRA2 = AttrVect_nRAttr(outAv2) - - PairedBufferLength = nRA1 + nRA2 - allocate(PairedBuffer(PairedBufferLength), OutPairedBuffer(PairedBufferLength), & - stat=ierr) - if(ierr /= 0) then - write(stderr,'(2a,i8)') myname_, & - ':: Fatal error--allocate(PairedBuffer...failed, ierr = ',ierr - call die(myname_) - endif - - ! Load the paired buffer - - PairedBuffer(1:nRA1) = outAv1%rAttr(1:nRA1,1) - PairedBuffer(nRA1+1:PairedBufferLength) = outAv2%rAttr(1:nRA2,1) - - ! Perform the global sum on the paired buffer - - call MPI_AllReduce(PairedBuffer, OutPairedBuffer, PairedBufferLength, & - MP_Type(PairedBuffer(1)), MP_SUM, comm, ierr) - if(ierr /= 0) then - write(stderr,'(2a,i8)') myname_, & - ':: Fatal Error--MPI_ALLREDUCE() failed with ierror = ',ierr - call MP_perr_die(myname_,'MPI_ALLREDUCE() failed',ierr) - endif - - ! Unload OutPairedBuffer into outAv1 and outAv2: - - outAv1%rAttr(1:nRA1,1) = OutPairedBuffer(1:nRA1) - outAv2%rAttr(1:nRA2,1) = OutPairedBuffer(nRA1+1:PairedBufferLength) - - ! Clean up allocated arrays: - - deallocate(PairedBuffer, OutPairedBuffer, stat=ierr) - if(ierr /= 0) then - write(stderr,'(2a,i8)') myname_, & - 'ERROR--deallocate(PairedBuffer,...) failed, ierr = ',ierr - call die(myname_) - endif - - end subroutine PairedSpatialIntegralRAttrVDP_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: PairedSpatialAverageRAttrVSP_ - Do two spatial averages at once. -! -! !DESCRIPTION: -! This routine computes spatial averages of the {\tt REAL} attributes -! of the {\tt REAL} attributes of the input {\tt AttrVect} arguments -! {\tt inAv1} and {\tt inAv2}, returning the integrals in the output -! {\tt AttrVect} arguments {\tt outAv1} and {\tt outAv2}, respectively . -! The averages of {\tt inAv1} and {\tt inAv2} are computed using -! spatial weights stored in the input {\tt REAL} array arguments -! {\tt Weights1} and {\tt Weights2}, respectively. This paired average -! is implicitly a -! distributed operation (the whole motivation for pairing the integrals is -! to reduce communication latency costs), and the Fortran MPI communicator -! handle is defined by the input {\tt INTEGER} argument {\tt comm}. The -! summation is an AllReduce operation, with all processes receiving the -! global sum. -! -! {\bf N.B.: } The local lengths of the {\tt AttrVect} argument {\tt inAv1} -! and the array {\tt Weights} must be equal. That is, there must be a -! one-to-one correspondence between the field point values stored -! in {\tt inAv1} and the spatial weights stored in {\tt Weights} -! -! {\bf N.B.: } The output {\tt AttrVect} arguments {\tt outAv1} and -! {\tt outAv2} are allocated data structures. The user must deallocate them -! using the routine {\tt AttrVect\_clean()} when they are no longer needed. -! Failure to do so will result in a memory leak. -! -! !INTERFACE: - - subroutine PairedSpatialAverageRAttrVSP_(inAv1, outAv1, Weights1, inAv2, & - outAv2, Weights2, comm) -! ! USES: - - use m_stdio - use m_die - use m_mpif90 - use m_realkinds, only : SP, FP - - use m_AttrVect, only : AttrVect - use m_AttrVect, only : AttrVect_init => init - use m_AttrVect, only : AttrVect_zero => zero - use m_AttrVect, only : AttrVect_clean => clean - use m_AttrVect, only : AttrVect_lsize => lsize - use m_AttrVect, only : AttrVect_nRAttr => nRAttr - use m_AttrVect, only : AttrVect_indexRA => indexRA - - use m_AttrVectReduce, only : AttrVect_LocalWeightedSumRAttr => & - LocalWeightedSumRAttr - - use m_List, only : List - use m_List, only : List_nullify => nullify - - implicit none - -! !INPUT PARAMETERS: - - type(AttrVect), intent(IN) :: inAv1 - real(SP),dimension(:),pointer :: Weights1 - type(AttrVect), intent(IN) :: inAv2 - real(SP),dimension(:),pointer :: Weights2 - integer, intent(IN) :: comm - -! !OUTPUT PARAMETERS: - - type(AttrVect), intent(OUT) :: outAv1 - type(AttrVect), intent(OUT) :: outAv2 - -! !REVISION HISTORY: -! 09May02 - J.W. Larson - Initial version. -! -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::PairedSpatialAverageRAttrVSP_' - - type(AttrVect) :: integratedAv1, integratedAv2 - type(List) :: nullIList - integer :: i, ierr, iweight1, iweight2 - - ! weight tags used to keep track of spatial weight sums - character*8, parameter :: WeightName1='WeightSum1' - character*8, parameter :: WeightName2='WeightSum2' - - ! Compute the paired spatial integral, including spatial weights: - - call PairedSpatialIntegralsV(inAv1, integratedAv1, Weights1, WeightName1, & - inAv2, integratedAv2, Weights2, WeightName2, & - .TRUE., comm) - - ! Check value of summed weights (to avoid division by zero): - - iweight1 = AttrVect_indexRA(integratedAv1, WeightName1) - if(integratedAv1%rAttr(iweight1, 1) == 0._FP) then - write(stderr,'(2a)') myname_, & - '::ERROR--Global sum of grid weights in first integral is zero.' - call die(myname_) - endif - - iweight2 = AttrVect_indexRA(integratedAv2, WeightName2) - if(integratedAv2%rAttr(iweight2, 1) == 0._FP) then - write(stderr,'(2a)') myname_, & - '::ERROR--Global sum of grid weights in second integral is zero.' - call die(myname_) - endif - - ! Initialize output AttrVects outAv1 and outAv2: - - call List_nullify(nullIList) - call AttrVect_init(outAv1, iList=nullIList, rList=inAv1%rList, lsize=1) - call AttrVect_zero(outAv1) - call AttrVect_init(outAv2, iList=nullIList, rList=inAv2%rList, lsize=1) - call AttrVect_zero(outAv2) - - ! Divide by global weight sum to compute spatial averages from - ! spatial integrals. - - do i=1,AttrVect_nRAttr(outAv1) - outAv1%rAttr(i,1) = integratedAv1%rAttr(i,1) & - / integratedAv1%rAttr(iweight1,1) - end do - - do i=1,AttrVect_nRAttr(outAv2) - outAv2%rAttr(i,1) = integratedAv2%rAttr(i,1) & - / integratedAv2%rAttr(iweight2,1) - end do - - ! Clean up temporary AttrVects: - - call AttrVect_clean(integratedAv1) - call AttrVect_clean(integratedAv2) - - end subroutine PairedSpatialAverageRAttrVSP_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -! ---------------------------------------------------------------------- -! -! !IROUTINE: PairedSpatialAverageRAttrVDP_ - Two spatial averages. -! -! !DESCRIPTION: -! Double precision version of PairedSpatialAverageRAttrVSP_ -! -! !INTERFACE: - - subroutine PairedSpatialAverageRAttrVDP_(inAv1, outAv1, Weights1, inAv2, & - outAv2, Weights2, comm) -! ! USES: - - use m_stdio - use m_die - use m_mpif90 - use m_realkinds, only : DP, FP - - use m_AttrVect, only : AttrVect - use m_AttrVect, only : AttrVect_init => init - use m_AttrVect, only : AttrVect_zero => zero - use m_AttrVect, only : AttrVect_clean => clean - use m_AttrVect, only : AttrVect_lsize => lsize - use m_AttrVect, only : AttrVect_nRAttr => nRAttr - use m_AttrVect, only : AttrVect_indexRA => indexRA - - use m_AttrVectReduce, only : AttrVect_LocalWeightedSumRAttr => & - LocalWeightedSumRAttr - - use m_List, only : List - use m_List, only : List_nullify => nullify - - implicit none - -! !INPUT PARAMETERS: - - type(AttrVect), intent(IN) :: inAv1 - real(DP),dimension(:),pointer :: Weights1 - type(AttrVect), intent(IN) :: inAv2 - real(DP),dimension(:),pointer :: Weights2 - integer, intent(IN) :: comm - -! !OUTPUT PARAMETERS: - - type(AttrVect), intent(OUT) :: outAv1 - type(AttrVect), intent(OUT) :: outAv2 - -! !REVISION HISTORY: -! 09May02 - J.W. Larson - Initial version. -! -! ______________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::PairedSpatialAverageRAttrVDP_' - - type(AttrVect) :: integratedAv1, integratedAv2 - type(List) :: nullIList - integer :: i, ierr, iweight1, iweight2 - - ! weight tags used to keep track of spatial weight sums - character*8, parameter :: WeightName1='WeightSum1' - character*8, parameter :: WeightName2='WeightSum2' - - ! Compute the paired spatial integral, including spatial weights: - - call PairedSpatialIntegralsV(inAv1, integratedAv1, Weights1, WeightName1, & - inAv2, integratedAv2, Weights2, WeightName2, & - .TRUE., comm) - - ! Check value of summed weights (to avoid division by zero): - - iweight1 = AttrVect_indexRA(integratedAv1, WeightName1) - if(integratedAv1%rAttr(iweight1, 1) == 0._FP) then - write(stderr,'(2a)') myname_, & - '::ERROR--Global sum of grid weights in first integral is zero.' - call die(myname_) - endif - - iweight2 = AttrVect_indexRA(integratedAv2, WeightName2) - if(integratedAv2%rAttr(iweight2, 1) == 0._FP) then - write(stderr,'(2a)') myname_, & - '::ERROR--Global sum of grid weights in second integral is zero.' - call die(myname_) - endif - - ! Initialize output AttrVects outAv1 and outAv2: - - call List_nullify(nullIList) - call AttrVect_init(outAv1, iList=nullIList, rList=inAv1%rList, lsize=1) - call AttrVect_zero(outAv1) - call AttrVect_init(outAv2, iList=nullIList, rList=inAv2%rList, lsize=1) - call AttrVect_zero(outAv2) - - ! Divide by global weight sum to compute spatial averages from - ! spatial integrals. - - do i=1,AttrVect_nRAttr(outAv1) - outAv1%rAttr(i,1) = integratedAv1%rAttr(i,1) & - / integratedAv1%rAttr(iweight1,1) - end do - - do i=1,AttrVect_nRAttr(outAv2) - outAv2%rAttr(i,1) = integratedAv2%rAttr(i,1) & - / integratedAv2%rAttr(iweight2,1) - end do - - ! Clean up temporary AttrVects: - - call AttrVect_clean(integratedAv1) - call AttrVect_clean(integratedAv2) - - end subroutine PairedSpatialAverageRAttrVDP_ - - end module m_SpatialIntegralV diff --git a/cesm/models/utils/mct/mct/m_Transfer.F90 b/cesm/models/utils/mct/mct/m_Transfer.F90 deleted file mode 100644 index 3ea8236..0000000 --- a/cesm/models/utils/mct/mct/m_Transfer.F90 +++ /dev/null @@ -1,818 +0,0 @@ -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!----------------------------------------------------------------------- -! CVS $Id$ -! CVS $Name$ -!BOP ------------------------------------------------------------------- -! -! !MODULE: m_Transfer - Routines for the MxN transfer of Attribute Vectors -! -! !DESCRIPTION: -! This module provides routines for doing MxN transfer of data in an -! Attribute Vector between two components on separate sets of MPI processes. -! Uses the Router datatype. -! -! !SEE ALSO: -! m_Rearranger - -! !INTERFACE: - - module m_Transfer - -! !USES: - use m_MCTWorld, only : MCTWorld - use m_MCTWorld, only : ThisMCTWorld - use m_AttrVect, only : AttrVect - use m_AttrVect, only : nIAttr,nRAttr - use m_AttrVect, only : Permute, Unpermute - use m_AttrVect, only : AttrVect_init => init - use m_AttrVect, only : AttrVect_copy => copy - use m_AttrVect, only : AttrVect_clean => clean - use m_AttrVect, only : lsize - use m_Router, only : Router - - use m_mpif90 - use m_die - use m_stdio - - implicit none - - private ! except - -! !PUBLIC MEMBER FUNCTIONS: - - public :: isend - public :: send - public :: waitsend - public :: irecv - public :: recv - public :: waitrecv - - - interface isend ; module procedure isend_ ; end interface - interface send ; module procedure send_ ; end interface - interface waitsend ; module procedure waitsend_ ; end interface - interface irecv ; module procedure irecv_ ; end interface - interface recv ; module procedure recv_ ; end interface - interface waitrecv ; module procedure waitrecv_ ; end interface - -! !DEFINED PARAMETERS: - - integer,parameter :: DefaultTag = 600 - -! !REVISION HISTORY: -! 08Nov02 - R. Jacob - make new module by combining -! MCT_Send, MCT_Recv and MCT_Recvsum -! 11Nov02 - R. Jacob - Remove MCT_Recvsum and use -! optional argument in recv_ to do the same thing. -! 23Jul03 - R. Jacob - Move buffers for data and -! MPI_Reqest and MPI_Status arrays to Router. Use them. -! 24Jul03 - R. Jacob - Split send_ into isend_ and -! waitsend_. Redefine send_. -! 22Jan08 - R. Jacob - Handle unordered GSMaps -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname='MCT::m_Transfer' - - contains - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: isend_ - Distributed non-blocking send of an Attribute Vector -! -! !DESCRIPTION: -! Send the the data in the {\tt AttrVect} {\tt aV} to the -! component specified in the {\tt Router} {\tt Rout}. An error will -! result if the size of the attribute vector does not match the size -! parameter stored in the {\tt Router}. -! -! Requires a corresponding {\tt recv\_} or {\tt irecv\_} to be called on the other component. -! -! The optional argument {\tt Tag} can be used to set the tag value used in -! the data transfer. DefaultTag will be used otherwise. {\tt Tag} must be -! the same in the matching {\tt recv\_} or {\tt irecv\_}. -! -! {\bf N.B.:} The {\tt AttrVect} argument in the corresponding -! {\tt recv\_} call is assumed to have exactly the same attributes -! in exactly the same order as {\tt aV}. -! -! !INTERFACE: - - subroutine isend_(aVin, Rout, Tag) - -! -! !USES: -! - implicit none - -! !INPUT PARAMETERS: -! - - Type(AttrVect),target,intent(in) :: aVin - Type(Router), intent(inout) :: Rout - integer,optional, intent(in) :: Tag - -! !REVISION HISTORY: -! 07Feb01 - R. Jacob - initial prototype -! 08Feb01 - R. Jacob - First working code -! 18May01 - R. Jacob - use MP_Type to determine type in mpi_send -! 07Jun01 - R. Jacob - remove logic to check "direction" of Router. -! remove references to ThisMCTWorld%mylrank -! 03Aug01 - E. Ong - Explicitly specify the starting address in mpi_send. -! 15Feb02 - R. Jacob - Use MCT_comm -! 26Mar02 - E. Ong - Apply faster copy order -! 26Sep02 - R. Jacob - Check Av against Router lAvsize -! 05Nov02 - R. Jacob - Remove iList, rList arguments. -! 08Nov02 - R. Jacob - MCT_Send is now send_ in m_Transfer -! 11Nov02 - R. Jacob - Use DefaultTag and add optional Tag argument -! 25Jul03 - R. Jacob - Split into isend_ and waitsend_ -! 22Jan08 - R. Jacob - Handle unordered GSMaps by permuting before send. -! remove special case for sending one segment directly from Av which probably -! wasn't safe. -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::isend_' - integer :: numi,numr,i,j,k,ier - integer :: mycomp,othercomp - integer :: AttrIndex,VectIndex,seg_start,seg_end - integer :: proc,nseg,mytag - integer :: mp_Type_rp1 - logical :: unordered - type(AttrVect),pointer :: Av - type(AttrVect),target :: Avtmp - -!-------------------------------------------------------- - -! Return if no one to send to - if(Rout%nprocs .eq. 0 ) RETURN - -! set up Av to send from - unordered = associated(Rout%permarr) - if (unordered) then - call AttrVect_init(Avtmp,Avin,lsize(Avin)) - call AttrVect_copy(Avin,aVtmp) - call Permute(aVtmp,Rout%permarr) - Av => Avtmp - else - Av => Avin - endif - -!check Av size against Router -! - if(lsize(aV) /= Rout%lAvsize) then - write(stderr,'(2a)') myname_, & - ' MCTERROR: AV size not appropriate for this Router...exiting' - call die(myname_) - endif - -! get ids of components involved in this communication - mycomp=Rout%comp1id - othercomp=Rout%comp2id - - -! find total number of real and integer vectors -! for now, assume we are sending all of them - Rout%numiatt = nIAttr(aV) - Rout%numratt = nRAttr(aV) - numi = Rout%numiatt - numr = Rout%numratt - -!!!!!!!!!!!!!! IF SENDING INTEGER DATA - if(numi .ge. 1) then - -! allocate buffers to hold all outgoing data - do proc=1,Rout%nprocs - allocate(Rout%ip1(proc)%pi(Rout%locsize(proc)*numi),stat=ier) - if(ier/=0) call die(myname_,'allocate(Rout%ip1%pi)',ier) - enddo - - endif - -!!!!!!!!!!!!!! IF SENDING REAL DATA - if(numr .ge. 1) then - -! allocate buffers to hold all outgoing data - do proc=1,Rout%nprocs - allocate(Rout%rp1(proc)%pr(Rout%locsize(proc)*numr),stat=ier) - if(ier/=0) call die(myname_,'allocate(Rout%rp1%pr)',ier) - enddo - - mp_Type_rp1=MP_Type(Rout%rp1(1)%pr(1)) - - endif - - - ! Load data going to each processor - do proc = 1,Rout%nprocs - - j=1 - k=1 - - ! load the correct pieces of the integer and real vectors - ! if Rout%num_segs(proc)=1, then this will do one loop - do nseg = 1,Rout%num_segs(proc) - seg_start = Rout%seg_starts(proc,nseg) - seg_end = seg_start + Rout%seg_lengths(proc,nseg)-1 - do VectIndex = seg_start,seg_end - do AttrIndex = 1,numi - Rout%ip1(proc)%pi(j) = aV%iAttr(AttrIndex,VectIndex) - j=j+1 - enddo - do AttrIndex = 1,numr - Rout%rp1(proc)%pr(k) = aV%rAttr(AttrIndex,VectIndex) - k=k+1 - enddo - enddo - enddo - - - - ! Send the integer data - if(numi .ge. 1) then - - ! set tag - mytag = DefaultTag - if(present(Tag)) mytag=Tag - - - call MPI_ISEND(Rout%ip1(proc)%pi(1), & - Rout%locsize(proc)*numi,MP_INTEGER,Rout%pe_list(proc), & - mytag,ThisMCTWorld%MCT_comm,Rout%ireqs(proc),ier) - - if(ier /= 0) call MP_perr_die(myname_,'MPI_ISEND(ints)',ier) - - endif - - ! Send the real data - if(numr .ge. 1) then - - ! set tag - mytag = DefaultTag + 1 - if(present(Tag)) mytag=Tag +1 - - - call MPI_ISEND(Rout%rp1(proc)%pr(1), & - Rout%locsize(proc)*numr,mp_Type_rp1,Rout%pe_list(proc), & - mytag,ThisMCTWorld%MCT_comm,Rout%rreqs(proc),ier) - - - if(ier /= 0) call MP_perr_die(myname_,'MPI_ISEND(reals)',ier) - - endif - - enddo - - if (unordered) then - call AttrVect_clean(aVtmp) - nullify(aV) - else - nullify(aV) - endif - -end subroutine isend_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: waitsend_ - Wait for a distributed non-blocking send to complete -! -! !DESCRIPTION: -! Wait for the data being sent with the {\tt Router} {\tt Rout} to complete. -! -! !INTERFACE: - - subroutine waitsend_(Rout) - -! -! !USES: -! - implicit none - -! !INPUT PARAMETERS: -! - Type(Router), intent(inout) :: Rout - -! !REVISION HISTORY: -! 24Jul03 - R. Jacob - First working version is -! the wait part of original send_ -!EOP ___________________________________________________________________ - character(len=*),parameter :: myname_=myname//'::waitsend_' - integer :: proc,ier - -! Return if nothing to wait for - if(Rout%nprocs .eq. 0 ) RETURN - - ! wait for all sends to complete - if(Rout%numiatt .ge. 1) then - - call MPI_WAITALL(Rout%nprocs,Rout%ireqs,Rout%istatus,ier) - if(ier /= 0) call MP_perr_die(myname_,'MPI_WAITALL(ints)',ier) - - do proc=1,Rout%nprocs - deallocate(Rout%ip1(proc)%pi,stat=ier) - if(ier/=0) call die(myname_,'deallocate(ip1%pi)',ier) - enddo - - endif - - if(Rout%numratt .ge. 1) then - - call MPI_WAITALL(Rout%nprocs,Rout%rreqs,Rout%rstatus,ier) - if(ier /= 0) call MP_perr_die(myname_,'MPI_WAITALL(reals)',ier) - - do proc=1,Rout%nprocs - deallocate(Rout%rp1(proc)%pr,stat=ier) - if(ier/=0) call die(myname_,'deallocate(rp1%pi)',ier) - enddo - - endif - - -end subroutine waitsend_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: send_ - Distributed blocking send of an Attribute Vector -! -! !DESCRIPTION: -! Send the the data in the {\tt AttrVect} {\tt aV} to the -! component specified in the {\tt Router} {\tt Rout}. An error will -! result if the size of the attribute vector does not match the size -! parameter stored in the {\tt Router}. -! -! Requires a corresponding {\tt recv\_} or {\tt irecv\_} to be called on the other -! component. -! -! The optional argument {\tt Tag} can be used to set the tag value used in -! the data transfer. DefaultTag will be used otherwise. {\tt Tag} must be -! the same in the matching {\tt recv\_} or {\tt irecv\_}. -! -! {\bf N.B.:} The {\tt AttrVect} argument in the corresponding -! {\tt recv} call is assumed to have exactly the same attributes -! in exactly the same order as {\tt aV}. -! -! !INTERFACE: - - subroutine send_(aV, Rout, Tag) - -! -! !USES: -! - implicit none - -! !INPUT PARAMETERS: -! - - Type(AttrVect), intent(in) :: aV - Type(Router), intent(inout) :: Rout - integer,optional, intent(in) :: Tag - -! !REVISION HISTORY: -! 24Jul03 - R. Jacob - New version uses isend and waitsend -!EOP ___________________________________________________________________ - character(len=*),parameter :: myname_=myname//'::send_' - - call isend_(aV,Rout,Tag) - - call waitsend_(Rout) - -end subroutine send_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: irecv_ - Distributed receive of an Attribute Vector -! -! !DESCRIPTION: -! Recieve into the {\tt AttrVect} {\tt aV} the data coming from the -! component specified in the {\tt Router} {\tt Rout}. An error will -! result if the size of the attribute vector does not match the size -! parameter stored in the {\tt Router}. -! -! Requires a corresponding {\tt send\_} or {\tt isend\_} to be called -! on the other component. -! -! The optional argument {\tt Tag} can be used to set the tag value used in -! the data transfer. DefaultTag will be used otherwise. {\tt Tag} must be -! the same in the matching {\tt send\_} or {\tt isend\_}. -! -! If data for a grid point is coming from more than one process, {\tt recv\_} -! will overwrite the duplicate values leaving the last received value -! in the output aV. If the optional argument {\tt Sum} is invoked, the output -! will contain the sum of any duplicate values received for the same grid point. -! -! Will return as soon as MPI\_IRECV's are posted. Call {\tt waitrecv\_} to -! complete the receive operation. -! -! {\bf N.B.:} The {\tt AttrVect} argument in the corresponding -! {\tt send\_} call is assumed to have exactly the same attributes -! in exactly the same order as {\tt aV}. -! -! !INTERFACE: - - subroutine irecv_(aV, Rout, Tag, Sum) -! -! !USES: -! - implicit none - -! !INPUT/OUTPUT PARAMETERS: -! - Type(AttrVect), intent(inout) :: aV - -! !INPUT PARAMETERS: -! - Type(Router), intent(inout) :: Rout - integer,optional, intent(in) :: Tag - logical,optional, intent(in) :: Sum - -! !REVISION HISTORY: -! 07Feb01 - R. Jacob - initial prototype -! 07Jun01 - R. Jacob - remove logic to -! check "direction" of Router. remove references -! to ThisMCTWorld%mylrank -! 03Aug01 - E.T. Ong - explicity specify starting -! address in MPI_RECV -! 27Nov01 - E.T. Ong - deallocated to prevent -! memory leaks -! 15Feb02 - R. Jacob - Use MCT_comm -! 26Mar02 - E. Ong - Apply faster copy order. -! 26Sep02 - R. Jacob - Check Av against Router lAvsize -! 08Nov02 - R. Jacob - MCT_Recv is now recv_ in m_Transfer -! 11Nov02 - R. Jacob - Add optional Sum argument to -! tell recv_ to sum data for the same point received from multiple -! processors. Replaces recvsum_ which had replaced MCT_Recvsum. -! Use DefaultTag and add optional Tag argument -! 25Jul03 - R. Jacob - break into irecv_ and waitrecv_ -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::irecv_' - integer :: numi,numr,i,j,k,ier - integer :: mycomp,othercomp - integer :: seg_start,seg_end - integer :: proc,numprocs,nseg,mytag - integer :: mp_Type_rp1 - logical :: DoSum - -!-------------------------------------------------------- - -! Return if no one to receive from - if(Rout%nprocs .eq. 0 ) RETURN - -!check Av size against Router -! - if(lsize(aV) /= Rout%lAvsize) then - write(stderr,'(2a)') myname_, & - ' MCTERROR: AV size not appropriate for this Router...exiting' - call die(myname_) - endif - - DoSum = .false. - if(present(Sum)) DoSum=Sum - - - mycomp=Rout%comp1id - othercomp=Rout%comp2id - -! find total number of real and integer vectors -! for now, assume we are receiving all of them - Rout%numiatt = nIAttr(aV) - Rout%numratt = nRAttr(aV) - numi = Rout%numiatt - numr = Rout%numratt - -!!!!!!!!!!!!!! IF RECEVING INTEGER DATA - if(numi .ge. 1) then - -! allocate buffers to hold all incoming data - do proc=1,Rout%nprocs - allocate(Rout%ip1(proc)%pi(Rout%locsize(proc)*numi),stat=ier) - if(ier/=0) call die(myname_,'allocate(Rout%ip1%pi)',ier) - enddo - - endif - -!!!!!!!!!!!!!! IF RECEIVING REAL DATA - if(numr .ge. 1) then - -! allocate buffers to hold all incoming data - do proc=1,Rout%nprocs - allocate(Rout%rp1(proc)%pr(Rout%locsize(proc)*numr),stat=ier) - if(ier/=0) call die(myname_,'allocate(Rout%rp1%pr)',ier) - enddo - - mp_Type_rp1=MP_Type(Rout%rp1(1)%pr(1)) - - endif - - ! Post all MPI_IRECV - do proc=1,Rout%nprocs - - ! receive the integer data - if(numi .ge. 1) then - - ! set tag - mytag = DefaultTag - if(present(Tag)) mytag=Tag - - if( Rout%num_segs(proc) > 1 .or. DoSum ) then - - call MPI_IRECV(Rout%ip1(proc)%pi(1), & - Rout%locsize(proc)*numi,MP_INTEGER,Rout%pe_list(proc), & - mytag,ThisMCTWorld%MCT_comm,Rout%ireqs(proc),ier) - - else - - call MPI_IRECV(aV%iAttr(1,Rout%seg_starts(proc,1)), & - Rout%locsize(proc)*numi,MP_INTEGER,Rout%pe_list(proc), & - mytag,ThisMCTWorld%MCT_comm,Rout%ireqs(proc),ier) - - endif - - if(ier /= 0) call MP_perr_die(myname_,'MPI_IRECV(ints)',ier) - - endif - - ! receive the real data - if(numr .ge. 1) then - - ! corresponding tag logic must be in send_ - mytag = DefaultTag + 1 - if(present(Tag)) mytag=Tag +1 - - if( Rout%num_segs(proc) > 1 .or. DoSum ) then - - call MPI_IRECV(Rout%rp1(proc)%pr(1), & - Rout%locsize(proc)*numr,mp_Type_rp1,Rout%pe_list(proc), & - mytag,ThisMCTWorld%MCT_comm,Rout%rreqs(proc),ier) - - else - - call MPI_IRECV(aV%rAttr(1,Rout%seg_starts(proc,1)), & - Rout%locsize(proc)*numr,mp_Type_rp1,Rout%pe_list(proc), & - mytag,ThisMCTWorld%MCT_comm,Rout%rreqs(proc),ier) - - endif - - if(ier /= 0) call MP_perr_die(myname_,'MPI_IRECV(reals)',ier) - - endif - - enddo - -end subroutine irecv_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: waitrecv_ - Wait for a distributed non-blocking recv to complete -! -! !DESCRIPTION: -! Wait for the data being received with the {\tt Router} {\tt Rout} to complete. -! When done, copy the data into the {\tt AttrVect} {\tt aV}. -! -! !INTERFACE: - - subroutine waitrecv_(aV, Rout, Sum) - -! -! !USES: -! - implicit none - -! !INPUT/OUTPUT PARAMETERS: -! - Type(AttrVect), intent(inout) :: aV - Type(Router), intent(inout) :: Rout - -! !INPUT PARAMETERS: -! - logical,optional, intent(in) :: Sum - - -! !REVISION HISTORY: -! 25Jul03 - R. Jacob - First working version is the wait -! and copy parts from old recv_. -! 25Jan08 - R. Jacob - Handle unordered GSMaps by -! applying permutation to received array. -!EOP ___________________________________________________________________ - character(len=*),parameter :: myname_=myname//'::waitrecv_' - integer :: proc,ier,j,k,nseg - integer :: AttrIndex,VectIndex,seg_start,seg_end - logical :: DoSum - logical :: unordered - -! Return if nothing to wait for - if(Rout%nprocs .eq. 0 ) RETURN - -!check Av size against Router -! - if(lsize(aV) /= Rout%lAvsize) then - write(stderr,'(2a)') myname_, & - ' MCTERROR: AV size not appropriate for this Router...exiting' - call die(myname_) - endif - - unordered = associated(Rout%permarr) - - DoSum = .false. - if(present(Sum)) DoSum=Sum - - ! wait for all recieves to complete - if(Rout%numiatt .ge. 1) then - - call MPI_WAITALL(Rout%nprocs,Rout%ireqs,Rout%istatus,ier) - if(ier /= 0) call MP_perr_die(myname_,'MPI_WAITALL(ints)',ier) - - endif - - if(Rout%numratt .ge. 1) then - - call MPI_WAITALL(Rout%nprocs,Rout%rreqs,Rout%rstatus,ier) - if(ier /= 0) call MP_perr_die(myname_,'MPI_WAITALL(reals)',ier) - - endif - - ! Load data which came from each processor - do proc=1,Rout%nprocs - - if( (Rout%num_segs(proc) > 1) .or. DoSum ) then - - j=1 - k=1 - - if(DoSum) then - ! sum the correct pieces of the integer and real vectors - do nseg = 1,Rout%num_segs(proc) - seg_start = Rout%seg_starts(proc,nseg) - seg_end = seg_start + Rout%seg_lengths(proc,nseg)-1 - do VectIndex = seg_start,seg_end - do AttrIndex = 1,Rout%numiatt - aV%iAttr(AttrIndex,VectIndex)= & - aV%iAttr(AttrIndex,VectIndex)+Rout%ip1(proc)%pi(j) - j=j+1 - enddo - do AttrIndex = 1,Rout%numratt - aV%rAttr(AttrIndex,VectIndex)= & - aV%rAttr(AttrIndex,VectIndex)+Rout%rp1(proc)%pr(k) - k=k+1 - enddo - enddo - enddo - else - ! load the correct pieces of the integer and real vectors - do nseg = 1,Rout%num_segs(proc) - seg_start = Rout%seg_starts(proc,nseg) - seg_end = seg_start + Rout%seg_lengths(proc,nseg)-1 - do VectIndex = seg_start,seg_end - do AttrIndex = 1,Rout%numiatt - aV%iAttr(AttrIndex,VectIndex)=Rout%ip1(proc)%pi(j) - j=j+1 - enddo - do AttrIndex = 1,Rout%numratt - aV%rAttr(AttrIndex,VectIndex)=Rout%rp1(proc)%pr(k) - k=k+1 - enddo - enddo - enddo - endif - - endif - - enddo - -!........................WAITANY METHOD................................ -! -!....NOTE: Make status argument a 1-dimensional array -! ! Load data which came from each processor -! do numprocs = 1,Rout%nprocs -! ! Load the integer data -! if(Rout%numiatt .ge. 1) then -! call MPI_WAITANY(Rout%nprocs,Rout%ireqs,proc,Rout%istatus,ier) -! if(ier /= 0) call MP_perr_die(myname_,'MPI_WAITANY(ints)',ier) -! j=1 -! ! load the correct pieces of the integer vectors -! do nseg = 1,Rout%num_segs(proc) -! seg_start = Rout%seg_starts(proc,nseg) -! seg_end = seg_start + Rout%seg_lengths(proc,nseg)-1 -! do VectIndex = seg_start,seg_end -! do AttrIndex = 1,Rout%numiatt -! aV%iAttr(AttrIndex,VectIndex)=Rout%ip1(proc)%pi(j) -! j=j+1 -! enddo -! enddo -! enddo -! endif -! ! Load the real data -! if(numr .ge. 1) then -! call MPI_WAITANY(Rout%nprocs,Rout%rreqs,proc,Rout%rstatus,ier) -! if(ier /= 0) call MP_perr_die(myname_,'MPI_WAITANY(reals)',ier) -! k=1 -! ! load the correct pieces of the real vectors -! do nseg = 1,Rout%num_segs(proc) -! seg_start = Rout%seg_starts(proc,nseg) -! seg_end = seg_start + Rout%seg_lengths(proc,nseg)-1 -! do VectIndex = seg_start,seg_end -! do AttrIndex = 1,numr -! aV%rAttr(AttrIndex,VectIndex)=Rout%rp1(proc)%pr(k) -! k=k+1 -! enddo -! enddo -! enddo -! endif -! enddo -!........................................................................ - - ! Deallocate all structures - if(Rout%numiatt .ge. 1) then - - ! Deallocate the receive buffers - do proc=1,Rout%nprocs - deallocate(Rout%ip1(proc)%pi,stat=ier) - if(ier/=0) call die(myname_,'deallocate(Rout%ip1%pi)',ier) - enddo - - endif - - if(Rout%numratt .ge. 1) then - - ! Deallocate the receive buffers - do proc=1,Rout%nprocs - deallocate(Rout%rp1(proc)%pr,stat=ier) - if(ier/=0) call die(myname_,'deallocate(Rout%rp1%pr)',ier) - enddo - - endif - - if (unordered) call Unpermute(aV,Rout%permarr) - -end subroutine waitrecv_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: recv_ - Distributed receive of an Attribute Vector -! -! !DESCRIPTION: -! Recieve into the {\tt AttrVect} {\tt aV} the data coming from the -! component specified in the {\tt Router} {\tt Rout}. An error will -! result if the size of the attribute vector does not match the size -! parameter stored in the {\tt Router}. -! -! Requires a corresponding {\tt send\_} or {\tt isend\_}to be called -! on the other component. -! -! The optional argument {\tt Tag} can be used to set the tag value used in -! the data transfer. DefaultTag will be used otherwise. {\tt Tag} must be -! the same in the matching {\tt send\_} -! -! If data for a grid point is coming from more than one process, {\tt recv\_} -! will overwrite the duplicate values leaving the last received value -! in the output aV. If the optional argument {\tt Sum} is invoked, the output -! will contain the sum of any duplicate values received for the same grid point. -! -! Will not return until all data has been received. -! -! {\bf N.B.:} The {\tt AttrVect} argument in the corresponding -! {\tt send\_} call is assumed to have exactly the same attributes -! in exactly the same order as {\tt aV}. -! -! !INTERFACE: - - subroutine recv_(aV, Rout, Tag, Sum) -! -! !USES: -! - implicit none - -! !INPUT/OUTPUT PARAMETERS: -! - Type(AttrVect), intent(inout) :: aV - -! !INPUT PARAMETERS: -! - Type(Router), intent(inout) :: Rout - integer,optional, intent(in) :: Tag - logical,optional, intent(in) :: Sum - -! !REVISION HISTORY: -! 25Jul03 - R. Jacob - Rewrite using irecv and waitrecv -!EOP ___________________________________________________________________ - character(len=*),parameter :: myname_=myname//'::recv_' - - call irecv_(aV,Rout,Tag,Sum) - - call waitrecv_(aV,Rout,Sum) - -end subroutine recv_ - - -end module m_Transfer diff --git a/cesm/models/utils/mct/mkinstalldirs b/cesm/models/utils/mct/mkinstalldirs deleted file mode 100755 index d2d5f21..0000000 --- a/cesm/models/utils/mct/mkinstalldirs +++ /dev/null @@ -1,111 +0,0 @@ -#! /bin/sh -# mkinstalldirs --- make directory hierarchy -# Author: Noah Friedman -# Created: 1993-05-16 -# Public domain - -errstatus=0 -dirmode="" - -usage="\ -Usage: mkinstalldirs [-h] [--help] [-m mode] dir ..." - -# process command line arguments -while test $# -gt 0 ; do - case $1 in - -h | --help | --h*) # -h for help - echo "$usage" 1>&2 - exit 0 - ;; - -m) # -m PERM arg - shift - test $# -eq 0 && { echo "$usage" 1>&2; exit 1; } - dirmode=$1 - shift - ;; - --) # stop option processing - shift - break - ;; - -*) # unknown option - echo "$usage" 1>&2 - exit 1 - ;; - *) # first non-opt arg - break - ;; - esac -done - -for file -do - if test -d "$file"; then - shift - else - break - fi -done - -case $# in - 0) exit 0 ;; -esac - -case $dirmode in - '') - if mkdir -p -- . 2>/dev/null; then - echo "mkdir -p -- $*" - exec mkdir -p -- "$@" - fi - ;; - *) - if mkdir -m "$dirmode" -p -- . 2>/dev/null; then - echo "mkdir -m $dirmode -p -- $*" - exec mkdir -m "$dirmode" -p -- "$@" - fi - ;; -esac - -for file -do - set fnord `echo ":$file" | sed -ne 's/^:\//#/;s/^://;s/\// /g;s/^#/\//;p'` - shift - - pathcomp= - for d - do - pathcomp="$pathcomp$d" - case $pathcomp in - -*) pathcomp=./$pathcomp ;; - esac - - if test ! -d "$pathcomp"; then - echo "mkdir $pathcomp" - - mkdir "$pathcomp" || lasterr=$? - - if test ! -d "$pathcomp"; then - errstatus=$lasterr - else - if test ! -z "$dirmode"; then - echo "chmod $dirmode $pathcomp" - lasterr="" - chmod "$dirmode" "$pathcomp" || lasterr=$? - - if test ! -z "$lasterr"; then - errstatus=$lasterr - fi - fi - fi - fi - - pathcomp="$pathcomp/" - done -done - -exit $errstatus - -# Local Variables: -# mode: shell-script -# sh-indentation: 2 -# End: -# mkinstalldirs ends here diff --git a/cesm/models/utils/mct/mpeu/Makefile b/cesm/models/utils/mct/mpeu/Makefile deleted file mode 100644 index dfadaec..0000000 --- a/cesm/models/utils/mct/mpeu/Makefile +++ /dev/null @@ -1,126 +0,0 @@ -.NOTPARALLEL: -# MACHINE AND COMPILER FLAGS - -include ../Makefile.conf - -VPATH = $(SRCDIR)/mpeu -SHELL = /bin/sh - -INCPATH += $(INCFLAG). $(INCFLAG)../ - -# SOURCE FILES - -MODULE = mpeu - -SRCS_F90 = m_IndexBin_char.F90 \ - m_IndexBin_integer.F90 \ - m_IndexBin_logical.F90 \ - m_List.F90 \ - m_MergeSorts.F90 \ - m_Filename.F90 \ - m_FcComms.F90 \ - m_Permuter.F90 \ - m_SortingTools.F90 \ - m_String.F90 \ - m_StrTemplate.F90 \ - m_chars.F90 \ - m_die.F90 \ - m_dropdead.F90 \ - m_FileResolv.F90 \ - m_flow.F90 \ - m_inpak90.F90 \ - m_ioutil.F90 \ - m_mall.F90 \ - m_mpif.F90 \ - m_mpif90.F90 \ - m_mpout.F90 \ - m_rankMerge.F90 \ - m_realkinds.F90 \ - m_stdio.F90 \ - m_TraceBack.F90 \ - m_zeit.F90 - -SRCS_C = get_zeits.c - -OBJS_ALL = $(SRCS_C:.c=.o) \ - $(SRCS_F90:.F90=.o) - - -# TARGETS - -all: lib$(MODULE).a - -lib$(MODULE).a: $(OBJS_ALL) - $(RM) $@ - $(AR) $@ $(OBJS_ALL) - $(RANLIB) $@ - -# ADDITIONAL FLAGS SPECIFIC FOR MPEU COMPILATION - -MPEUFLAGS = - -# RULES - -.SUFFIXES: -.SUFFIXES: .F90 .c .o - -.c.o: - $(CC) -c $(CPPDEFS) $(CFLAGS) $(INCPATH) $< - -.F90.o: - $(FC) -c $(INCPATH) $(FPPDEFS) $(FCFLAGS) $(MPEUFLAGS) $< - -clean: - ${RM} *.o *.mod lib$(MODULE).a - -install: all - $(MKINSTALLDIRS) $(libdir) $(includedir) - $(INSTALL) lib$(MODULE).a -m 644 $(libdir) - @for modfile in *.mod; do \ - echo $(INSTALL) $$modfile -m 644 $(includedir); \ - $(INSTALL) $$modfile -m 644 $(includedir); \ - done - -# DEPENDENCIES - -m_IndexBin_char.o: m_die.o m_stdio.o -m_IndexBin_integer.o: m_die.o m_stdio.o -m_IndexBin_logical.o: m_die.o m_stdio.o -m_List.o: m_String.o m_die.o m_mall.o -m_MergeSorts.o: m_die.o m_realkinds.o m_stdio.o -m_Filename.o: -m_Permuter.o: m_die.o m_realkinds.o -m_SortingTools.o: m_IndexBin_char.o m_IndexBin_integer.o m_IndexBin_logical.o m_MergeSorts.o m_Permuter.o m_rankMerge.o -m_String.o: m_die.o m_mall.o m_mpif90.o -m_StrTemplate.o: m_chars.o m_die.o m_stdio.o -m_chars.o: -m_die.o: m_dropdead.o m_flow.o m_mpif90.o m_mpout.o m_stdio.o -m_dropdead.o: m_mpif90.o m_stdio.o -m_flow.o: m_chars.o -m_inpak90.o: m_die.o m_ioutil.o m_mall.o m_mpif90.o m_realkinds.o m_stdio.o -m_ioutil.o: m_stdio.o -m_mall.o: m_chars.o m_die.o m_ioutil.o m_realkinds.o m_stdio.o -m_mpif.o: -m_mpif90.o: m_mpif.o m_realkinds.o m_stdio.o -m_mpout.o: m_dropdead.o m_ioutil.o m_mpif90.o m_stdio.o -m_rankMerge.o: -m_realkinds.o: -m_stdio.o: -m_zeit.o: m_SortingTools.o m_die.o m_ioutil.o m_mpif90.o m_stdio.o get_zeits.o -get_zeits.o: -m_FileResolv.o: m_die.o m_StrTemplate.o -m_TraceBack.o: m_die.o m_stdio.o m_String.o - - - - - - - - - - - - - - diff --git a/cesm/models/utils/mct/mpeu/README b/cesm/models/utils/mct/mpeu/README deleted file mode 100644 index 4a45b62..0000000 --- a/cesm/models/utils/mct/mpeu/README +++ /dev/null @@ -1,59 +0,0 @@ -!----------------------------------------------------------------------- -! CVS $Id$ -! CVS $Name$ -!----------------------------------------------------------------------- - -This directory contains a version of MPEU distributed as part -of the Model Coupling Toolkit (MCT). MPEU was written by -Jing Guo of the NASA Data Assimilation Office. - -This copy of MPEU provided by Jing Guo. Usage is covered -by terms in the file MCT/COPYRIGHT. - -MCT distribution contents: -MCT/ -MCT/COPYRIGHT -MCT/doc/ -MCT/examples/ -MCT/mct/ -MCT/mpeu/ <- You are here -MCT/protex/ - -A complete distribution of MCT can be obtained from http://www.mcs.anl.gov/mct. - ---------------------------------------------------- -Build instructions: - -In top level directory, type "./configure", then "make". - -If "./configure" has already been run, you can also type "make" -in this directory. - ---------------------------------------------------- -NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS - -28Sep99 - Jing Guo - - Changed supported libraries to - - mpeu: libmpeu.a libeu.a with the _same_ interface in mpeu/ - - - Implemented several design changes: - - . Removed -r8/_R8_ compiler flags in Makefile.conf.IRIX64. - The current design is expected to support both single and - double precision REAL kinds. The selection should be made - by the compiler through Fortran 90 generic interface - feature. - - . Added MP_type() function in mpif90.F90 to allow a more - portable approach of using MPI_REAL. - - . Removed _SINGLE_PE_ flag to make the interface in mpeu/ - portable to both library versions. - - -14Sep99 - Jing Guo - Targets supported in this directory - - mpeu: make -f Makefile all for MPI env - eu: make -f Makefile.1pe all for single PE env - diff --git a/cesm/models/utils/mct/mpeu/assertmpeu.H b/cesm/models/utils/mct/mpeu/assertmpeu.H deleted file mode 100644 index 16c2154..0000000 --- a/cesm/models/utils/mct/mpeu/assertmpeu.H +++ /dev/null @@ -1,55 +0,0 @@ -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!----------------------------------------------------------------------- -! CVS $Id$ -! CVS $Name$ -!BOP ------------------------------------------------------------------- -! -! !MODULE: assertmpeu.H - an #include section of ASSERT() macro for Fortran -! -! !DESCRIPTION: -! -! !INTERFACE: -! -! #define NDEBUG -! #include "assertmpeu.H" -! ... -! use m_die,only : assert_ -! ... -! ASSERT( ) -! ALWAYS_ASSERT( ) -! -! !BUGS -! This macro requires Fortran friendly cpp() for macro processing. -! -! !REVISION HISTORY: -! 17Aug07 - R. Jacob - renamed from assert.H to -! prevent namespace collision with assert.h on Mac -! 28Aug00 - Jing Guo -! - modified -! - added the prolog for a brief documentation -! before - Tom Clune -! - Created for MP PSAS -!EOP ___________________________________________________________________ - - ! This implementation allows multi-"#include" in a single file - -#ifndef ALWAYS_ASSERT - -#define ALWAYS_ASSERT(EX) If (.not. (EX) ) call assert_("EX",__FILE__,__LINE__) -#endif - - -#ifndef ASSERT - -#ifdef NDEBUG - -#define ASSERT(EX) ! Skip assertion: EX - -#else - -#define ASSERT(EX) ALWAYS_ASSERT(EX) - -#endif - -#endif diff --git a/cesm/models/utils/mct/mpeu/get_zeits.c b/cesm/models/utils/mct/mpeu/get_zeits.c deleted file mode 100644 index 003a37b..0000000 --- a/cesm/models/utils/mct/mpeu/get_zeits.c +++ /dev/null @@ -1,76 +0,0 @@ -/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!----------------------------------------------------------------------- -! CVS $Id$ -! CVS $Name$ -!----------------------------------------------------------------------- -!BOP -! -! !ROUTINE: get_zeits - a C interface to times for Fortran calls -! -! !DESCRIPTION: -! -! !INTERFACE: */ - /* - System times() dependencies: - */ - - -#include -#ifndef NOTIMES -#include -#endif - -#include /* POSIX standard says CLOCKS_PER_SEC is here */ -#include "config.h" -/* - * CLK_TCK is obsolete - replace with CLOCKS_PER_SEC - */ - -#define ZCLK_TCK ((double)CLOCKS_PER_SEC) - - - - - /* Prototype: */ - - void FC_FUNC(get_zeits,GET_ZEITS)(double *zts); - void FC_FUNC(get_ztick,GET_ZTICK)(double *tic); - -/*!REVISION HISTORY: -! 12Mar98 - Jing Guo - initial prototype/prolog/code -! 06Jul99 - J.W. Larson - support for AIX platform -!EOP */ - -/* Implementations: */ - -void FC_FUNC(get_zeits,GET_ZEITS)(zts) - double *zts; -{ - -#ifndef NOTIMES - struct tms tm; - double secs; - secs=1./ZCLK_TCK; - - zts[0]=times(&tm)*secs; - zts[1]=tm.tms_utime*secs; - zts[2]=tm.tms_stime*secs; - zts[3]=tm.tms_cutime*secs; - zts[4]=tm.tms_cstime*secs; -#else - zts[0]=0.; - zts[1]=0.; - zts[2]=0.; - zts[3]=0.; - zts[4]=0.; -#endif - -} - -void FC_FUNC(get_ztick,GET_ZTICK)(tic) - double *tic; -{ - tic[0]=1./ZCLK_TCK; -} - diff --git a/cesm/models/utils/mct/mpeu/m_FcComms.F90 b/cesm/models/utils/mct/mpeu/m_FcComms.F90 deleted file mode 100644 index 36f74d3..0000000 --- a/cesm/models/utils/mct/mpeu/m_FcComms.F90 +++ /dev/null @@ -1,685 +0,0 @@ -!BOP ------------------------------------------------------------------- -! -! !MODULE: m_FcComms - MPI collective communication operators -! with explict flow control -! -! !DESCRIPTION: -! -! This module includes implementations of MPI collective operators that -! have proven problematic on certain systems when run at scale. By -! introducing additonal flow control, these problems (exhausting internal -! system resources) can be avoided. These routines were ported from -! the Community Atmosphere Model's spmd_utils.F90. -! -! !INTERFACE: -! -! Workaround for performance issue with rsend on cray systems with -! gemini interconnect -! -#ifdef _NO_MPI_RSEND -#define MPI_RSEND MPI_SEND -#define mpi_rsend mpi_send -#define MPI_IRSEND MPI_ISEND -#define mpi_irsend mpi_isend -#endif - - module m_FcComms - - implicit none - - private ! except - - public :: fc_gather_int ! flow control version of mpi_gather for integer vectors - public :: fc_gather_fp ! flow control version of mpi_gather for FP vectors - public :: fc_gatherv_int ! flow control version of mpi_gatherv for integer vectors - public :: fc_gatherv_fp ! flow control version of mpi_gatherv for integer vectors - public :: get_fcblocksize ! get current value of max_gather_block_size - public :: set_fcblocksize ! set current value of max_gather_block_size - - -! !REVISION HISTORY: -! 30Jan09 - P.H. Worley - imported routines -! from CAM's spmd_utils to create this module. - - integer, public :: max_gather_block_size = 64 - character(len=*),parameter :: myname='MCT(MPEU)::m_FcComms' - - contains - -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: fc_gather_int - Gather an array of type integer -! -! !DESCRIPTION: -! This routine gathers a {\em distributed} array of type {\em integer} -! to the {\tt root} process. Explicit handshaking messages are used -! to control the number of processes communicating with the root -! at any one time. -! -! If flow_cntl optional parameter -! < 0 : use MPI_Gather -! >= 0: use point-to-point with handshaking messages and -! preposting receive requests up to -! min(max(1,flow_cntl),max_gather_block_size) -! ahead if optional flow_cntl parameter is present. -! Otherwise, max_gather_block_size is used in its place. -! Default value is max_gather_block_size. -! !INTERFACE: -! - subroutine fc_gather_int (sendbuf, sendcnt, sendtype, & - recvbuf, recvcnt, recvtype, & - root, comm, flow_cntl ) -! -! !USES: -! - use m_die - use m_mpif90 -! -! !INPUT PARAMETERS: -! - integer, intent(in) :: sendbuf(*) - integer, intent(in) :: sendcnt - integer, intent(in) :: sendtype - integer, intent(in) :: recvcnt - integer, intent(in) :: recvtype - integer, intent(in) :: root - integer, intent(in) :: comm - integer, optional, intent(in) :: flow_cntl - -! !OUTPUT PARAMETERS: -! - integer, intent(out) :: recvbuf(*) - -! !REVISION HISTORY: -! 30Jan09 - P.H. Worley - imported from spmd_utils.F90 -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::fc_gather_int' - - integer :: signal - logical fc_gather ! use explicit flow control? - integer gather_block_size ! number of preposted receive requests - - integer :: mytid, mysize, mtag, p, i, count, displs - integer :: preposts, head, tail - integer :: rcvid(max_gather_block_size) - integer :: status(MP_STATUS_SIZE) - integer :: ier ! MPI error code - - signal = 1 - if ( present(flow_cntl) ) then - if (flow_cntl >= 0) then - gather_block_size = min(max(1,flow_cntl),max_gather_block_size) - fc_gather = .true. - else - fc_gather = .false. - endif - else - gather_block_size = max(1,max_gather_block_size) - fc_gather = .true. - endif - - if (fc_gather) then - - call mpi_comm_rank (comm, mytid, ier) - call mpi_comm_size (comm, mysize, ier) - mtag = 0 - if (root .eq. mytid) then - -! prepost gather_block_size irecvs, and start receiving data - preposts = min(mysize-1, gather_block_size) - head = 0 - count = 0 - do p=0, mysize-1 - if (p .ne. root) then - if (recvcnt > 0) then - count = count + 1 - if (count > preposts) then - tail = mod(head,preposts) + 1 - call mpi_wait (rcvid(tail), status, ier) - end if - head = mod(head,preposts) + 1 - displs = p*recvcnt - call mpi_irecv ( recvbuf(displs+1), recvcnt, & - recvtype, p, mtag, comm, rcvid(head), & - ier ) - call mpi_send ( signal, 1, recvtype, p, mtag, comm, ier ) - end if - end if - end do - -! copy local data - displs = mytid*recvcnt - do i=1,sendcnt - recvbuf(displs+i) = sendbuf(i) - enddo - -! wait for final data - do i=1,min(count,preposts) - call mpi_wait (rcvid(i), status, ier) - enddo - - else - - if (sendcnt > 0) then - call mpi_recv ( signal, 1, sendtype, root, mtag, comm, & - status, ier ) - call mpi_rsend ( sendbuf, sendcnt, sendtype, root, mtag, & - comm, ier ) - end if - - endif - if (ier /= 0) then - call MP_perr_die(myname_,':: (point-to-point implementation)',ier) - end if - - else - - call mpi_gather (sendbuf, sendcnt, sendtype, & - recvbuf, recvcnt, recvtype, & - root, comm, ier) - if (ier /= 0) then - call MP_perr_die(myname_,':: MPI_GATHER',ier) - end if - - endif - - return - end subroutine fc_gather_int - -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: fc_gather_fp - Gather an array of type FP -! -! !DESCRIPTION: -! This routine gathers a {\em distributed} array of type {\em FP} to -! the {\tt root} process. Explicit handshaking messages are used -! to control the number of processes communicating with the root -! at any one time. -! -! If flow_cntl optional parameter -! < 0 : use MPI_Gather -! >= 0: use point-to-point with handshaking messages and -! preposting receive requests up to -! min(max(1,flow_cntl),max_gather_block_size) -! ahead if optional flow_cntl parameter is present. -! Otherwise, max_gather_block_size is used in its place. -! Default value is max_gather_block_size. -! !INTERFACE: -! - subroutine fc_gather_fp (sendbuf, sendcnt, sendtype, & - recvbuf, recvcnt, recvtype, & - root, comm, flow_cntl ) -! -! !USES: -! - use m_realkinds, only : FP - use m_die - use m_mpif90 -! -! !INPUT PARAMETERS: -! - real (FP), intent(in) :: sendbuf(*) - integer, intent(in) :: sendcnt - integer, intent(in) :: sendtype - integer, intent(in) :: recvcnt - integer, intent(in) :: recvtype - integer, intent(in) :: root - integer, intent(in) :: comm - integer, optional, intent(in) :: flow_cntl - -! !OUTPUT PARAMETERS: -! - real (FP), intent(out) :: recvbuf(*) - -! !REVISION HISTORY: -! 30Jan09 - P.H. Worley - imported from spmd_utils.F90 -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::fc_gather_fp' - - real (FP) :: signal - logical fc_gather ! use explicit flow control? - integer gather_block_size ! number of preposted receive requests - - integer :: mytid, mysize, mtag, p, i, count, displs - integer :: preposts, head, tail - integer :: rcvid(max_gather_block_size) - integer :: status(MP_STATUS_SIZE) - integer :: ier ! MPI error code - - signal = 1.0 - if ( present(flow_cntl) ) then - if (flow_cntl >= 0) then - gather_block_size = min(max(1,flow_cntl),max_gather_block_size) - fc_gather = .true. - else - fc_gather = .false. - endif - else - gather_block_size = max(1,max_gather_block_size) - fc_gather = .true. - endif - - if (fc_gather) then - - call mpi_comm_rank (comm, mytid, ier) - call mpi_comm_size (comm, mysize, ier) - mtag = 0 - if (root .eq. mytid) then - -! prepost gather_block_size irecvs, and start receiving data - preposts = min(mysize-1, gather_block_size) - head = 0 - count = 0 - do p=0, mysize-1 - if (p .ne. root) then - if (recvcnt > 0) then - count = count + 1 - if (count > preposts) then - tail = mod(head,preposts) + 1 - call mpi_wait (rcvid(tail), status, ier) - end if - head = mod(head,preposts) + 1 - displs = p*recvcnt - call mpi_irecv ( recvbuf(displs+1), recvcnt, & - recvtype, p, mtag, comm, rcvid(head), & - ier ) - call mpi_send ( signal, 1, recvtype, p, mtag, comm, ier ) - end if - end if - end do - -! copy local data - displs = mytid*recvcnt - do i=1,sendcnt - recvbuf(displs+i) = sendbuf(i) - enddo - -! wait for final data - do i=1,min(count,preposts) - call mpi_wait (rcvid(i), status, ier) - enddo - - else - - if (sendcnt > 0) then - call mpi_recv ( signal, 1, sendtype, root, mtag, comm, & - status, ier ) - call mpi_rsend ( sendbuf, sendcnt, sendtype, root, mtag, & - comm, ier ) - end if - - endif - if (ier /= 0) then - call MP_perr_die(myname_,':: (point-to-point implementation)',ier) - end if - - else - - call mpi_gather (sendbuf, sendcnt, sendtype, & - recvbuf, recvcnt, recvtype, & - root, comm, ier) - if (ier /= 0) then - call MP_perr_die(myname_,':: MPI_GATHER',ier) - end if - - endif - - return - end subroutine fc_gather_fp - -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: fc_gatherv_int - Gather an array of type integer -! -! !DESCRIPTION: -! This routine gathers a {\em distributed} array of type {\em integer} -! to the {\tt root} process. Explicit handshaking messages are used -! to control the number of processes communicating with the root -! at any one time. -! -! If flow_cntl optional parameter -! < 0 : use MPI_Gatherv -! >= 0: use point-to-point with handshaking messages and -! preposting receive requests up to -! min(max(1,flow_cntl),max_gather_block_size) -! ahead if optional flow_cntl parameter is present. -! Otherwise, max_gather_block_size is used in its place. -! Default value is max_gather_block_size. -! !INTERFACE: -! - subroutine fc_gatherv_int (sendbuf, sendcnt, sendtype, & - recvbuf, recvcnts, displs, recvtype, & - root, comm, flow_cntl ) -! -! !USES: -! - use m_die - use m_mpif90 -! -! !INPUT PARAMETERS: -! - integer, intent(in) :: sendbuf(*) - integer, intent(in) :: sendcnt - integer, intent(in) :: sendtype - integer, intent(in) :: recvcnts(*) - integer, intent(in) :: displs(*) - integer, intent(in) :: recvtype - integer, intent(in) :: root - integer, intent(in) :: comm - integer, optional, intent(in) :: flow_cntl - -! !OUTPUT PARAMETERS: -! - integer, intent(out) :: recvbuf(*) - -! !REVISION HISTORY: -! 30Jan09 - P.H. Worley - imported from spmd_utils.F90 -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::fc_gatherv_int' - - integer :: signal - logical fc_gather ! use explicit flow control? - integer gather_block_size ! number of preposted receive requests - - integer :: mytid, mysize, mtag, p, q, i, count - integer :: preposts, head, tail - integer :: rcvid(max_gather_block_size) - integer :: status(MP_STATUS_SIZE) - integer :: ier ! MPI error code - - signal = 1 - if ( present(flow_cntl) ) then - if (flow_cntl >= 0) then - gather_block_size = min(max(1,flow_cntl),max_gather_block_size) - fc_gather = .true. - else - fc_gather = .false. - endif - else - gather_block_size = max(1,max_gather_block_size) - fc_gather = .true. - endif - - if (fc_gather) then - - call mpi_comm_rank (comm, mytid, ier) - call mpi_comm_size (comm, mysize, ier) - mtag = 0 - if (root .eq. mytid) then - -! prepost gather_block_size irecvs, and start receiving data - preposts = min(mysize-1, gather_block_size) - head = 0 - count = 0 - do p=0, mysize-1 - if (p .ne. root) then - q = p+1 - if (recvcnts(q) > 0) then - count = count + 1 - if (count > preposts) then - tail = mod(head,preposts) + 1 - call mpi_wait (rcvid(tail), status, ier) - end if - head = mod(head,preposts) + 1 - call mpi_irecv ( recvbuf(displs(q)+1), recvcnts(q), & - recvtype, p, mtag, comm, rcvid(head), & - ier ) - call mpi_send ( signal, 1, recvtype, p, mtag, comm, ier ) - end if - end if - end do - -! copy local data - q = mytid+1 - do i=1,sendcnt - recvbuf(displs(q)+i) = sendbuf(i) - enddo - -! wait for final data - do i=1,min(count,preposts) - call mpi_wait (rcvid(i), status, ier) - enddo - - else - - if (sendcnt > 0) then - call mpi_recv ( signal, 1, sendtype, root, mtag, comm, & - status, ier ) - call mpi_rsend ( sendbuf, sendcnt, sendtype, root, mtag, & - comm, ier ) - end if - - endif - if (ier /= 0) then - call MP_perr_die(myname_,':: (point-to-point implementation)',ier) - end if - - else - - call mpi_gatherv (sendbuf, sendcnt, sendtype, & - recvbuf, recvcnts, displs, recvtype, & - root, comm, ier) - if (ier /= 0) then - call MP_perr_die(myname_,':: MPI_GATHERV',ier) - end if - - endif - - return - end subroutine fc_gatherv_int - -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: fc_gatherv_fp - Gather an array of type FP -! -! !DESCRIPTION: -! This routine gathers a {\em distributed} array of type {\em FP} to -! the {\tt root} process. Explicit handshaking messages are used -! to control the number of processes communicating with the root -! at any one time. -! -! If flow_cntl optional parameter -! < 0 : use MPI_Gatherv -! >= 0: use point-to-point with handshaking messages and -! preposting receive requests up to -! min(max(1,flow_cntl),max_gather_block_size) -! ahead if optional flow_cntl parameter is present. -! Otherwise, max_gather_block_size is used in its place. -! Default value is max_gather_block_size. -! !INTERFACE: -! - subroutine fc_gatherv_fp (sendbuf, sendcnt, sendtype, & - recvbuf, recvcnts, displs, recvtype, & - root, comm, flow_cntl ) -! -! !USES: -! - use m_realkinds, only : FP - use m_die - use m_mpif90 -! -! !INPUT PARAMETERS: -! - real (FP), intent(in) :: sendbuf(*) - integer, intent(in) :: sendcnt - integer, intent(in) :: sendtype - integer, intent(in) :: recvcnts(*) - integer, intent(in) :: displs(*) - integer, intent(in) :: recvtype - integer, intent(in) :: root - integer, intent(in) :: comm - integer, optional, intent(in) :: flow_cntl - -! !OUTPUT PARAMETERS: -! - real (FP), intent(out) :: recvbuf(*) - -! !REVISION HISTORY: -! 30Jan09 - P.H. Worley - imported from spmd_utils.F90 -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::fc_gatherv_fp' - - real (FP) :: signal - logical fc_gather ! use explicit flow control? - integer gather_block_size ! number of preposted receive requests - - integer :: mytid, mysize, mtag, p, q, i, count - integer :: preposts, head, tail - integer :: rcvid(max_gather_block_size) - integer :: status(MP_STATUS_SIZE) - integer :: ier ! MPI error code - - signal = 1.0 - if ( present(flow_cntl) ) then - if (flow_cntl >= 0) then - gather_block_size = min(max(1,flow_cntl),max_gather_block_size) - fc_gather = .true. - else - fc_gather = .false. - endif - else - gather_block_size = max(1,max_gather_block_size) - fc_gather = .true. - endif - - if (fc_gather) then - - call mpi_comm_rank (comm, mytid, ier) - call mpi_comm_size (comm, mysize, ier) - mtag = 0 - if (root .eq. mytid) then - -! prepost gather_block_size irecvs, and start receiving data - preposts = min(mysize-1, gather_block_size) - head = 0 - count = 0 - do p=0, mysize-1 - if (p .ne. root) then - q = p+1 - if (recvcnts(q) > 0) then - count = count + 1 - if (count > preposts) then - tail = mod(head,preposts) + 1 - call mpi_wait (rcvid(tail), status, ier) - end if - head = mod(head,preposts) + 1 - call mpi_irecv ( recvbuf(displs(q)+1), recvcnts(q), & - recvtype, p, mtag, comm, rcvid(head), & - ier ) - call mpi_send ( signal, 1, recvtype, p, mtag, comm, ier ) - end if - end if - end do - -! copy local data - q = mytid+1 - do i=1,sendcnt - recvbuf(displs(q)+i) = sendbuf(i) - enddo - -! wait for final data - do i=1,min(count,preposts) - call mpi_wait (rcvid(i), status, ier) - enddo - - else - - if (sendcnt > 0) then - call mpi_recv ( signal, 1, sendtype, root, mtag, comm, & - status, ier ) - call mpi_rsend ( sendbuf, sendcnt, sendtype, root, mtag, & - comm, ier ) - end if - - endif - if (ier /= 0) then - call MP_perr_die(myname_,':: (point-to-point implementation)',ier) - end if - - else - - call mpi_gatherv (sendbuf, sendcnt, sendtype, & - recvbuf, recvcnts, displs, recvtype, & - root, comm, ier) - if (ier /= 0) then - call MP_perr_die(myname_,':: MPI_GATHERV',ier) - end if - - endif - - return - end subroutine fc_gatherv_fp - -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: get_fcblocksize - return max_gather_block_size -! -! !DESCRIPTION: -! This function returns the current value of max_gather_block_size -! -! !INTERFACE: - - function get_fcblocksize() - -! !USES: -! -! No external modules are used by this function. - - implicit none - -! !INPUT PARAMETERS: -! - -! !OUTPUT PARAMETERS: -! - integer :: get_fcblocksize - -! !REVISION HISTORY: -! 03Mar09 - R. Jacob (jacob@mcs.anl.gov) -- intial version -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::get_fcblocksize' - - get_fcblocksize = max_gather_block_size - - end function get_fcblocksize - -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: set_fcblocksize - set max_gather_block_size -! -! !DESCRIPTION: -! This function sets the current value of max_gather_block_size -! -! !INTERFACE: - - subroutine set_fcblocksize(gather_block_size) - -! !USES: -! -! No external modules are used by this function. - - implicit none - -! !INPUT PARAMETERS: -! - integer :: gather_block_size - -! !OUTPUT PARAMETERS: -! - -! !REVISION HISTORY: -! 03Mar09 - R. Jacob (jacob@mcs.anl.gov) -- intial version -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//':: set_fcblocksize' - - max_gather_block_size = gather_block_size - - end subroutine set_fcblocksize - - end module m_FcComms diff --git a/cesm/models/utils/mct/mpeu/m_FileResolv.F90 b/cesm/models/utils/mct/mpeu/m_FileResolv.F90 deleted file mode 100644 index 86af5bd..0000000 --- a/cesm/models/utils/mct/mpeu/m_FileResolv.F90 +++ /dev/null @@ -1,273 +0,0 @@ -!------------------------------------------------------------------------- -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!------------------------------------------------------------------------- -! CVS $Id$ -! CVS $Name$ -!----------------------------------------------------------------------- -!BOP -! -! !MODULE: m_FileResolv --- Resolve file name templates -! -! !INTERFACE: -! - - MODULE m_FileResolv - -! !USES: - - use m_StrTemplate ! grads style templates - use m_die - Implicit NONE - -! -! !PUBLIC MEMBER FUNCTIONS: -! - PRIVATE - PUBLIC FileResolv - PUBLIC remote_cp - PUBLIC gunzip -! -! !DESCRIPTION: This module provides routines for resolving GrADS like -! file name templates. -! -! !REVISION HISTORY: -! -! 10Jan2000 da Silva Initial code. -! -!EOP -!------------------------------------------------------------------------- - - character(len=255) :: remote_cp = 'rcp' - character(len=255) :: gunzip = 'gunzip' - -CONTAINS - -!------------------------------------------------------------------------- -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!------------------------------------------------------------------------- -!BOP -! -! !IROUTINE: FileResolv -- Resolve file name templates (single file) -! -! !INTERFACE: -! - subroutine FileResolv ( expid, nymd, nhms, templ, fname, & - stat, cache ) - -! !USES: - - IMPLICIT NONE - -! -! !INPUT PARAMETERS: -! - character(len=*), intent(in) :: expid ! Experiment id - integer, intent(in) :: nymd ! Year-month-day - integer, intent(in) :: nhms ! Hour-min-sec - character(len=*), intent(in) :: templ ! file name template - -! -! !OUTPUT PARAMETERS: -! - character(len=*), intent(out) :: fname ! resolved file name - - integer, OPTIONAL, intent(out) :: stat ! Status - ! 0 - file exists - ! 1 - file does not exist - - logical, OPTIONAL, intent(in) :: cache ! skips rcp/gunzip if - ! file exists locally - -! !DESCRIPTION: Resolve file name templates, rcp'ing files from remote and -! performing gunzip'ing as necessary. -! -! !TO DO: -! 1. Expand environment variables in templates -! -! !REVISION HISTORY: -! -! 10Jan2000 da Silva Initial code, -! 23Jul2002 J. Larson - fixed bug detected by the -! Fujitsu frt compiler (on the VPP). -! -!EOP -!-------------------------------------------------------------------------- - - character(len=*), parameter :: myname = 'MCT(MPEU)::FileResolv' - -#if SYSUNICOS || CPRCRAY - integer, external :: ishell -#elif (!defined __GFORTRAN__) - integer, external :: system -#endif - character(len=255) :: path, host, dirn, basen, head, tail, cmd, filen - - integer i, rc - logical :: fexists, caching - - -! Default is cache = .true. -! ------------------------- - if ( present(cache) ) then - caching = cache - else - caching = .TRUE. - end if - -! Start by expanding template -! --------------------------- - call strTemplate ( path, templ, 'GRADS', trim(expid), nymd, nhms, rc ) - if ( rc .ne. 0 ) then - if ( present(stat) ) then - stat = 1 - return - else - call die ( myname, 'cannot expand template '//trim(templ) ) - end if - end if - - -! Parse file name -! --------------- - i = index ( trim(path), ':' ) - if ( i .gt. 0 ) then - host = path(1:i-1) - fname = path(i+1:) - else - host = '' - fname = path - end if - i = index ( trim(fname), '/', back=.true. ) - if ( i .gt. 1 ) then - dirn = fname(1:i-1) - basen = fname(i+1:) - else if ( i .gt. 0 ) then - dirn = fname(1:i) - basen = fname(i+1:) - else - dirn = '' - basen = fname - end if - i = index ( basen, '.', back=.true. ) - if ( i .gt. 0 ) then - head = basen(1:i-1) - tail = basen(i+1:) - else - head = basen - tail = '' - end if - -! print *, 'Template = |'//trim(templ)//'|' -! print *, ' path = |'//trim(path)//'|' -! print *, ' host = |'//trim(host)//'|' -! print *, ' dirn = |'//trim(dirn)//'|' -! print *, ' basen = |'//trim(basen)//'|' -! print *, ' head = |'//trim(head)//'|' -! print *, ' tail = |'//trim(tail)//'|' -! print *, ' fname = |'//trim(fname)//'|' - - -! If file is remote, bring it here -! -------------------------------- - if ( len_trim(host) .gt. 0 ) then - if ( trim(tail) .eq. 'gz' ) then - inquire ( file=trim(head), exist=fexists ) - filen = head - else - inquire ( file=trim(basen), exist=fexists ) - filen = basen - end if - if ( .not. ( fexists .and. caching ) ) then - cmd = trim(remote_cp) // ' ' // & - trim(host) // ':' // trim(fname) // ' . ' -#if SYSUNICOS || CPRCRAY - rc = ishell ( cmd ) -#else - rc = system ( cmd ) -#endif - - if ( rc .eq. 0 ) then - fname = basen - else - if ( present(stat) ) then ! return an error code - stat = 2 - return - else ! shut down - fname = basen - call die ( myname, 'cannot execute: '//trim(cmd) ) - end if - end if - else - fname = filen - call warn(myname,'using cached version of '//trim(filen) ) - end if - - -! If not, make sure file exists locally -! ------------------------------------- - else - - inquire ( file=trim(fname), exist=fexists ) - if ( .not. fexists ) then - if ( present(stat) ) then - stat = 3 - else - call die(myname,'cannot find '//trim(fname) ) - end if - end if - - end if - - -! If file is gzip'ed, leave original alone and create uncompressed -! version in the local directory -! ---------------------------------------------------------------- - if ( trim(tail) .eq. 'gz' ) then - inquire ( file=trim(head), exist=fexists ) ! do we have a local copy? - if ( .not. ( fexists .and. caching ) ) then - if ( len_trim(host) .gt. 0 ) then ! remove file.gz - cmd = trim(gunzip) // ' -f ' // trim(fname) - else ! keep file.gz - cmd = trim(gunzip) // ' -c ' // trim(fname) // ' > ' // trim(head) - end if -#if SYSUNICOS || CPRCRAY - rc = ishell ( cmd ) -#else - rc = system ( cmd ) -#endif - if ( rc .eq. 0 ) then - fname = head - else - if ( present(stat) ) then - stat = 4 - return - else - call die ( myname, 'cannot execute: '//trim(cmd) ) - end if - end if - else - fname = head - call warn(myname,'using cached version of '//trim(head) ) - end if - end if - - -! Once more, make sure file exists -! -------------------------------- - inquire ( file=trim(fname), exist=fexists ) - if ( .not. fexists ) then - if ( present(stat) ) then - stat = 3 - else - call die(myname,'cannot find '//trim(fname) ) - end if - end if - - -! All done -! -------- - if ( present(stat) ) stat = 0 - - end subroutine FileResolv - - end MODULE m_FileResolv diff --git a/cesm/models/utils/mct/mpeu/m_Filename.F90 b/cesm/models/utils/mct/mpeu/m_Filename.F90 deleted file mode 100644 index 93736c2..0000000 --- a/cesm/models/utils/mct/mpeu/m_Filename.F90 +++ /dev/null @@ -1,106 +0,0 @@ -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!----------------------------------------------------------------------- -! CVS $Id$ -! CVS $Name$ -!BOP ------------------------------------------------------------------- -! -! !MODULE: m_Filename - Filename manipulation routines -! -! !DESCRIPTION: -! -! !INTERFACE: - - module m_Filename - implicit none - private ! except - - public :: Filename_base ! basename() - public :: Filename_dir ! dirname() - - interface Filename_base; module procedure base_; end interface - interface Filename_dir; module procedure dir_; end interface - -! !REVISION HISTORY: -! 14Feb00 - Jing Guo -! - initial prototype/prolog/code -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname='MCT(MPEU)::m_Filename' - -contains -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: base_ - basename -! -! !DESCRIPTION: -! -! !INTERFACE: - - function base_(cstr,sfx) - implicit none - character(len=*) ,intent(in) :: cstr - character(len=*),optional,intent(in) :: sfx - character(len=len(cstr)) :: base_ - -! !REVISION HISTORY: -! 14Feb00 - Jing Guo -! - initial prototype/prolog/code -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::base_' - integer :: l,lb,le - - l =index(cstr,'/',back=.true.) - lb=l+1 ! correct either a '/' is in the string or not. - le=len_trim(cstr) - - if(present(sfx)) then - - l=le-len_trim(sfx) - if(sfx==cstr(l+1:le)) le=l - - endif - - base_=cstr(lb:le) - -end function base_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: dir_ - dirname -! -! !DESCRIPTION: -! -! !INTERFACE: - - function dir_(cstr) - implicit none - character(len=*),intent(in) :: cstr - character(len=len(cstr)) :: dir_ - -! !REVISION HISTORY: -! 14Feb00 - Jing Guo -! - initial prototype/prolog/code -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::dir_' - integer :: l - - l =index(cstr,'/',back=.true.) - select case(l) - case(0) - dir_='.' - case(1) - dir_='/' - case default - dir_=cstr(1:l-1) - end select - -end function dir_ - -end module m_Filename diff --git a/cesm/models/utils/mct/mpeu/m_IndexBin_char.F90 b/cesm/models/utils/mct/mpeu/m_IndexBin_char.F90 deleted file mode 100644 index be42c1b..0000000 --- a/cesm/models/utils/mct/mpeu/m_IndexBin_char.F90 +++ /dev/null @@ -1,257 +0,0 @@ -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!----------------------------------------------------------------------- -! CVS $Id$ -! CVS $Name$ -!BOP ------------------------------------------------------------------- -! -! !MODULE: m_IndexBin_char - Template of indexed bin-sorting module -! -! !DESCRIPTION: -! -! !INTERFACE: - - module m_IndexBin_char - implicit none - private ! except - - public :: IndexBin - interface IndexBin; module procedure & - IndexBin0_, & - IndexBin1_, & - IndexBin1w_ - end interface - -! !REVISION HISTORY: -! 17Feb99 - Jing Guo - initial prototype/prolog/code -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname='MCT(MPEU)::m_IndexBin_char' - -contains -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: IndexBin0_ - Indexed sorting for a single value -! -! !DESCRIPTION: -! -! !INTERFACE: - - subroutine IndexBin0_(n,indx,keys,key0,ln0) - use m_stdio, only : stderr - use m_die, only : die - implicit none - - integer, intent(in) :: n - integer, dimension(n), intent(inout) :: indx - character(len=*), dimension(n), intent(in) :: keys - character(len=*), intent(in) :: key0 ! value - integer,optional,intent(out) :: ln0 - -! !REVISION HISTORY: -! 16Feb99 - Jing Guo - initial prototype/prolog/code -! 27Sep99 - Jing Guo - Fixed a bug pointed out by -! Chris Redder -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::IndexBin0_' - integer,allocatable,dimension(:) :: inew - integer :: ni,ix,i,ier - integer :: ln(0:1),lc(0:1) -!________________________________________ - - allocate(inew(n),stat=ier) - if(ier /= 0) then - write(stderr,'(2a,i4)') myname_, & - ': allocate() error, stat =',ier - call die(myname_) - endif -!________________________________________ - ! Count numbers entries for the given key0 - - lc(0)=1 ! the location of values the same as key0 - ln(0)=0 - do i=1,n - if(keys(i) == key0) ln(0)=ln(0)+1 - end do - - lc(1)=ln(0)+1 ! the location of values not the same as key0 -!________________________________________ - ! Reset the counters - ln(0:1)=0 - do i=1,n - ix=indx(i) - if(keys(ix) == key0) then - ni=lc(0)+ln(0) - ln(0)=ln(0)+1 - - else - ni=lc(1)+ln(1) - ln(1)=ln(1)+1 - endif - - inew(ni)=ix - end do - -!________________________________________ - ! Sort out the old pointers according to the new order - indx(:)=inew(:) - if(present(ln0)) ln0=ln(0) -!________________________________________ - - deallocate(inew) - -end subroutine IndexBin0_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: IndexBin1_ - Indexed sorting into a set of given bins -! -! !DESCRIPTION: -! -! !INTERFACE: - - subroutine IndexBin1_(n,indx,keys,bins,lcs,lns) - use m_stdio, only : stderr - use m_die, only : die - implicit none - - integer, intent(in) :: n - integer, dimension(n),intent(inout) :: indx - character(len=*),dimension(n),intent(in) :: keys - character(len=*),dimension(:),intent(in) :: bins ! values - integer, dimension(:),intent(out) :: lcs ! locs. of the bins - integer, dimension(:),intent(out) :: lns ! sizes of the bins - -! !REVISION HISTORY: -! 16Feb99 - Jing Guo - initial prototype/prolog/code -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::IndexBin1_' - integer,allocatable,dimension(:) :: ibin,inew - integer :: nbin,lc0,ln0 - integer :: ni,ix,ib,i,ier -!________________________________________ - - nbin=size(bins) - if(nbin==0) return -!________________________________________ - - allocate(ibin(n),inew(n),stat=ier) - if(ier /= 0) then - write(stderr,'(2a,i4)') myname_, & - ': allocate() error, stat =',ier - call die(myname_) - endif -!________________________________________ - - do ib=1,nbin - lns(ib)=0 - lcs(ib)=0 - end do -!________________________________________ - ! Count numbers in every bin, and store the bin-ID for - ! later use. - do i=1,n - ix=indx(i) - - call search_(keys(ix),nbin,bins,ib) ! ib = 1:nbin; =0 if not found - - ibin(i)=ib - if(ib /= 0) lns(ib)=lns(ib)+1 - end do -!________________________________________ - ! Count the locations of every bin. - lc0=1 - do ib=1,nbin - lcs(ib)=lc0 - lc0=lc0+lns(ib) - end do -!________________________________________ - ! Reset the counters - ln0=0 - lns(1:nbin)=0 - do i=1,n - ib=ibin(i) ! the bin-index of keys(indx(i)) - if(ib/=0) then - ni=lcs(ib)+lns(ib) - lns(ib)=lns(ib)+1 - else - ni=lc0+ln0 - ln0=ln0+1 - endif - inew(ni)=indx(i) ! the current value is put in the new order - end do -!________________________________________ - ! Sort out the old pointers according to the new order - indx(:)=inew(:) -!________________________________________ - - deallocate(ibin,inew) - -contains -subroutine search_(key,nbin,bins,ib) - implicit none - character(len=*), intent(in) :: key - integer,intent(in) :: nbin - character(len=*), intent(in),dimension(:) :: bins - integer,intent(out) :: ib - integer :: i - - ib=0 - do i=1,nbin - if(key==bins(i)) then - ib=i - return - endif - end do -end subroutine search_ - -end subroutine IndexBin1_ -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: IndexBin1w_ - IndexBin1_ wrapped without working arrays -! -! !DESCRIPTION: -! -! !INTERFACE: - - subroutine IndexBin1w_(n,indx,keys,bins) - use m_stdio, only : stderr - use m_die, only : die - implicit none - - integer, intent(in) :: n - integer,dimension(n),intent(inout) :: indx - character(len=*),dimension(n),intent(in) :: keys - character(len=*),dimension(:),intent(in) :: bins ! values - -! !REVISION HISTORY: -! 17Feb99 - Jing Guo - initial prototype/prolog/code -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::IndexBin1w_' - integer :: ier - integer,dimension(:),allocatable :: lcs,lns - integer :: nbin - - nbin=size(bins) - if(nbin==0) return - - allocate(lcs(nbin),lns(nbin),stat=ier) - if(ier /= 0) then - write(stderr,'(2a,i4)') myname_,': allocate() error, stat =',ier - call die(myname_) - endif - - call IndexBin1_(n,indx,keys,bins,lcs,lns) - - deallocate(lcs,lns) -end subroutine IndexBin1w_ -end module m_IndexBin_char diff --git a/cesm/models/utils/mct/mpeu/m_IndexBin_integer.F90 b/cesm/models/utils/mct/mpeu/m_IndexBin_integer.F90 deleted file mode 100644 index a826f99..0000000 --- a/cesm/models/utils/mct/mpeu/m_IndexBin_integer.F90 +++ /dev/null @@ -1,257 +0,0 @@ -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!----------------------------------------------------------------------- -! CVS $Id$ -! CVS $Name$ -!BOP ------------------------------------------------------------------- -! -! !MODULE: m_IndexBin_integer - Template of indexed bin-sorting module -! -! !DESCRIPTION: -! -! !INTERFACE: - - module m_IndexBin_integer - implicit none - private ! except - - public :: IndexBin - interface IndexBin; module procedure & - IndexBin0_, & - IndexBin1_, & - IndexBin1w_ - end interface - -! !REVISION HISTORY: -! 17Feb99 - Jing Guo - initial prototype/prolog/code -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname='MCT(MPEU)::m_IndexBin_integer' - -contains -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: IndexBin0_ - Indexed sorting for a single value -! -! !DESCRIPTION: -! -! !INTERFACE: - - subroutine IndexBin0_(n,indx,keys,key0,ln0) - use m_stdio, only : stderr - use m_die, only : die - implicit none - - integer, intent(in) :: n - integer, dimension(n), intent(inout) :: indx - integer, dimension(n), intent(in) :: keys - integer, intent(in) :: key0 ! The key value to be moved to front - integer,optional,intent(out) :: ln0 - -! !REVISION HISTORY: -! 16Feb99 - Jing Guo - initial prototype/prolog/code -! 27Sep99 - Jing Guo - Fixed a bug pointed out by -! Chris Redder -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::IndexBin0_' - integer,allocatable,dimension(:) :: inew - integer :: ni,ix,i,ier - integer :: ln(0:1),lc(0:1) -!________________________________________ - - allocate(inew(n),stat=ier) - if(ier /= 0) then - write(stderr,'(2a,i4)') myname_, & - ': allocate() error, stat =',ier - call die(myname_) - endif -!________________________________________ - ! Count numbers entries for the given key0 - - lc(0)=1 ! the location of values the same as key0 - ln(0)=0 - do i=1,n - if(keys(i) == key0) ln(0)=ln(0)+1 - end do - - lc(1)=ln(0)+1 ! the location of values not the same as key0 -!________________________________________ - ! Reset the counters - ln(0:1)=0 - do i=1,n - ix=indx(i) - if(keys(ix) == key0) then - ni=lc(0)+ln(0) - ln(0)=ln(0)+1 - - else - ni=lc(1)+ln(1) - ln(1)=ln(1)+1 - endif - - inew(ni)=ix - end do - -!________________________________________ - ! Sort out the old pointers according to the new order - indx(:)=inew(:) - if(present(ln0)) ln0=ln(0) -!________________________________________ - - deallocate(inew) - -end subroutine IndexBin0_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: IndexBin1_ - Indexed sorting into a set of given bins -! -! !DESCRIPTION: -! -! !INTERFACE: - - subroutine IndexBin1_(n,indx,keys,bins,lcs,lns) - use m_stdio, only : stderr - use m_die, only : die - implicit none - - integer, intent(in) :: n - integer, dimension(n),intent(inout) :: indx - integer, dimension(n),intent(in) :: keys - integer, dimension(:),intent(in) :: bins! values of the bins - integer, dimension(:),intent(out) :: lcs ! locs. of the bins - integer, dimension(:),intent(out) :: lns ! sizes of the bins - -! !REVISION HISTORY: -! 16Feb99 - Jing Guo - initial prototype/prolog/code -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::IndexBin1_' - integer,allocatable,dimension(:) :: ibin,inew - integer :: nbin,lc0,ln0 - integer :: ni,ix,ib,i,ier -!________________________________________ - - nbin=size(bins) - if(nbin==0) return -!________________________________________ - - allocate(ibin(n),inew(n),stat=ier) - if(ier /= 0) then - write(stderr,'(2a,i4)') myname_, & - ': allocate() error, stat =',ier - call die(myname_) - endif -!________________________________________ - - do ib=1,nbin - lns(ib)=0 - lcs(ib)=0 - end do -!________________________________________ - ! Count numbers in every bin, and store the bin-ID for - ! later use. - do i=1,n - ix=indx(i) - - call search_(keys(ix),nbin,bins,ib) ! ib = 1:nbin; =0 if not found - - ibin(i)=ib - if(ib /= 0) lns(ib)=lns(ib)+1 - end do -!________________________________________ - ! Count the locations of every bin. - lc0=1 - do ib=1,nbin - lcs(ib)=lc0 - lc0=lc0+lns(ib) - end do -!________________________________________ - ! Reset the counters - ln0=0 - lns(1:nbin)=0 - do i=1,n - ib=ibin(i) ! the bin-index of keys(indx(i)) - if(ib/=0) then - ni=lcs(ib)+lns(ib) - lns(ib)=lns(ib)+1 - else - ni=lc0+ln0 - ln0=ln0+1 - endif - inew(ni)=indx(i) ! the current value is put in the new order - end do -!________________________________________ - ! Sort out the old pointers according to the new order - indx(:)=inew(:) -!________________________________________ - - deallocate(ibin,inew) - -contains -subroutine search_(key,nbin,bins,ib) - implicit none - integer, intent(in) :: key - integer,intent(in) :: nbin - integer, intent(in),dimension(:) :: bins - integer,intent(out) :: ib - integer :: i - - ib=0 - do i=1,nbin - if(key==bins(i)) then - ib=i - return - endif - end do -end subroutine search_ - -end subroutine IndexBin1_ -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: IndexBin1w_ - IndexBin1_ wrapped without working arrays -! -! !DESCRIPTION: -! -! !INTERFACE: - - subroutine IndexBin1w_(n,indx,keys,bins) - use m_stdio, only : stderr - use m_die, only : die - implicit none - - integer, intent(in) :: n - integer,dimension(n),intent(inout) :: indx - integer,dimension(n),intent(in) :: keys - integer,dimension(:),intent(in) :: bins ! values of the bins - -! !REVISION HISTORY: -! 17Feb99 - Jing Guo - initial prototype/prolog/code -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::IndexBin1w_' - integer :: ier - integer,dimension(:),allocatable :: lcs,lns - integer :: nbin - - nbin=size(bins) - if(nbin==0) return - - allocate(lcs(nbin),lns(nbin),stat=ier) - if(ier /= 0) then - write(stderr,'(2a,i4)') myname_,': allocate() error, stat =',ier - call die(myname_) - endif - - call IndexBin1_(n,indx,keys,bins,lcs,lns) - - deallocate(lcs,lns) -end subroutine IndexBin1w_ -end module m_IndexBin_integer diff --git a/cesm/models/utils/mct/mpeu/m_IndexBin_logical.F90 b/cesm/models/utils/mct/mpeu/m_IndexBin_logical.F90 deleted file mode 100644 index 875e61c..0000000 --- a/cesm/models/utils/mct/mpeu/m_IndexBin_logical.F90 +++ /dev/null @@ -1,105 +0,0 @@ -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!----------------------------------------------------------------------- -! CVS $Id$ -! CVS $Name$ -!BOP ------------------------------------------------------------------- -! -! !MODULE: m_IndexBin_logical - Template of indexed bin-sorting module -! -! !DESCRIPTION: -! -! !INTERFACE: - - module m_IndexBin_logical - implicit none - private ! except - - public :: IndexBin - interface IndexBin; module procedure & - IndexBin0_ - end interface - -! !REVISION HISTORY: -! 17Feb99 - Jing Guo - initial prototype/prolog/code -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname='MCT(MPEU)::m_IndexBin_logical' - -contains -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: IndexBin0_ - Indexed sorting for a single value -! -! !DESCRIPTION: -! -! !INTERFACE: - - subroutine IndexBin0_(n,indx,keys,key0,ln0) - use m_stdio, only : stderr - use m_die, only : die - implicit none - - integer, intent(in) :: n - integer, dimension(n), intent(inout) :: indx - logical, dimension(n), intent(in) :: keys - logical, intent(in) :: key0 ! The key value to be moved to front - integer,optional,intent(out) :: ln0 - -! !REVISION HISTORY: -! 16Feb99 - Jing Guo - initial prototype/prolog/code -! 27Sep99 - Jing Guo - Fixed a bug pointed out by -! Chris Redder -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::IndexBin0_' - integer,allocatable,dimension(:) :: inew - integer :: ni,ix,i,ier - integer :: ln(0:1),lc(0:1) -!________________________________________ - - allocate(inew(n),stat=ier) - if(ier /= 0) then - write(stderr,'(2a,i4)') myname_, & - ': allocate() error, stat =',ier - call die(myname_) - endif -!________________________________________ - ! Count numbers entries for the given key0 - - lc(0)=1 ! the location of values the same as key0 - ln(0)=0 - do i=1,n - if(keys(i) .eqv. key0) ln(0)=ln(0)+1 - end do - - lc(1)=ln(0)+1 ! the location of values not the same as key0 -!________________________________________ - ! Reset the counters - ln(0:1)=0 - do i=1,n - ix=indx(i) - if(keys(ix) .eqv. key0) then - ni=lc(0)+ln(0) - ln(0)=ln(0)+1 - - else - ni=lc(1)+ln(1) - ln(1)=ln(1)+1 - endif - - inew(ni)=ix - end do - -!________________________________________ - ! Sort out the old pointers according to the new order - indx(:)=inew(:) - if(present(ln0)) ln0=ln(0) -!________________________________________ - - deallocate(inew) - -end subroutine IndexBin0_ -end module m_IndexBin_logical diff --git a/cesm/models/utils/mct/mpeu/m_List.F90 b/cesm/models/utils/mct/mpeu/m_List.F90 deleted file mode 100644 index 615af1c..0000000 --- a/cesm/models/utils/mct/mpeu/m_List.F90 +++ /dev/null @@ -1,2112 +0,0 @@ -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!----------------------------------------------------------------------- -! CVS $Id$ -! CVS $Name$ -!BOP ------------------------------------------------------------------- -! -! !MODULE: m_List - A List Manager -! -! !DESCRIPTION: A {\em List} is a character buffer comprising -! substrings called {\em items} separated by colons, combined with -! indexing information describing (1) the starting point in the character -! buffer of each substring, and (2) the length of each substring. The -! only constraints on the valid list items are (1) the value of an -! item does not contain the ``\verb":"'' delimitter, and (2) leading -! and trailing blanks are stripped from any character string presented -! to define a list item (although any imbeded blanks are retained). -! -! {\bf Example:} Suppose we wish to define a List containing the -! items {\tt 'latitude'}, {\tt 'longitude'}, and {\tt 'pressure'}. -! The character buffer of the List containing these items will be the -! 27-character string -! \begin{verbatim} -! 'latitude:longitude:pressure' -! \end{verbatim} -! and the indexing information is summarized in the table below. -! -!\begin{table}[htbp] -!\begin{center} -!\begin{tabular}{|c|c|c|} -!\hline -!{\bf Item} & {\bf Starting Point in Buffer} & {\bf Length} \\ -!\hline -!{\tt latitude} & 1 & 8 \\ -!\hline -!{\tt longitude} & 9 & 9 \\ -!\hline -!{\tt pressure} & 20 & 8\\ -!\hline -!\end{tabular} -!\end{center} -!\end{table} -! -! One final note: All operations for the {\tt List} datatype are -! {\bf case sensitive}. -! -! !INTERFACE: - - module m_List - -! !USES: -! -! No other Fortran modules are used. - - implicit none - - private ! except - -! !PUBLIC TYPES: - - public :: List ! The class data structure - - Type List -#ifdef SEQUENCE - sequence -#endif - character(len=1),dimension(:),pointer :: bf - integer, dimension(:,:),pointer :: lc - End Type List - -! !PUBLIC MEMBER FUNCTIONS: - - public :: init - public :: clean - public :: nullify - public :: index - public :: get_indices - public :: test_indices - public :: nitem - public :: get - public :: identical - public :: assignment(=) - public :: allocated - public :: copy - public :: exportToChar - public :: exportToString - public :: CharBufferSize - public :: append - public :: concatenate - public :: bcast - public :: send - public :: recv - public :: GetSharedListIndices - - interface init ; module procedure & - init_, & - initStr_, & - initstr1_ - end interface - interface clean; module procedure clean_; end interface - interface nullify; module procedure nullify_; end interface - interface index; module procedure & - index_, & - indexStr_ - end interface - interface get_indices; module procedure get_indices_; end interface - interface test_indices; module procedure test_indices_; end interface - interface nitem; module procedure nitem_; end interface - interface get ; module procedure & - get_, & - getall_, & - getrange_ - end interface - interface identical; module procedure identical_; end interface - interface assignment(=) - module procedure copy_ - end interface - interface allocated ; module procedure & - allocated_ - end interface - interface copy ; module procedure copy_ ; end interface - interface exportToChar ; module procedure & - exportToChar_ - end interface - interface exportToString ; module procedure & - exportToString_ - end interface - interface CharBufferSize ; module procedure & - CharBufferSize_ - end interface - interface append ; module procedure append_ ; end interface - interface concatenate ; module procedure concatenate_ ; end interface - interface bcast; module procedure bcast_; end interface - interface send; module procedure send_; end interface - interface recv; module procedure recv_; end interface - interface GetSharedListIndices; module procedure & - GetSharedListIndices_ - end interface - -! !REVISION HISTORY: -! 22Apr98 - Jing Guo - initial prototype/prolog/code -! 16May01 - J. Larson - Several changes / fixes: -! public interface for copy_(), corrected version of copy_(), -! corrected version of bcast_(). -! 15Oct01 - J. Larson - Added the LOGICAL -! function identical_(). -! 14Dec01 - J. Larson - Added the LOGICAL -! function allocated_(). -! 13Feb02 - J. Larson - Added the List query -! functions exportToChar() and CharBufferLength(). -! 13Jun02- R.L. Jacob - Move GetSharedListIndices -! from mct to this module. -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname='MCT(MPEU)::m_List' - - contains - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: init_ - Initialize a List from a CHARACTER String -! -! !DESCRIPTION: -! -! A list is a string in the form of ``\verb"Larry:Moe:Curly"'', -! or ``\verb"lat:lon:lev"'', combined with substring location and -! length information. Through the initialization call, the -! items delimited by ``\verb":"'' are stored as an array of sub- -! strings of a long string, accessible through an array of substring -! indices. The only constraints now on the valid list entries are, -! (1) the value of an entry does not contain ``\verb":"'', and (2) -! The leading and the trailing blanks are insignificant, although -! any imbeded blanks are. For example, -! -! \begin{verbatim} -! call init_(aList, 'batman :SUPERMAN:Green Lantern: Aquaman') -! \end{verbatim} -! will result in {\tt aList} having four items: 'batman', 'SUPERMAN', -! 'Green Lantern', and 'Aquaman'. That is -! \begin{verbatim} -! aList%bf = 'batman:SUPERMAN:Green Lantern:Aquaman' -! \end{verbatim} -! -! !INTERFACE: - - subroutine init_(aList,Values) - -! !USES: -! - use m_die,only : die - use m_mall,only : mall_mci,mall_ison - - implicit none - -! !INPUT PARAMETERS: -! - character(len=*),intent(in) :: Values ! ":" delimited names - -! !OUTPUT PARAMETERS: -! - type(List),intent(out) :: aList ! an indexed string values - - -! !REVISION HISTORY: -! 22Apr98 - Jing Guo - initial prototype/prolog/code -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::init_' - character(len=1) :: c - integer :: ib,ie,id,lb,le,ni,i,ier - - ! Pass 1, getting the sizes - le=0 - ni=0 - ib=1 - ie=0 - id=0 - do i=1,len(Values) - c=Values(i:i) - select case(c) - case(' ') - if(ib==i) ib=i+1 ! moving ib up, starting from the next - case(':') - if(ib<=ie) then - ni=ni+1 - id=1 ! mark a ':' - endif - ib=i+1 ! moving ib up, starting from the next - case default - ie=i - if(id==1) then ! count an earlier marked ':' - id=0 - le=le+1 - endif - le=le+1 - end select - end do - if(ib<=ie) ni=ni+1 - - ! COMPILER MAY NOT SIGNAL AN ERROR IF - ! ALIST HAS ALREADY BEEN INITIALIZED. - ! PLEASE CHECK FOR PREVIOUS INITIALIZATION - - allocate(aList%bf(le),aList%lc(0:1,ni),stat=ier) - if(ier /= 0) call die(myname_,'allocate()',ier) - - if(mall_ison()) then - call mall_mci(aList%bf,myname) - call mall_mci(aList%lc,myname) - endif - - ! Pass 2, copy the value and assign the pointers - lb=1 - le=0 - ni=0 - ib=1 - ie=0 - id=0 - do i=1,len(Values) - c=Values(i:i) - - select case(c) - case(' ') - if(ib==i) ib=i+1 ! moving ib up, starting from the next - case(':') - if(ib<=ie) then - ni=ni+1 - aList%lc(0:1,ni)=(/lb,le/) - id=1 ! mark a ':' - endif - - ib=i+1 ! moving ib up, starting from the next - lb=le+2 ! skip to the next non-':' and non-',' - case default - ie=i - if(id==1) then ! copy an earlier marked ':' - id=0 - le=le+1 - aList%bf(le)=':' - endif - - le=le+1 - aList%bf(le)=c - end select - end do - if(ib<=ie) then - ni=ni+1 - aList%lc(0:1,ni)=(/lb,le/) - endif - - end subroutine init_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: initStr_ - Initialize a List Using the String Type -! -! !DESCRIPTION: This routine initializes a {\tt List} datatype given -! an input {\tt String} datatype (see {\tt m\_String} for more -! information regarding the {\tt String} type). The contents of the -! input {\tt String} argument {\tt pstr} must adhere to the restrictions -! stated for character input stated in the prologue of the routine -! {\tt init\_()} in this module. -! -! !INTERFACE: - - subroutine initStr_(aList, pstr) - -! !USES: -! - use m_String, only : String,toChar - - implicit none - -! !INPUT PARAMETERS: -! - type(String),intent(in) :: pstr - -! !OUTPUT PARAMETERS: -! - type(List),intent(out) :: aList ! an indexed string values - - -! !REVISION HISTORY: -! 23Apr98 - Jing Guo - initial prototype/prolog/code -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::initStr_' - - call init_(aList,toChar(pstr)) - - end subroutine initStr_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: initStr1_ - Initialize a List Using an Array of Strings -! -! !DESCRIPTION: This routine initializes a {\tt List} datatype given -! as input array of {\tt String} datatypes (see {\tt m\_String} for more -! information regarding the {\tt String} type). The contents of each -! {\tt String} element of the input array {\tt strs} must adhere to the -! restrictions stated for character input stated in the prologue of the -! routine {\tt init\_()} in this module. Specifically, no element in -! {\tt strs} may contain the colon \verb':' delimiter, and any -! leading or trailing blanks will be stripped (though embedded blank -! spaces will be retained). For example, consider an invocation of -! {\tt initStr1\_()} where the array {\tt strs(:)} contains four entries: -! {\tt strs(1)='John'}, {\tt strs(2)=' Paul'}, -! {\tt strs(3)='George '}, and {\tt strs(4)=' Ringo'}. The resulting -! {\tt List} output {\tt aList} will have -! \begin{verbatim} -! aList%bf = 'John:Paul:George:Ringo' -! \end{verbatim} -! !INTERFACE: - - subroutine initStr1_(aList, strs) - -! !USES: -! - use m_String, only : String,toChar - use m_String, only : len - use m_String, only : ptr_chars - use m_die,only : die - - implicit none - -! !INPUT PARAMETERS: -! - type(String),dimension(:),intent(in) :: strs - -! !OUTPUT PARAMETERS: -! - type(List),intent(out) :: aList ! an indexed string values - - -! !REVISION HISTORY: -! 23Apr98 - Jing Guo - initial prototype/prolog/code -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::initStr1_' - character(len=1),allocatable,dimension(:) :: ch1 - integer :: ier - integer :: n,i,lc,le - - n=size(strs) - le=0 - do i=1,n - le=le+len(strs(i)) - end do - le=le+n-1 ! for n-1 ":"s - - allocate(ch1(le),stat=ier) - if(ier/=0) call die(myname_,'allocate()',ier) - - le=0 - do i=1,n - if(i>1) then - le=le+1 - ch1(le)=':' - endif - - lc=le+1 - le=le+len(strs(i)) - ch1(lc:le)=ptr_chars(strs(i)) - end do - - call init_(aList,toChar(ch1)) - - deallocate(ch1,stat=ier) - if(ier/=0) call die(myname_,'deallocate()',ier) - - end subroutine initStr1_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: clean_ - Deallocate Memory Used by a List -! -! !DESCRIPTION: This routine deallocates the allocated memory components -! of the input/output {\tt List} argument {\tt aList}. Specifically, it -! deallocates {\tt aList\%bf} and {\tt aList\%lc}. If the optional -! output {\tt INTEGER} arguemnt {\tt stat} is supplied, no warning will -! be printed if the Fortran intrinsic {\tt deallocate()} returns with an -! error condition. -! -! !INTERFACE: - - subroutine clean_(aList, stat) - -! !USES: -! - use m_die, only : warn - use m_mall, only : mall_mco,mall_ison - - implicit none - -! !INPUT/OUTPUT PARAMETERS: -! - type(List), intent(inout) :: aList - -! !OUTPUT PARAMETERS: -! - integer, optional, intent(out) :: stat - -! !REVISION HISTORY: -! 22Apr98 - Jing Guo - initial prototype/prolog/code -! 1Mar02 - E.T. Ong - added stat argument and -! removed die to prevent crashes. -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::clean_' - integer :: ier - - if(mall_ison()) then - if(associated(aList%bf)) call mall_mco(aList%bf,myname_) - if(associated(aList%lc)) call mall_mco(aList%lc,myname_) - endif - - if(associated(aList%bf) .and. associated(aList%lc)) then - - deallocate(aList%bf, aList%lc, stat=ier) - - if(present(stat)) then - stat=ier - else - if(ier /= 0) call warn(myname_,'deallocate(aList%...)',ier) - endif - - endif - - end subroutine clean_ - -!--- ------------------------------------------------------------------- -! Math + Computer Science Division / Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: nullify_ - Nullify Pointers in a List -! -! !DESCRIPTION: In Fortran 90, pointers may have three states: -! (1) {\tt ASSOCIATED}, that is the pointer is pointing at a target, -! (2) {\tt UNASSOCIATED}, and (3) {\tt UNINITIALIZED}. On some -! platforms, the Fortran intrinsic function {\tt associated()} -! will view uninitialized pointers as {\tt UNASSOCIATED} by default. -! This is not always the case. It is good programming practice to -! nullify pointers if they are not to be used. This routine nullifies -! the pointers present in the {\tt List} datatype. -! -! !INTERFACE: - - subroutine nullify_(aList) - -! !USES: -! - use m_die,only : die - - implicit none - -! !INPUT/OUTPUT PARAMETERS: -! - type(List),intent(inout) :: aList - -! !REVISION HISTORY: -! 18Jun01 - J.W. Larson - - initial version -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::nullify_' - - nullify(aList%bf) - nullify(aList%lc) - - end subroutine nullify_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: nitem_ - Return the Number of Items in a List -! -! !DESCRIPTION: -! This function enumerates the number of items in the input {\tt List} -! argument {\tt aList}. For example, suppose -! \begin{verbatim} -! aList%bf = 'John:Paul:George:Ringo' -! \end{verbatim} -! Then, -! $${\tt nitem\_(aList)} = 4 .$$ -! -! !INTERFACE: - - integer function nitem_(aList) - -! !USES: -! - implicit none - -! !INPUT PARAMETERS: -! - type(List),intent(in) :: aList - -! !REVISION HISTORY: -! 22Apr98 - Jing Guo - initial prototype/prolog/code -! 10Oct01 - J.W. Larson - modified routine to -! check pointers aList%bf and aList%lc using the f90 -! intrinsic ASSOCIATED before proceeding with the item -! count. If these pointers are UNASSOCIATED, an item -! count of zero is returned. -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::nitem_' - integer :: NumItems - - ! Initialize item count to zero - - NumItems = 0 - - ! If the List pointers are ASSOCIATED, perform item count: - - if(ASSOCIATED(aList%bf) .and. ASSOCIATED(aList%lc)) then - NumItems = size(aList%lc,2) - endif - - nitem_ = NumItems - - end function nitem_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: index_ - Return Rank in a List of a Given Item (CHARACTER) -! -! !DESCRIPTION: -! This function returns the rank of an item (defined by the -! {\tt CHARACTER} argument {\tt item}) in the input {\tt List} argument -! {\tt aList}. If {\tt item} is not present in {\tt aList}, then zero -! is returned. For example, suppose -! \begin{verbatim} -! aList%bf = 'Bob:Carol:Ted:Alice' -! \end{verbatim} -! Then, ${\tt index\_(aList, 'Ted')}=3$, ${\tt index\_(aList, 'Carol')}=2$, -! and ${\tt index\_(aList, 'The Dude')}=0.$ -! -! !INTERFACE: - - integer function index_(aList, item) - -! !USES: -! - use m_String, only : toChar - - implicit none - -! !INPUT PARAMETERS: -! - type(List), intent(in) :: aList ! a List of names - character(len=*),intent(in) :: item ! a given item name - -! !REVISION HISTORY: -! 22Apr98 - Jing Guo - initial prototype/prolog/code -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::index_' - integer :: i,lb,le - integer :: itemLength, length, nMatch, j - - ! How long is the input item name? - - itemLength = len(item) - - ! Set output to zero (no item match) value: - - index_=0 - - ! Now, go through the aList one item at a time - - ITEM_COMPARE: do i=1,size(aList%lc,2) ! == nitem_(aList) - - ! Compute some stats for the current item in aList: - - lb=aList%lc(0,i) ! starting index of item in aList%bf - le=aList%lc(1,i) ! ending index item in aList%bf - - length = le -lb + 1 ! length of the current item - if(length /= itemLength) then ! this list item can't match input item - - CYCLE ! that is, jump to the next item in aList... - - else ! compare one character at a time... - - ! Initialize number of matching characters in the two strings - - nMatch = 0 - - ! Now, compare item to the current item in aList one character - ! at a time: - - CHAR_COMPARE: do j=1,length - if(aList%bf(lb+j-1) == item(j:j)) then ! a match for this character - nMatch = nMatch + 1 - else - EXIT - endif - end do CHAR_COMPARE - - ! Check the number of leading characters in the current item in aList - ! that match the input item. If it is equal to the item length, then - ! we have found a match and are finished. Otherwise, we cycle on to - ! the next item in aList. - - if(nMatch == itemLength) then - index_ = i - EXIT - endif - -! Old code that does not work with V. of the IBM -! if(item==toChar(aList%bf(lb:le))) then -! index_=i -! exit - endif - end do ITEM_COMPARE - - end function index_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: indexStr_ - Return Rank in a List of a Given Item (String) -! -! !DESCRIPTION: -! This function performs the same operation as the function -! {\tt index\_()}, but the item to be indexed is instead presented in -! the form of a {\tt String} datatype (see the module {\tt m\_String} -! for more information about the {\tt String} type). This routine -! searches through the input {\tt List} argument {\tt aList} for an -! item that matches the item defined by {\tt itemStr}, and if a match -! is found, the rank of the item in the list is returned (see also the -! prologue for the routine {\tt index\_()} in this module). If no match -! is found, a value of zero is returned. -! -! !INTERFACE: - - integer function indexStr_(aList, itemStr) - -! !USES: -! - use m_String,only : String,toChar - - implicit none - -! !INPUT PARAMETERS: -! - type(List), intent(in) :: aList ! a List of names - type(String), intent(in) :: itemStr - -! !REVISION HISTORY: -! 22Apr98 - Jing Guo - initial prototype/prolog/code -! 25Oct02 - R. Jacob - just call index_ above -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::indexStr_' - - indexStr_=0 - indexStr_=index_(aList,toChar(itemStr)) - - end function indexStr_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: allocated_ - Check Pointers in a List for Association Status -! -! !DESCRIPTION: -! This function checks the input {\tt List} argument {\tt inList} to -! determine whether or not it has been allocated. It does this by -! invoking the Fortran90 intrinsic function {\tt associated()} on the -! pointers {\tt inList\%bf} and {\tt inList\%lc}. If both of these -! pointers are associated, the return value is {\tt .TRUE.}. -! -! {\bf N.B.:} In Fortran90, pointers have three different states: -! {\tt ASSOCIATED}, {\tt UNASSOCIATED}, and {\tt UNDEFINED}. -! If a pointer is {\tt UNDEFINED}, this function may return either -! {\tt .TRUE.} or {\tt .FALSE.} values, depending on the Fortran90 -! compiler. To avoid such problems, we advise that users invoke the -! {\tt List} method {\tt nullify()} to nullify any {\tt List} pointers -! for {\tt List} variables that are not initialized. -! -! !INTERFACE: - - logical function allocated_(inList) - -! !USES: - - use m_die,only : die - - implicit none - -! !INPUT PARAMETERS: - - type(List), intent(in) :: inList - -! !REVISION HISTORY: -! 14Dec01 - J. Larson - inital version -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::allocated_' - - allocated_ = associated(inList%bf) .and. associated(inList%lc) - - end function allocated_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: copy_ - Copy a List -! -! !DESCRIPTION: -! This routine copies the contents of the input {\tt List} argument -! {\tt xL} into the output {\tt List} argument {\tt yL}. -! -! !INTERFACE: - - subroutine copy_(yL,xL) ! yL=xL - -! !USES: -! - use m_die,only : die - use m_stdio - use m_String ,only : String - use m_String ,only : String_clean - use m_mall,only : mall_mci,mall_ison - - implicit none - -! !INPUT PARAMETERS: -! - type(List),intent(in) :: xL - -! !OUTPUT PARAMETERS: -! - type(List),intent(out) :: yL - - -! !REVISION HISTORY: -! 22Apr98 - Jing Guo - initial prototype/prolog/code -! 16May01 - J. Larson - simpler, working -! version that exploits the String datatype (see m_String) -! 1Aug02 - Larson/Ong - Added logic for correct copying of blank -! Lists. -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::copy_' - type(String) DummStr - - if(size(xL%lc,2) > 0) then - - ! Download input List info from xL to String DummStr - - call getall_(DummStr,xL) - - ! Initialize yL from DummStr - - call initStr_(yL,DummStr) - - call String_clean(DummStr) - - else - if(size(xL%lc,2) < 0) then ! serious error... - write(stderr,'(2a,i8)') myname_, & - ':: FATAL size(xL%lc,2) = ',size(xL%lc,2) - endif - ! Initialize yL as a blank list - call init_(yL, ' ') - endif - - end subroutine copy_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: exportToChar_ - Export List to a CHARACTER -! -! !DESCRIPTION: This function returns the character buffer portion of -! the input {\tt List} argument {\tt inList}---that is, the contents of -! {\tt inList\%bf}---as a {\tt CHARACTER} (suitable for printing). An -! example of the use of this function is: -! \begin{verbatim} -! write(stdout,'(1a)') exportToChar(inList) -! \end{verbatim} -! which writes the contents of {\tt inList\%bf} to the Fortran device -! {\tt stdout}. -! -! !INTERFACE: - - function exportToChar_(inList) - -! !USES: -! - use m_die, only : die - use m_stdio, only : stderr - use m_String, only : String - use m_String, only : String_ToChar => toChar - use m_String, only : String_clean - - implicit none - -! ! INPUT PARAMETERS: - - type(List), intent(in) :: inList - -! ! OUTPUT PARAMETERS: - - character(len=size(inList%bf,1)) :: exportToChar_ - -! !REVISION HISTORY: -! 13Feb02 - J. Larson - initial version. -! 06Jun03 - R. Jacob - return blank if List is not allocated -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::exportToChar_' - type(String) DummStr - - ! Download input List info from inList to String DummStr - if(allocated_(inList)) then - call getall_(DummStr,inList) - exportToChar_ = String_ToChar(DummStr) - call String_clean(DummStr) - else - exportToChar_ = '' - endif - - end function exportToChar_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: exportToString_ - Export List to a String -! -! !DESCRIPTION: This function returns the character buffer portion of -! the input {\tt List} argument {\tt inList}---that is, the contents of -! {\tt inList\%bf}---as a {\tt String} (see the mpeu module m\_String -! for more information regarding the {\tt String} type). This function -! was created to circumvent problems with implementing inheritance of -! the function {\tt exportToChar\_()} to other datatypes build on top -! of the {\tt List} type. -! -! !INTERFACE: - - function exportToString_(inList) - -! !USES: -! - use m_die, only : die - use m_stdio, only : stderr - - use m_String, only : String - use m_String, only : String_init => init - - implicit none - -! ! INPUT PARAMETERS: - - type(List), intent(in) :: inList - -! ! OUTPUT PARAMETERS: - - type(String) :: exportToString_ - -! !REVISION HISTORY: -! 14Aug02 - J. Larson - initial version. -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::exportToString_' - - if(allocated_(inList)) then - call getall_(exportToString_, inList) - else - call String_init(exportToString_, 'NOTHING') - endif - - end function exportToString_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: CharBufferSize_ - Return size of a List's Character Buffer -! -! !DESCRIPTION: This function returns the length of the character -! buffer portion of the input {\tt List} argument {\tt inList} (that -! is, the number of characters stored in {\tt inList\%bf}) as an -! {\tt INTEGER}. Suppose for the sake of argument that {\tt inList} -! was created using the following call to {\tt init\_()}: -! \begin{verbatim} -! call init_(inList, 'Groucho:Harpo:Chico:Zeppo') -! \end{verbatim} -! Then, using the above example value of {\tt inList}, we can use -! {\tt CharBufferSize\_()} as follows: -! \begin{verbatim} -! integer :: BufferLength -! BufferLength = CharBufferSize(inList) -! \end{verbatim} -! and the resulting value of {\tt BufferLength} will be 25. -! -! !INTERFACE: - - integer function CharBufferSize_(inList) - -! !USES: -! - use m_die, only : die - use m_stdio, only : stderr - - implicit none - -! ! INPUT PARAMETERS: - - type(List), intent(in) :: inList - -! !REVISION HISTORY: -! 13Feb02 - J. Larson - initial version. -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::CharBufferSize_' - - if(allocated_(inList)) then - CharBufferSize_ = size(inList%bf) - else - write(stderr,'(2a)') myname_,":: Argument inList not allocated." - call die(myname_) - endif - - end function CharBufferSize_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: get_ - Retrieve a Numbered Item from a List as a String -! -! !DESCRIPTION: -! This routine retrieves a numbered item (defined by the input -! {\tt INTEGER} argument {\tt ith}) from the input {\tt List} argument -! {\tt aList}, and returns it in the output {\tt String} argument -! {\tt itemStr} (see the module {\tt m\_String} for more information -! about the {\tt String} type). If the argument {\tt ith} is nonpositive, -! or greater than the number of items in {\tt aList}, a String containing -! one blank space is returned. -! -! !INTERFACE: - - subroutine get_(itemStr, ith, aList) - -! !USES: -! - use m_String, only : String, init, toChar - - implicit none - -! !INPUT PARAMETERS: -! - integer, intent(in) :: ith - type(List), intent(in) :: aList - -! !OUTPUT PARAMETERS: -! - type(String),intent(out) :: itemStr - - -! !REVISION HISTORY: -! 23Apr98 - Jing Guo - initial prototype/prolog/code -! 14May07 - Larson, Jacob - add space to else case string so function -! matches documentation. -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::get_' - integer :: lb,le - - if(ith>0 .and. ith <= size(aList%lc,2)) then - lb=aList%lc(0,ith) - le=aList%lc(1,ith) - call init(itemStr,toChar(aList%bf(lb:le))) - else - call init(itemStr,' ') - endif - - end subroutine get_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: getall_ - Return all Items from a List as one String -! -! !DESCRIPTION: -! This routine returns all the items from the input {\tt List} argument -! {\tt aList} in the output {\tt String} argument {\tt itemStr} (see -! the module {\tt m\_String} for more information about the {\tt String} -! type). The contents of the character buffer in {\tt itemStr} will -! be the all of the items in {\tt aList}, separated by the colon delimiter. -! -! !INTERFACE: - - subroutine getall_(itemStr, aList) - -! !USES: -! - use m_String, only : String, init, toChar - - implicit none - -! !INPUT PARAMETERS: -! - type(List), intent(in) :: aList - -! !OUTPUT PARAMETERS: -! - type(String), intent(out) :: itemStr - - -! !REVISION HISTORY: -! 23Apr98 - Jing Guo - initial prototype/prolog/code -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::getall_' - integer :: lb,le,ni - - ni=size(aList%lc,2) - lb=aList%lc(0,1) - le=aList%lc(1,ni) - call init(itemStr,toChar(aList%bf(lb:le))) - - end subroutine getall_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: getrange_ - Return a Range of Items from a List as one String -! -! !DESCRIPTION: -! This routine returns all the items ranked {\tt i1} through {\tt i2} -! from the input {\tt List} argument {\tt aList} in the output -! {\tt String} argument {\tt itemStr} (see the module {\tt m\_String} -! for more information about the {\tt String} type). The contents of -! the character buffer in {\tt itemStr} will be items in {\tt i1} through -! {\tt i2} {\tt aList}, separated by the colon delimiter. -! -! !INTERFACE: - - subroutine getrange_(itemStr, i1, i2, aList) - -! !USES: -! - use m_die, only : die - use m_stdio, only : stderr - use m_String, only : String,init,toChar - - implicit none - -! !INPUT PARAMETERS: -! - integer, intent(in) :: i1 - integer, intent(in) :: i2 - type(List), intent(in) :: aList - -! !OUTPUT PARAMETERS: -! - type(String),intent(out) :: itemStr - -! !REVISION HISTORY: -! 23Apr98 - Jing Guo - initial prototype/prolog/code -! 26Jul02 - J. Larson - Added argument checks. -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::getrange_' - integer :: lb,le,ni - - ! Argument Sanity Checks: - - if(.not. allocated_(aList)) then - write(stderr,'(2a)') myname_, & - ':: FATAL--List argument aList is not initialized.' - call die(myname_) - endif - - ! is i2 >= i1 as we assume? - - if(i1 > i2) then - write(stderr,'(2a,2(a,i8))') myname_, & - ':: FATAL. Starting/Ending item ranks are out of order; ', & - 'i2 must be greater or equal to i1. i1 =',i1,' i2 = ',i2 - call die(myname_) - endif - - ni=size(aList%lc,2) ! the number of items in aList... - - ! is i1 or i2 too big? - - if(i1 > ni) then - write(stderr,'(2a,2(a,i8))') myname_, & - ':: FATAL--i1 is greater than the number of items in ', & - 'The List argument aList: i1 =',i1,' ni = ',ni - call die(myname_) - endif - - if(i2 > ni) then - write(stderr,'(2a,2(a,i8))') myname_, & - ':: FATAL--i2 is greater than the number of items in ', & - 'The List argument aList: i2 =',i2,' ni = ',ni - call die(myname_) - endif - - ! End of Argument Sanity Checks. - - lb=aList%lc(0,max(1,i1)) - le=aList%lc(1,min(ni,i2)) - call init(itemStr,toChar(aList%bf(lb:le))) - - end subroutine getrange_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: identical_ - Compare Two Lists for Equality -! -! !DESCRIPTION: -! This function compares the string buffer and indexing information in -! the two input {\tt List} arguments {\tt yL} and {\tt xL}. If the -! string buffers and index buffers of {\tt yL} and {\tt xL} match, this -! function returns a value of {\tt .TRUE.} Otherwise, it returns a -! value of {\tt .FALSE.} -! -! !INTERFACE: - - logical function identical_(yL, xL) - -! !USES: -! - use m_die,only : die - use m_String ,only : String - use m_String ,only : String_clean - - implicit none - -! !INPUT PARAMETERS: -! - type(List), intent(in) :: yL - type(List), intent(in) :: xL - -! !REVISION HISTORY: -! 14Oct01 - J. Larson - original version -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::identical_' - - logical :: myIdentical - type(String) :: DummStr - integer :: n, NumItems - - ! Compare the number of the items in the Lists xL and yL. - ! If they differ, myIdentical is set to .FALSE. and we are - ! finished. If both Lists sport the same number of items, - ! we must compare them one-by-one... - - myIdentical = .FALSE. - - if(nitem_(yL) == nitem_(xL)) then - - NumItems = nitem_(yL) - - COMPARE_LOOP: do n=1,NumItems - - call get_(DummStr, n, yL) ! retrieve nth tag as a String - - if( indexStr_(xL, Dummstr) /= n ) then ! a discrepency spotted. - call String_clean(Dummstr) - myIdentical = .FALSE. - EXIT - else - call String_clean(Dummstr) - endif - - myIdentical = .TRUE. ! we survived the whole test process. - - end do COMPARE_LOOP - - endif - - identical_ = myIdentical - - end function identical_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: get_indices_ - Index Multiple Items in a List -! -! !DESCRIPTION: This routine takes as input a {\tt List} argument -! {\tt aList}, and a {\tt CHARACTER} string {Values}, which is a colon- -! delimited string of items, and returns an {\tt INTEGER} array -! {\tt indices(:)}, which contain the rank of each item in {\tt aList}. -! For example, suppose {\tt aList} was created from the character string -! \begin{verbatim} -! 'happy:sleepy:sneezey:grumpy:dopey::bashful:doc' -! \end{verbatim} -! and get\_indices\_() is invoked as follows: -! \begin{verbatim} -! call get_indices_(indices, aList, 'sleepy:grumpy:bashful:doc') -! \end{verbatim} -! The array {\tt indices(:)} will be returned with 4 entries: -! ${\tt indices(1)}=2$, ${\tt indices(2)}=4$, ${\tt indices(3)}=6$, and -! ${\tt indices(4)}=7$. -! -! {\bf N.B.}: This routine operates on the assumption that each of the -! substrings in the colon-delimited string {\tt Values} is an item in -! {\tt aList}. If this assumption is invalid, this routine terminates -! execution with an error message. -! -! {\bf N.B.}: The pointer {\tt indices} must be {\tt UNASSOCIATED} on entry -! to this routine, and will be {\tt ASSOCIATED} upon return. After this pointer -! is no longer needed, it should be deallocated. Failure to do so will result -! in a memory leak. -! -! !INTERFACE: - - subroutine get_indices_(indices, aList, Values) - -! !USES: -! - use m_stdio - use m_die - use m_String, only : String - use m_String, only : String_clean => clean - use m_String, only : String_toChar => toChar - - implicit none - -! !INPUT PARAMETERS: -! - type(List), intent(in) :: aList ! an indexed string values - character(len=*), intent(in) :: Values ! ":" delimited names - -! !OUTPUT PARAMETERS: -! - integer, dimension(:), pointer :: indices - -! !REVISION HISTORY: -! 31May98 - Jing Guo - initial prototype/prolog/code -! 12Feb03 - J. Larson Working refactored version -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::get_indices_' - type(List) :: tList - type(String) :: tStr - integer :: i, ierr, n - - ! Create working list based on input colon-delimited string - - call init_(tList, values) - - - ! Count items in tList and allocate indices(:) accordingly - - n = nitem_(tList) - - if(n > nitem_(aList)) then - write(stderr,'(5a,2(i8,a))') myname_, & - ':: FATAL--more items in argument Values than aList! Input string', & - 'Values = "',Values,'" has ',n,' items. aList has ',nitem_(aList), & - ' items.' - call die(myname_) - endif - allocate(indices(n), stat=ierr) - if(ierr /= 0) then - write(stderr,'(2a,i8,a)') myname_, & - ':: FATAL--allocate(indices(...) failed with stat=',ierr,& - '. On entry to this routine, this pointer must be NULL.' - call die(myname_) - endif - - ! Retrieve each item from tList as a String and index it - - do i=1,n - call get_(tStr,i,tList) - indices(i) = indexStr_(aList,tStr) - if(indices(i) == 0) then ! ith item not present in aList! - write(stderr,'(4a)') myname_, & - ':: FATAL--item "',String_toChar(tStr),'" not found.' - call die(myname_) - endif - call String_clean(tStr) - end do - - ! Clean up temporary List tList - - call clean_(tList) - - end subroutine get_indices_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: test_indices_ - Test/Index Multiple Items in a List -! -! !DESCRIPTION: This routine takes as input a {\tt List} argument -! {\tt aList}, and a {\tt CHARACTER} string {Values}, which is a colon- -! delimited string of items, and returns an {\tt INTEGER} array -! {\tt indices(:)}, which contain the rank of each item in {\tt aList}. -! For example, suppose {\tt aList} was created from the character string -! \begin{verbatim} -! 'happy:sleepy:sneezey:grumpy:dopey::bashful:doc' -! \end{verbatim} -! and {\tt test\_indices\_()} is invoked as follows: -! \begin{verbatim} -! call test_indices_(indices, aList, 'sleepy:grumpy:bashful:doc') -! \end{verbatim} -! The array {\tt indices(:)} will be returned with 4 entries: -! ${\tt indices(1)}=2$, ${\tt indices(2)}=4$, ${\tt indices(3)}=6$, and -! ${\tt indices(4)}=7$. -! -! Now suppose {\tt test\_indices\_()} is invoked as follows: -! \begin{verbatim} -! call test_indices_(indices, aList, 'sleepy:grumpy:bashful:Snow White') -! \end{verbatim} -! The array {\tt indices(:)} will be returned with 4 entries: -! ${\tt indices(1)}=2$, ${\tt indices(2)}=4$, ${\tt indices(3)}=6$, and -! ${\tt indices(4)}=0$. -! -! {\bf N.B.}: This routine operates on the assumption that one or more -! of the substrings in the colon-delimited string {\tt Values} is may not -! be an item in {\tt aList}. If an item in {\tt Values} is {\em not} in -! {\tt aList}, its corresponding entry in {\tt indices(:)} is set to zero. -! -! {\bf N.B.}: The pointer {\tt indices} must be {\tt UNASSOCIATED} on entry -! to this routine, and will be {\tt ASSOCIATED} upon return. After this pointer -! is no longer needed, it should be deallocated. Failure to do so will result -! in a memory leak. -! -! !INTERFACE: - - subroutine test_indices_(indices, aList, Values) - -! !USES: -! - use m_stdio - use m_die - use m_String, only : String - use m_String, only : String_clean => clean - use m_String, only : String_toChar => toChar - - implicit none - -! !INPUT PARAMETERS: -! - type(List), intent(in) :: aList ! an indexed string values - character(len=*), intent(in) :: Values ! ":" delimited names - -! !OUTPUT PARAMETERS: -! - integer, dimension(:), pointer :: indices - -! !REVISION HISTORY: -! 12Feb03 - J. Larson Working refactored version -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::test_indices_' - type(List) :: tList - type(String) :: tStr - integer :: i, ierr, n - - ! Create working list based on input colon-delimited string - - call init_(tList, values) - - - ! Count items in tList and allocate indices(:) accordingly - - n = nitem_(tList) - allocate(indices(n), stat=ierr) - if(ierr /= 0) then - write(stderr,'(2a,i8,a)') myname_, & - ':: FATAL--allocate(indices(...) failed with stat=',ierr,& - '. On entry to this routine, this pointer must be NULL.' - call die(myname_) - endif - - ! Retrieve each item from tList as a String and index it - - do i=1,n - call get_(tStr,i,tList) - indices(i) = indexStr_(aList,tStr) - call String_clean(tStr) - end do - - ! Clean up temporary List tList - - call clean_(tList) - - end subroutine test_indices_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: append_ - Append One List Onto the End of Another -! -! !DESCRIPTION: This routine takes two {\tt List} arguments -! {\tt iList1} and {\tt iList2}, and appends {\tt List2} onto -! the end of {\tt List1}. -! -! {\bf N.B.}: There is no check for shared items in the arguments -! {\tt List1} and {\tt List2}. It is the user's responsibility to -! ensure {\tt List1} and {\tt List2} share no items. If this routine -! is invoked in such a manner that {\tt List1} and {\tt List2} share -! common items, the resultant value of {\tt List1} will produce -! ambiguous results for some of the {\tt List} query functions. -! -! {\bf N.B.}: The outcome of this routine is order dependent. That is, -! the entries of {\tt iList2} will follow the {\em input} entries in -! {\tt iList1}. -! -! !INTERFACE: - - subroutine append_(iList1, iList2) -! -! !USES: -! - use m_stdio - use m_die, only : die - - use m_mpif90 - - use m_String, only: String - use m_String, only: String_toChar => toChar - use m_String, only: String_len - use m_String, only: String_clean => clean - - implicit none - -! !INPUT PARAMETERS: -! - type(List), intent(in) :: iList2 - -! !INPUT/OUTPUT PARAMETERS: -! - type(List), intent(inout) :: iList1 - -! !REVISION HISTORY: -! 6Aug02 - J. Larson - Initial version -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::append_' - - type(List) :: DummyList - - call copy_(DummyList, iList1) - call clean_(iList1) - call concatenate(DummyList, iList2, iList1) - call clean_(DummyList) - - end subroutine append_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: concatenate_ - Concatenates two Lists to form a Third List. -! -! !DESCRIPTION: This routine takes two input {\tt List} arguments -! {\tt iList1} and {\tt iList2}, and concatenates them, producing an -! output {\tt List} argument {\tt oList}. -! -! {\bf N.B.}: The nature of this routine is such that one must -! {\bf never} supply as the actual value of {\tt oList} the same -! value supplied for either {\tt iList1} or {\tt iList2}. -! -! {\bf N.B.}: The outcome of this routine is order dependent. That is, -! the entries of {\tt iList2} will follow {\tt iList1}. -! -! !INTERFACE: - - subroutine concatenate_(iList1, iList2, oList) -! -! !USES: -! - use m_stdio - use m_die, only : die - - use m_mpif90 - - use m_String, only: String - use m_String, only: String_init => init - use m_String, only: String_clean => clean - - implicit none - -! !INPUT PARAMETERS: -! - type(List), intent(in) :: iList1 - type(List), intent(in) :: iList2 - -! !OUTPUT PARAMETERS: -! - type(List), intent(out) :: oList - -! !BUGS: For now, the List concatenate algorithm relies on fixed-length -! CHARACTER variables as intermediate storage. The lengths of these -! scratch variables is hard-wired to 10000, which should be large enough -! for most applications. This undesirable feature should be corrected -! ASAP. -! -! !REVISION HISTORY: -! 8May01 - J.W. Larson - initial version. -! 17May01 - J.W. Larson - Re-worked and tested successfully. -! 17Jul02 - E. Ong - fixed the bug mentioned above -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::concatenate_' - - character, dimension(:), allocatable :: CatBuff - integer :: CatBuffLength, i, ierr, Length1, Length2 - type(String) :: CatString - - ! First, handle the case of either iList1 and/or iList2 being - ! null - - if((nitem_(iList1) == 0) .or. (nitem_(iList2) == 0)) then - - if((nitem_(iList1) == 0) .and. (nitem_(iList2) == 0)) then - call init_(oList,'') - else - if((nitem_(iList1) == 0) .and. (nitem_(iList2) > 0)) then - call copy_(oList, iList2) - endif - if((nitem_(iList1) > 0) .and. (nitem_(iList2) == 0)) then - call copy_(oList,iList1) - endif - endif - - else ! both lists are non-null - - ! Step one: Get lengths of character buffers of iList1 and iList2: - - Length1 = CharBufferSize_(iList1) - Length2 = CharBufferSize_(iList2) - - ! Step two: create CatBuff(:) as workspace - - CatBuffLength = Length1 + Length2 + 1 - allocate(CatBuff(CatBuffLength), stat=ierr) - if(ierr /= 0) then - write(stderr,'(2a,i8)') myname_, & - ':: FATAL--allocate(CatBuff(...) failed. ierr=',ierr - call die(myname_) - endif - - ! Step three: concatenate CHARACTERs with the colon separator - ! into CatBuff(:) - - do i=1,Length1 - CatBuff(i) = iList1%bf(i) - end do - - CatBuff(Length1 + 1) = ':' - - do i=1,Length2 - CatBuff(Length1 + 1 + i) = iList2%bf(i) - end do - - ! Step four: initialize a String CatString: - - call String_init(CatString, CatBuff) - - ! Step five: initialize oList: - - call initStr_(oList, CatString) - - ! The concatenation is complete. Now, clean up - - call String_clean(CatString) - - deallocate(CatBuff,stat=ierr) - if(ierr /= 0) then - write(stderr,'(2a,i8)') myname_, & - ':: FATAL--deallocate(CatBuff) failed. ierr=',ierr - call die(myname_) - endif - - endif - - end subroutine concatenate_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: bcast_ - MPI Broadcast for the List Type -! -! !DESCRIPTION: This routine takes an input {\tt List} argument -! {\tt iList} (on input, valid on the root only), and broadcasts it. -! -! {\bf N.B.}: The outcome of this routine, {\tt ioList} on non-root -! processes, represents allocated memory. When this {\tt List} is -! no longer needed, it must be deallocated by invoking the routine -! {\tt List\_clean()}. Failure to do so will cause a memory leak. -! -! !INTERFACE: - - subroutine bcast_(ioList, root, comm, status) -! -! !USES: -! - use m_stdio, only : stderr - use m_die, only : MP_perr_die, die - - use m_String, only: String - use m_String, only: String_bcast => bcast - use m_String, only: String_clean => clean - - use m_mpif90 - - implicit none - -! !INPUT PARAMETERS: -! - integer, intent(in) :: root - integer, intent(in) :: comm - -! !INPUT/OUTPUT PARAMETERS: -! - type(List), intent(inout) :: ioList - - -! !OUTPUT PARAMETERS: -! - integer, optional, intent(out) :: status - -! !REVISION HISTORY: -! 7May01 - J.W. Larson - initial version. -! 14May01 - R.L. Jacob - fix error checking -! 16May01 - J.W. Larson - new, simpler String-based algorigthm -! (see m_String for details), which works properly on -! the SGI platform. -! 13Jun01 - J.W. Larson - Initialize status -! (if present). -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::bcast_' - integer :: myID, ierr - type(String) :: DummStr - - ! Initialize status (if present) - - if(present(status)) status = 0 - - ! Which process am I? - - call MPI_COMM_RANK(comm, myID, ierr) - if(ierr /= 0) then - if(present(status)) then - status = ierr - write(stderr,'(2a,i4)') myname_,":: MPI_COMM_RANK(), ierr=",ierr - return - else - call MP_perr_die(myname_,"MPI_COMM_RANK()",ierr) - endif - endif - - ! on the root, convert ioList into the String variable DummStr - - if(myID == root) then - if(CharBufferSize_(ioList) <= 0) then - call die(myname_, 'Attempting to broadcast an empty list!',& - CharBufferSize_(ioList)) - endif - call getall_(DummStr, ioList) - endif - - ! Broadcast DummStr - - call String_bcast(DummStr, root, comm, ierr) - if(ierr /= 0) then - if(present(status)) then - status = ierr - write(stderr,'(2a,i4)') myname_,":: call String_bcast(), ierr=",ierr - return - else - call MP_perr_die(myname_,"String_bcast() failed, stat=",ierr) - endif - endif - - ! Initialize ioList off the root using DummStr - - if(myID /= root) then - call initStr_(ioList, DummStr) - endif - - ! And now, the List broadcast is complete. - - call String_clean(DummStr) - - end subroutine bcast_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: send_ - MPI Point-to-Point Send for the List Type -! -! !DESCRIPTION: This routine takes an input {\tt List} argument -! {\tt inList} and sends it to processor {\tt dest} on the communicator -! associated with the fortran 90 {\tt INTEGER} handle {\tt comm}. The -! message is tagged by the input {\tt INTEGER} argument {\tt TagBase}. -! The success (failure) of this operation is reported in the zero -! (nonzero) optional output argument {\tt status}. -! -! {\bf N.B.}: One must avoid assigning elsewhere the MPI tag values -! {\tt TagBase} and {\tt TagBase+1}. This is because {\tt send\_()} -! performs the send of the {\tt List} as a pair of operations. The -! first send is the number of characters in {\tt inList\%bf}, and is -! given MPI tag value {\tt TagBase}. The second send is the -! {\tt CHARACTER} data present in {\tt inList\%bf}, and is given MPI -! tag value {\tt TagBase+1}. -! -! !INTERFACE: - - subroutine send_(inList, dest, TagBase, comm, status) -! -! !USES: -! - use m_stdio - use m_die, only : MP_perr_die - - use m_mpif90 - - use m_String, only: String - use m_String, only: String_toChar => toChar - use m_String, only: String_len - use m_String, only: String_clean => clean - - implicit none - -! !INPUT PARAMETERS: -! - type(List), intent(in) :: inList - integer, intent(in) :: dest - integer, intent(in) :: TagBase - integer, intent(in) :: comm - -! !OUTPUT PARAMETERS: -! - integer, optional, intent(out) :: status - -! !REVISION HISTORY: -! 6Jun01 - J.W. Larson - initial version. -! 13Jun01 - J.W. Larson - Initialize status -! (if present). -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::send_' - - type(String) :: DummStr - integer :: ierr, length - - ! Set status flag to zero (success) if present: - - if(present(status)) status = 0 - - ! Step 1. Extract CHARACTER buffer from inList and store it - ! in String variable DummStr, determine its length. - - call getall_(DummStr, inList) - length = String_len(DummStr) - - ! Step 2. Send Length of String DummStr to process dest. - - call MPI_SEND(length, 1, MP_type(length), dest, TagBase, comm, ierr) - if(ierr /= 0) then - if(present(status)) then - write(stderr,'(2a,i8)') myname_, & - ':: MPI_SEND(length...) failed. ierror=', ierr - status = ierr - return - else - call MP_perr_die(myname_,':: MPI_SEND(length...) failed',ierr) - endif - endif - - ! Step 3. Send CHARACTER portion of String DummStr - ! to process dest. - - call MPI_SEND(DummStr%c(1), length, MP_CHARACTER, dest, TagBase+1, & - comm, ierr) - if(ierr /= 0) then - if(present(status)) then - write(stderr,'(2a,i8)') myname_, & - ':: MPI_SEND(DummStr%c...) failed. ierror=', ierr - status = ierr - return - else - call MP_perr_die(myname_,':: MPI_SEND(DummStr%c...) failed',ierr) - endif - endif - - end subroutine send_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: recv_ - MPI Point-to-Point Receive for the List Type -! -! !DESCRIPTION: This routine receives the output {\tt List} argument -! {\tt outList} from processor {\tt source} on the communicator associated -! with the fortran 90 {\tt INTEGER} handle {\tt comm}. The message is -! tagged by the input {\tt INTEGER} argument {\tt TagBase}. The success -! (failure) of this operation is reported in the zero (nonzero) optional -! output argument {\tt status}. -! -! {\bf N.B.}: One must avoid assigning elsewhere the MPI tag values -! {\tt TagBase} and {\tt TagBase+1}. This is because {\tt recv\_()} -! performs the receive of the {\tt List} as a pair of operations. The -! first receive is the number of characters in {\tt outList\%bf}, and -! is given MPI tag value {\tt TagBase}. The second receive is the -! {\tt CHARACTER} data present in {\tt outList\%bf}, and is given MPI -! tag value {\tt TagBase+1}. -! -! !INTERFACE: - - subroutine recv_(outList, source, TagBase, comm, status) -! -! !USES: -! - use m_stdio, only : stderr - use m_die, only : MP_perr_die - - use m_mpif90 - - use m_String, only : String - - implicit none - -! !INPUT PARAMETERS: -! - integer, intent(in) :: source - integer, intent(in) :: TagBase - integer, intent(in) :: comm - -! !OUTPUT PARAMETERS: -! - type(List), intent(out) :: outList - integer, optional, intent(out) :: status - -! !REVISION HISTORY: -! 6Jun01 - J.W. Larson - initial version. -! 11Jun01 - R. Jacob - small bug fix; status in MPI_RECV -! 13Jun01 - J.W. Larson - Initialize status -! (if present). -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::recv_' - - integer :: ierr, length - integer :: MPstatus(MP_STATUS_SIZE) - type(String) :: DummStr - - ! Initialize status to zero (success), if present. - - if(present(status)) status = 0 - - ! Step 1. Receive Length of String DummStr from process source. - - call MPI_RECV(length, 1, MP_type(length), source, TagBase, comm, & - MPstatus, ierr) - if(ierr /= 0) then - if(present(status)) then - write(stderr,'(2a,i8)') myname_, & - ':: MPI_RECV(length...) failed. ierror=', ierr - status = ierr - return - else - call MP_perr_die(myname_,':: MPI_RECV(length...) failed',ierr) - endif - endif - - allocate(DummStr%c(length), stat=ierr) - - ! Step 2. Send CHARACTER portion of String DummStr - ! to process dest. - - call MPI_RECV(DummStr%c(1), length, MP_CHARACTER, source, TagBase+1, & - comm, MPstatus, ierr) - if(ierr /= 0) then - if(present(status)) then - write(stderr,'(2a,i8)') myname_, & - ':: MPI_RECV(DummStr%c...) failed. ierror=', ierr - status = ierr - return - else - call MP_perr_die(myname_,':: MPI_RECV(DummStr%c...) failed',ierr) - endif - endif - - ! Step 3. Initialize outList. - - call initStr_(outList, DummStr) - - end subroutine recv_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: GetSharedListIndices_ - Index Shared Items for Two Lists -! -! !DESCRIPTION: {\tt GetSharedListIndices\_()} compares two user- -! supplied {\tt List} arguments {\tt List1} and {\tt Lis2} to determine: -! the number of shared items {\tt NumShared}, and arrays of the locations -! {\tt Indices1} and {\tt Indices2} in {\tt List1} and {\tt List2}, -! respectively. -! -! {\bf N.B.:} This routine returns two allocated arrays: {\tt Indices1(:)} -! and {\tt Indices2(:)}. Both of these arrays must be deallocated once they -! are no longer needed. Failure to do this will create a memory leak. -! -! !INTERFACE: - - subroutine GetSharedListIndices_(List1, List2, NumShared, Indices1, & - Indices2) - -! -! !USES: -! - use m_die, only : MP_perr_die, die, warn - - use m_String, only : String - use m_String, only : String_clean => clean - - implicit none - -! !INPUT PARAMETERS: -! - type(List), intent(in) :: List1 - type(List), intent(in) :: List2 - -! !OUTPUT PARAMETERS: -! - integer, intent(out) :: NumShared - - integer,dimension(:), pointer :: Indices1 - integer,dimension(:), pointer :: Indices2 - -! !REVISION HISTORY: -! 7Feb01 - J.W. Larson - initial version -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::GetSharedListIndices_' - -! Error flag - integer :: ierr - -! number of items in List1 and List2, respectively: - integer :: nitem1, nitem2 - -! MAXIMUM number of matches possible: - integer :: NumSharedMax - -! Temporary storage for a string tag retrieved from a list: - type(String) :: tag - -! Loop counters / temporary indices: - integer :: n1, n2 - - ! Determine the number of items in each list: - - nitem1 = nitem_(List1) - nitem2 = nitem_(List2) - - ! The maximum number of list item matches possible - ! is the minimum(nitem1,nitem2): - - NumSharedMax = min(nitem1,nitem2) - - ! Allocate sufficient space for the matches we may find: - - allocate(Indices1(NumSharedMax), Indices2(NumSharedMax), stat=ierr) - if(ierr /= 0) call die(myname_,'allocate() Indices1 and 2',ierr) - - ! Initialize the counter for the number of matches found: - - NumShared = 0 - - ! Scan through the two lists. For the sake of speed, loop - ! over the shorter of the two lists... - - if(nitem1 <= nitem2) then ! List1 is shorter--scan it... - - do n1=1,NumSharedMax - - ! Retrieve string tag n1 from List1: - call get_(tag, n1, List1) - - ! Index this tag WRT List2--a nonzero value signifies a match - n2 = indexStr_(List2, tag) - - ! Clear out tag for the next iteration... - call String_clean(tag) - - ! If we have a hit, update NumShared, and load the indices - ! n1 and n2 in Indices1 and Indices2, respectively... - - if((0 < n2) .and. (n2 <= nitem2)) then - NumShared = NumShared + 1 - Indices1(NumShared) = n1 - Indices2(NumShared) = n2 - endif - - end do ! do n1=1,NumSharedMax - - else ! List1 is shorter--scan it... - - do n2=1,NumSharedMax - - ! Retrieve string tag n2 from List2: - call get_(tag, n2, List2) - - ! Index this tag WRT List1--a nonzero value signifies a match - n1 = indexStr_(List1, tag) - - ! Clear out tag for the next iteration... - call String_clean(tag) - - ! If we have a hit, update NumShared, and load the indices - ! n1 and n2 in Indices1 and Indices2, respectively... - - if((0 < n1) .and. (n1 <= nitem1)) then - NumShared = NumShared + 1 - Indices1(NumShared) = n1 - Indices2(NumShared) = n2 - endif - - end do ! do n2=1,NumSharedMax - - endif ! if(nitem1 <= nitem2)... - - end subroutine GetSharedListIndices_ - - end module m_List -!. - - - - - - - - - diff --git a/cesm/models/utils/mct/mpeu/m_MergeSorts.F90 b/cesm/models/utils/mct/mpeu/m_MergeSorts.F90 deleted file mode 100644 index b829c17..0000000 --- a/cesm/models/utils/mct/mpeu/m_MergeSorts.F90 +++ /dev/null @@ -1,1195 +0,0 @@ -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!----------------------------------------------------------------------- -! CVS $Id$ -! CVS $Name$ -!BOP ------------------------------------------------------------------- -! -! !MODULE: m_MergeSorts - Tools for incremental indexed-sorting -! -! !DESCRIPTION: -! -! This tool module contains basic sorting procedures, that in -! addition to a couple of standard Fortran 90 statements in the -! array syntex, allow a full range sort or unsort operations. -! The main characteristics of the sorting algorithm used in this -! module are, a) stable, and b) index sorting. -! -! !INTERFACE: - - module m_MergeSorts - implicit none - private ! except - - public :: IndexSet - - public :: IndexSort - - interface IndexSet - module procedure setn_ - module procedure set_ - end interface - interface IndexSort - module procedure iSortn_ - module procedure rSortn_ - module procedure dSortn_ - module procedure cSortn_ - module procedure iSort_ - module procedure rSort_ - module procedure dSort_ - module procedure cSort_ - module procedure iSort1_ - module procedure rSort1_ - module procedure dSort1_ - module procedure cSort1_ - end interface - -! !EXAMPLES: -! -! ... -! integer, intent(in) :: No -! type(Observations), dimension(No), intent(inout) :: obs -! -! integer, dimension(No) :: indx ! automatic array -! -! call IndexSet(No,indx) -! call IndexSort(No,indx,obs(1:No)%lev,descend=.false.) -! call IndexSort(No,indx,obs(1:No)%lon,descend=.false.) -! call IndexSort(No,indx,obs(1:No)%lat,descend=.false.) -! call IndexSort(No,indx,obs(1:No)%kt,descend=.false.) -! call IndexSort(No,indx,obs(1:No)%ks,descend=.false.) -! call IndexSort(No,indx,obs(1:No)%kx,descend=.false.) -! call IndexSort(No,indx,obs(1:No)%kr,descend=.false.) -! -! ! Sorting -! obs(1:No) = obs( (/ (indx(i),i=1,No) /) ) -! ... -! ! Unsorting -! obs( (/ (indx(i),i=1,No) /) ) = obs(1:No) -! -! !REVISION HISTORY: -! 15Mar00 - Jing Guo -! . Added interfaces without the explicit size -! . Added interfaces for two dimensional arrays -! 02Feb99 - Jing Guo - Added if(present(stat)) ... -! 04Jan99 - Jing Guo - revised -! 09Sep97 - Jing Guo - initial prototype/prolog/code -!EOP ___________________________________________________________________ - - character(len=*), parameter :: myname='MCT(MPEU)::m_MergeSorts' - -contains - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: setn_ - Initialize an array of data location indices -! -! !DESCRIPTION: -! -! !INTERFACE: - - subroutine setn_(n,indx) - implicit none - integer, intent(in) :: n ! size of indx(:) - integer, dimension(n), intent(out) :: indx ! indices - -! !REVISION HISTORY: -! 15Mar00 - Jing Guo -! . initial prototype/prolog/code -! . redefined for the original interface -!EOP ___________________________________________________________________ - - call set_(indx(1:n)) -end subroutine setn_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: set_ - Initialize an array of data location indices -! -! !DESCRIPTION: -! -! !INTERFACE: - - subroutine set_(indx) - implicit none - integer, dimension(:), intent(out) :: indx ! indices - -! !REVISION HISTORY: -! 15Mar00 - Jing Guo -! . Modified the interface, by removing the explicit size -! 09Sep97 - Jing Guo - initial prototype/prolog/code -! 04Jan99 - Jing Guo - revised prolog format -!EOP ___________________________________________________________________ - - integer :: i - - do i=1,size(indx) - indx(i)=i - end do - -end subroutine set_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: iSortn_ - A stable merge index sorting of INTs. -! -! !DESCRIPTION: -! -! !INTERFACE: - - subroutine iSortn_(n,indx,keys,descend,stat) - implicit none - - integer,intent(in) :: n - integer, dimension(n), intent(inout) :: indx - integer, dimension(n), intent(in) :: keys - logical, optional, intent(in) :: descend - integer, optional, intent(out) :: stat - -! !REVISION HISTORY: -! 15Mar00 - Jing Guo -! . initial prototype/prolog/code -! . redefined for the original interface -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::iSortn_' - - call iSort_(indx(1:n),keys(1:n),descend,stat) -end subroutine iSortn_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: rSortn_ - A stable merge index sorting REALs. -! -! !DESCRIPTION: -! -! !INTERFACE: - - subroutine rSortn_(n,indx,keys,descend,stat) - use m_realkinds,only : SP - implicit none - - integer,intent(in) :: n - integer, dimension(n), intent(inout) :: indx - real(SP),dimension(n), intent(in) :: keys - logical, optional, intent(in) :: descend - integer, optional, intent(out) :: stat - -! !REVISION HISTORY: -! 15Mar00 - Jing Guo -! . initial prototype/prolog/code -! . redefined for the original interface -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::rSortn_' - - call rSort_(indx(1:n),keys(1:n),descend,stat) -end subroutine rSortn_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: dSortn_ - A stable merge index sorting DOUBLEs. -! -! !DESCRIPTION: -! -! !INTERFACE: - - subroutine dSortn_(n,indx,keys,descend,stat) - use m_realkinds,only : DP - implicit none - - integer,intent(in) :: n - integer, dimension(n), intent(inout) :: indx - real(DP), dimension(n), intent(in) :: keys - logical, optional, intent(in) :: descend - integer, optional, intent(out) :: stat - -! !REVISION HISTORY: -! 15Mar00 - Jing Guo -! . initial prototype/prolog/code -! . redefined for the original interface -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::dSortn_' - - call dSort_(indx(1:n),keys(1:n),descend,stat) -end subroutine dSortn_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: cSortn_ - A stable merge index sorting of CHAR(*)s. -! -! !DESCRIPTION: -! -! !INTERFACE: - - subroutine cSortn_(n,indx,keys,descend,stat) - implicit none - - integer,intent(in) :: n - integer, dimension(n), intent(inout) :: indx - character(len=*), dimension(n), intent(in) :: keys - logical, optional, intent(in) :: descend - integer, optional, intent(out) :: stat - -! !REVISION HISTORY: -! 15Mar00 - Jing Guo -! . initial prototype/prolog/code -! . redefined for the original interface -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::cSortn_' - - call cSort_(indx(1:n),keys(1:n),descend,stat) -end subroutine cSortn_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: iSort_ - A stable merge index sorting of INTs. -! -! !DESCRIPTION: -! -! !INTERFACE: - - subroutine iSort_(indx,keys,descend,stat) - use m_stdio, only : stderr - use m_die, only : die - implicit none - - integer, dimension(:), intent(inout) :: indx - integer, dimension(:), intent(in) :: keys - logical, optional, intent(in) :: descend - integer, optional, intent(out) :: stat - -! !REVISION HISTORY: -! 15Mar00 - Jing Guo -! . Modified the interface, by removing the explicit size -! 02Feb99 - Jing Guo - Added if(present(stat)) ... -! 04Jan99 - Jing Guo - revised the prolog -! 09Sep97 - Jing Guo - initial prototype/prolog/code -!EOP ___________________________________________________________________ - - logical :: dsnd - integer :: ierr - integer, dimension(:),allocatable :: mtmp - integer :: n - - character(len=*),parameter :: myname_=myname//'::iSort_' - - if(present(stat)) stat=0 - - n=size(indx) - - allocate(mtmp(n),stat=ierr) - if(ierr /= 0) then - write(stderr,'(2a,i4)') myname_, & - ': allocate(mtmp(:)) error, stat =',ierr - if(.not.present(stat)) call die(myname_) - stat=ierr - return - endif - - dsnd=.false. - if(present(descend)) dsnd=descend - - call MergeSort_() - - deallocate(mtmp) - -contains -subroutine MergeSort_() - implicit none - integer :: mstep,lstep - integer :: lb,lm,le - - mstep=1 - do while(mstep < n) - lstep=mstep*2 - - lb=1 - do while(lb < n) - lm=lb+mstep - le=min(lm-1+mstep,n) - - call merge_(lb,lm,le) - indx(lb:le)=mtmp(lb:le) - lb=le+1 - end do - - mstep=lstep - end do -end subroutine MergeSort_ - -subroutine merge_(lb,lm,le) - integer,intent(in) :: lb,lm,le - integer :: l1,l2,l - - l1=lb - l2=lm - do l=lb,le - if(l2.gt.le) then - mtmp(l)=indx(l1) - l1=l1+1 - elseif(l1.ge.lm) then - mtmp(l)=indx(l2) - l2=l2+1 - else - if(dsnd) then - if(keys(indx(l1)) .ge. keys(indx(l2))) then - mtmp(l)=indx(l1) - l1=l1+1 - else - mtmp(l)=indx(l2) - l2=l2+1 - endif - else - if(keys(indx(l1)) .le. keys(indx(l2))) then - mtmp(l)=indx(l1) - l1=l1+1 - else - mtmp(l)=indx(l2) - l2=l2+1 - endif - endif - endif - end do -end subroutine merge_ - -end subroutine iSort_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: rSort_ - A stable merge index sorting REALs. -! -! !DESCRIPTION: -! -! !INTERFACE: - - subroutine rSort_(indx,keys,descend,stat) - use m_stdio, only : stderr - use m_die, only : die - use m_realkinds,only : SP - implicit none - - integer, dimension(:), intent(inout) :: indx - real(SP),dimension(:), intent(in) :: keys - logical, optional, intent(in) :: descend - integer, optional, intent(out) :: stat - -! !REVISION HISTORY: -! 15Mar00 - Jing Guo -! . Modified the interface, by removing the explicit size -! 02Feb99 - Jing Guo - Added if(present(stat)) ... -! 04Jan99 - Jing Guo - revised the prolog -! 09Sep97 - Jing Guo - initial prototype/prolog/code -!EOP ___________________________________________________________________ - - logical :: dsnd - integer :: ierr - integer, dimension(:),allocatable :: mtmp - integer :: n - - character(len=*),parameter :: myname_=myname//'::rSort_' - - if(present(stat)) stat=0 - - n=size(indx) - - allocate(mtmp(n),stat=ierr) - if(ierr /= 0) then - write(stderr,'(2a,i4)') myname_, & - ': allocate(mtmp(:)) error, stat =',ierr - if(.not.present(stat)) call die(myname_) - stat=ierr - return - endif - - dsnd=.false. - if(present(descend)) dsnd=descend - - call MergeSort_() - - deallocate(mtmp) - -contains -subroutine MergeSort_() - implicit none - integer :: mstep,lstep - integer :: lb,lm,le - - mstep=1 - do while(mstep < n) - lstep=mstep*2 - - lb=1 - do while(lb < n) - lm=lb+mstep - le=min(lm-1+mstep,n) - - call merge_(lb,lm,le) - indx(lb:le)=mtmp(lb:le) - lb=le+1 - end do - - mstep=lstep - end do -end subroutine MergeSort_ - -subroutine merge_(lb,lm,le) - integer,intent(in) :: lb,lm,le - integer :: l1,l2,l - - l1=lb - l2=lm - do l=lb,le - if(l2.gt.le) then - mtmp(l)=indx(l1) - l1=l1+1 - elseif(l1.ge.lm) then - mtmp(l)=indx(l2) - l2=l2+1 - else - if(dsnd) then - if(keys(indx(l1)) .ge. keys(indx(l2))) then - mtmp(l)=indx(l1) - l1=l1+1 - else - mtmp(l)=indx(l2) - l2=l2+1 - endif - else - if(keys(indx(l1)) .le. keys(indx(l2))) then - mtmp(l)=indx(l1) - l1=l1+1 - else - mtmp(l)=indx(l2) - l2=l2+1 - endif - endif - endif - end do -end subroutine merge_ - -end subroutine rSort_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: dSort_ - A stable merge index sorting DOUBLEs. -! -! !DESCRIPTION: -! -! !INTERFACE: - - subroutine dSort_(indx,keys,descend,stat) - use m_stdio, only : stderr - use m_die, only : die - use m_realkinds,only : DP - implicit none - - integer, dimension(:), intent(inout) :: indx - real(DP), dimension(:), intent(in) :: keys - logical, optional, intent(in) :: descend - integer, optional, intent(out) :: stat - -! !REVISION HISTORY: -! 15Mar00 - Jing Guo -! . Modified the interface, by removing the explicit size -! 02Feb99 - Jing Guo - Added if(present(stat)) ... -! 04Jan99 - Jing Guo - revised the prolog -! 09Sep97 - Jing Guo - initial prototype/prolog/code -!EOP ___________________________________________________________________ - - logical :: dsnd - integer :: ierr - integer, dimension(:),allocatable :: mtmp - integer :: n - - character(len=*),parameter :: myname_=myname//'::dSort_' - - if(present(stat)) stat=0 - - n=size(indx) - - allocate(mtmp(n),stat=ierr) - if(ierr /= 0) then - write(stderr,'(2a,i4)') myname_, & - ': allocate(mtmp(:)) error, stat =',ierr - if(.not.present(stat)) call die(myname_) - stat=ierr - return - endif - - dsnd=.false. - if(present(descend)) dsnd=descend - - call MergeSort_() - - deallocate(mtmp) - -contains -subroutine MergeSort_() - implicit none - integer :: mstep,lstep - integer :: lb,lm,le - - mstep=1 - do while(mstep < n) - lstep=mstep*2 - - lb=1 - do while(lb < n) - lm=lb+mstep - le=min(lm-1+mstep,n) - - call merge_(lb,lm,le) - indx(lb:le)=mtmp(lb:le) - lb=le+1 - end do - - mstep=lstep - end do -end subroutine MergeSort_ - -subroutine merge_(lb,lm,le) - integer,intent(in) :: lb,lm,le - integer :: l1,l2,l - - l1=lb - l2=lm - do l=lb,le - if(l2.gt.le) then - mtmp(l)=indx(l1) - l1=l1+1 - elseif(l1.ge.lm) then - mtmp(l)=indx(l2) - l2=l2+1 - else - if(dsnd) then - if(keys(indx(l1)) .ge. keys(indx(l2))) then - mtmp(l)=indx(l1) - l1=l1+1 - else - mtmp(l)=indx(l2) - l2=l2+1 - endif - else - if(keys(indx(l1)) .le. keys(indx(l2))) then - mtmp(l)=indx(l1) - l1=l1+1 - else - mtmp(l)=indx(l2) - l2=l2+1 - endif - endif - endif - end do -end subroutine merge_ - -end subroutine dSort_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: cSort_ - A stable merge index sorting of CHAR(*)s. -! -! !DESCRIPTION: -! -! !INTERFACE: - - subroutine cSort_(indx,keys,descend,stat) - use m_stdio, only : stderr - use m_die, only : die - implicit none - - integer, dimension(:), intent(inout) :: indx - character(len=*), dimension(:), intent(in) :: keys - logical, optional, intent(in) :: descend - integer, optional, intent(out) :: stat - -! !REVISION HISTORY: -! 15Mar00 - Jing Guo -! . Modified the interface, by removing the explicit size -! 02Feb99 - Jing Guo - Added if(present(stat)) ... -! 04Jan99 - Jing Guo - revised the prolog -! 09Sep97 - Jing Guo - initial prototype/prolog/code -!EOP ___________________________________________________________________ - - logical :: dsnd - integer :: ierr - integer, dimension(:),allocatable :: mtmp - integer :: n - - character(len=*),parameter :: myname_=myname//'::cSort_' - - if(present(stat)) stat=0 - - n=size(indx) - - allocate(mtmp(n),stat=ierr) - if(ierr /= 0) then - write(stderr,'(2a,i4)') myname_, & - ': allocate(mtmp(:)) error, stat =',ierr - if(.not.present(stat)) call die(myname_) - stat=ierr - return - endif - - dsnd=.false. - if(present(descend)) dsnd=descend - - call MergeSort_() - - deallocate(mtmp) - -contains -subroutine MergeSort_() - implicit none - integer :: mstep,lstep - integer :: lb,lm,le - - mstep=1 - do while(mstep < n) - lstep=mstep*2 - - lb=1 - do while(lb < n) - lm=lb+mstep - le=min(lm-1+mstep,n) - - call merge_(lb,lm,le) - indx(lb:le)=mtmp(lb:le) - lb=le+1 - end do - - mstep=lstep - end do -end subroutine MergeSort_ - -subroutine merge_(lb,lm,le) - integer,intent(in) :: lb,lm,le - integer :: l1,l2,l - - l1=lb - l2=lm - do l=lb,le - if(l2.gt.le) then - mtmp(l)=indx(l1) - l1=l1+1 - elseif(l1.ge.lm) then - mtmp(l)=indx(l2) - l2=l2+1 - else - if(dsnd) then - if(keys(indx(l1)) .ge. keys(indx(l2))) then - mtmp(l)=indx(l1) - l1=l1+1 - else - mtmp(l)=indx(l2) - l2=l2+1 - endif - else - if(keys(indx(l1)) .le. keys(indx(l2))) then - mtmp(l)=indx(l1) - l1=l1+1 - else - mtmp(l)=indx(l2) - l2=l2+1 - endif - endif - endif - end do -end subroutine merge_ - -end subroutine cSort_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: iSort1_ - A stable merge index sorting of INTs. -! -! !DESCRIPTION: -! -! !INTERFACE: - - subroutine iSort1_(indx,keys,ikey,descend,stat) - use m_stdio, only : stderr - use m_die, only : die - implicit none - - integer, dimension(:), intent(inout) :: indx - integer, dimension(:,:), intent(in) :: keys - integer,intent(in) :: ikey - logical, optional, intent(in) :: descend - integer, optional, intent(out) :: stat - -! !REVISION HISTORY: -! 15Mar00 - Jing Guo -! . initial prototype/prolog/code -! . Copied code from iSort_ -! . Extended the interface and the algorithm to handle -! 2-d arrays with an index. -!EOP ___________________________________________________________________ - - logical :: dsnd - integer :: ierr - integer, dimension(:),allocatable :: mtmp - integer :: n - - character(len=*),parameter :: myname_=myname//'::iSort1_' - - if(present(stat)) stat=0 - - n=size(indx) - - allocate(mtmp(n),stat=ierr) - if(ierr /= 0) then - write(stderr,'(2a,i4)') myname_, & - ': allocate(mtmp(:)) error, stat =',ierr - if(.not.present(stat)) call die(myname_) - stat=ierr - return - endif - - dsnd=.false. - if(present(descend)) dsnd=descend - - call MergeSort_() - - deallocate(mtmp) - -contains -subroutine MergeSort_() - implicit none - integer :: mstep,lstep - integer :: lb,lm,le - - mstep=1 - do while(mstep < n) - lstep=mstep*2 - - lb=1 - do while(lb < n) - lm=lb+mstep - le=min(lm-1+mstep,n) - - call merge_(lb,lm,le) - indx(lb:le)=mtmp(lb:le) - lb=le+1 - end do - - mstep=lstep - end do -end subroutine MergeSort_ - -subroutine merge_(lb,lm,le) - integer,intent(in) :: lb,lm,le - integer :: l1,l2,l - - l1=lb - l2=lm - do l=lb,le - if(l2.gt.le) then - mtmp(l)=indx(l1) - l1=l1+1 - elseif(l1.ge.lm) then - mtmp(l)=indx(l2) - l2=l2+1 - else - if(dsnd) then - if(keys(ikey,indx(l1)) .ge. keys(ikey,indx(l2))) then - mtmp(l)=indx(l1) - l1=l1+1 - else - mtmp(l)=indx(l2) - l2=l2+1 - endif - else - if(keys(ikey,indx(l1)) .le. keys(ikey,indx(l2))) then - mtmp(l)=indx(l1) - l1=l1+1 - else - mtmp(l)=indx(l2) - l2=l2+1 - endif - endif - endif - end do -end subroutine merge_ - -end subroutine iSort1_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: rSort1_ - A stable merge index sorting REALs. -! -! !DESCRIPTION: -! -! !INTERFACE: - - subroutine rSort1_(indx,keys,ikey,descend,stat) - use m_stdio, only : stderr - use m_die, only : die - use m_realkinds,only : SP - implicit none - - integer, dimension(:), intent(inout) :: indx - real(SP),dimension(:,:), intent(in) :: keys - integer,intent(in) :: ikey - logical, optional, intent(in) :: descend - integer, optional, intent(out) :: stat - -! !REVISION HISTORY: -! 15Mar00 - Jing Guo -! . initial prototype/prolog/code -! . Copied code from rSort_ -! . Extended the interface and the algorithm to handle -! 2-d arrays with an index. -!EOP ___________________________________________________________________ - - logical :: dsnd - integer :: ierr - integer, dimension(:),allocatable :: mtmp - integer :: n - - character(len=*),parameter :: myname_=myname//'::rSort1_' - - if(present(stat)) stat=0 - - n=size(indx) - - allocate(mtmp(n),stat=ierr) - if(ierr /= 0) then - write(stderr,'(2a,i4)') myname_, & - ': allocate(mtmp(:)) error, stat =',ierr - if(.not.present(stat)) call die(myname_) - stat=ierr - return - endif - - dsnd=.false. - if(present(descend)) dsnd=descend - - call MergeSort_() - - deallocate(mtmp) - -contains -subroutine MergeSort_() - implicit none - integer :: mstep,lstep - integer :: lb,lm,le - - mstep=1 - do while(mstep < n) - lstep=mstep*2 - - lb=1 - do while(lb < n) - lm=lb+mstep - le=min(lm-1+mstep,n) - - call merge_(lb,lm,le) - indx(lb:le)=mtmp(lb:le) - lb=le+1 - end do - - mstep=lstep - end do -end subroutine MergeSort_ - -subroutine merge_(lb,lm,le) - integer,intent(in) :: lb,lm,le - integer :: l1,l2,l - - l1=lb - l2=lm - do l=lb,le - if(l2.gt.le) then - mtmp(l)=indx(l1) - l1=l1+1 - elseif(l1.ge.lm) then - mtmp(l)=indx(l2) - l2=l2+1 - else - if(dsnd) then - if(keys(ikey,indx(l1)) .ge. keys(ikey,indx(l2))) then - mtmp(l)=indx(l1) - l1=l1+1 - else - mtmp(l)=indx(l2) - l2=l2+1 - endif - else - if(keys(ikey,indx(l1)) .le. keys(ikey,indx(l2))) then - mtmp(l)=indx(l1) - l1=l1+1 - else - mtmp(l)=indx(l2) - l2=l2+1 - endif - endif - endif - end do -end subroutine merge_ - -end subroutine rSort1_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: dSort1_ - A stable merge index sorting DOUBLEs. -! -! !DESCRIPTION: -! -! !INTERFACE: - - subroutine dSort1_(indx,keys,ikey,descend,stat) - use m_stdio, only : stderr - use m_die, only : die - use m_realkinds,only : DP - implicit none - - integer, dimension(:), intent(inout) :: indx - real(DP), dimension(:,:), intent(in) :: keys - integer,intent(in) :: ikey - logical, optional, intent(in) :: descend - integer, optional, intent(out) :: stat - -! !REVISION HISTORY: -! 15Mar00 - Jing Guo -! . initial prototype/prolog/code -! . Copied code from dSort_ -! . Extended the interface and the algorithm to handle -! 2-d arrays with an index. -!EOP ___________________________________________________________________ - - logical :: dsnd - integer :: ierr - integer, dimension(:),allocatable :: mtmp - integer :: n - - character(len=*),parameter :: myname_=myname//'::dSort1_' - - if(present(stat)) stat=0 - - n=size(indx) - - allocate(mtmp(n),stat=ierr) - if(ierr /= 0) then - write(stderr,'(2a,i4)') myname_, & - ': allocate(mtmp(:)) error, stat =',ierr - if(.not.present(stat)) call die(myname_) - stat=ierr - return - endif - - dsnd=.false. - if(present(descend)) dsnd=descend - - call MergeSort_() - - deallocate(mtmp) - -contains -subroutine MergeSort_() - implicit none - integer :: mstep,lstep - integer :: lb,lm,le - - mstep=1 - do while(mstep < n) - lstep=mstep*2 - - lb=1 - do while(lb < n) - lm=lb+mstep - le=min(lm-1+mstep,n) - - call merge_(lb,lm,le) - indx(lb:le)=mtmp(lb:le) - lb=le+1 - end do - - mstep=lstep - end do -end subroutine MergeSort_ - -subroutine merge_(lb,lm,le) - integer,intent(in) :: lb,lm,le - integer :: l1,l2,l - - l1=lb - l2=lm - do l=lb,le - if(l2.gt.le) then - mtmp(l)=indx(l1) - l1=l1+1 - elseif(l1.ge.lm) then - mtmp(l)=indx(l2) - l2=l2+1 - else - if(dsnd) then - if(keys(ikey,indx(l1)) .ge. keys(ikey,indx(l2))) then - mtmp(l)=indx(l1) - l1=l1+1 - else - mtmp(l)=indx(l2) - l2=l2+1 - endif - else - if(keys(ikey,indx(l1)) .le. keys(ikey,indx(l2))) then - mtmp(l)=indx(l1) - l1=l1+1 - else - mtmp(l)=indx(l2) - l2=l2+1 - endif - endif - endif - end do -end subroutine merge_ - -end subroutine dSort1_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: cSort1_ - A stable merge index sorting of CHAR(*)s. -! -! !DESCRIPTION: -! -! !INTERFACE: - - subroutine cSort1_(indx,keys,ikey,descend,stat) - use m_stdio, only : stderr - use m_die, only : die - implicit none - - integer, dimension(:), intent(inout) :: indx - character(len=*), dimension(:,:), intent(in) :: keys - integer,intent(in) :: ikey - logical, optional, intent(in) :: descend - integer, optional, intent(out) :: stat - -! !REVISION HISTORY: -! 15Mar00 - Jing Guo -! . initial prototype/prolog/code -! . Copied code from cSort_ -! . Extended the interface and the algorithm to handle -! 2-d arrays with an index. -!EOP ___________________________________________________________________ - - logical :: dsnd - integer :: ierr - integer, dimension(:),allocatable :: mtmp - integer :: n - - character(len=*),parameter :: myname_=myname//'::cSort1_' - - if(present(stat)) stat=0 - - n=size(indx) - - allocate(mtmp(n),stat=ierr) - if(ierr /= 0) then - write(stderr,'(2a,i4)') myname_, & - ': allocate(mtmp(:)) error, stat =',ierr - if(.not.present(stat)) call die(myname_) - stat=ierr - return - endif - - dsnd=.false. - if(present(descend)) dsnd=descend - - call MergeSort_() - - deallocate(mtmp) - -contains -subroutine MergeSort_() - implicit none - integer :: mstep,lstep - integer :: lb,lm,le - - mstep=1 - do while(mstep < n) - lstep=mstep*2 - - lb=1 - do while(lb < n) - lm=lb+mstep - le=min(lm-1+mstep,n) - - call merge_(lb,lm,le) - indx(lb:le)=mtmp(lb:le) - lb=le+1 - end do - - mstep=lstep - end do -end subroutine MergeSort_ - -subroutine merge_(lb,lm,le) - integer,intent(in) :: lb,lm,le - integer :: l1,l2,l - - l1=lb - l2=lm - do l=lb,le - if(l2.gt.le) then - mtmp(l)=indx(l1) - l1=l1+1 - elseif(l1.ge.lm) then - mtmp(l)=indx(l2) - l2=l2+1 - else - if(dsnd) then - if(keys(ikey,indx(l1)) .ge. keys(ikey,indx(l2))) then - mtmp(l)=indx(l1) - l1=l1+1 - else - mtmp(l)=indx(l2) - l2=l2+1 - endif - else - if(keys(ikey,indx(l1)) .le. keys(ikey,indx(l2))) then - mtmp(l)=indx(l1) - l1=l1+1 - else - mtmp(l)=indx(l2) - l2=l2+1 - endif - endif - endif - end do -end subroutine merge_ - -end subroutine cSort1_ -!----------------------------------------------------------------------- -end module m_MergeSorts -!. diff --git a/cesm/models/utils/mct/mpeu/m_Permuter.F90 b/cesm/models/utils/mct/mpeu/m_Permuter.F90 deleted file mode 100644 index 70ebc7e..0000000 --- a/cesm/models/utils/mct/mpeu/m_Permuter.F90 +++ /dev/null @@ -1,1284 +0,0 @@ -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!----------------------------------------------------------------------- -! CVS $Id$ -! CVS $Name$ -!BOP ------------------------------------------------------------------- -! -! !MODULE: m_Permuter - permute/unpermute -! -! !DESCRIPTION: -! -! !INTERFACE: - - module m_Permuter - implicit none - private ! except - - public :: permute - public :: unpermute - - interface permute; module procedure & - permutei_, & ! integer in place - permuteio_, & ! integer with an output - permutei1_, & ! integer in place - permuteio1_, & ! integer with an output - permuter_, & ! real in place - permutero_, & ! real with an output - permuter1_, & ! real in place - permutero1_, & ! real with an output - permuted_, & ! dble in place - permutedo_, & ! dble with an output - permuted1_, & ! dble in place - permutedo1_, & ! dble with an output - permutel_, & ! logical in place - permutelo_, & ! logical with an output - permutel1_, & ! logical in place - permutelo1_ ! logical with an output - end interface - - interface unpermute; module procedure & - unpermutei_, & ! integer in place - unpermuteio_, & ! integer with an output - unpermutei1_, & ! integer in place - unpermuteio1_, & ! integer with an output - unpermuter_, & ! real in place - unpermutero_, & ! real with an output - unpermuter1_, & ! real in place - unpermutero1_, & ! real with an output - unpermuted_, & ! dble in place - unpermutedo_, & ! dble with an output - unpermuted1_, & ! dble in place - unpermutedo1_, & ! dble with an output - unpermutel_, & ! logical in place - unpermutelo_, & ! logical with an output - unpermutel1_, & ! logical in place - unpermutelo1_ ! logical with an output - end interface - -! !REVISION HISTORY: -! 25Aug99 - Jing Guo -! - initial prototype/prolog/code -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname='MCT(MPEU)::m_Permuter' - -contains - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: permutei_ - permute an integer array according to indx[] -! -! !DESCRIPTION: -! -! !INTERFACE: - - subroutine permutei_(ary,indx,n) - use m_die - implicit none - integer,dimension(:),intent(inout) :: ary - integer,dimension(:),intent(in) :: indx - integer, intent(in) :: n - -! !REVISION HISTORY: -! 25Aug99 - Jing Guo -! - initial prototype/prolog/code -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::permutei_' - - integer,allocatable,dimension(:) :: wk - integer :: i,ier - - allocate(wk(n),stat=ier) - if(ier/=0) call perr_die(myname_,'allocate()',ier) - - call permuteio_(wk,ary,indx,n) - - do i=1,n - ary(i)=wk(i) - end do - - deallocate(wk,stat=ier) - if(ier/=0) call perr_die(myname_,'deallocate()',ier) - -end subroutine permutei_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: permuteio_ - permute an integer array according to indx[] -! -! !DESCRIPTION: -! -! !INTERFACE: - - subroutine permuteio_(aout,ary,indx,n) - implicit none - integer,dimension(:),intent(inout) :: aout - integer,dimension(:),intent(in ) :: ary - integer,dimension(:),intent(in) :: indx - integer, intent(in) :: n - -! !REVISION HISTORY: -! 25Aug99 - Jing Guo -! - initial prototype/prolog/code -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::permuteio_' - - integer :: i,l - - do i=1,n - l=indx(i) - aout(i)=ary(l) - end do - -end subroutine permuteio_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: unpermutei_ - unpermute a _permuted_ integer array -! -! !DESCRIPTION: -! -! !INTERFACE: - - subroutine unpermutei_(ary,indx,n) - use m_die - implicit none - integer,dimension(:),intent(inout) :: ary - integer,dimension(:),intent(in) :: indx - integer, intent(in) :: n - -! !REVISION HISTORY: -! 25Aug99 - Jing Guo -! - initial prototype/prolog/code -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::unpermutei_' - - integer,allocatable,dimension(:) :: wk - integer :: i,ier - - allocate(wk(n),stat=ier) - if(ier/=0) call perr_die(myname_,'allocate()',ier) - - call unpermuteio_(wk,ary,indx,n) - - do i=1,n - ary(i)=wk(i) - end do - - deallocate(wk,stat=ier) - if(ier/=0) call perr_die(myname_,'deallocate()',ier) - -end subroutine unpermutei_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: unpermuteio_ - unpermute a _permuted_ integer array -! -! !DESCRIPTION: -! -! !INTERFACE: - - subroutine unpermuteio_(aout,ary,indx,n) - implicit none - integer,dimension(:),intent(inout) :: aout - integer,dimension(:),intent(in) :: ary - integer,dimension(:),intent(in) :: indx - integer, intent(in) :: n - -! !REVISION HISTORY: -! 25Aug99 - Jing Guo -! - initial prototype/prolog/code -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::unpermuteio_' - - integer :: i,l - - do i=1,n - l=indx(i) - aout(l)=ary(i) - end do - -end subroutine unpermuteio_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: permuter_ - permute a real array according to indx[] -! -! !DESCRIPTION: -! -! !INTERFACE: - - subroutine permuter_(ary,indx,n) - use m_die - use m_realkinds,only : SP - implicit none - real(SP),dimension(:),intent(inout) :: ary - integer ,dimension(:),intent(in) :: indx - integer , intent(in) :: n - -! !REVISION HISTORY: -! 25Aug99 - Jing Guo -! - initial prototype/prolog/code -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::permuter_' - - real(kind(ary)),allocatable,dimension(:) :: wk - integer :: i,ier - - allocate(wk(n),stat=ier) - if(ier/=0) call perr_die(myname_,'allocate()',ier) - - call permutero_(wk,ary,indx,n) - - do i=1,n - ary(i)=wk(i) - end do - - deallocate(wk,stat=ier) - if(ier/=0) call perr_die(myname_,'deallocate()',ier) - -end subroutine permuter_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: permutero_ - permute a real array according to indx[] -! -! !DESCRIPTION: -! -! !INTERFACE: - - subroutine permutero_(aout,ary,indx,n) - use m_realkinds,only : SP - implicit none - real(SP),dimension(:),intent(inout) :: aout - real(SP),dimension(:),intent(in) :: ary - integer ,dimension(:),intent(in) :: indx - integer , intent(in) :: n - -! !REVISION HISTORY: -! 25Aug99 - Jing Guo -! - initial prototype/prolog/code -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::permutero_' - - integer :: i,l - - do i=1,n - l=indx(i) - aout(i)=ary(l) - end do - -end subroutine permutero_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: unpermuter_ - unpermute a _permuted_ real array -! -! !DESCRIPTION: -! -! !INTERFACE: - - subroutine unpermuter_(ary,indx,n) - use m_die - use m_realkinds,only : SP - implicit none - real(SP),dimension(:),intent(inout) :: ary - integer ,dimension(:),intent(in) :: indx - integer , intent(in) :: n - -! !REVISION HISTORY: -! 25Aug99 - Jing Guo -! - initial prototype/prolog/code -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::unpermuter_' - - real(kind(ary)),allocatable,dimension(:) :: wk - integer :: i,ier - - allocate(wk(n),stat=ier) - if(ier/=0) call perr_die(myname_,'allocate()',ier) - - call unpermutero_(wk,ary,indx,n) - - do i=1,n - ary(i)=wk(i) - end do - - deallocate(wk,stat=ier) - if(ier/=0) call perr_die(myname_,'deallocate()',ier) - -end subroutine unpermuter_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: unpermutero_ - unpermute a _permuted_ real array -! -! !DESCRIPTION: -! -! !INTERFACE: - - subroutine unpermutero_(aout,ary,indx,n) - use m_realkinds,only : SP - implicit none - real(SP),dimension(:),intent(inout) :: aout - real(SP),dimension(:),intent(in) :: ary - integer ,dimension(:),intent(in) :: indx - integer , intent(in) :: n - -! !REVISION HISTORY: -! 25Aug99 - Jing Guo -! - initial prototype/prolog/code -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::unpermutero_' - - integer :: i,l - - do i=1,n - l=indx(i) - aout(l)=ary(i) - end do - -end subroutine unpermutero_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: permuted_ - permute a double precision array -! -! !DESCRIPTION: -! -! !INTERFACE: - - subroutine permuted_(ary,indx,n) - use m_die - use m_realkinds,only : DP - implicit none - real(DP),dimension(:),intent(inout) :: ary - integer ,dimension(:),intent(in) :: indx - integer , intent(in) :: n - -! !REVISION HISTORY: -! 25Aug99 - Jing Guo -! - initial prototype/prolog/code -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::permuted_' - - real(kind(ary)),allocatable,dimension(:) :: wk - integer :: i,ier - - allocate(wk(n),stat=ier) - if(ier/=0) call perr_die(myname_,'allocate()',ier) - - call permutedo_(wk,ary,indx,n) - - do i=1,n - ary(i)=wk(i) - end do - - deallocate(wk,stat=ier) - if(ier/=0) call perr_die(myname_,'deallocate()',ier) - -end subroutine permuted_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: permutedo_ - permute a double precision array -! -! !DESCRIPTION: -! -! !INTERFACE: - - subroutine permutedo_(aout,ary,indx,n) - use m_realkinds,only : DP - implicit none - real(DP),dimension(:),intent(inout) :: aout - real(DP),dimension(:),intent(in) :: ary - integer ,dimension(:),intent(in) :: indx - integer , intent(in) :: n - -! !REVISION HISTORY: -! 25Aug99 - Jing Guo -! - initial prototype/prolog/code -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::permutedo_' - - integer :: i,l - - do i=1,n - l=indx(i) - aout(i)=ary(l) - end do - -end subroutine permutedo_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: unpermuted_ - unpermute a double precision array -! -! !DESCRIPTION: -! -! !INTERFACE: - - subroutine unpermuted_(ary,indx,n) - use m_die - use m_realkinds,only : DP - implicit none - real(DP),dimension(:),intent(inout) :: ary - integer ,dimension(:),intent(in) :: indx - integer , intent(in) :: n - -! !REVISION HISTORY: -! 25Aug99 - Jing Guo -! - initial prototype/prolog/code -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::unpermuted_' - - real(kind(ary)),allocatable,dimension(:) :: wk - integer :: i,ier - - allocate(wk(n),stat=ier) - if(ier/=0) call perr_die(myname_,'allocate()',ier) - - call unpermutedo_(wk,ary,indx,n) - - do i=1,n - ary(i)=wk(i) - end do - - deallocate(wk,stat=ier) - if(ier/=0) call perr_die(myname_,'deallocate()',ier) - -end subroutine unpermuted_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: unpermutedo_ - unpermute a double precision array -! -! !DESCRIPTION: -! -! !INTERFACE: - - subroutine unpermutedo_(aout,ary,indx,n) - use m_realkinds,only : DP - implicit none - real(DP),dimension(:),intent(inout) :: aout - real(DP),dimension(:),intent(in) :: ary - integer ,dimension(:),intent(in) :: indx - integer , intent(in) :: n - -! !REVISION HISTORY: -! 25Aug99 - Jing Guo -! - initial prototype/prolog/code -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::unpermutedo_' - - integer :: i,l - - do i=1,n - l=indx(i) - aout(l)=ary(i) - end do - -end subroutine unpermutedo_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: permutel_ - permute a real array according to indx[] -! -! !DESCRIPTION: -! -! !INTERFACE: - - subroutine permutel_(ary,indx,n) - use m_die - implicit none - logical,dimension(:),intent(inout) :: ary - integer,dimension(:),intent(in) :: indx - integer, intent(in) :: n - -! !REVISION HISTORY: -! 25Aug99 - Jing Guo -! - initial prototype/prolog/code -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::permutel_' - - logical,allocatable,dimension(:) :: wk - integer :: i,ier - - allocate(wk(n),stat=ier) - if(ier/=0) call perr_die(myname_,'allocate()',ier) - - call permutelo_(wk,ary,indx,n) - - do i=1,n - ary(i)=wk(i) - end do - - deallocate(wk,stat=ier) - if(ier/=0) call perr_die(myname_,'deallocate()',ier) - -end subroutine permutel_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: permutelo_ - permute a real array according to indx[] -! -! !DESCRIPTION: -! -! !INTERFACE: - - subroutine permutelo_(aout,ary,indx,n) - implicit none - logical,dimension(:),intent(inout) :: aout - logical,dimension(:),intent(in) :: ary - integer,dimension(:),intent(in) :: indx - integer, intent(in) :: n - -! !REVISION HISTORY: -! 25Aug99 - Jing Guo -! - initial prototype/prolog/code -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::permutelo_' - - integer :: i,l - - do i=1,n - l=indx(i) - aout(i)=ary(l) - end do - -end subroutine permutelo_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: unpermutel_ - unpermute a _permuted_ logical array -! -! !DESCRIPTION: -! -! !INTERFACE: - - subroutine unpermutel_(ary,indx,n) - use m_die - implicit none - logical,dimension(:),intent(inout) :: ary - integer,dimension(:),intent(in) :: indx - integer, intent(in) :: n - -! !REVISION HISTORY: -! 25Aug99 - Jing Guo -! - initial prototype/prolog/code -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::unpermutel_' - - logical,allocatable,dimension(:) :: wk - integer :: i,ier - - allocate(wk(n),stat=ier) - if(ier/=0) call perr_die(myname_,'allocate()',ier) - - call unpermutelo_(wk,ary,indx,n) - - do i=1,n - ary(i)=wk(i) - end do - - deallocate(wk,stat=ier) - if(ier/=0) call perr_die(myname_,'deallocate()',ier) - -end subroutine unpermutel_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: unpermutelo_ - unpermute a _permuted_ logical array -! -! !DESCRIPTION: -! -! !INTERFACE: - - subroutine unpermutelo_(aout,ary,indx,n) - implicit none - logical,dimension(:),intent(inout) :: aout - logical,dimension(:),intent(in) :: ary - integer,dimension(:),intent(in) :: indx - integer, intent(in) :: n - -! !REVISION HISTORY: -! 25Aug99 - Jing Guo -! - initial prototype/prolog/code -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::unpermutelo_' - - integer :: i,l - - do i=1,n - l=indx(i) - aout(l)=ary(i) - end do - -end subroutine unpermutelo_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: permutei1_ - permute an integer array according to indx[] -! -! !DESCRIPTION: -! -! !INTERFACE: - - subroutine permutei1_(ary,indx,n) - use m_die - implicit none - integer,dimension(:,:),intent(inout) :: ary - integer,dimension(:),intent(in) :: indx - integer, intent(in) :: n - -! !REVISION HISTORY: -! 25Aug99 - Jing Guo -! - initial prototype/prolog/code -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::permutei1_' - - integer,allocatable,dimension(:,:) :: wk - integer :: i,l,ier - - l=size(ary,1) - allocate(wk(l,n),stat=ier) - if(ier/=0) call perr_die(myname_,'allocate()',ier) - - call permuteio1_(wk,ary,indx,n) - - do i=1,n - ary(:,i)=wk(:,i) - end do - - deallocate(wk,stat=ier) - if(ier/=0) call perr_die(myname_,'deallocate()',ier) - -end subroutine permutei1_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: permuteio1_ - permute an integer array according to indx[] -! -! !DESCRIPTION: -! -! !INTERFACE: - - subroutine permuteio1_(aout,ary,indx,n) - implicit none - integer,dimension(:,:),intent(inout) :: aout - integer,dimension(:,:),intent(in ) :: ary - integer,dimension(:),intent(in) :: indx - integer, intent(in) :: n - -! !REVISION HISTORY: -! 25Aug99 - Jing Guo -! - initial prototype/prolog/code -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::permuteio1_' - - integer :: i,l,m - - m=min(size(aout,1),size(ary,1)) - do i=1,n - l=indx(i) - aout(1:m,i)=ary(1:m,l) - end do - -end subroutine permuteio1_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: unpermutei1_ - unpermute a _permuted_ integer array -! -! !DESCRIPTION: -! -! !INTERFACE: - - subroutine unpermutei1_(ary,indx,n) - use m_die - implicit none - integer,dimension(:,:),intent(inout) :: ary - integer,dimension(:),intent(in) :: indx - integer, intent(in) :: n - -! !REVISION HISTORY: -! 25Aug99 - Jing Guo -! - initial prototype/prolog/code -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::unpermutei1_' - - integer,allocatable,dimension(:,:) :: wk - integer :: i,l,ier - - l=size(ary,1) - allocate(wk(l,n),stat=ier) - if(ier/=0) call perr_die(myname_,'allocate()',ier) - - call unpermuteio1_(wk,ary,indx,n) - - do i=1,n - ary(:,i)=wk(:,i) - end do - - deallocate(wk,stat=ier) - if(ier/=0) call perr_die(myname_,'deallocate()',ier) - -end subroutine unpermutei1_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: unpermuteio1_ - unpermute a _permuted_ integer array -! -! !DESCRIPTION: -! -! !INTERFACE: - - subroutine unpermuteio1_(aout,ary,indx,n) - implicit none - integer,dimension(:,:),intent(inout) :: aout - integer,dimension(:,:),intent(in) :: ary - integer,dimension(:),intent(in) :: indx - integer, intent(in) :: n - -! !REVISION HISTORY: -! 25Aug99 - Jing Guo -! - initial prototype/prolog/code -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::unpermuteio1_' - - integer :: i,l,m - - m=min(size(aout,1),size(ary,1)) - do i=1,n - l=indx(i) - aout(1:m,l)=ary(1:m,i) - end do - -end subroutine unpermuteio1_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: permuter1_ - permute a real array according to indx[] -! -! !DESCRIPTION: -! -! !INTERFACE: - - subroutine permuter1_(ary,indx,n) - use m_die - use m_realkinds,only : SP - implicit none - real(SP),dimension(:,:),intent(inout) :: ary - integer ,dimension(:),intent(in) :: indx - integer , intent(in) :: n - -! !REVISION HISTORY: -! 25Aug99 - Jing Guo -! - initial prototype/prolog/code -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::permuter1_' - - real(kind(ary)),allocatable,dimension(:,:) :: wk - integer :: i,l,ier - - l=size(ary,1) - allocate(wk(l,n),stat=ier) - if(ier/=0) call perr_die(myname_,'allocate()',ier) - - call permutero1_(wk,ary,indx,n) - - do i=1,n - ary(:,i)=wk(:,i) - end do - - deallocate(wk,stat=ier) - if(ier/=0) call perr_die(myname_,'deallocate()',ier) - -end subroutine permuter1_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: permutero1_ - permute a real array according to indx[] -! -! !DESCRIPTION: -! -! !INTERFACE: - - subroutine permutero1_(aout,ary,indx,n) - use m_realkinds,only : SP - implicit none - real(SP),dimension(:,:),intent(inout) :: aout - real(SP),dimension(:,:),intent(in) :: ary - integer ,dimension(:),intent(in) :: indx - integer , intent(in) :: n - -! !REVISION HISTORY: -! 25Aug99 - Jing Guo -! - initial prototype/prolog/code -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::permutero1_' - - integer :: i,l,m - - m=min(size(aout,1),size(ary,1)) - do i=1,n - l=indx(i) - aout(1:m,i)=ary(1:m,l) - end do - -end subroutine permutero1_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: unpermuter1_ - unpermute a _permuted_ real array -! -! !DESCRIPTION: -! -! !INTERFACE: - - subroutine unpermuter1_(ary,indx,n) - use m_die - use m_realkinds,only : SP - implicit none - real(SP),dimension(:,:),intent(inout) :: ary - integer ,dimension(:),intent(in) :: indx - integer , intent(in) :: n - -! !REVISION HISTORY: -! 25Aug99 - Jing Guo -! - initial prototype/prolog/code -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::unpermuter1_' - - real(kind(ary)),allocatable,dimension(:,:) :: wk - integer :: i,l,ier - - l=size(ary,1) - allocate(wk(l,n),stat=ier) - if(ier/=0) call perr_die(myname_,'allocate()',ier) - - call unpermutero1_(wk,ary,indx,n) - - do i=1,n - ary(:,i)=wk(:,i) - end do - - deallocate(wk,stat=ier) - if(ier/=0) call perr_die(myname_,'deallocate()',ier) - -end subroutine unpermuter1_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: unpermutero1_ - unpermute a _permuted_ real array -! -! !DESCRIPTION: -! -! !INTERFACE: - - subroutine unpermutero1_(aout,ary,indx,n) - use m_realkinds,only : SP - implicit none - real(SP),dimension(:,:),intent(inout) :: aout - real(SP),dimension(:,:),intent(in) :: ary - integer ,dimension(:),intent(in) :: indx - integer , intent(in) :: n - -! !REVISION HISTORY: -! 25Aug99 - Jing Guo -! - initial prototype/prolog/code -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::unpermutero1_' - - integer :: i,l,m - - m=min(size(aout,1),size(ary,1)) - do i=1,n - l=indx(i) - aout(1:m,l)=ary(1:m,i) - end do - -end subroutine unpermutero1_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: permuted1_ - permute a double precision array -! -! !DESCRIPTION: -! -! !INTERFACE: - - subroutine permuted1_(ary,indx,n) - use m_die - use m_realkinds,only : DP - implicit none - real(DP),dimension(:,:),intent(inout) :: ary - integer ,dimension(:),intent(in) :: indx - integer , intent(in) :: n - -! !REVISION HISTORY: -! 25Aug99 - Jing Guo -! - initial prototype/prolog/code -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::permuted1_' - - real(kind(ary)),allocatable,dimension(:,:) :: wk - integer :: i,l,ier - - l=size(ary,1) - allocate(wk(l,n),stat=ier) - if(ier/=0) call perr_die(myname_,'allocate()',ier) - - call permutedo1_(wk,ary,indx,n) - - do i=1,n - ary(:,i)=wk(:,i) - end do - - deallocate(wk,stat=ier) - if(ier/=0) call perr_die(myname_,'deallocate()',ier) - -end subroutine permuted1_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: permutedo1_ - permute a double precision array -! -! !DESCRIPTION: -! -! !INTERFACE: - - subroutine permutedo1_(aout,ary,indx,n) - use m_realkinds,only : DP - implicit none - real(DP),dimension(:,:),intent(inout) :: aout - real(DP),dimension(:,:),intent(in) :: ary - integer ,dimension(:),intent(in) :: indx - integer , intent(in) :: n - -! !REVISION HISTORY: -! 25Aug99 - Jing Guo -! - initial prototype/prolog/code -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::permutedo1_' - - integer :: i,l,m - - m=min(size(aout,1),size(ary,1)) - do i=1,n - l=indx(i) - aout(1:m,i)=ary(1:m,l) - end do - -end subroutine permutedo1_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: unpermuted1_ - unpermute a double precision array -! -! !DESCRIPTION: -! -! !INTERFACE: - - subroutine unpermuted1_(ary,indx,n) - use m_die - use m_realkinds,only : DP - implicit none - real(DP),dimension(:,:),intent(inout) :: ary - integer ,dimension(:),intent(in) :: indx - integer , intent(in) :: n - -! !REVISION HISTORY: -! 25Aug99 - Jing Guo -! - initial prototype/prolog/code -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::unpermuted1_' - - real(kind(ary)),allocatable,dimension(:,:) :: wk - integer :: i,l,ier - - l=size(ary,1) - allocate(wk(l,n),stat=ier) - if(ier/=0) call perr_die(myname_,'allocate()',ier) - - call unpermutedo1_(wk,ary,indx,n) - - do i=1,n - ary(:,i)=wk(:,i) - end do - - deallocate(wk,stat=ier) - if(ier/=0) call perr_die(myname_,'deallocate()',ier) - -end subroutine unpermuted1_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: unpermutedo1_ - unpermute a double precision array -! -! !DESCRIPTION: -! -! !INTERFACE: - - subroutine unpermutedo1_(aout,ary,indx,n) - use m_realkinds,only : DP - implicit none - real(DP),dimension(:,:),intent(inout) :: aout - real(DP),dimension(:,:),intent(in) :: ary - integer ,dimension(:),intent(in) :: indx - integer , intent(in) :: n - -! !REVISION HISTORY: -! 25Aug99 - Jing Guo -! - initial prototype/prolog/code -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::unpermutedo1_' - - integer :: i,l,m - - m=min(size(aout,1),size(ary,1)) - do i=1,n - l=indx(i) - aout(1:m,l)=ary(1:m,i) - end do - -end subroutine unpermutedo1_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: permutel1_ - permute a real array according to indx[] -! -! !DESCRIPTION: -! -! !INTERFACE: - - subroutine permutel1_(ary,indx,n) - use m_die - implicit none - logical,dimension(:,:),intent(inout) :: ary - integer,dimension(:),intent(in) :: indx - integer, intent(in) :: n - -! !REVISION HISTORY: -! 25Aug99 - Jing Guo -! - initial prototype/prolog/code -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::permutel1_' - - logical,allocatable,dimension(:,:) :: wk - integer :: i,l,ier - - l=size(ary,1) - allocate(wk(l,n),stat=ier) - if(ier/=0) call perr_die(myname_,'allocate()',ier) - - call permutelo1_(wk,ary,indx,n) - - do i=1,n - ary(:,i)=wk(:,i) - end do - - deallocate(wk,stat=ier) - if(ier/=0) call perr_die(myname_,'deallocate()',ier) - -end subroutine permutel1_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: permutelo1_ - permute a real array according to indx[] -! -! !DESCRIPTION: -! -! !INTERFACE: - - subroutine permutelo1_(aout,ary,indx,n) - implicit none - logical,dimension(:,:),intent(inout) :: aout - logical,dimension(:,:),intent(in) :: ary - integer,dimension(:),intent(in) :: indx - integer, intent(in) :: n - -! !REVISION HISTORY: -! 25Aug99 - Jing Guo -! - initial prototype/prolog/code -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::permutelo1_' - - integer :: i,l,m - - m=min(size(aout,1),size(ary,1)) - do i=1,n - l=indx(i) - aout(1:m,i)=ary(1:m,l) - end do - -end subroutine permutelo1_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: unpermutel1_ - unpermute a _permuted_ logical array -! -! !DESCRIPTION: -! -! !INTERFACE: - - subroutine unpermutel1_(ary,indx,n) - use m_die - implicit none - logical,dimension(:,:),intent(inout) :: ary - integer,dimension(:),intent(in) :: indx - integer, intent(in) :: n - -! !REVISION HISTORY: -! 25Aug99 - Jing Guo -! - initial prototype/prolog/code -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::unpermutel1_' - - logical,allocatable,dimension(:,:) :: wk - integer :: i,l,ier - - l=size(ary,1) - allocate(wk(l,n),stat=ier) - if(ier/=0) call perr_die(myname_,'allocate()',ier) - - call unpermutelo1_(wk,ary,indx,n) - - do i=1,n - ary(:,i)=wk(:,i) - end do - - deallocate(wk,stat=ier) - if(ier/=0) call perr_die(myname_,'deallocate()',ier) - -end subroutine unpermutel1_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: unpermutelo1_ - unpermute a _permuted_ logical array -! -! !DESCRIPTION: -! -! !INTERFACE: - - subroutine unpermutelo1_(aout,ary,indx,n) - implicit none - logical,dimension(:,:),intent(inout) :: aout - logical,dimension(:,:),intent(in) :: ary - integer,dimension(:),intent(in) :: indx - integer, intent(in) :: n - -! !REVISION HISTORY: -! 25Aug99 - Jing Guo -! - initial prototype/prolog/code -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::unpermutelo1_' - - integer :: i,l,m - - m=min(size(aout,1),size(ary,1)) - do i=1,n - l=indx(i) - aout(1:m,l)=ary(1:m,i) - end do - -end subroutine unpermutelo1_ - -end module m_Permuter diff --git a/cesm/models/utils/mct/mpeu/m_SortingTools.F90 b/cesm/models/utils/mct/mpeu/m_SortingTools.F90 deleted file mode 100644 index acb04dc..0000000 --- a/cesm/models/utils/mct/mpeu/m_SortingTools.F90 +++ /dev/null @@ -1,96 +0,0 @@ -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!----------------------------------------------------------------------- -! CVS $Id$ -! CVS $Name$ -!BOP ------------------------------------------------------------------- -! -! !MODULE: m_SortingTools - A collection of different sorting tools -! -! !DESCRIPTION: -! -! This module contains a collection of sorting utilities. The -! utilities are accessed through three generic interfaces, IndexSet(), -! IndexSort(), and IndexBin(). -! -! Note that, a version of IndexBin() for real arguments is not -! implemented due to the difficulty of comparing two real values as -! being equal. For example, a bin for real values may be specified -! as a single number, a range of two numbers, a number with an -! absolute error-bar, or a number with a relative error-bar. -! -! In general, one may have to map both keys(:) and bins(:) to -! integer indices by the a given rule, then use the integer version -! of IndexBin() with the two integer index arrays to do the sorting. -! This mapping rule, however, is application dependent. -! -! Also note that, in principle, it is possible to use both -! IndexSort() and IndexBin() in the same sorting task. -! -! !INTERFACE: - - module m_SortingTools - - use m_MergeSorts !only : IndexSet,IndexSort - use m_IndexBin_integer !only : IndexBin - use m_IndexBin_char !only : IndexBin - use m_IndexBin_logical !only : IndexBin - use m_rankMerge !only : RankSet,RankMerge,IndexedRankMerge - use m_Permuter !only : Permute, Unpermute - - implicit none - - private ! except - - public :: IndexSet ! define an initial list of indices - public :: IndexSort ! index for a new rank out of the old - public :: IndexBin ! index for sorting bins - public :: RankSet ! define an initial list of ranks - public :: RankMerge ! merge two arrays by re-ranking - public :: IndexedRankMerge ! index-merge two array segments - public :: Permute ! permute array entries - public :: Unpermute ! invert permutation - -! !EXAMPLES: -! -! - An example of using IndexSet()/IndexSort() in combination with -! the convenience of the Fortran 90 array syntex can be found in the -! prolog of m_MergeSorts. -! -! - An example of using IndexSet()/IndexBin(): Copying all "good" -! data to another array. -! -! integer :: indx(n) -! call IndexSet(n,indx) -! call IndexBin(n,indx,allObs(:)%qcflag,GOOD,ln0=ln_GOOD) -! -! ! Copy all "good" data to another array -! goodObs(1:ln_GOOD)=allObs( indx(1:ln_GOOD) ) -! -! ! Refill all "good" data back to their original places -! allObs( indx(1:ln_GOOD) ) = goodObs(1:ln_GOOD) -! -! - Similarily, multiple keys may be used in an IndexBin() call -! to selectively sort the data. The following code will move data -! with kt = kt_Us,kt_U,kt_Vs,kt_V up to the front: -! -! call IndexBin(n,indx,allObs(:)%kt,(/kt_Us,kt_U,kt_Vs,kt_V/)) -! allObs(1:n) = allObs( indx(1:n) ) -! -! - Additional applications can also be implemented with other -! argument combinations. -! -! !REVISION HISTORY: -! 15Mar00 - Jing Guo -! . Added m_rankMerge module interface -! 20Apr99 - Jing Guo -! - Commented "only" in use m_IndexBin_xxx to avoid an -! apperent compiler bug on DEC/OSF1 -! 17Feb99 - Jing Guo - initial prototype/prolog/code -! 19Oct00 - J.W. Larson - added Permuter and -! Unpermuter to list of public functions. -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname='MCT(MPEU)::m_SortingTools' - -end module m_SortingTools diff --git a/cesm/models/utils/mct/mpeu/m_StrTemplate.F90 b/cesm/models/utils/mct/mpeu/m_StrTemplate.F90 deleted file mode 100644 index 92cbc13..0000000 --- a/cesm/models/utils/mct/mpeu/m_StrTemplate.F90 +++ /dev/null @@ -1,454 +0,0 @@ -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!----------------------------------------------------------------------- -! CVS $Id$ -! CVS $Name$ -!BOP ------------------------------------------------------------------- -! -! !MODULE: m_StrTemplate - A template formatting a string with variables -! -! !DESCRIPTION: -! -! A template resolver formatting a string with a string variable -! and time variables. The format descriptors are similar to those -! used in the GrADS. -! -! "%y4" substitute with a 4 digit year -! "%y2" a 2 digit year -! "%m1" a 1 or 2 digit month -! "%m2" a 2 digit month -! "%mc" a 3 letter month in lower cases -! "%Mc" a 3 letter month with a leading letter in upper case -! "%MC" a 3 letter month in upper cases -! "%d1" a 1 or 2 digit day -! "%d2" a 2 digit day -! "%h1" a 1 or 2 digit hour -! "%h2" a 2 digit hour -! "%h3" a 3 digit hour (?) -! "%n2" a 2 digit minute -! "%s" a string variable -! "%%" a "%" -! -! !INTERFACE: - - module m_StrTemplate - implicit none - private ! except - - public :: StrTemplate ! Substitute variables in a template - - interface StrTemplate - module procedure strTemplate_ - end interface - -! !REVISION HISTORY: -! 01Jun99 - Jing Guo -! - initial prototype/prolog/code -! 19Jan01 - Jay Larson - removed numerous -! double-quote characters appearing inside single-quote -! blocks. This was done to comply with pgf90. Also, -! numerous double-quote characters were removed from -! within comment blocks because pgf90 kept trying to -! interpret them (spooky). -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname='MCT(MPEU)::m_StrTemplate' - - character(len=3),parameter,dimension(12) :: mon_lc = (/ & - 'jan','feb','mar','apr','may','jun', & - 'jul','aug','sep','oct','nov','dec' /) - - character(len=3),parameter,dimension(12) :: mon_wd = (/ & - 'Jan','Feb','Mar','Apr','May','Jun', & - 'Jul','Aug','Sep','Oct','Nov','Dec' /) - - character(len=3),parameter,dimension(12) :: mon_uc = (/ & - 'JAN','FEB','MAR','APR','MAY','JUN', & - 'JUL','AUG','SEP','OCT','NOV','DEC' /) - -contains -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: strTemplate_ - expanding a format template to a string -! -! !DESCRIPTION: -! -! !INTERFACE: - - subroutine strTemplate_(str,tmpl,class,xid,nymd,nhms,stat) - use m_chars, only : uppercase - use m_stdio, only : stderr - use m_die, only : die - implicit none - - character(len=*),intent(out) :: str ! the output - - character(len=*),intent(in ) :: tmpl ! a "format" - - character(len=*),intent(in ),optional :: class - ! choose a UNIX or a GrADS(defulat) type format - - character(len=*),intent(in ),optional :: xid - ! a string substituting a '%s'. Trailing - ! spaces will be ignored - - integer,intent(in ),optional :: nymd - ! yyyymmdd, substituting '%y4', '%y2', '%m1', - ! '%m2', '%mc', '%Mc', and '%MC' - - integer,intent(in ),optional :: nhms - ! hhmmss, substituting '%h1', '%h2', '%h3', - ! and '%n2' - - integer,intent(out),optional :: stat - ! error code - -! !REVISION HISTORY: -! 03Jun99 - Jing Guo -! - initial prototype/prolog/code -! 08Jan03 - R. Jacob Small change to get -! around IBM compiler bug. Cant have character valued functions -! in case statements. Fix found by Everest Ong. -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::strTemplate_' - character(len=16) :: tmpl_class - character(len=16) :: tmp_upper - - tmpl_class="GX" - if(present(class)) tmpl_class=class - - tmp_upper = uppercase(tmpl_class) - select case(tmp_upper) - - case("GX","GRADS") - call GX_(str,tmpl,xid,nymd,nhms,stat) - - !case("UX","UNIX") ! yet to be implemented - ! call UX_(str,tmpl,xid,nymd,nhms,stat) - - case default - write(stderr,'(4a)') myname_,': unknown class: ', & - trim(tmpl_class),'.' - if(.not.present(stat)) call die(myname_) - stat=-1 - return - end select - -end subroutine strTemplate_ -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: GX_ - evaluate a GrADS style string template -! -! !DESCRIPTION: -! -! !INTERFACE: - - subroutine GX_(str,tmpl,xid,nymd,nhms,stat) - use m_stdio,only : stderr - use m_die, only : die,perr - implicit none - character(len=*),intent(out) :: str - character(len=*),intent(in ) :: tmpl - character(len=*),optional,intent(in) :: xid - integer,optional,intent(in) :: nymd - integer,optional,intent(in) :: nhms - integer,optional,intent(out) :: stat - -! !REVISION HISTORY: -! 01Jun99 - Jing Guo -! - initial prototype/prolog/code -! 19Jan01 - Jay Larson - added -! variable c1c2, to store c1//c2, which pgf90 -! would not allow as an argument to the 'select case' -! statement. -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::GX_' - - integer :: iy4,iy2,imo,idy - integer :: ihr,imn - integer :: i,i1,i2,m,k - integer :: ln_tmpl,ln_str - integer :: istp,kstp - - character(len=1) :: c0,c1,c2 - character(len=2) :: c1c2 - character(len=4) :: sbuf -!________________________________________ - ! Determine iyr, imo, and idy - iy4=-1 - iy2=-1 - imo=-1 - idy=-1 - if(present(nymd)) then - if(nymd < 0) then - call perr(myname_,'nymd < 0',nymd) - if(.not.present(stat)) call die(myname_) - stat=1 - return - endif - - i=nymd - iy4=i/10000 - iy2=mod(iy4,100) - i=mod(i,10000) - imo=i/100 - i=mod(i,100) - idy=i - endif -!________________________________________ - ! Determine ihr and imn - ihr=-1 - imn=-1 - if(present(nhms)) then - if(nhms < 0) then - call perr(myname_,'nhms < 0',nhms) - if(.not.present(stat)) call die(myname_) - stat=1 - return - endif - - i=nhms - ihr=i/10000 - i=mod(i,10000) - imn=i/100 - endif -!________________________________________ - - ln_tmpl=len_trim(tmpl) ! size of the format template - ln_str =len(str) ! size of the output string -!________________________________________ - - if(present(stat)) stat=0 - -str="" - -i=0; istp=1 -k=1; kstp=1 - -do while( i+istp <= ln_tmpl ) ! A loop over all tokens in (tmpl) - - if(k>ln_Str) exit ! truncate the output here. - - i=i+istp - c0=tmpl(i:i) - - select case(c0) - case ("%") - !________________________________________ - - c1="" - i1=i+1 - if(i1 <= ln_Tmpl) c1=tmpl(i1:i1) - !________________________________________ - - select case(c1) - - case("s") - if(.not.present(xid)) then - write(stderr,'(2a)') myname_, & - ': optional argument expected, "xid="' - if(.not.present(stat)) call die(myname_) - stat=1 - return - endif - - istp=2 - m=min(k+len_trim(xid)-1,ln_str) - str(k:m)=xid - k=m+1 - cycle - - case("%") - - istp=2 - str(k:k)="%" - k=k+1 ! kstp=1 - cycle - - case default - - c2="" - i2=i+2 - if(i2 <= ln_Tmpl) c2=tmpl(i2:i2) - !________________________________________ - - c1c2 = c1 // c2 - select case(c1c2) - - case("y4","y2","m1","m2","mc","Mc","MC","d1","d2") - if(.not.present(nymd)) then - write(stderr,'(2a)') myname_, & - ': optional argument expected, "nymd="' - if(.not.present(stat)) call die(myname_) - stat=1 - return - endif - istp=3 - - case("h1","h2","h3","n2") - if(.not.present(nhms)) then - write(stderr,'(2a)') myname_, & - ': optional argument expected, "nhms="' - if(.not.present(stat)) call die(myname_) - stat=1 - return - endif - istp=3 - - case default - - write(stderr,'(4a)') myname_, & - ': invalid template entry: ',trim(tmpl(i:)),'.' - if(.not.present(stat)) call die(myname_) - stat=2 - return - - end select ! case(c1//c2) - end select ! case(c1) - !________________________________________ - - select case(c1) - - case("y") - select case(c2) - case("2") - write(sbuf,'(i2.2)') iy2 - kstp=2 - case("4") - write(sbuf,'(i4.4)') iy4 - kstp=4 - case default - write(stderr,'(4a)') myname_, & - ': invalid template entry: ',trim(tmpl(i:)),'.' - if(.not.present(stat)) call die(myname_) - stat=2 - return - end select - - case("m") - select case(c2) - case("1") - if(imo < 10) then - write(sbuf,'(i1)') imo - kstp=1 - else - write(sbuf,'(i2)') imo - kstp=2 - endif - case("2") - write(sbuf,'(i2.2)') imo - kstp=2 - case("c") - sbuf=mon_lc(imo) - kstp=3 - case default - write(stderr,'(4a)') myname_, & - ': invalid template entry: ',trim(tmpl(i:)),'.' - if(.not.present(stat)) call die(myname_) - stat=2 - return - end select - - case("M") - select case(c2) - case("c") - sbuf=mon_wd(imo) - kstp=3 - case("C") - sbuf=mon_uc(imo) - kstp=3 - case default - write(stderr,'(4a)') myname_, & - ': invalid template entry: ',trim(tmpl(i:)),'.' - if(.not.present(stat)) call die(myname_) - stat=2 - return - end select - - case("d") - select case(c2) - case("1") - if(idy < 10) then - write(sbuf,'(i1)') idy - kstp=1 - else - write(sbuf,'(i2)') idy - kstp=2 - endif - case("2") - write(sbuf,'(i2.2)') idy - kstp=2 - case default - write(stderr,'(4a)') myname_, & - ': invalid template entry: ',trim(tmpl(i:)),'.' - if(.not.present(stat)) call die(myname_) - stat=2 - return - end select - - case("h") - select case(c2) - case("1") - if(ihr < 10) then - write(sbuf,'(i1)') ihr - kstp=1 - else - write(sbuf,'(i2)') ihr - kstp=2 - endif - case("2") - write(sbuf,'(i2.2)') ihr - kstp=2 - case("3") - write(sbuf,'(i3.3)') ihr - kstp=3 - case default - write(stderr,'(4a)') myname_, & - ': invalid template entry: ',trim(tmpl(i:)),'.' - if(.not.present(stat)) call die(myname_) - stat=2 - return - end select - - case("n") - select case(c2) - case("2") - write(sbuf,'(i2.2)') imn - kstp=2 - case default - write(stderr,'(4a)') myname_, & - ': invalid template entry: ',trim(tmpl(i:)),'.' - if(.not.present(stat)) call die(myname_) - stat=2 - return - end select - - case default - write(stderr,'(4a)') myname_, & - ': invalid template entry: ',trim(tmpl(i:)),'.' - if(.not.present(stat)) call die(myname_) - stat=2 - return - end select ! case(c1) - - m=min(k+kstp-1,ln_Str) - str(k:m)=sbuf - k=m+1 - - case default - - istp=1 - str(k:k)=tmpl(i:i) - k=k+1 - - end select ! case(c0) -end do - -end subroutine GX_ -end module m_StrTemplate diff --git a/cesm/models/utils/mct/mpeu/m_String.F90 b/cesm/models/utils/mct/mpeu/m_String.F90 deleted file mode 100644 index 3eace54..0000000 --- a/cesm/models/utils/mct/mpeu/m_String.F90 +++ /dev/null @@ -1,831 +0,0 @@ -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!----------------------------------------------------------------------- -! CVS $Id$ -! CVS $Name$ -!BOP ------------------------------------------------------------------- -! -! !MODULE: m_String - The String Datatype -! -! !DESCRIPTION: -! The {\tt String} datatype is an encapsulated pointer to a one-dimensional -! array of single characters. This allows one to define variable-length -! strings, and arrays of variable-length strings. -! -! !INTERFACE: - - module m_String - -! !USES: -! No external modules are used in the declaration section of this module. - - implicit none - - private ! except - -! !PUBLIC TYPES: - - public :: String ! The class data structure - - Type String -#ifdef SEQUENCE - sequence -#endif - character(len=1),dimension(:),pointer :: c - End Type String - -! !PUBLIC MEMBER FUNCTIONS: - - public :: toChar - public :: char ! convert to a CHARACTER(*) - - public :: String_init - public :: init ! set a CHARACTER(*) type to a String - - public :: String_clean - public :: clean ! Deallocate memory occupied by a String - - public :: String_len - public :: len ! length of a String - - public :: String_bcast - public :: bcast ! Broadcast a String - - public :: String_mci ! Track memory used to store a String - public :: String_mco - - public :: ptr_chars ! Assign a pointer to a String's - ! character buffer - - interface char; module procedure & - str2ch0_, & - ch12ch0_ - end interface - - interface toChar; module procedure & - str2ch0_, & - ch12ch0_ - end interface - - interface String_init; module procedure & - initc_, & - initc1_, & - inits_ - end interface - - interface init; module procedure & - initc_, & - initc1_, & - inits_ - end interface - - interface String_clean; module procedure clean_; end interface - interface clean; module procedure clean_; end interface - interface String_len; module procedure len_; end interface - interface len; module procedure len_; end interface - interface String_bcast; module procedure bcast_; end interface - interface bcast; module procedure bcast_; end interface - - interface String_mci; module procedure & - mci0_, & - mci1_, & - mci2_, & - mci3_ - end interface - - interface String_mco; module procedure & - mco0_, & - mco1_, & - mco2_, & - mco3_ - end interface - - interface ptr_chars; module procedure & - ptr_chars_ - end interface - -! !REVISION HISTORY: -! 22Apr98 - Jing Guo - initial prototype/prolog/code -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname='MCT(MPEU)::m_String' - -contains -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: str2ch0_ - Convert a String to a CHARACTER -! -! !DESCRIPTION: -! This function returns the contents of the character buffer of the -! input {\tt String} argument {\tt str} as a {\tt CHARCTER} suitable -! for printing. -! -! !INTERFACE: - - function str2ch0_(str) - -! !USES: -! -! No external modules are used by this function. - - implicit none - -! !INPUT PARAMETERS: -! - type(String), intent(in) :: str - -! !OUTPUT PARAMETERS: -! - character(len=size(str%c,1)) :: str2ch0_ - -! !REVISION HISTORY: -! 23Apr98 - Jing Guo - initial prototype/prolog/code -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::str2ch0_' - integer :: i - - do i=1,size(str%c) - str2ch0_(i:i)=str%c(i) - end do - - end function str2ch0_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: ch12ch0_ - Convert a CHARACTER(:) to a CHARACTER(*) -! -! !DESCRIPTION: -! This function takes an input one-dimensional array of single characters -! and returns a single character string. -! -! !INTERFACE: - - function ch12ch0_(ch1) - -! !USES: -! -! No external modules are used by this function. - - implicit none - -! !INPUT PARAMETERS: -! - character(len=1), dimension(:), intent(in) :: ch1 - -! !OUTPUT PARAMETERS: -! - character(len=size(ch1,1)) :: ch12ch0_ - -! !REVISION HISTORY: -! 22Apr98 - Jing Guo - initial prototype/prolog/code -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::ch12ch0_' - integer :: i - - do i=1,size(ch1) - ch12ch0_(i:i)=ch1(i) - end do - - end function ch12ch0_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: initc_ - Create a String using a CHARACTER -! -! !DESCRIPTION: -! This routine takes an input scalar {\tt CHARACTER} argument {\tt chr}, -! and uses it to create the output {\tt String} argument {\tt str}. -! -! !INTERFACE: - - subroutine initc_(str, chr) - -! !USES: -! - use m_die, only : die,perr - use m_mall,only : mall_mci,mall_ison - - implicit none - -! !INPUT PARAMETERS: -! - character(len=*), intent(in) :: chr - -! !OUTPUT PARAMETERS: -! - type(String), intent(out) :: str - -! !REVISION HISTORY: -! 23Apr98 - Jing Guo - initial prototype/prolog/code -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::initc_' - integer :: ln,ier,i - - ln=len(chr) - allocate(str%c(ln),stat=ier) - if(ier /= 0) then - call perr(myname_,'allocate()',ier) - call die(myname_) - endif - - if(mall_ison()) call mall_mci(str%c,myname) - - do i=1,ln - str%c(i)=chr(i:i) - end do - - end subroutine initc_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: initc1_ - Create a String using a CHARACTER array -! -! !DESCRIPTION: -! This routine takes an input {\tt CHARACTER(:)} argument {\tt chr}, -! and uses it to create the output {\tt String} argument {\tt str}. -! -! !INTERFACE: - - subroutine initc1_(str, chr) - -! !USES: -! - use m_die, only : die,perr - use m_mall,only : mall_mci,mall_ison - - implicit none - -! !INPUT PARAMETERS: -! - character, dimension(:), intent(in) :: chr - -! !OUTPUT PARAMETERS: -! - type(String), intent(out) :: str - -! !REVISION HISTORY: -! 2Aug02 - J. Larson - initial prototype -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::initc1_' - integer :: ln,ier,i - - ln=size(chr) - allocate(str%c(ln),stat=ier) - if(ier /= 0) then - call perr(myname_,'allocate()',ier) - call die(myname_) - endif - - if(mall_ison()) call mall_mci(str%c,myname) - - do i=1,ln - str%c(i)=chr(i) - end do - - end subroutine initc1_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: inits_ - Initialization of a String from another String -! -! !DESCRIPTION: -! This routine takes an input {\tt String} argument {\tt iStr} and -! creates an output {\tt String} argument {\tt oStr}. In other words, -! it copies {\tt iStr} to {\tt oStr}. -! -! !INTERFACE: - - subroutine inits_(oStr, iStr) - -! !USES: -! - use m_die, only : die - use m_mall,only : mall_mci,mall_ison - - implicit none - -! !INPUT PARAMETERS: -! - type(String), intent(in) :: iStr - -! !OUTPUT PARAMETERS: -! - type(String), intent(out) :: oStr - -! !REVISION HISTORY: -! 07Feb00 - Jing Guo -! - initial prototype/prolog/code -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::inits_' - integer :: ln,ier,i - - ln=size(iStr%c) - - allocate(oStr%c(ln),stat=ier) - if(ier /= 0) call die(myname_,'allocate()',ier) - - if(mall_ison()) call mall_mci(oStr%c,myname) - - do i=1,ln - oStr%c(i)=iStr%c(i) - end do - - end subroutine inits_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: clean_ - Deallocate Memory Occupied by a String -! -! !DESCRIPTION: -! This routine deallocates memory associated with the input/output -! {\tt String} argument {\tt str}. This amounts to deallocating -! {\tt str\%c}. -! -! !INTERFACE: - - subroutine clean_(str) - -! !USES: -! - use m_die, only : die,perr - use m_mall,only : mall_mco,mall_ison - - implicit none - -! !INPUT/OUTPUT PARAMETERS: -! - type(String), intent(inout) :: str - -! !REVISION HISTORY: -! 23Apr98 - Jing Guo - initial prototype/prolog/code -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::clean_' - integer :: ier - - if(mall_ison()) call mall_mco(str%c,myname) - - deallocate(str%c,stat=ier) - if(ier /= 0) then - call perr(myname_,'deallocate()',ier) - call die(myname_) - endif - - end subroutine clean_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: bcast_ - MPI Broadcast of a rank-0 String -! -! !DESCRIPTION: -! This routine performs an MPI broadcast of the input/output {\tt String} -! argument {\tt Str} on a communicator associated with the Fortran integer -! handle {\tt comm}. The broadcast originates from the process with rank -! given by {\tt root} on {\tt comm}. The {\tt String} argument {\tt Str} -! is on entry valid only on the {\tt root} process, and is valid on exit -! on all processes on the communicator {\tt comm}. The success (failure) -! is signified by a zero (non-zero) value of the optional {\tt INTEGER} -! output argument {\tt stat}. -! -! !INTERFACE: - - subroutine bcast_(Str, root, comm, stat) - -! !USES: -! - use m_mpif90 - use m_die, only : perr,die - use m_mall,only : mall_mci,mall_ison - - implicit none - -! !INPUT PARAMETERS: -! - integer, intent(in) :: root - integer, intent(in) :: comm - -! !INPUT/OUTPUT PARAMETERS: -! - type(String), intent(inout) :: Str ! (IN) on the root, - ! (OUT) elsewhere - -! !OUTPUT PARAMETERS: -! - integer, optional, intent(out) :: stat - -! !REVISION HISTORY: -! 27Apr98 - Jing Guo - initial prototype/prolog/code -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::bcast_' - integer :: ln,ier,myID - - if(present(stat)) stat=0 - - call MP_comm_rank(comm,myID,ier) - if(ier /= 0) then - call MP_perr(myname_,'MP_comm_rank()',ier) - if(.not.present(stat)) call die(myname_) - stat=ier - return - endif - - if(myID==root) then - ln=size(Str%c) - if(ln<=0) call die(myname_,'size(Str%c) <= 0') - endif - - call MPI_bcast(ln,1,MP_INTEGER,root,comm,ier) - if(ier/=0) then - call MP_perr(myname_,'MPI_bcast(ln)',ier) - if(.not.present(stat)) call die(myname_) - stat=ier - return - endif - - if(myID /= root) then - - allocate(Str%c(ln),stat=ier) - if(ier /= 0) then - call perr(myname_,'allocate()',ier) - if(.not.present(stat)) call die(myname_) - stat=ier - return - endif - - if(mall_ison()) call mall_mci(Str%c,myname) - endif - - call MPI_bcast(Str%c(1),ln,MP_CHARACTER,root,comm,ier) - if(ier/=0) then - call MP_perr(myname_,'MPI_bcast(Str%c)',ier) - if(.not.present(stat)) call die(myname_) - stat=ier - return - endif - - end subroutine bcast_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: mci0_ - checking in a String scalar -! -! !DESCRIPTION: -! -! !INTERFACE: - - subroutine mci0_(marg,thread) - -! !USES: -! - use m_mall, only : mall_ci - - implicit none - -! !INPUT PARAMETERS: -! - type(String), intent(in) :: marg - character(len=*), intent(in) :: thread - -! !REVISION HISTORY: -! 07Feb00 - Jing Guo -! - initial prototype/prolog/code -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::mci0_' - - call mall_ci(1,thread) - - end subroutine mci0_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: mco0_ - checking out a String scalar -! -! !DESCRIPTION: -! -! !INTERFACE: - - subroutine mco0_(marg,thread) - -! !USES: -! - use m_mall, only : mall_co - - implicit none - - type(String), intent(in) :: marg - character(len=*),intent(in) :: thread - -! !REVISION HISTORY: -! 07Feb00 - Jing Guo -! - initial prototype/prolog/code -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::mco0_' - - call mall_co(1,thread) - - end subroutine mco0_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: mci1_ - checking in a String scalar -! -! !DESCRIPTION: -! -! !INTERFACE: - - subroutine mci1_(marg,thread) - -! !USES: -! - use m_mall, only : mall_ci - - implicit none - -! !INPUT PARAMETERS: -! - type(String), dimension(:), intent(in) :: marg - character(len=*), intent(in) :: thread - -! !REVISION HISTORY: -! 07Feb00 - Jing Guo -! - initial prototype/prolog/code -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::mci1_' - - call mall_ci(size(marg),thread) - - end subroutine mci1_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: mco1_ - checking out a String scalar -! -! !DESCRIPTION: -! -! !INTERFACE: - - subroutine mco1_(marg,thread) - -! !USES: -! - use m_mall, only : mall_co - - implicit none - -! !INPUT PARAMETERS: -! - type(String), dimension(:), intent(in) :: marg - character(len=*), intent(in) :: thread - -! !REVISION HISTORY: -! 07Feb00 - Jing Guo -! - initial prototype/prolog/code -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::mco1_' - - call mall_co(size(marg),thread) - - end subroutine mco1_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: mci2_ - checking in a String scalar -! -! !DESCRIPTION: -! -! !INTERFACE: - - subroutine mci2_(marg, thread) - -! !USES: -! - use m_mall, only : mall_ci - - implicit none - -! !INPUT PARAMETERS: -! - type(String), dimension(:,:), intent(in) :: marg - character(len=*), intent(in) :: thread - -! !REVISION HISTORY: -! 07Feb00 - Jing Guo -! - initial prototype/prolog/code -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::mci2_' - - call mall_ci(size(marg),thread) - - end subroutine mci2_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: mco2_ - checking out a String scalar -! -! !DESCRIPTION: -! -! !INTERFACE: - - subroutine mco2_(marg,thread) - -! !USES: -! - use m_mall, only : mall_co - - implicit none - -! !INPUT PARAMETERS: -! - type(String), dimension(:,:), intent(in) :: marg - character(len=*), intent(in) :: thread - -! !REVISION HISTORY: -! 07Feb00 - Jing Guo -! - initial prototype/prolog/code -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::mco2_' - - call mall_co(size(marg),thread) - - end subroutine mco2_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: mci3_ - checking in a String scalar -! -! !DESCRIPTION: -! -! !INTERFACE: - - subroutine mci3_(marg,thread) - -! !USES: -! - use m_mall, only : mall_ci - - implicit none - -! !INPUT PARAMETERS: -! - type(String), dimension(:,:,:), intent(in) :: marg - character(len=*), intent(in) :: thread - -! !REVISION HISTORY: -! 07Feb00 - Jing Guo -! - initial prototype/prolog/code -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::mci3_' - - call mall_ci(size(marg),thread) - - end subroutine mci3_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: mco3_ - checking out a String scalar -! -! !DESCRIPTION: -! -! !INTERFACE: - - subroutine mco3_(marg,thread) - -! !USES: -! - use m_mall, only : mall_co - - implicit none - -! !INPUT PARAMETERS: -! - type(String), dimension(:,:,:), intent(in) :: marg - character(len=*), intent(in) :: thread - -! !REVISION HISTORY: -! 07Feb00 - Jing Guo -! - initial prototype/prolog/code -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::mco3_' - - call mall_co(size(marg),thread) - - end subroutine mco3_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: len_ = len of a String -! -! !DESCRIPTION: -! -! !INTERFACE: - - integer function len_(str) - -! !USES: -! -! No external modules are used by this function. - - implicit none - -! !INPUT PARAMETERS: -! - type(String),intent(in) :: str - -! !REVISION HISTORY: -! 10Apr00 - Jing Guo -! - initial prototype/prolog/code -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::len_' - - len_=size(str%c) - - end function len_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: ptr_chars_ - direct -! -! !DESCRIPTION: -! This pointer-valued function provides a direct interface to the -! character buffer in the input {\tt String} argument {\tt str}. That -! is, {\tt ptr\_chars\_ => str\%c}. -! -! !INTERFACE: - - function ptr_chars_(str) - -! !USES: -! -! No external modules are used by this function. - - implicit none - -! !INPUT PARAMETERS: -! - type(String), intent(in) :: str - -! !OUTPUT PARAMETERS: -! - character(len=1), dimension(:), pointer :: ptr_chars_ - -! !REVISION HISTORY: -! 10Apr00 - Jing Guo -! - initial prototype/prolog/code -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::ptr_chars_' - - ptr_chars_ => str%c - - end function ptr_chars_ - - end module m_String diff --git a/cesm/models/utils/mct/mpeu/m_StringLinkedList.F90 b/cesm/models/utils/mct/mpeu/m_StringLinkedList.F90 deleted file mode 100644 index 1543f8b..0000000 --- a/cesm/models/utils/mct/mpeu/m_StringLinkedList.F90 +++ /dev/null @@ -1,553 +0,0 @@ -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!BOP ------------------------------------------------------------------- -! -! !MODULE: m_StringLinkedList - A linked-list of String -! -! !DESCRIPTION: -! -! !INTERFACE: - - module m_StringLinkedList - use m_String,only : String - implicit none - private ! except - - public :: StringLinkedList ! The class data structure - - ! o An object of a StringLinkedList should be defined - ! as a pointer of a StringLinkedList. It is often - ! represented by a pointer to the head-node of the - ! linked-list. - ! - ! o A node in a StringLinkedList is specificed by a - ! reference pointer. A reference pointer is a - ! logical reference of a node in the list. However, - ! it does not physically point to that node. In - ! fact, a reference pointer normally references to - ! the node physically pointed by the pointer in the - ! node physically pointed by the reference pointer, - ! - ! [this] -> [..|next] -> [..|next] - ! - ! where the last node is the logically referenced - ! node. - - public :: StringLinkedList_init ! constructor - public :: StringLinkedList_clean ! destructor - - ! A _clean() action will reset a StringLinkedList to its - ! pre-_init() status. - - public :: StringLinkedList_insert ! grower, insert a node - public :: StringLinkedList_delete ! ungrower, delete a node - - ! Both procedures processing the node through a given - ! reference pointer. The reference pointer will not - ! be modified directly through either _insert() or - ! _delete(). It is the pointer in the node physically - ! pointed by a reference pointer got modified. Also, - ! the node logically referenced by the reference - ! pointer is either the new node for an _insert(), and - ! the removed node for a _delete(). - - public :: StringLinkedList_eol ! inquirer, is an end-node? - - ! An end-of-list situation occurs when the reference - ! pointer is logically referencing to the end-node or - ! beyond. Note that an end-node links to itself. - - public :: StringLinkedList_next ! iterator, go to the next node. - - public :: StringLinkedList_count ! counter - - ! Count the number of nodes from this reference pointer, - ! starting from and including the logical node but - ! excluding the end-node. - - public :: StringLinkedList_get ! fetcher - - ! Get the value logically referenced by a reference - ! pointer. Return EOL if the referenced node is an - ! EOL(). The reference pointer will be iterated to - ! the next node if the referenced node is not an EOL. - - type StringLinkedList - type(String) :: str - type(StringLinkedList),pointer :: next - end type StringLinkedList - - interface StringLinkedList_init ; module procedure & - init_ - end interface - - interface StringLinkedList_clean ; module procedure & - clean_ - end interface - - interface StringLinkedList_insert; module procedure & - insertc_, & ! insert a CHARACTER(len=*) argument - inserts_ ! insert a String argument - end interface - - interface StringLinkedList_delete; module procedure & - delete_ - end interface - - interface StringLinkedList_eol ; module procedure & - eol_ - end interface - - interface StringLinkedList_next ; module procedure & - next_ - end interface - - interface StringLinkedList_count ; module procedure & - count_ - end interface - - interface StringLinkedList_get ; module procedure & - getc_, & ! get as a CHARACTER(len=*) - gets_ ! get as a String - end interface - -! !REVISION HISTORY: -! 16Feb00 - Jing Guo -! - initial prototype/prolog/code -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname='MCT(MPEU)::m_StringLinkedList' - -! Examples: -! -! 1) Creating a first-in-first-out linked-list, -! -! type(StringLinkedList),pointer :: head,this -! character(len=80) :: aline -! -! call StringLinkedList_init(head) -! this => head -! do -! read(*,'(a)',iostat=ier) aline -! if(ier/=0) exit -! call StringLinkedList_insert(trim(aline),this) -! call StringLinkedList_next(this) -! end do -! -! 2) Creating a last-in-first-out linked-list, Note that the only -! difference from Example (1) is without a call to -! StringLinkedList_next(). -! -! type(StringLinkedList),pointer :: head,this -! character(len=80) :: aline -! -! call StringLinkedList_init(head) -! this => head -! do -! read(*,'(a)',iostat=ier) aline -! if(ier/=0) exit -! call StringLinkedList_insert(trim(aline),this) -! end do -! - -contains -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: init_ - initialize a StringLinkedList from a pointer -! -! !DESCRIPTION: -! -! !INTERFACE: - - subroutine init_(head) - use m_die, only : die - use m_mall,only : mall_ison,mall_ci - implicit none - type(StringLinkedList),pointer :: head ! (out) a list - -! !REVISION HISTORY: -! 22Feb00 - Jing Guo -! - initial prototype/prolog/code -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::init_' - type(StringLinkedList),pointer :: tail - integer :: ier - - ! Two special nodes are needed for a linked-list, according to - ! Robert Sedgewick (Algorithms, QA76.6.S435, page 21). - ! - ! It seems only _head_ will be needed for external references. - ! Node _tail_ will be used to denote an end-node. - - allocate(head,tail,stat=ier) - if(ier/=0) call die(myname_,'allocate()',ier) - - if(mall_ison()) call mall_ci(2,myname) ! for two nodes - - head%next => tail - tail%next => tail - - nullify(tail) - -end subroutine init_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: insertc_ - insert before the logically referenced node -! -! !DESCRIPTION: -! -! !INTERFACE: - - subroutine insertc_(cstr,this) - use m_String,only : String_init - use m_mall, only : mall_ison,mall_ci - use m_die, only : die - implicit none - character(len=*),intent(in) :: cstr ! a new entry - type(StringLinkedList),pointer :: this ! (in) a node - -! !REVISION HISTORY: -! 16Feb00 - Jing Guo -! - initial prototype/prolog/code -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::insertc_' - type(StringLinkedList),pointer :: tmpl - integer :: ier - - ! Create a memory cell for the new entry of StringLinkedList - - allocate(tmpl,stat=ier) - if(ier/=0) call die(myname_,'allocate()',ier) - - if(mall_ison()) call mall_ci(1,myname) ! for one nodes - - ! Store the data - - call String_init(tmpl%str,cstr) - - ! Rebuild the links, if the List was not empty - - tmpl%next => this%next - this%next => tmpl - - ! Clean the working pointer - - nullify(tmpl) - -end subroutine insertc_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: inserts_ - insert before the logically referenced node -! -! !DESCRIPTION: -! -! !INTERFACE: - - subroutine inserts_(str,this) - use m_String,only : String,String_init - use m_mall, only : mall_ison,mall_ci - use m_die, only : die - implicit none - type(String),intent(in) :: str ! a new entry - type(StringLinkedList),pointer :: this ! (in) a node - -! !REVISION HISTORY: -! 16Feb00 - Jing Guo -! - initial prototype/prolog/code -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::inserts_' - type(StringLinkedList),pointer :: tmpl - integer :: ier - - ! Create a memory cell for the new entry of StringLinkedList - - allocate(tmpl,stat=ier) - if(ier/=0) call die(myname_,'allocate()',ier) - - if(mall_ison()) call mall_ci(1,myname) ! for one nodes - - ! Store the data - - call String_init(tmpl%str,str) - - ! Rebuild the links, if the List was not empty - - tmpl%next => this%next - this%next => tmpl - - ! Clean the working pointer, if it mean anyting - - nullify(tmpl) - -end subroutine inserts_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: delete_ - delete the logically referenced node -! -! !DESCRIPTION: -! -! !INTERFACE: - - subroutine delete_(this) - use m_String,only : String_clean - use m_mall, only : mall_ison,mall_co - use m_die, only : die - implicit none - type(StringLinkedList),pointer :: this ! (in) a node - -! !REVISION HISTORY: -! 17Feb00 - Jing Guo -! - initial prototype/prolog/code -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::delete_' - type(StringLinkedList),pointer :: tmpl - integer :: ier - - tmpl => this%next%next ! hold the next target - call String_clean(this%next%str) ! remove the next storage - - if(mall_ison()) call mall_co(1,myname) ! removing one node - - deallocate(this%next,stat=ier) ! Clean memory gabage - if(ier/=0) call die(myname_,'deallocate()',ier) - - ! Skip the current target. Rebuild the link to the target - ! of the current target. - - this%next => tmpl - - ! Clean the working pointer, if it mean anything - - nullify(tmpl) -end subroutine delete_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: eol_ - if the logically referenced node is an end-node -! -! !DESCRIPTION: -! -! !INTERFACE: - - function eol_(this) - implicit none - type(StringLinkedList),pointer :: this ! (in) a node - logical :: eol_ ! returned value - -! !REVISION HISTORY: -! 23Feb00 - Jing Guo -! - initial prototype/prolog/code -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::eol_' - - eol_=associated(this%next,this%next%next) -end function eol_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: next_ - point a reference pointer to the next node -! -! !DESCRIPTION: -! -! !INTERFACE: - - subroutine next_(this) - implicit none - type(StringLinkedList),pointer :: this ! (inout) a node - -! !REVISION HISTORY: -! 23Feb00 - Jing Guo -! - initial prototype/prolog/code -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::next_' - - this => this%next - -end subroutine next_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: count_ - count the number of nodes -! -! !DESCRIPTION: -! -! !INTERFACE: - - function count_(this) - implicit none - type(StringLinkedList),pointer :: this ! (in) a node - integer :: count_ ! returned value - -! !REVISION HISTORY: -! 24Feb00 - Jing Guo -! - initial prototype/prolog/code -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::count_' - type(StringLinkedList),pointer :: tmpl - - tmpl => this - - count_=0 - do while(.not.eol_(tmpl)) - count_=count_+1 - call next_(tmpl) - end do - - nullify(tmpl) -end function count_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: getc_ - get the logically referenced value as CHARACTERs -! -! !DESCRIPTION: -! -! !INTERFACE: - - subroutine getc_(this,cstr,eol) - use m_String,only : String - use m_String,only : String_init - use m_String,only : String_clean - use m_String,only : char - implicit none - type(StringLinkedList),pointer :: this ! (inout) a node - character(len=*),intent(out) :: cstr ! the referenced value - logical ,intent(out) :: eol ! if the node is an end-node - -! !REVISION HISTORY: -! 17Feb00 - Jing Guo -! - initial prototype/prolog/code -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::getc_' - type(String) :: str - - call gets_(this,str,eol) - - if(.not.eol) then - cstr=char(str) - call String_clean(str) - endif - -end subroutine getc_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: gets_ - get the logically referenced value as a String -! -! !DESCRIPTION: -! -! !INTERFACE: - - subroutine gets_(this,str,eol) - use m_String,only : String - use m_String,only : String_init - implicit none - type(StringLinkedList),pointer :: this ! (inout) a node - type(String),intent(out) :: str ! the referenced value - logical ,intent(out) :: eol ! if the node is an end-node - -! !REVISION HISTORY: -! 17Feb00 - Jing Guo -! - initial prototype/prolog/code -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::gets_' - - eol=eol_(this) - if(.not.eol) then - call String_init(str,this%next%str) - call next_(this) - endif - -end subroutine gets_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: clean_ - clean the whole object from this point -! -! !DESCRIPTION: -! -! !INTERFACE: - - subroutine clean_(head,stat) - use m_die,only : die,perr - use m_mall,only : mall_ison,mall_co - implicit none - type(StringLinkedList),pointer :: head ! (inout) a head-node - integer,optional,intent(out) :: stat ! return status - -! !REVISION HISTORY: -! 17Feb00 - Jing Guo -! - initial prototype/prolog/code -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::clean_' - integer :: ier - logical :: err - - if(present(stat)) stat=0 - - ! Verify if the pointer is valid - - err=.not.associated(head) - if(.not.err) err=.not.associated(head%next) - - if(err) then - call perr(myname_,'Attempting to clean an uninitialized list') - if(.not.present(stat)) call die(myname_) - stat=-1 - return - endif - - ! Clean the rest before delete the current one. - - do - if(eol_(head)) exit - call delete_(head) - end do - - if(mall_ison()) call mall_co(2,myname) ! remove two nodes - - deallocate(head%next,stat=ier) - if(ier==0) deallocate(head,stat=ier) - if(ier/=0) then - call perr(myname_,'deallocate()',ier) - if(.not.present(stat)) call die(myname_) - stat=-1 - return - endif - -end subroutine clean_ - -end module m_StringLinkedList diff --git a/cesm/models/utils/mct/mpeu/m_TraceBack.F90 b/cesm/models/utils/mct/mpeu/m_TraceBack.F90 deleted file mode 100644 index 0a23fd3..0000000 --- a/cesm/models/utils/mct/mpeu/m_TraceBack.F90 +++ /dev/null @@ -1,240 +0,0 @@ -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!----------------------------------------------------------------------- -! CVS $Id$ -! CVS $Name$ -!BOP ------------------------------------------------------------------- -! -! !MODULE: m_TraceBack - Generation of Traceback Information -! -! !DESCRIPTION: -! This module supports the generation of traceback information for -! a given routine. -! -! -! !INTERFACE: - - module m_TraceBack - -! !USES: -! No external modules are used in the declaration section of this module. - - implicit none - - private ! except - -! !PUBLIC TYPES: -! No public types are declared in this module. - - -! !PUBLIC MEMBER FUNCTIONS: - - public :: GenTraceBackString - - interface GenTraceBackString; module procedure & - GenTraceBackString1, & - GenTraceBackString2 - end interface - -! !PUBLIC DATA MEMBERS: -! No public data member constants are declared in this module. - - -! !REVISION HISTORY: -! 5 Aug02 - J. Larson - Initial version. -!EOP ___________________________________________________________________ - -! Parameters local to this module: - - character(len=*),parameter :: myname='MCT(MPEU)::m_TraceBackString' - - character(len=len('|X|')), parameter :: StartChar = '|X|' - character(len=len('->')), parameter :: ArrowChar = '->' - - contains - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: GenTraceBackString1 - Start a TraceBack with One Routine Name -! -! !DESCRIPTION: -! This routine takes in CHARACTER form the names of the calling routine -! (the input argument {\tt RoutineName} and returns a {\tt String} -! (the output argument {\tt TraceBackString}) that portrays this routine -! as the starting point of a downwards procedural trace. The contents -! of {\tt TraceBackString} is merely an {\tt '|X|'}, followed immediately -! by the value of {\tt RoutineName}. -! -! !INTERFACE: - - subroutine GenTraceBackString1(TraceBackString, RoutineName) -! -! !USES: -! - use m_stdio - use m_die - - use m_String, only : String - use m_String, only : String_init => init - - implicit none - -! !INPUT PARAMETERS: -! - character(len=*), intent(in) :: RoutineName - -! !OUTPUT PARAMETERS: -! - type(String), intent(out) :: TraceBackString - -! !REVISION HISTORY: -! 5Aug02 - J. Larson - Initial version. -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::GenTraceBackString1' - integer :: i, ierr - integer :: RoutineNameLength, ScratchBufferLength - character, dimension(:), allocatable :: ScratchBuffer - - ! Note: The value of ArrowChar is inherited - ! from the declaration section of this module. - - ! Determine the lengths of ParentName and ChildName - - RoutineNameLength = len(RoutineName) - - ! Set up ScratchBuffer: - - ScratchBufferLength = len(StartChar) + RoutineNameLength - - allocate(ScratchBuffer(ScratchBufferLength), stat=ierr) - if(ierr /= 0) then - write(stderr,'(2a,i8)') myname_, & - ':: Allocate(ScratchBuffer...) failed. ierr = ',ierr - call die(myname_) - endif - - ! Load ScratchBuffer: - - - do i=1,len(StartChar) ! Load the '|X|'... - ScratchBuffer(i) = StartChar(i:i) - end do - - do i=1,RoutineNameLength - ScratchBuffer(len(StartChar)+i) = RoutineName(i:i) - end do - - ! Create TraceBackString - - call String_init(TraceBackString, ScratchBuffer) - - ! Clean up: - - deallocate(ScratchBuffer, stat=ierr) - if(ierr /= 0) then - write(stderr,'(2a,i8)') myname_, & - ':: Deallocate(ScratchBuffer...) failed. ierr = ',ierr - call die(myname_) - endif - - end subroutine GenTraceBackString1 - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: GenTraceBackString2 - Connect Two Routine Names in a TraceBack -! -! !DESCRIPTION: -! This routine takes in CHARACTER form the names of the parent and -! child routines (the input arguments {\tt ParentName} and -! {\tt ChildName}, repsectively), and returns a {\tt String} (the output -! argument {\tt TraceBackString}) that portrays their procedural -! relationship. The contents of {\tt TraceBackString} is merely -! {\tt ParentName}, followe by an arrow ({\tt "->"}), followed by -! {\tt ChildName}. -! -! !INTERFACE: - - subroutine GenTraceBackString2(TraceBackString, ParentName, ChildName) -! -! !USES: -! - use m_stdio - use m_die - - use m_String, only : String - use m_String, only : String_init => init - - implicit none - -! !INPUT PARAMETERS: -! - character(len=*), intent(in) :: ParentName - character(len=*), intent(in) :: ChildName - -! !OUTPUT PARAMETERS: -! - type(String), intent(out) :: TraceBackString - -! !REVISION HISTORY: -! 5Aug02 - J. Larson - Initial version. -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::GenTraceBackString2' - integer :: i, ierr - integer :: ParentNameLength, ChildNameLength, ScratchBufferLength - character, dimension(:), allocatable :: ScratchBuffer - - ! Note: The value of ArrowChar is inherited - ! from the declaration section of this module. - - ! Determine the lengths of ParentName and ChildName - - ParentNameLength = len(ParentName) - ChildNameLength = len(ChildName) - - ! Set up ScratchBuffer: - - ScratchBufferLength = ParentNameLength + ChildNameLength + & - len(ArrowChar) - allocate(ScratchBuffer(ScratchBufferLength), stat=ierr) - if(ierr /= 0) then - write(stderr,'(2a,i8)') myname_, & - ':: Allocate(ScratchBuffer...) failed. ierr = ',ierr - call die(myname_) - endif - - ! Load ScratchBuffer: - - do i=1,ParentNameLength ! Load the Parent Routine Name... - ScratchBuffer(i) = ParentName(i:i) - end do - - do i=1,len(ArrowChar) ! Load the Arrow... - ScratchBuffer(ParentNameLength+i) = ArrowChar(i:i) - end do - - do i=1,ChildNameLength - ScratchBuffer(ParentNameLength+len(ArrowChar)+i) = ChildName(i:i) - end do - - ! Create TraceBackString - - call String_init(TraceBackString, ScratchBuffer) - - ! Clean up: - - deallocate(ScratchBuffer, stat=ierr) - if(ierr /= 0) then - write(stderr,'(2a,i8)') myname_, & - ':: Deallocate(ScratchBuffer...) failed. ierr = ',ierr - call die(myname_) - endif - - end subroutine GenTraceBackString2 - - end module m_TraceBack diff --git a/cesm/models/utils/mct/mpeu/m_chars.F90 b/cesm/models/utils/mct/mpeu/m_chars.F90 deleted file mode 100644 index 05df3df..0000000 --- a/cesm/models/utils/mct/mpeu/m_chars.F90 +++ /dev/null @@ -1,107 +0,0 @@ -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!----------------------------------------------------------------------- -! CVS $Id$ -! CVS $Name$ -!----------------------------------------------------------------------- -!BOP -! -! !MODULE: m_chars - a module for character class object operations -! -! !DESCRIPTION: -! -! !INTERFACE: - - module m_chars - implicit none - private - - public :: operator (.upper.) ! convert a string to uppercase - public :: uppercase - - public :: operator (.lower.) ! convert a string to lowercase - public :: lowercase - - interface operator (.upper.) - module procedure upper_case - end interface - interface uppercase - module procedure upper_case - end interface - - interface operator (.lower.) - module procedure lower_case - end interface - interface lowercase - module procedure lower_case - end interface - -! !REVISION HISTORY: -! 16Jul96 - J. Guo - (to do) -!EOP -!_______________________________________________________________________ - character(len=*),parameter :: myname='MCT(MPEU)::m_chars' - -contains -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!----------------------------------------------------------------------- -!BOP -! -! !IROUTINE: upper_case - convert lowercase letters to uppercase. -! -! !DESCRIPTION: -! -! !INTERFACE: - - function upper_case(str) result(ustr) - implicit none - character(len=*), intent(in) :: str - character(len=len(str)) :: ustr - -! !REVISION HISTORY: -! 13Aug96 - J. Guo - (to do) -!EOP -!_______________________________________________________________________ - integer i - integer,parameter :: il2u=ichar('A')-ichar('a') - - ustr=str - do i=1,len_trim(str) - if(str(i:i).ge.'a'.and.str(i:i).le.'z') & - ustr(i:i)=char(ichar(str(i:i))+il2u) - end do - end function upper_case - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!----------------------------------------------------------------------- -!BOP -! -! !IROUTINE: lower_case - convert uppercase letters to lowercase. -! -! !DESCRIPTION: -! -! !INTERFACE: - - function lower_case(str) result(lstr) - implicit none - character(len=*), intent(in) :: str - character(len=len(str)) :: lstr - -! !REVISION HISTORY: -! 13Aug96 - J. Guo - (to do) -!EOP -!_______________________________________________________________________ - integer i - integer,parameter :: iu2l=ichar('a')-ichar('A') - - lstr=str - do i=1,len_trim(str) - if(str(i:i).ge.'A'.and.str(i:i).le.'Z') & - lstr(i:i)=char(ichar(str(i:i))+iu2l) - end do - end function lower_case - -end module m_chars -!. diff --git a/cesm/models/utils/mct/mpeu/m_die.F90 b/cesm/models/utils/mct/mpeu/m_die.F90 deleted file mode 100644 index 9534c39..0000000 --- a/cesm/models/utils/mct/mpeu/m_die.F90 +++ /dev/null @@ -1,404 +0,0 @@ -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!----------------------------------------------------------------------- -! CVS $Id$ -! CVS $Name$ -!----------------------------------------------------------------------- -!BOP -! -! !MODULE: m_die - die with mpout flushed -! -! !DESCRIPTION: -! -! !INTERFACE: - - module m_die - use m_mpif90, only : MP_perr - implicit none - private ! except - - public :: die ! signal an exception - public :: diex ! a special die() supporting macros - public :: perr,warn ! message(s) to stderr - public :: perr_die ! to be phased out - public :: MP_die ! a special die() for MPI errors - public :: MP_perr ! perr for MPI errors, from m_mpif90 - public :: MP_perr_die ! a special die() for MPI errors - public :: assert_ ! used by ASSERT() macro of assert.H - - interface die; module procedure & - die0_, & ! die(where) - die1_, & ! die(where,message) - die2_, & ! die(where,proc,ier) - die4_ ! die(where,mesg1,ival1,mesg2,ival2) - end interface - - interface diex; module procedure & - diex_ ! diex(where,filename,lineno) - end interface - - interface perr; module procedure & - perr1_, & ! perr(where,message) - perr2_, & ! perr(where,proc,ier) - perr4_ ! perr(where,mesg1,ival1,mesg2,ival2) - end interface - interface warn; module procedure & - perr1_, & ! perr(where,message) - perr2_, & ! perr(where,proc,ier) - perr4_ ! perr(where,mesg1,ival1,mesg2,ival2) - end interface - - interface perr_die; module procedure & - die2_ ! perr_die(where,proc,ier) - end interface - - interface MP_die; module procedure & - MPdie2_ ! MP_die(where,proc,ier) - end interface - interface MP_perr_die; module procedure & - MPdie2_ ! MP_die(where,proc,ier) - end interface - - -! !REVISION HISTORY: -! 26Feb98 - Jing Guo - initial prototype/prolog/code -!EOP -!_______________________________________________________________________ - character(len=*),parameter :: myname='MCT(MPEU)::m_die' -contains -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!----------------------------------------------------------------------- -!BOP -! -! !IROUTINE: die0_ - flush(mpout) before die() -! -! !DESCRIPTION: -! -! !INTERFACE: - - subroutine die0_(where) - use m_mpout, only : mpout,mpout_flush,mpout_close,mpout_ison - use m_flow, only : flow_flush - use m_dropdead, only : ddie => die - implicit none - character(len=*),intent(in) :: where - -! !REVISION HISTORY: -! 26Feb98 - Jing Guo - initial prototype/prolog/code -!EOP -!_______________________________________________________________________ - character(len=*),parameter :: myname_=myname//'::die0_' - - call mpout_flush() - if(mpout_ison()) call flow_flush(mpout) - call mpout_close() - call ddie(where) - -end subroutine die0_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!----------------------------------------------------------------------- -!BOP -! -! !IROUTINE: die1_ - flush(mpout) before die() -! -! !DESCRIPTION: -! -! !INTERFACE: - - subroutine die1_(where,message) - use m_mpout, only : mpout,mpout_flush,mpout_close,mpout_ison - use m_flow, only : flow_flush - use m_dropdead, only : ddie => die - implicit none - character(len=*),intent(in) :: where - character(len=*),intent(in) :: message - -! !REVISION HISTORY: -! 26Feb98 - Jing Guo - initial prototype/prolog/code -!EOP -!_______________________________________________________________________ - character(len=*),parameter :: myname_=myname//'::die1_' - - call mpout_flush() - if(mpout_ison()) call flow_flush(mpout) - call mpout_close() - - call perr1_(where,message) - call ddie(where) - -end subroutine die1_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!----------------------------------------------------------------------- -!BOP -! -! !IROUTINE: die2_ - flush(mpout) before die() -! -! !DESCRIPTION: -! -! !INTERFACE: - - subroutine die2_(where,proc,ier) - use m_mpout, only : mpout,mpout_flush,mpout_close,mpout_ison - use m_flow, only : flow_flush - use m_dropdead, only : ddie => die - implicit none - character(len=*),intent(in) :: where - character(len=*),intent(in) :: proc - integer,intent(in) :: ier - -! !REVISION HISTORY: -! 26Feb98 - Jing Guo - initial prototype/prolog/code -!EOP -!_______________________________________________________________________ - character(len=*),parameter :: myname_=myname//'::die2_' - - call mpout_flush() - if(mpout_ison()) call flow_flush(mpout) - call mpout_close() - - call perr2_(where,proc,ier) - call ddie(where) - -end subroutine die2_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!----------------------------------------------------------------------- -!BOP -! -! !IROUTINE: die4_ - flush(mpout) before die() -! -! !DESCRIPTION: -! -! !INTERFACE: - - subroutine die4_(where,mesg1,ival1,mesg2,ival2) - use m_mpout, only : mpout,mpout_flush,mpout_close,mpout_ison - use m_flow, only : flow_flush - use m_dropdead, only : ddie => die - implicit none - character(len=*),intent(in) :: where - character(len=*),intent(in) :: mesg1 - integer,intent(in) :: ival1 - character(len=*),intent(in) :: mesg2 - integer,intent(in) :: ival2 - -! !REVISION HISTORY: -! 26Feb98 - Jing Guo - initial prototype/prolog/code -!EOP -!_______________________________________________________________________ - character(len=*),parameter :: myname_=myname//'::die4_' - - call mpout_flush() - if(mpout_ison()) call flow_flush(mpout) - call mpout_close() - - call perr4_(where,mesg1,ival1,mesg2,ival2) - call ddie(where) - -end subroutine die4_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!----------------------------------------------------------------------- -!BOP -! -! !IROUTINE: diex_ - flush(mpout) before die() -! -! !DESCRIPTION: -! -! !INTERFACE: - - subroutine diex_(where,filename,line) - use m_mpout, only : mpout,mpout_flush,mpout_close,mpout_ison - use m_flow, only : flow_flush - use m_dropdead, only : ddie => die - implicit none - character(len=*),intent(in) :: where - character(len=*),intent(in) :: filename - integer,intent(in) :: line - -! !REVISION HISTORY: -! 26Feb98 - Jing Guo - initial prototype/prolog/code -!EOP -!_______________________________________________________________________ - character(len=*),parameter :: myname_=myname//'::diex_' - - call mpout_flush() - if(mpout_ison()) call flow_flush(mpout) - call mpout_close() - call ddie(where,filename,line) - -end subroutine diex_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: perr1_ - send a simple error message to _stderr_ -! -! !DESCRIPTION: -! -! !INTERFACE: - - subroutine perr1_(where,message) - use m_stdio,only : stderr - implicit none - character(len=*),intent(in) :: where - character(len=*),intent(in) :: message - -! !REVISION HISTORY: -! 27Apr98 - Jing Guo - initial prototype/prolog/code -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::perr1_' - - write(stderr,'(3a)') where,': ',message - -end subroutine perr1_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: perr2_ - send a simple error message to _stderr_ -! -! !DESCRIPTION: -! -! !INTERFACE: - - subroutine perr2_(where,proc,ier) - use m_stdio,only : stderr - implicit none - character(len=*),intent(in) :: where - character(len=*),intent(in) :: proc - integer,intent(in) :: ier - -! !REVISION HISTORY: -! 27Apr98 - Jing Guo - initial prototype/prolog/code -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::perr2_' - character(len=16) :: cer - integer :: ios - - cer='*******' - write(cer,'(i16)',iostat=ios) ier - write(stderr,'(5a)') where,': ', & - proc,' error, stat =',trim(adjustl(cer)) - -end subroutine perr2_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: perr4_ - send a simple error message to _stderr_ -! -! !DESCRIPTION: -! -! !INTERFACE: - - subroutine perr4_(where,mesg1,ival1,mesg2,ival2) - use m_stdio,only : stderr - implicit none - character(len=*),intent(in) :: where - character(len=*),intent(in) :: mesg1 - integer,intent(in) :: ival1 - character(len=*),intent(in) :: mesg2 - integer,intent(in) :: ival2 - -! !REVISION HISTORY: -! 27Apr98 - Jing Guo - initial prototype/prolog/code -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::perr4_' - character(len=16) :: cval1,cval2 - integer :: ios - - cval1='*******' - cval2='*******' - write(cval1,'(i16)',iostat=ios) ival1 - write(cval2,'(i16)',iostat=ios) ival2 - - write(stderr,'(10a)') where,': error, ', & - mesg1,'=',trim(adjustl(cval1)),', ', & - mesg2,'=',trim(adjustl(cval2)),'.' - -end subroutine perr4_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: MPdie2_ - invoke MP_perr before die_ -! -! !DESCRIPTION: -! -! !INTERFACE: - - subroutine MPdie2_(where,proc,ier) - use m_mpif90, only : MP_perr - implicit none - character(len=*),intent(in) :: where - character(len=*),intent(in) :: proc - integer,intent(in) :: ier - -! !REVISION HISTORY: -! 27Apr98 - Jing Guo - initial prototype/prolog/code -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::MPdie2_' - - call MP_perr(where,proc,ier) - call die0_(where) - -end subroutine MPdie2_ -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: assert_ - an utility called by ASSERT() macro only -! -! !DESCRIPTION: -! -! !INTERFACE: - - subroutine assert_(str, file, line) - use m_mpout,only : mpout,mpout_flush,mpout_close,mpout_ison - use m_flow,only : flow_flush - use m_dropdead,only : ddie => die - implicit none - Character(Len=*), Intent(In) :: str ! a message - Character(Len=*), Intent(In) :: file ! a filename - Integer, Intent(In) :: line ! a line number - -! !REVISION HISTORY: -! 25Aug00 - Jing Guo -! - modified -! - included into m_die for easier module management -! before - Tom Clune -! - Created for MPI PSAS implementation as a separate -! module -! 19Jan01 - J. Larson - removed nested -! single/double/single quotes in the second argument -! to the call to perr1_(). This was done for the pgf90 -! port. -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_='ASSERT_' - - call mpout_flush() - if(mpout_ison()) call flow_flush(mpout) - call mpout_close() - - call perr1_(myname_,'failed: "//str//")') - call ddie(myname_,file,line) - -End subroutine assert_ -end module m_die diff --git a/cesm/models/utils/mct/mpeu/m_dropdead.F90 b/cesm/models/utils/mct/mpeu/m_dropdead.F90 deleted file mode 100644 index a430b35..0000000 --- a/cesm/models/utils/mct/mpeu/m_dropdead.F90 +++ /dev/null @@ -1,191 +0,0 @@ -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!----------------------------------------------------------------------- -! CVS $Id$ -! CVS $Name$ -!----------------------------------------------------------------------- -!BOP -! -! !MODULE: m_dropdead - An abort() with a style -! -! !DESCRIPTION: -! -! !INTERFACE: - - module m_dropdead - implicit none - private ! except - - public :: die ! terminate a program with a condition - - interface die; module procedure & - die_, & - diex_ - end interface - -! !REVISION HISTORY: -! 20Feb97 - Jing Guo - defined template -!EOP -!_______________________________________________________________________ - -contains - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!----------------------------------------------------------------------- -!BOP -! !IROUTINE: die_ - Clean up and raise an exception to the OS -! -! !DESCRIPTION: -! -! A call to die() exits the program with minimum information for -! both the user and the operating system. -! -! !INTERFACE: - - subroutine die_(where) - use m_stdio, only : stderr - use m_mpif90,only : MP_comm_world - use m_mpif90,only : MP_comm_rank - use m_mpif90,only : MP_abort - use m_mpif90,only : MP_initialized - implicit none - character(len=*),intent(in) :: where ! where it is called - -! !REVISION HISTORY: -! 20Feb97 - Jing Guo - defined template -! 09Jan07 - R. Loy - check for initialized, add -! options for abort -! -!EOP -!_______________________________________________________________________ - - character(len=*),parameter :: myname_='MCT(MPEU)::die.' - integer :: myrank,ier - logical :: initialized - - call MP_initialized(initialized,ier) - - if (initialized) then - - !------------------------------------------------- - ! MPI_ should have been initialized for this call - !------------------------------------------------- - - call MP_comm_rank(MP_comm_world,myrank,ier) - - ! a message for the users: - - write(stderr,'(z3.3,5a)') myrank,'.',myname_, & - ': from ',trim(where),'()' - - ! raise a condition to the OS - -#ifdef ENABLE_UNIX_ABORT - call abort -#else - call MP_abort(MP_comm_world,2,ier) -#endif - - else - - write(stderr,'(5a)') 'unknown rank .',myname_, & - ': from ',trim(where),'()' - -#ifdef ENABLE_UNIX_ABORT - call abort -#else - stop -#endif - - endif - -end subroutine die_ -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!----------------------------------------------------------------------- -!BOP -! -! !IROUTINE: diex_ - Clean up and raise an exception to the OS -! -! !DESCRIPTION: -! -! A call to die() exits the program with minimum information for -! both the user and the operating system. This implementation, -! however, may be used in conjunction with with a source preprocessor -! to produce more detailed location information. -! -! !INTERFACE: - - subroutine diex_(where,fnam,line) - use m_stdio, only : stderr - use m_mpif90,only : MP_comm_world - use m_mpif90,only : MP_comm_rank - use m_mpif90,only : MP_abort - use m_mpif90,only : MP_initialized - implicit none - character(len=*),intent(in) :: where ! where it is called - character(len=*),intent(in) :: fnam - integer,intent(in) :: line - -! !REVISION HISTORY: -! 20Feb97 - Jing Guo - defined template -! 09Jan07 - R. Loy - check for initialized, add -! options for abort -! -!EOP -!_______________________________________________________________________ - - character(len=*),parameter :: myname_='die.' - integer :: myrank,ier - character(len=16) :: lineno - - logical :: initialized - - write(lineno,'(i16)') line - - call MP_initialized(initialized,ier) - - if (initialized) then - - !------------------------------------------------- - ! MPI_ should have been initialized for this call - !------------------------------------------------- - - call MP_comm_rank(MP_comm_world,myrank,ier) - - ! a message for the users: - write(stderr,'(z3.3,9a)') myrank,'.',myname_, & - ': from ',trim(where),'()', & - ', line ',trim(adjustl(lineno)), & - ' of file ',fnam - - ! raise a condition to the OS - -#ifdef ENABLE_UNIX_ABORT - call abort -#else - call MP_abort(MP_comm_world,2,ier) -#endif - - else - - ! a message for the users: - write(stderr,'(9a)') 'unknown rank .',myname_, & - ': from ',trim(where),'()', & - ', line ',trim(adjustl(lineno)), & - ' of file ',fnam - -#ifdef ENABLE_UNIX_ABORT - call abort -#else - stop -#endif - - endif - - -end subroutine diex_ -!======================================================================= -end module m_dropdead -!. diff --git a/cesm/models/utils/mct/mpeu/m_flow.F90 b/cesm/models/utils/mct/mpeu/m_flow.F90 deleted file mode 100644 index 1a4d486..0000000 --- a/cesm/models/utils/mct/mpeu/m_flow.F90 +++ /dev/null @@ -1,196 +0,0 @@ -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!----------------------------------------------------------------------- -! CVS $Id$ -! CVS $Name$ -!----------------------------------------------------------------------- -!BOP -! -! !MODULE: m_flow - tracing the program calling tree -! -! !DESCRIPTION: -! -! !INTERFACE: - - module m_flow - implicit none - private ! except - - public :: flow_ci - public :: flow_co - public :: flow_flush - public :: flow_reset - - interface flow_ci; module procedure ci_; end interface - interface flow_co; module procedure co_; end interface - interface flow_flush; module procedure flush_; end interface - interface flow_reset; module procedure reset_; end interface - -! !REVISION HISTORY: -! 26Feb98 - Jing Guo - initial prototype/prolog/code -!EOP -!_______________________________________________________________________ - character(len=*),parameter :: myname='MCT(MPEU)::m_flow' - - integer,parameter :: MX_TNAME= 64 - integer,parameter :: LN_TNAME= 32 - - integer,save :: mxdep= 0 - integer,save :: iname=-1 - character(len=LN_TNAME),save,dimension(0:MX_TNAME-1) :: tname - - character(len=LN_TNAME),save :: ciname=' ' - character(len=LN_TNAME),save :: coname=' ' - logical,save :: balanced=.true. - -contains -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!----------------------------------------------------------------------- -!BOP -! -! !IROUTINE: ci_ - checking in a level -! -! !DESCRIPTION: -! -! !INTERFACE: - - subroutine ci_(name) - implicit none - character(len=*),intent(in) :: name - -! !REVISION HISTORY: -! 26Feb98 - Jing Guo - initial prototype/prolog/code -!EOP -!_______________________________________________________________________ - character(len=*),parameter :: myname_=myname//'::ci_' - - ! Push in an entry in to a circulated list storage to save - ! only the last MX_TNAME entries. - - iname=iname+1 - tname(modulo(iname,MX_TNAME)) = name - - if(mxdep < iname+1) mxdep=iname+1 -end subroutine ci_ -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!----------------------------------------------------------------------- -!BOP -! -! !IROUTINE: co_ - checking out a level -! -! !DESCRIPTION: -! -! !INTERFACE: - - subroutine co_(name) - use m_chars, only : uppercase - implicit none - character(len=*),intent(in) :: name - -! !REVISION HISTORY: -! 26Feb98 - Jing Guo - initial prototype/prolog/code -!EOP -!_______________________________________________________________________ - character(len=*),parameter :: myname_=myname//'::co_' - character(len=LN_TNAME) :: uname - - if(balanced) then - uname='?' - balanced=iname >= 0 - if(balanced) then - uname=tname(modulo(iname,MX_TNAME)) - balanced = uname == ' ' .or. uppercase(uname) == uppercase(name) - endif - if(.not.balanced) then - ciname=uname - coname= name - endif - endif - - ! Pop out an entry - - tname(modulo(iname,MX_TNAME))=' ' - iname=iname-1 - -end subroutine co_ -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!----------------------------------------------------------------------- -!BOP -! -! !IROUTINE: flush_ - print all remaining entries in the list -! -! !DESCRIPTION: -! -! !INTERFACE: - - subroutine flush_(lu) - implicit none - integer,intent(in) :: lu - -! !REVISION HISTORY: -! 26Feb98 - Jing Guo - initial prototype/prolog/code -!EOP -!_______________________________________________________________________ - character(len=*),parameter :: myname_=myname//'::flush_' - integer :: i - - ! Nothing to show - - if(mxdep == 0 .and. iname == -1) return - - write(lu,'(2a,i4)',advance='no') myname,': depth =',mxdep - - if(.not.balanced .or. iname < -1) then - - write(lu,'(4a)',advance='no') & - ', ci/co unbalanced at ',trim(ciname),'/',trim(coname) - - write(lu,'(a,i4)') ', level =',iname+1 - return - - endif - - if(iname >= 0) then - write(lu,'(a)',advance='no') ', ' - do i=0,iname-1 - write(lu,'(2a)',advance='no') trim(tname(modulo(i,MX_TNAME))),'>' - end do - write(lu,'(a)',advance='no') trim(tname(modulo(iname,MX_TNAME))) - endif - write(lu,*) - -end subroutine flush_ -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!----------------------------------------------------------------------- -!BOP -! -! !IROUTINE: reset_ - set the stack to empty -! -! !DESCRIPTION: -! -! !INTERFACE: - - subroutine reset_() - implicit none - -! !REVISION HISTORY: -! 26Feb98 - Jing Guo - initial prototype/prolog/code -!EOP -!_______________________________________________________________________ - character(len=*),parameter :: myname_=myname//'::reset_' - integer :: i - - mxdep=0 - iname=-1 - tname(0:MX_TNAME-1)=' ' - - ciname=' ' - coname=' ' - balanced=.true. - -end subroutine reset_ -end module m_flow diff --git a/cesm/models/utils/mct/mpeu/m_inpak90.F90 b/cesm/models/utils/mct/mpeu/m_inpak90.F90 deleted file mode 100644 index 56480a3..0000000 --- a/cesm/models/utils/mct/mpeu/m_inpak90.F90 +++ /dev/null @@ -1,2049 +0,0 @@ -!------------------------------------------------------------------------- -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!------------------------------------------------------------------------- -! CVS $Id$ -! CVS $Name$ -!------------------------------------------------------------------------- -!BOI -! -! !TITLE: Inpak 90 Documentation \\ Version 1.01 -! -! !AUTHORS: Arlindo da Silva -! -! !AFFILIATION: Data Assimilation Office, NASA/GSFC, Greenbelt, MD 20771 -! -! !DATE: June 20, 1996 -! -! !INTRODUCTION: Package Overview -! -! Inpak 90 is a Fortran (77/90) collection of -! routines/functions for accessing {\em Resource Files} -! in ASCII format. The package is optimized -! for minimizing formatted I/O, performing all of its string -! operations in memory using Fortran intrinsic functions. -! -! \subsection{Resource Files} -! -! A {\em Resource File} is a text file consisting of variable -! length lines (records), each possibly starting with a {\em label} -! (or {\em key}), followed by some data. A simple resource file -! looks like this: -! -! \begin{verbatim} -! # Lines starting with # are comments which are -! # ignored during processing. -! my_file_names: jan87.dat jan88.dat jan89.dat -! radius_of_the_earth: 6.37E6 # these are comments too -! constants: 3.1415 25 -! my_favourite_colors: green blue 022 # text & number are OK -! \end{verbatim} -! -! In this example, {\tt my\_file\_names:} and {\tt constants:} -! are labels, while {\tt jan87.dat, jan88.dat} and {\tt jan89.dat} are -! data associated with label {\tt my\_file\_names:}. -! Resource files can also contain simple tables of the form, -! -! \begin{verbatim} -! my_table_name:: -! 1000 3000 263.0 -! 925 3000 263.0 -! 850 3000 263.0 -! 700 3000 269.0 -! 500 3000 287.0 -! 400 3000 295.8 -! 300 3000 295.8 -! :: -! \end{verbatim} -! -! Resource files are random access, the particular order of the -! records are not important (except between ::s in a table definition). -! -! \subsection{A Quick Stroll} -! -! The first step is to load the ASCII resource (rc) file into -! memory\footnote{See next section for a complete description -! of parameters for each routine/function}: -! -! \begin{verbatim} -! call i90_LoadF ( 'my_file.rc', iret ) -! \end{verbatim} -! -! The next step is to select the label (record) of interest, say -! -! \begin{verbatim} -! call i90_label ( 'constants:', iret ) -! \end{verbatim} -! -! The 2 constants above can be retrieved with the following code -! fragment: -! \begin{verbatim} -! real r -! integer i -! call i90_label ( 'constants:', iret ) -! r = i90_gfloat(iret) ! results in r = 3.1415 -! i = i90_gint(iret) ! results in i = 25 -! \end{verbatim} -! -! The file names above can be retrieved with the following -! code fragment: -! \begin{verbatim} -! character*20 fn1, fn2, fn3 -! integer iret -! call i90_label ( 'my_file_names:', iret ) -! call i90_Gtoken ( fn1, iret ) ! ==> fn1 = 'jan87.dat' -! call i90_Gtoken ( fn2, iret ) ! ==> fn1 = 'jan88.dat' -! call i90_Gtoken ( fn3, iret ) ! ==> fn1 = 'jan89.dat' -! \end{verbatim} -! -! To access the table above, the user first must use {\tt i90\_label()} to -! locate the beginning of the table, e.g., -! -! \begin{verbatim} -! call i90_label ( 'my_table_name::', iret ) -! \end{verbatim} -! -! Subsequently, {\tt i90\_gline()} can be used to gain access to each -! row of the table. Here is a code fragment to read the above -! table (7 rows, 3 columns): -! -! \begin{verbatim} -! real table(7,3) -! character*20 word -! integer iret -! call i90_label ( 'my_table_name::', iret ) -! do i = 1, 7 -! call i90_gline ( iret ) -! do j = 1, 3 -! table(i,j) = i90_gfloat ( iret ) -! end do -! end do -! \end{verbatim} -! -! Get the idea? -! -! \newpage -! \subsection{Main Routine/Functions} -! -! \begin{verbatim} -! ------------------------------------------------------------------ -! Routine/Function Description -! ------------------------------------------------------------------ -! I90_LoadF ( filen, iret ) loads resource file into memory -! I90_Label ( label, iret ) selects a label (key) -! I90_GLine ( iret ) selects next line (for tables) -! I90_Gtoken ( word, iret ) get next token -! I90_Gfloat ( iret ) returns next float number (function) -! I90_GInt ( iret ) returns next integer number (function) -! i90_AtoF ( string, iret ) ASCII to float (function) -! i90_AtoI ( string, iret ) ASCII to integer (function) -! I90_Len ( string ) string length without trailing blanks -! LabLin ( label ) similar to i90_label (no iret) -! FltGet ( default ) returns next float number (function) -! IntGet ( default ) returns next integer number (function) -! ChrGet ( default ) returns next character (function) -! TokGet ( string, default ) get next token -! ------------------------------------------------------------------ -! \end{verbatim} -! -! {\em Common Arguments:} -! -! \begin{verbatim} -! character*(*) filen file name -! integer iret error return code (0 is OK) -! character*(*) label label (key) to locate record -! character*(*) word blank delimited string -! character*(*) string a sequence of characters -! \end{verbatim} -! -! See the Prologues in the next section for additional details. -! -! -! \subsection{Package History} -! Back in the 70s Eli Isaacson wrote IOPACK in Fortran -! 66. In June of 1987 I wrote Inpak77 using -! Fortran 77 string functions; Inpak 77 is a vastly -! simplified IOPACK, but has its own goodies not found in -! IOPACK. Inpak 90 removes some obsolete functionality in -! Inpak77, and parses the whole resource file in memory for -! performance. Despite its name, Inpak 90 compiles fine -! under any modern Fortran 77 compiler. -! -! \subsection{Bugs} -! Inpak 90 is not very gracious with error messages. -! The interactive functionality of Inpak77 has not been implemented. -! The comment character \# cannot be escaped. -! -! \subsection{Availability} -! -! This software is available at -! \begin{verbatim} -! ftp://niteroi.gsfc.nasa.gov/pub/packages/i90/ -! \end{verbatim} -! There you will find the following files: -! \begin{verbatim} -! i90.f Fortran 77/90 source code -! i90.h Include file needed by i90.f -! ti90.f Test code -! i90.ps Postscript documentation -! \end{verbatim} -! An on-line version of this document is available at -! \begin{verbatim} -! ftp://niteroi.gsfc.nasa.gov/www/packages/i90/i90.html -! \end{verbatim} -! -!EOI -!------------------------------------------------------------------------- -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!----------------------------------------------------------------------- -! -! !REVISION HISTORY: -! 03Jul96 - J. Guo - evolved to Fortran 90 module. The -! modifications include 1) additional subroutines to -! dynamically manage the memory, 2) privatized most -! entries, 3) included "i90.h" into the module source -! with better initializations, 4) removed blockdata, 5) -! used a portable opntext() call to avoid I/O portability -! problems. -! -! See I90_page() I90_Release(), and I90_LoadF() for -! details. -! -! 05Aug98 - Jing Guo - -! Removed i90_page() and its references. -! Added internal subroutines push_() and pop_(). -! Modified i90_release(). -! Added i90_fullrelease(). -! Removed %loaded. Check i90_depth instead. -! 06Aug98 - Todling - made I90_gstr public -! 20Dec98 - Jing Guo - replaced the description of I90_Gstr -! 28Sep99 - Jing Guo - Merged with the MPI version with -! some addtional changes based on -! merging decisions. -! 12Oct99 - Larson/Guo - Overloaded fltget() to new routines -! getfltsp() and fltgetdp(), providing better support -! for 32 and 64 bit platforms, respectively. -!_______________________________________________________________________ - - module m_inpak90 - use m_stdio, only : stderr,stdout - use m_realkinds, only: FP, SP, DP,kind_r8 - implicit none - private - public :: I90_LoadF ! loads a resource file into memory - public :: I90_allLoadF! loads/populates a resource file to all PEs - public :: I90_Release ! Releases one cached resource file - public :: I90_fullRelease ! Releases the whole stack - public :: I90_Label ! selects a label (key) - public :: I90_GLine ! selects the next line (for tables) - public :: I90_Gtoken ! gets the next token - public :: I90_Gstr ! get a string upto to a "$" or EOL - - public :: I90_AtoF ! ASCII to float (function) - public :: I90_AtoI ! ASCII to integer (function) - - public :: I90_Gfloat ! returns next float number (function) - public :: I90_GInt ! returns next integer number (function) - - public :: lablin,rdnext,fltget,intget,getwrd,str2rn,chrget,getstr - public :: strget - - interface fltget; module procedure & - fltgetsp, & - fltgetdp - end interface - - -!----------------------------------------------------------------------- -! -! This part was originally in "i90.h", but included for module. -! - - ! revised parameter table to fit Fortran 90 standard - - integer, parameter :: LSZ = 256 - -!ams -! On Linux with the Fujitsu compiler, I needed to reduce NBUF_MAX -!ams -! integer, parameter :: NBUF_MAX = 400*(LSZ) ! max size of buffer -! integer, parameter :: NBUF_MAX = 200*(LSZ) ! max size of buffer -! Further reduction of NBUF_MAX was necessary for the Fujitsu VPP: - integer, parameter :: NBUF_MAX = 128*(LSZ)-1 ! Maximum buffer size - ! that works with the - ! Fujitsu-VPP platform. - - - character, parameter :: BLK = achar(32) ! blank (space) - character, parameter :: TAB = achar(09) ! TAB - character, parameter :: EOL = achar(10) ! end of line mark (newline) - character, parameter :: EOB = achar(00) ! end of buffer mark (null) - character, parameter :: NULL= achar(00) ! what it says - - type inpak90 - ! May be easily paged for extentable file size (J.G.) - - integer :: nbuf ! actual size of buffer - character(len=NBUF_MAX),pointer :: buffer ! hold the whole file? - character(len=LSZ), pointer :: this_line ! the current line - - integer :: next_line ! index for next line on buffer - - type(inpak90),pointer :: last - end type inpak90 - - integer,parameter :: MALLSIZE_=10 ! just an estimation - - character(len=*),parameter :: myname='MCT(MPEU)::m_inpak90' -!----------------------------------------------------------------------- - - integer,parameter :: i90_MXDEP = 4 - integer,save :: i90_depth = 0 - type(inpak90),save,pointer :: i90_now - -!----------------------------------------------------------------------- - contains -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: I90_allLoadF - populate a rooted database to all PEs -! -! !DESCRIPTION: -! -! !INTERFACE: - - subroutine I90_allLoadF(fname,root,comm,istat) - use m_mpif90, only : MP_perr - use m_mpif90, only : MP_comm_rank - use m_mpif90, only : MP_CHARACTER - use m_mpif90, only : MP_INTEGER - use m_die, only : perr - implicit none - character(len=*),intent(in) :: fname - integer,intent(in) :: root - integer,intent(in) :: comm - integer,intent(out) :: istat - -! !REVISION HISTORY: -! 28Jul98 - Jing Guo - initial prototype/prolog/code -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::I90_allLoadF' - integer :: myID,ier - - istat=0 - - call MP_comm_rank(comm,myID,ier) - if(ier/=0) then - call MP_perr(myname_,'MP_comm_rank()',ier) - istat=ier - return - endif - - if(myID == root) then - call i90_LoadF(fname,ier) - if(ier /= 0) then - call perr(myname_,'i90_LoadF("//trim(fname)//")',ier) - istat=ier - return - endif - else - call push_(ier) - if(ier /= 0) then - call perr(myname_,'push_()',ier) - istat=ier - return - endif - endif - - ! Initialize the buffer on all PEs - - call MPI_Bcast(i90_now%buffer,NBUF_MAX,MP_CHARACTER,root,comm,ier) - if(ier /= 0) then - call MP_perr(myname_,'MPI_Bcast(%buffer)',ier) - istat=ier - return - endif - - call MPI_Bcast(i90_now%nbuf,1,MP_INTEGER,root,comm,ier) - if(ier /= 0) then - call MP_perr(myname_,'MPI_Bcast(%nbuf)',ier) - istat=ier - return - endif - - i90_now%this_line=' ' - i90_now%next_line=0 - -end subroutine I90_allLoadF - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: push_ - push on a new layer of the internal file _i90_now_ -! -! !DESCRIPTION: -! -! !INTERFACE: - - subroutine push_(ier) - use m_die, only : perr - use m_mall,only : mall_mci,mall_ci,mall_ison - implicit none - integer,intent(out) :: ier - -! !REVISION HISTORY: -! 05Aug98 - Jing Guo - initial prototype/prolog/code -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::push_' - type(inpak90),pointer :: new - - if(i90_depth <= 0) nullify(i90_now) ! just an initialization - - ! Too many levels - - if(i90_depth >= i90_MXDEP) then - call perr(myname_,'(overflow)',i90_depth) - ier=1 - return - endif - - allocate(new,stat=ier) - if(ier /= 0) then - call perr(myname_,'allocate(new)',ier) - return - endif - - if(mall_ison()) call mall_ci(MALLSIZE_,myname) - - allocate(new%buffer,new%this_line,stat=ier) - if(ier /= 0) then - call perr(myname_,'allocate(new%..)',ier) - return - endif - - if(mall_ison()) then - call mall_mci(new%buffer,myname) - call mall_mci(new%this_line,myname) - endif - - new%last => i90_now - i90_now => new - nullify(new) - - i90_depth = i90_depth+1 -end subroutine push_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: pop_ - pop off a layer of the internal file _i90_now_ -! -! !DESCRIPTION: -! -! !INTERFACE: - - subroutine pop_(ier) - use m_die, only : perr - use m_mall,only : mall_mco,mall_co,mall_ison - implicit none - integer,intent(out) :: ier - -! !REVISION HISTORY: -! 05Aug98 - Jing Guo - initial prototype/prolog/code -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::pop_' - type(inpak90),pointer :: old - - if(i90_depth <= 0) then - call perr(myname_,'(underflow)',i90_depth) - ier=1 - return - endif - - old => i90_now%last - - if(mall_ison()) then - call mall_mco(i90_now%this_line,myname) - call mall_mco(i90_now%buffer,myname) - endif - - deallocate(i90_now%buffer,i90_now%this_line,stat=ier) - if(ier /= 0) then - call perr(myname_,'deallocate(new%..)',ier) - return - endif - - if(mall_ison()) call mall_co(MALLSIZE_,myname) - - deallocate(i90_now,stat=ier) - if(ier /= 0) then - call perr(myname_,'deallocate(new)',ier) - return - endif - - i90_now => old - nullify(old) - - i90_depth = i90_depth - 1 -end subroutine pop_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!----------------------------------------------------------------------- -! -! !ROUTINE: I90_Release - deallocate memory used to load a resource file -! -! !INTERFACE: -! - subroutine I90_Release(stat) - use m_die,only : perr,die - implicit none - integer,optional, intent(out) :: stat -! -! !DESCRIPTION: -! -! I90_Release() is used to pair I90_LoadF() to release the memory -! used by I90_LoadF() for resourse data input. -! -! !SEE ALSO: -! -! !REVISION HISTORY: -! 03Jul96 - J. Guo - added to Arlindos inpak90 for its -! Fortran 90 revision. -!_______________________________________________________________________ - character(len=*),parameter :: myname_=myname//'::i90_Release' - integer :: ier - - if(present(stat)) stat=0 - - call pop_(ier) - if(ier/=0) then - call perr(myname_,'pop_()',ier) - if(.not.present(stat)) call die(myname_) - stat=ier - return - endif - - end subroutine I90_Release - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: i90_fullRelease - releases the whole stack led by _i90_now_ -! -! !DESCRIPTION: -! -! !INTERFACE: - - subroutine i90_fullRelease(ier) - use m_die,only : perr - implicit none - integer,intent(out) :: ier - -! !REVISION HISTORY: -! 05Aug98 - Jing Guo - initial prototype/prolog/code -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::i90_fullRelease' - - do while(i90_depth > 0) - call pop_(ier) - if(ier /= 0) then - call perr(myname_,'pop_()',ier) - return - endif - end do - ier=0 - -end subroutine i90_fullRelease -!======================================================================= - subroutine I90_LoadF ( filen, iret ) - use m_ioutil, only : luavail,opntext,clstext - use m_die, only : perr - implicit NONE - -!------------------------------------------------------------------------- -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!------------------------------------------------------------------------- -!BOP -! -! !ROUTINE: I90_LoadF() --- Loads resource file into memory. -! -! !DESCRIPTION: -! -! Reads resource file, strips out comments, translate TABs into -! blanks, and loads the modified file contents into memory. -! Must be called only once for each resource file. -! -! !CALLING SEQUENCE: -! -! call i90_LoadF ( filen, iret ) -! -! !INPUT PARAMETERS: -! - character*(*) filen ! file name - -! !OUTPUT PARAMETERS: - - integer iret ! Return code: - ! 0 no error - ! -98 coult not get unit number - ! (strange!) - ! -98 talk to a wizzard - ! -99 out of memory: increase - ! NBUF_MAX in 'i90.h' - ! other iostat from open statement. -! -! !BUGS: -! -! It does not perform dynamic allocation, mostly to keep vanilla f77 -! compatibility. Overall amount of static memory is small (~100K -! for default NBUF_MAX = 400*256). -! -! !SEE ALSO: -! -! i90_label() selects a label (key) -! -! !FILES USED: -! -! File name supplied on input. The file is opened, read and then closed. -! -! !REVISION HISTORY: -! -! 19Jun96 da Silva Original code. -! -!EOP -!------------------------------------------------------------------------- - integer lu, ios, loop, ls, ptr - character*256 line - character(len=*), parameter :: myname_ = myname//'::i90_loadf' - - ! Check to make sure there is not too many levels - ! of the stacked resource files - - if(i90_depth >= i90_MXDEP) then - call perr(myname_,'(overflow)',i90_depth) - iret=1 - return - endif - -! Open file -! --------- -! lu = i90_lua() - - lu = luavail() ! a more portable version - if ( lu .lt. 0 ) then - iret = -97 - return - end if - - ! A open through an interface to avoid portability problems. - ! (J.G.) - - call opntext(lu,filen,'old',ios) - if ( ios .ne. 0 ) then - write(stderr,'(2a,i5)') myname_,': opntext() error, ios =',ios - iret = ios - return - end if - - ! Create a dynamic page to store the file. It might be expanded - ! to allocate memory on requests (a link list) (J.G.) - - ! Changed from page_() to push_(), to allow multiple (stacked) - ! inpak90 buffers. J.G. - - call push_(ios) ! to create buffer space - if ( ios .ne. 0 ) then - write(stderr,'(2a,i5)') myname_,': push_() error, ios =',ios - iret = ios - return - end if - -! Read to end of file -! ------------------- - i90_now%buffer(1:1) = EOL - ptr = 2 ! next buffer position - do loop = 1, NBUF_MAX - -! Read next line -! -------------- - read(lu,'(a)', end=11) line ! read next line - call i90_trim ( line ) ! remove trailing blanks - call i90_pad ( line ) ! Pad with # from end of line - -! A non-empty line -! ---------------- - ls = index(line,'#' ) - 1 ! line length - if ( ls .gt. 0 ) then - if ( (ptr+ls) .gt. NBUF_MAX ) then - iret = -99 - return - end if - i90_now%buffer(ptr:ptr+ls) = line(1:ls) // EOL - ptr = ptr + ls + 1 - end if - - end do - - iret = -98 ! good chance i90_now%buffer is not big enough - return - - 11 continue - -! All done -! -------- -! close(lu) - call clstext(lu,ios) - if(ios /= 0) then - iret=-99 - return - endif - i90_now%buffer(ptr:ptr) = EOB - i90_now%nbuf = ptr - i90_now%this_line=' ' - i90_now%next_line=0 - iret = 0 - - return - end subroutine I90_LoadF - - -!................................................................... - - subroutine i90_label ( label, iret ) - - implicit NONE - -!------------------------------------------------------------------------- -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!------------------------------------------------------------------------- -!BOP -! -! !ROUTINE: I90_Label() --- Selects a label (record). -! -! !DESCRIPTION: -! -! Once the buffer has been loaded with {\tt i90\_loadf()}, this routine -! selects a given ``line'' (record/table) associated with ``label''. -! Think of ``label'' as a resource name or data base ``key''. -! -! !CALLING SEQUENCE: -! -! call i90_Label ( label, iret ) -! -! !INPUT PARAMETERS: -! - character(len=*),intent(in) :: label ! input label - -! !OUTPUT PARAMETERS: - - integer iret ! Return code: - ! 0 no error - ! -1 buffer not loaded - ! -2 could not find label -! -! !SEE ALSO: -! -! i90_loadf() load file into buffer -! i90_gtoken() get next token -! i90_gline() get next line (for tables) -! atof() convert word (string) to float -! atoi() convert word (string) to integer -! -! !REVISION HISTORY: -! -! 19Jun96 da Silva Original code. -! 19Jan01 Jay Larson - introduced CHARACTER -! variable EOL_label, which is used to circumvent pgf90 -! problems with passing concatenated characters as an argument -! to a function. -! -!EOP -!------------------------------------------------------------------------- - - integer i, j - - character(len=(len(label)+len(EOL))) :: EOL_label - -! Make sure that a buffer is defined (JG) -! ---------------------------------- - if(i90_depth <= 0) then - iret = -1 - return - endif - -! Determine whether label exists -! ------------------------------ - EOL_label = EOL // label - i = index ( i90_now%buffer(1:i90_now%nbuf), EOL_label ) + 1 - if ( i .le. 1 ) then - i90_now%this_line = BLK // EOL - iret = -2 - return - end if - -! Extract the line associated with this label -! ------------------------------------------- - i = i + len ( label ) - j = i + index(i90_now%buffer(i:i90_now%nbuf),EOL) - 2 - i90_now%this_line = i90_now%buffer(i:j) // BLK // EOL - - i90_now%next_line = j + 2 - - iret = 0 - - return - end subroutine i90_label - -!................................................................... - - subroutine i90_gline ( iret ) - - implicit NONE - -!------------------------------------------------------------------------- -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!------------------------------------------------------------------------- -!BOP -! -! !ROUTINE: I90_GLine() --- Selects next line. -! -! !DESCRIPTION: -! -! Selects next line, irrespective of of label. If the next line starts -! with :: (end of table mark), then it lets the user know. This sequential -! access of the buffer is useful to assess tables, a concept introduced -! in Inpak 77 by Jing Guo. A table is a construct like this: -! -! \begin{verbatim} -! my_table_name:: -! 1000 3000 263.0 -! 925 3000 263.0 -! 850 3000 263.0 -! 700 3000 269.0 -! 500 3000 287.0 -! 400 3000 295.8 -! 300 3000 295.8 -! :: -! \end{verbatim} -! -! To access this table, the user first must use {\tt i90\_label()} to -! locate the beginning of the table, e.g., -! -! \begin{verbatim} -! call i90_label ( 'my_table_name::', iret ) -! \end{verbatim} -! -! Subsequently, {\tt i90\_gline()} can be used to gain acess to each -! row of the table. Here is a code fragment to read the above -! table (7 rows, 3 columns): -! -! \begin{verbatim} -! real table(7,3) -! character*20 word -! integer iret -! call i90_label ( 'my_table_name::', iret ) -! do i = 1, 7 -! call i90_gline ( iret ) -! do j = 1, 3 -! table(i,j) = fltget ( 0. ) -! end do -! end do -! \end{verbatim} -! -! For simplicity we have assumed that the dimensions of table were -! known. It is relatively simple to infer the table dimensions -! by manipulating ``iret''. -! -! !CALLING SEQUENCE: -! -! call i90_gline ( iret ) -! -! !INPUT PARAMETERS: -! -! None. -! -! !OUTPUT PARAMETERS: -! - integer iret ! Return code: - ! 0 no error - ! -1 end of buffer reached - ! +1 end of table reached - -! !SEE ALSO: -! -! i90_label() selects a line (record/table) -! -! !REVISION HISTORY: -! -! 10feb95 Guo Wrote rdnext(), Inpak 77 extension. -! 19Jun96 da Silva Original code with functionality of rdnext() -! -!EOP -!------------------------------------------------------------------------- - - integer i, j - -! Make sure that a buffer is defined (JG) -! ---------------------------------- - if(i90_depth <= 0) then - iret = -1 - return - endif - - if ( i90_now%next_line .ge. i90_now%nbuf ) then - iret = -1 - return - end if - - i = i90_now%next_line - j = i + index(i90_now%buffer(i:i90_now%nbuf),EOL) - 2 - i90_now%this_line = i90_now%buffer(i:j) // BLK // EOL - - if ( i90_now%this_line(1:2) .eq. '::' ) then - iret = 1 ! end of table - i90_now%next_line = i90_now%nbuf + 1 - return - end if - - i90_now%next_line = j + 2 - iret = 0 - - return - end subroutine i90_gline - -!................................................................... - - subroutine i90_GToken ( token, iret ) - - implicit NONE - -!------------------------------------------------------------------------- -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!------------------------------------------------------------------------- -!BOP -! -! !ROUTINE: I90_GToken() --- Gets next token. -! -! !DESCRIPTION: -! -! Get next token from current line. The current line is defined by a -! call to {\tt i90\_label()}. Tokens are sequences of characters (including -! blanks) which may be enclosed by single or double quotes. -! If no quotes are present, the token from the current position to the next -! blank of TAB is returned. -! -! {\em Examples of valid token:} -! -! \begin{verbatim} -! single_token "second token on line" -! "this is a token" -! 'Another example of a token' -! 'this is how you get a " inside a token' -! "this is how you get a ' inside a token" -! This is valid too # the line ends before the # -! \end{verbatim} -! The last line has 4 valid tokens: {\tt This, is, valid} and {\tt too}. -! -! {\em Invalid string constructs:} -! -! \begin{verbatim} -! cannot handle mixed quotes (i.e. single/double) -! 'escaping like this \' is not implemented' -! 'this # will not work because of the #' -! \end{verbatim} -! The \# character is reserved for comments and cannot be included -! inside quotation marks. -! -! !CALLING SEQUENCE: -! -! call i90_GToken ( token, iret ) -! -! !INPUT PARAMETERS: -! -! None. -! -! !OUTPUT PARAMETERS: -! - character*(*) token ! Next token from current line - integer iret ! Return code: - ! 0 no error - ! -1 either nothing left - ! on line or mismatched - ! quotation marks. - -! !BUGS: -! -! Standard Unix escaping is not implemented at the moment. -! -! -! !SEE ALSO: -! -! i90_label() selects a line (record/table) -! i90_gline() get next line (for tables) -! atof() convert word (string) to float -! atoi() convert word (string) to integer -! -! -! !REVISION HISTORY: -! -! 19Jun96 da Silva Original code. -! -!EOP -!------------------------------------------------------------------------- - - character*1 ch - integer ib, ie - -! Make sure that a buffer is defined (JG) -! ---------------------------------- - if(i90_depth <= 0) then - iret = -1 - return - endif - - call i90_trim ( i90_now%this_line ) - - ch = i90_now%this_line(1:1) - if ( ch .eq. '"' .or. ch .eq. "'" ) then - ib = 2 - ie = index ( i90_now%this_line(ib:), ch ) - else - ib = 1 - ie = min(index(i90_now%this_line,BLK), & - index(i90_now%this_line,EOL)) - 1 - - end if - - if ( ie .lt. ib ) then - token = BLK - iret = -1 - return - else - ! Get the token, and shift the rest of %this_line to - ! the left - - token = i90_now%this_line(ib:ie) - i90_now%this_line = i90_now%this_line(ie+2:) - iret = 0 - end if - - return - end subroutine i90_gtoken -!................................................................... - subroutine i90_gstr ( string, iret ) - - implicit NONE - -!------------------------------------------------------------------------- -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!------------------------------------------------------------------------- -! -! !ROUTINE: I90\_GStr() -! -! !DESCRIPTION: -! -! Get next string from current line. The current line is defined by a -! call to {\tt i90\_label()}. Strings are sequence of characters (including -! blanks) enclosed by single or double quotes. If no quotes -! are present, the string from the current position to the end of -! the line is returned. -! -! NOTE: This routine is defined differently from \verb"i90_GTolen()", -! where a {\sl token} is white-space delimited, but this routine -! will try to fetch a string either terminated by a "$" or by the -! end of the line. -! -! {\em Examples of valid strings:} -! -! \begin{verbatim} -! "this is a string" -! 'Another example of string' -! 'this is how you get a " inside a string' -! "this is how you get a ' inside a string" -! This is valid too # the line ends before the # -! -! \end{verbatim} -! -! {\em Invalid string constructs:} -! -! \begin{verbatim} -! cannot handle mixed quotes -! 'escaping like this \' is not implemented' -! \end{verbatim} -! -! {\em Obsolete feature (for Inpak 77 compatibility):} -! -! \begin{verbatim} -! the string ends after a $ this is another string -! \end{verbatim} -! -! !CALLING SEQUENCE: -! -! \begin{verbatim} -! call i90_Gstr ( string, iret ) -! \end{verbatim} -! -! !INPUT PARAMETERS: -! - character*(*) string ! A NULL (char(0)) delimited string. - -! !OUTPUT PARAMETERS: -! - integer iret ! Return code: - ! 0 no error - ! -1 either nothing left - ! on line or mismatched - ! quotation marks. - -! !BUGS: -! -! Standard Unix escaping is not implemented at the moment. -! No way to tell sintax error from end of line (same iret). -! -! -! !SEE ALSO: -! -! i90_label() selects a line (record/table) -! i90_gtoken() get next token -! i90_gline() get next line (for tables) -! atof() convert word (string) to float -! atoi() convert word (string) to integer -! -! -! !REVISION HISTORY: -! -! 19Jun96 da Silva Original code. -! 01Oct96 Jing Guo Removed the null terminitor -! -!------------------------------------------------------------------------- - - character*1 ch - integer ib, ie - -! Make sure that a buffer is defined (JG) -! ---------------------------------- - if(i90_depth <= 0) then - iret = -1 - return - endif - - call i90_trim ( i90_now%this_line ) - - ch = i90_now%this_line(1:1) - if ( ch .eq. '"' .or. ch .eq. "'" ) then - ib = 2 - ie = index ( i90_now%this_line(ib:), ch ) - else - ib = 1 - ie = index(i90_now%this_line,'$')-1 ! undocumented feature! - if ( ie .lt. 1 ) ie = index(i90_now%this_line,EOL)-2 - end if - - if ( ie .lt. ib ) then -! string = NULL - iret = -1 - return - else - string = i90_now%this_line(ib:ie) ! // NULL - i90_now%this_line = i90_now%this_line(ie+2:) - iret = 0 - end if - - return - end subroutine i90_gstr - -!................................................................... - - real(FP) function i90_GFloat( iret ) - - implicit NONE - -!------------------------------------------------------------------------- -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!------------------------------------------------------------------------- -!BOP -! -! !ROUTINE: i90_GFloat() --- Returns next float number. -! -! !DESCRIPTION: -! -! Returns next float (real number) from the current line. -! If an error occurs a zero value is returned. -! -! !CALLING SEQUENCE: -! -! real rnumber -! rnumber = i90_gfloat ( default ) -! -! !OUTPUT PARAMETERS: -! - integer,intent(out) :: iret ! Return code: - ! 0 no error - ! -1 either nothing left - ! on line or mismatched - ! quotation marks. - ! -2 parsing error - -! -! !REVISION HISTORY: -! -! 19Jun96 da Silva Original code. -! -!EOP -!------------------------------------------------------------------------- - - character*256 token - integer ios - real(FP) x - -! Make sure that a buffer is defined (JG) -! ---------------------------------- - if(i90_depth <= 0) then - iret = -1 - return - endif - - call i90_gtoken ( token, iret ) - if ( iret .eq. 0 ) then - read(token,*,iostat=ios) x ! Does it require an extension? - if ( ios .ne. 0 ) iret = -2 - end if - if ( iret .ne. 0 ) x = 0. - i90_GFloat = x - - return - end function i90_GFloat - -!................................................................... - - integer function I90_GInt ( iret ) - - implicit NONE - -!------------------------------------------------------------------------- -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!------------------------------------------------------------------------- -!BOP -! -! !ROUTINE: I90_GInt() --- Returns next integer number. -! -! !DESCRIPTION: -! -! Returns next integer number from the current line. -! If an error occurs a zero value is returned. -! -! !CALLING SEQUENCE: -! -! integer number -! number = i90_gint ( default ) -! -! !OUTPUT PARAMETERS: -! - integer iret ! Return code: - ! 0 no error - ! -1 either nothing left - ! on line or mismatched - ! quotation marks. - ! -2 parsing error - -! -! !REVISION HISTORY: -! -! 19Jun96 da Silva Original code. -! 24may00 da Silva delcared x as real*8 in case this module is compiled -! with real*4 -! -!EOP -!------------------------------------------------------------------------- - - character*256 token - real(kind_r8) x - integer ios - -! Make sure that a buffer is defined (JG) -! ---------------------------------- - if(i90_depth <= 0) then - iret = -1 - return - endif - - call i90_gtoken ( token, iret ) - if ( iret .eq. 0 ) then - read(token,*,iostat=ios) x - if ( ios .ne. 0 ) iret = -2 - end if - if ( iret .ne. 0 ) x = 0 - i90_gint = nint(x) - - return - end function i90_gint - -!................................................................... - - real(FP) function i90_AtoF( string, iret ) - - implicit NONE - -!------------------------------------------------------------------------- -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!------------------------------------------------------------------------- -!BOP -! -! !ROUTINE: i90_AtoF() --- Translates ASCII (string) to float. -! -! !DESCRIPTION: -! -! Converts string to real number. Same as obsolete {\tt str2rn()}. -! -! !CALLING SEQUENCE: -! -! real rnumber -! rnumber = i90_atof ( string, iret ) -! -! !INPUT PARAMETERS: -! - character(len=*),intent(in) :: string ! a string - -! !OUTPUT PARAMETERS: -! - integer,intent(out) :: iret ! Return code: - ! 0 no error - ! -1 could not convert, probably - ! string is not a number - -! -! !REVISION HISTORY: -! -! 19Jun96 da Silva Original code. -! -!EOP -!------------------------------------------------------------------------- - - read(string,*,end=11,err=11) i90_AtoF - iret = 0 - return - 11 iret = -1 - return - end function i90_AtoF - -!................................................................... - - integer function i90_atoi ( string, iret ) - - implicit NONE - -!------------------------------------------------------------------------- -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!------------------------------------------------------------------------- -!BOP -! -! !ROUTINE: I90_AtoI() --- Translates ASCII (strings) to integer. -! -! !DESCRIPTION: -! -! Converts string to integer number. -! -! !CALLING SEQUENCE: -! -! integer number -! number = i90_atoi ( string, iret ) -! -! !INPUT PARAMETERS: -! - character*(*) string ! a string - -! !OUTPUT PARAMETERS: -! - integer iret ! Return code: - ! 0 no error - ! -1 could not convert, probably - ! string is not a number - -! -! !REVISION HISTORY: -! -! 19Jun96 da Silva Original code. -! -!EOP -!------------------------------------------------------------------------- - - read(string,*,end=11,err=11) i90_atoi - iret = 0 - return - 11 iret = -1 - return - end function i90_atoi - -!................................................................... - - integer function i90_Len ( string ) - - implicit NONE - -!------------------------------------------------------------------------- -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!------------------------------------------------------------------------- -!BOP -! -! !ROUTINE: I90_Len() --- Returns length of string. -! -! !DESCRIPTION: -! -! Returns the length of a string excluding trailing blanks. -! It follows that -! \begin{verbatim} -! i90_len(string) .le. len(string), -! \end{verbatim} -! where {\tt len} is the intrinsic string length function. -! Example: -! \begin{verbatim} -! ls = len('abc ') ! results in ls = 5 -! ls = i90_len ('abc ') ! results in ls = 3 -! \end{verbatim} -! -! !CALLING SEQUENCE: -! -! integer ls -! ls = i90_len ( string ) -! -! !INPUT PARAMETERS: -! - character*(*) string ! a string -! -! !OUTPUT PARAMETERS: -! -! The length of the string, excluding trailing blanks. -! -! !REVISION HISTORY: -! -! 01Apr94 Guo Original code (a.k.a. luavail()) -! 19Jun96 da Silva Minor modification + prologue. -! -!EOP -!------------------------------------------------------------------------- - - integer ls, i, l - ls = len(string) - do i = ls, 1, -1 - l = i - if ( string(i:i) .ne. BLK ) go to 11 - end do - l = l - 1 - 11 continue - i90_len = l - return - end function i90_len - -!................................................................... - - integer function I90_Lua() - - implicit NONE - -!------------------------------------------------------------------------- -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!------------------------------------------------------------------------- -!BOP -! -! !ROUTINE: I90_Lua() --- Returns available logical unit number. -! -! !DESCRIPTION: -! -! Look for an available (not opened) Fortran logical unit for i/o. -! -! !CALLING SEQUENCE: -! -! integer lu -! lu = i90_lua() -! -! !INPUT PARAMETERS: -! -! None. -! -! !OUTPUT PARAMETERS: -! -! The desired unit number if positive, -1 if unsucessful. -! -! !REVISION HISTORY: -! -! 01Apr94 Guo Original code (a.k.a. luavail()) -! 19Jun96 da Silva Minor modification + prologue. -! -!EOP -!------------------------------------------------------------------------- - - - integer lu,ios - logical opnd - lu=7 - inquire(unit=lu,opened=opnd,iostat=ios) - do while(ios.eq.0.and.opnd) - lu=lu+1 - inquire(unit=lu,opened=opnd,iostat=ios) - end do - if(ios.ne.0) lu=-1 - i90_lua=lu - return - end function i90_lua - -!................................................................... - - subroutine i90_pad ( string ) - - implicit NONE - -!------------------------------------------------------------------------- -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!------------------------------------------------------------------------- -!BOP -! -! !ROUTINE: I90_Pad() --- Pad strings. -! -! !DESCRIPTION: -! -! Pads from the right with the comment character (\#). It also -! replaces TABs with blanks for convenience. This is a low level -! i90 routine. -! -! !CALLING SEQUENCE: -! -! call i90_pad ( string ) -! -! !INPUT PARAMETERS: -! - character*256 string ! input string - -! !OUTPUT PARAMETERS: ! modified string -! -! character*256 string -! -! !BUGS: -! -! It alters TABs even inside strings. -! -! -! !REVISION HISTORY: -! -! 19Jun96 da Silva Original code. -! -!EOP -!------------------------------------------------------------------------- - - integer i - -! Pad end of string with # -! ------------------------ - do i = 256, 1, -1 - if ( string(i:i) .ne. ' ' .and. & - string(i:i) .ne. '$' ) go to 11 - string(i:i) = '#' - end do - 11 continue - -! Replace TABs with blanks -! ------------------------- - do i = 1, 256 - if ( string(i:i) .eq. TAB ) string(i:i) = BLK - if ( string(i:i) .eq. '#' ) go to 21 - end do - 21 continue - - return - end subroutine i90_pad - -!................................................................... - - subroutine I90_Trim ( string ) - - implicit NONE - -!------------------------------------------------------------------------- -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!------------------------------------------------------------------------- -!BOP -! -! !ROUTINE: I90_Trim() - Removes leading blanks from strings. -! -! !DESCRIPTION: -! -! Removes blanks and TABS from begenning of string. -! This is a low level i90 routine. -! -! !CALLING SEQUENCE: -! -! call i90_Trim ( string ) -! -! !INPUT PARAMETERS: -! - character*256 string ! the input string -! -! !OUTPUT PARAMETERS: -! -! character*256 string ! the modified string -! -! -! !REVISION HISTORY: -! -! 19Jun96 da Silva Original code. -! -!EOP -!------------------------------------------------------------------------- - - integer ib, i - -! Get rid of leading blanks -! ------------------------- - ib = 1 - do i = 1, 255 - if ( string(i:i) .ne. ' ' .and. & - string(i:i) .ne. TAB ) go to 21 - ib = ib + 1 - end do - 21 continue - -! String without trailling blanks -! ------------------------------- - string = string(ib:) - - return - end subroutine i90_trim - - -!========================================================================== - - -! ----------------------------- -! Inpak 77 Upward Compatibility -! ----------------------------- - - - subroutine lablin ( label ) - - implicit NONE - -!------------------------------------------------------------------------- -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!------------------------------------------------------------------------- -!BOP -! -! !ROUTINE: Lablin() --- Selects a Label (Inpak 77) -! -! !DESCRIPTION: -! -! Selects a given ``line'' (record/table) associated with ``label''. -! Similar to {\tt i90\_label()}, but prints a message to {\tt stdout} -! if it cannot locate the label. Kept for Inpak 77 upward compatibility. -! -! !CALLING SEQUENCE: -! -! call lablin ( label ) -! -! !INPUT PARAMETERS: - - character(len=*),intent(in) :: label ! string with label name -! -! !OUTPUT PARAMETERS: -! -! None. -! -! !REVISION HISTORY: -! -! 19Jun96 da Silva Original code. -! -!EOP -!------------------------------------------------------------------------- - - integer iret - - call i90_label ( label, iret ) - if ( iret .ne. 0 ) then - write(stderr,'(2a)') 'i90/lablin: cannot find label ', label - endif - - end subroutine lablin - -!................................................................... - - real(SP) function fltgetsp ( default ) - - implicit NONE - -!------------------------------------------------------------------------- -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!------------------------------------------------------------------------- -!BOP -! -! !ROUTINE: FltGetsp() --- Returns next float (Inpak 77, single precision) -! -! !DESCRIPTION: -! -! Returns next float (real number, single precision) from the current -! line, or a default value if it fails to obtain the desired number. -! Kept for Inpak 77 upward compatibility. -! -! !CALLING SEQUENCE: -! -! real rnumber, default -! rnumber = fltgetsp ( default ) -! -! !INPUT PARAMETERS: -! - real(SP), intent(IN) :: default ! default value. - -! -! !REVISION HISTORY: -! -! 19Jun96 da Silva Original code. -! 12Oct99 Guo/Larson - Built from original FltGet() function. -! -!EOP -!------------------------------------------------------------------------- - - character*256 token - real(FP) x - integer iret - - call i90_gtoken ( token, iret ) - if ( iret .eq. 0 ) then - read(token,*,iostat=iret) x - end if - if ( iret .ne. 0 ) x = default - !print *, x - fltgetsp = x - - return - end function fltgetsp - -!................................................................... - - real(DP) function fltgetdp ( default ) - - implicit NONE - -!------------------------------------------------------------------------- -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!------------------------------------------------------------------------- -!BOP -! -! !ROUTINE: FltGetdp() --- Returns next float (Inpak 77) -! -! !DESCRIPTION: -! -! Returns next float (real number) from the current line, or a -! default value (double precision) if it fails to obtain the desired -! number. Kept for Inpak 77 upward compatibility. -! -! !CALLING SEQUENCE: -! -! real(DP) :: default -! real :: rnumber -! rnumber = FltGetdp(default) -! -! !INPUT PARAMETERS: -! - real(DP), intent(IN) :: default ! default value. - -! -! !REVISION HISTORY: -! -! 19Jun96 da Silva Original code. -! 12Oct99 Guo/Larson - Built from original FltGet() function. -! -!EOP -!------------------------------------------------------------------------- - - character*256 token - real(FP) x - integer iret - - call i90_gtoken ( token, iret ) - if ( iret .eq. 0 ) then - read(token,*,iostat=iret) x - end if - if ( iret .ne. 0 ) x = default - !print *, x - fltgetdp = x - - return - end function fltgetdp - -!................................................................... - - integer function intget ( default ) - - implicit NONE - -!------------------------------------------------------------------------- -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!------------------------------------------------------------------------- -!BOP -! -! !ROUTINE: IntGet() --- Returns next integer (Inpak 77). -! -! !DESCRIPTION: -! -! Returns next integer number from the current line, or a default -! value if it fails to obtain the desired number. -! Kept for Inpak 77 upward compatibility. -! -! !CALLING SEQUENCE: -! -! integer number, default -! number = intget ( default ) -! -! !INPUT PARAMETERS: -! - integer default ! default value. - -! -! !REVISION HISTORY: -! -! 19Jun96 da Silva Original code. -! -!EOP -!------------------------------------------------------------------------- - - character*256 token - real(FP) x - integer iret - - call i90_gtoken ( token, iret ) - if ( iret .eq. 0 ) then - read(token,*,iostat=iret) x - end if - if ( iret .ne. 0 ) x = default - intget = nint(x) - !print *, intget - - return - end function intget - -!................................................................... - - character(len=1) function chrget ( default ) - - implicit NONE - -!------------------------------------------------------------------------- -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!------------------------------------------------------------------------- -!BOP -! -! !ROUTINE: ChrGet() --- Returns next character (Inpak 77). -! -! !DESCRIPTION: -! -! Returns next non-blank character from the current line, or a default -! character if it fails for whatever reason. -! Kept for Inpak 77 upward compatibility. -! -! !CALLING SEQUENCE: -! -! character*1 ch, default -! ch = chrget ( default ) -! -! !INPUT PARAMETERS: -! - character*1 default ! default value. - -! -! !REVISION HISTORY: -! -! 19Jun96 da Silva Original code. -! -!EOP -!------------------------------------------------------------------------- - - character*256 token - integer iret - - call i90_gtoken ( token, iret ) - if ( iret .ne. 0 ) then - chrget = default - else - chrget = token(1:1) - end if - !print *, chrget - - return - end function chrget - -!................................................................... - - subroutine TokGet ( token, default ) - - implicit NONE - - -!------------------------------------------------------------------------- -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!------------------------------------------------------------------------- -!BOP -! -! !ROUTINE: TokGet() --- Gets next token (Inpakk 77 like). -! -! !DESCRIPTION: -! -! Returns next token from the current line, or a default -! word if it fails for whatever reason. -! -! !CALLING SEQUENCE: -! -! call TokGet ( token, default ) -! -! !INPUT PARAMETERS: -! - character*(*) default ! default token - -! !OUTPUT PARAMETERS: -! - character*(*) token ! desired token -! -! !REVISION HISTORY: -! -! 19Jun96 da Silva Original code. -! -!EOP -!------------------------------------------------------------------------- - - integer iret - - call i90_GToken ( token, iret ) - if ( iret .ne. 0 ) then - token = default - end if - !print *, token - - return - end subroutine tokget - -!==================================================================== - -! -------------------------- -! Obsolete Inpak 77 Routines -! (Not Documented) -! -------------------------- - -!................................................................... - - subroutine iniin() - print *, & - 'i90: iniin() is obsolete, use i90_loadf() instead!' - return - end subroutine iniin - - -!................................................................... - - subroutine iunits ( mifans, moftrm, moferr, miftrm ) - integer mifans, moftrm, moferr, miftrm - print *, & - 'i90: iunits() is obsolete, use i90_loadf() instead!' - return - end subroutine iunits - -!................................................................... - - subroutine getstr ( iret, string ) - implicit NONE - character*(*) string - integer iret !, ls - call i90_gstr ( string, iret ) - return - end subroutine getstr - -!................................................................... - - subroutine getwrd ( iret, word ) - implicit NONE - character*(*) word - integer iret - call i90_gtoken ( word, iret ) - return - end subroutine getwrd - -!................................................................... - - subroutine rdnext ( iret ) - implicit NONE - integer iret - call i90_gline ( iret ) - return - end subroutine rdnext - -!................................................................... - - real(FP) function str2rn ( string, iret ) - implicit NONE - character*(*) string - integer iret - read(string,*,end=11,err=11) str2rn - iret = 0 - return - 11 iret = 1 - return - end function str2rn - -!................................................................... - - subroutine strget ( string, default ) - - implicit NONE - -!------------------------------------------------------------------------- -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!------------------------------------------------------------------------- -! -! !ROUTINE: StrGet() -! -! !DESCRIPTION: -! -! Returns next string on the current line, or a default -! string if it fails for whatever reason. Similar to {\tt i90\_gstr()}. -! Kept for Inpak 77 upward compatibility. -! -! NOTE: This is an obsolete routine. The notion of "string" used -! here is not conventional. Please use routine {\tt TokGet()} -! instead. -! -! !CALLING SEQUENCE: -! -! call strget ( string, default ) -! -! !INPUT PARAMETERS: -! - character*(*) default ! default string - -! !OUTPUT PARAMETERS: - - character*(*) string ! desired string - -! -! !REVISION HISTORY: -! -! 19Jun96 da Silva Original code. -! 01Oct96 Jing Guo Removed the null terminitor -! -!------------------------------------------------------------------------- - - integer iret - - call i90_gstr ( string, iret ) - if ( iret .ne. 0 ) then - string = default - end if - - return - end subroutine strget - - -end module m_inpak90 diff --git a/cesm/models/utils/mct/mpeu/m_ioutil.F90 b/cesm/models/utils/mct/mpeu/m_ioutil.F90 deleted file mode 100644 index 9c452a5..0000000 --- a/cesm/models/utils/mct/mpeu/m_ioutil.F90 +++ /dev/null @@ -1,439 +0,0 @@ -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!----------------------------------------------------------------------- -! CVS $Id$ -! CVS $Name$ -!----------------------------------------------------------------------- -!BOP -! -! !MODULE: m_ioutil - a F90 module for several convenient I/O functions -! -! !DESCRIPTION: -! -! m\_ioutil is a module containing several portable interfaces for -! some highly system dependent, but frequently used I/O functions. -! -! !INTERFACE: - - module m_ioutil - implicit none - private ! except - - public :: opntext,clstext ! open/close a text file - public :: opnieee,clsieee ! open/close a binary sequential file - public :: luavail ! return a free logical unit - public :: luflush ! flush the buffer of a given unit - !public :: MX_LU - -! !REVISION HISTORY: -! 16Jul96 - J. Guo - (to do) -! 02Apr97 - Jing Guo - finished the coding -! 11Feb97 - Jing Guo - added luflush() -! 08Nov01 - Jace A Mogill FORTRAN only defines -! 99 units, three units below unit 10 are often used for -! stdin, stdout, and stderr. Be far more conservative -! and stay within FORTRAN standard. -! -!EOP -!_______________________________________________________________________ - - character(len=*),parameter :: myname="MCT(MPEU)::m_ioutil" - integer,parameter :: MX_LU=99 - -contains - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!----------------------------------------------------------------------- -!BOP -! -! !IROUTINE: opnieee - portablly open an IEEE format file -! -! !DESCRIPTION: -! -! Open a file in IEEE format. -! -! IEEE format is refered as a FORTRAN "unformatted" file with -! "sequantial" access and variable record lengths. Under common -! Unix, it is only a file with records packed with a leading 4- -! byte word and a trailing 4-byte word indicating the size of -! the record in bytes. However, under UNICOS, it is also assumed -! to have numerical data representations represented according to -! the IEEE standard corresponding KIND conversions. Under a DEC -! machine, it means that compilations of the source code should -! have the "-bigendian" option specified. -! -! !INTERFACE: - - subroutine opnieee(lu,fname,status,ier,recl) - use m_stdio,only : stderr - implicit none - - integer, intent(in) :: lu ! logical unit number - character(len=*),intent(in) :: fname ! filename to be opended - character(len=*),intent(in) :: status ! the value for STATUS= - integer, intent(out):: ier ! the status - integer,optional,intent(in) :: recl ! record length - -! !REVISION HISTORY: -! 02Feb95 - Jing G. - First version included in PSAS. It is not -! used in the libpsas.a calls, since no binary data input/ -! output is to be handled. -! -! 09Oct96 - J. Guo - Check for any previous assign() call under -! UNICOS. -!EOP -!_______________________________________________________________________ - -#ifdef _UNICOS - character(len=128) :: attr -#endif - - ! local parameter - character(len=*),parameter :: myname_=myname//'::opnieee' - - integer,parameter :: iA=ichar('a') - integer,parameter :: mA=ichar('A') - integer,parameter :: iZ=ichar('z') - - logical :: direct - character(len=16) :: clen - character(len=len(status)) :: Ustat - integer :: i,ic - -! Work-around for absoft 9.0 f90, which has trouble understanding that -! ier is an output argument from the write() call below. - - ier = 0 - - direct=.false. - if(present(recl)) then - if(recl<0) then - clen='****************' - write(clen,'(i16)',iostat=ier) recl - write(stderr,'(3a)') myname_, & - ': invalid recl, ',trim(adjustl(clen)) - ier=-1 - return - endif - direct = recl>0 - endif - -#ifdef _UNICOS - call asnqunit(lu,attr,ier) ! test the unit - - if(ier.eq.-1) then ! the unit is not used - if(direct) then - call asnunit(lu,'-N ieee -F null',ier) - else - call asnunit(lu,'-N ieee -F f77',ier) - endif - ier=0 - - elseif(ier.ge.0) then ! the unit is already assigned - ier=-1 - endif - if(ier.ne.0) return -#endif - - do i=1,len(status) - ic=ichar(status(i:i)) - if(ic >= iA .and. ic <= iZ) ic=ic+(mA-iA) - Ustat(i:i)=char(ic) - end do - - select case(Ustat) - - case ('APPEND') - - if(direct) then - write(stderr,'(2a)') myname_, & - ': invalid arguments, (status=="APPEND",recl>0)' - ier=1 - return - endif - - open( & - unit =lu, & - file =fname, & - form ='unformatted', & - access ='sequential', & - status ='unknown', & - position ='append', & - iostat =ier ) - - case default - - if(direct) then - open( & - unit =lu, & - file =fname, & - form ='unformatted', & - access ='direct', & - status =status, & - recl =recl, & - iostat =ier ) - - else - open( & - unit =lu, & - file =fname, & - form ='unformatted', & - access ='sequential', & - status =status, & - position ='asis', & - iostat =ier ) - endif - - end select - - end subroutine opnieee -!----------------------------------------------------------------------- -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!----------------------------------------------------------------------- -!BOP -! -! !IROUTINE: clsieee - Close a logical unit opened by opnieee() -! -! !DESCRIPTION: -! -! The reason for a paired clsieee() for opnieee() instead of a -! simple close(), is for the portability reason. For example, -! under UNICOS, special system calls may be need to set up the -! unit right, and the status of the unit should be restored upon -! close. -! -! !INTERFACE: - - subroutine clsieee(lu,ier) - implicit none - integer, intent(in) :: lu ! the unit used by opnieee() - integer, intent(out) :: ier ! the status - -! !REVISION HISTORY: -! 10Oct96 - J. Guo - (to do) -!EOP -!_______________________________________________________________________ - close(lu,iostat=ier) -#ifdef _UNICOS - if(ier==0) call asnunit(lu,'-R',ier) ! remove attributes -#endif - - end subroutine clsieee - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!----------------------------------------------------------------------- -!BOP -! -! !IROUTINE: opntext - portablly open a text file -! -! !DESCRIPTION: -! -! Open a text (ASCII) file. Under FORTRAN, it is defined as -! "formatted" with "sequential" access. -! -! !INTERFACE: - - subroutine opntext(lu,fname,status,ier) - implicit none - - integer, intent(in) :: lu ! logical unit number - character(len=*),intent(in) :: fname ! filename to be opended - character(len=*),intent(in) :: status ! the value for STATUS=<> - integer, intent(out):: ier ! the status - - -! !REVISION HISTORY: -! -! 02Feb95 - Jing G. - First version included in PSAS and libpsas.a -! 09Oct96 - J. Guo - modified to allow assign() call under UNICOS -! = and now, it is a module in Fortran 90. -!EOP -!_______________________________________________________________________ - - ! local parameter - character(len=*),parameter :: myname_=myname//'::opntext' - - integer,parameter :: iA=ichar('a') - integer,parameter :: mA=ichar('A') - integer,parameter :: iZ=ichar('z') - - character(len=len(status)) :: Ustat - integer :: i,ic - -#ifdef _UNICOS - call asnunit(lu,'-R',ier) ! remove any set attributes - if(ier.ne.0) return ! let the parent handle it -#endif - - do i=1,len(status) - ic=ichar(status(i:i)) - if(ic >= iA .and. ic <= iZ) ic=ic+(mA-iA) - Ustat(i:i)=char(ic) - end do - - select case(Ustat) - - case ('APPEND') - - open( & - unit =lu, & - file =fname, & - form ='formatted', & - access ='sequential', & - status ='unknown', & - position ='append', & - iostat =ier ) - - case default - - open( & - unit =lu, & - file =fname, & - form ='formatted', & - access ='sequential', & - status =status, & - position ='asis', & - iostat =ier ) - - end select - - end subroutine opntext - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!----------------------------------------------------------------------- -!BOP -! -! !IROUTINE: clstext - close a text file opend with an opntext() call -! -! !DESCRIPTION: -! -! !INTERFACE: - - subroutine clstext(lu,ier) - implicit none - - integer, intent(in) :: lu ! a logical unit to close - integer, intent(out) :: ier ! the status - -! !REVISION HISTORY: -! 09Oct96 - J. Guo - (to do) -!EOP -!_______________________________________________________________________ - - close(lu,iostat=ier) -#ifdef _UNICOS - if(ier == 0) call asnunit(lu,'-R',ier) ! remove any attributes -#endif - - end subroutine clstext - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: luavail - locate the next available unit -! -! !DESCRIPTION: -! -! luavail() Look for an available (not opened and not statically -! assigned to any I/O attributes to) logical unit. -! -! !INTERFACE: - - function luavail() - use m_stdio - implicit none - integer :: luavail ! result - -! !REVISION HISTORY: -! 23Apr98 - Jing Guo - new prototype/prolog/code -! - with additional unit constraints for SunOS. -! -! : Jing Guo, [09-Oct-96] -! + Checking also Cray assign() attributes, with some -! changes to the code. See also other routines. -! -! : Jing Guo, [01-Apr-94] -! + Initial code. -! 2001-11-08 - Jace A Mogill clean up -! logic for finding lu. -! -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::luavail' - - integer lu,ios - logical inuse - - lu=10 - ios=0 - inuse=.true. - - do while(ios.eq.0 .and. inuse .and. lu.le.MX_LU) - lu=lu+1 - inquire(unit=lu,opened=inuse,iostat=ios) - end do - - if(ios.ne.0) lu=-1 - luavail=lu -end function luavail - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!----------------------------------------------------------------------- -!BOP -! -! !IROUTINE: luflush - a uniform interface of system flush() -! -! !DESCRIPTION: -! -! Flush() calls available on many systems are often implementation -! dependent. This subroutine provides a uniform interface. It -! also ignores invalid logical unit value. -! -! !INTERFACE: - - subroutine luflush(unit) - use m_stdio, only : stdout -#ifdef CPRNAG - use F90_UNIX_IO,only : flush -#endif - implicit none - integer,optional,intent(in) :: unit - -! !REVISION HISTORY: -! 13Mar98 - Jing Guo - initial prototype/prolog/code -! 08Jul02 - E. Ong - added flush support for nag95 -! 2001-11-08 Jace A Mogill - Flush is not part of -! the F90 standard. Default is NO unit flush. -!EOP -!_______________________________________________________________________ - character(len=*),parameter :: myname_=myname//'::luflush' - - integer :: ier - integer :: lu - - ! Which logical unit number? - - lu=stdout - if(present(unit)) lu=unit - if(lu < 0) return - - ! The following call may be system dependent. - -#if SYSIRIX64 || CPRNAG || SYSUNICOS - call flush(lu,ier) -#elif SYSAIX || CPRXLF - call flush_(lu) ! Function defined in xlf reference document. -#elif SYSLINUX || SYSOSF1 || SYSSUNOS || SYST3E || SYSUNIXSYSTEMV || SYSSUPERUX - call flush(lu) -#endif - -end subroutine luflush -!----------------------------------------------------------------------- -end module m_ioutil -!. diff --git a/cesm/models/utils/mct/mpeu/m_mall.F90 b/cesm/models/utils/mct/mpeu/m_mall.F90 deleted file mode 100644 index 8e10e3a..0000000 --- a/cesm/models/utils/mct/mpeu/m_mall.F90 +++ /dev/null @@ -1,1669 +0,0 @@ -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!----------------------------------------------------------------------- -! CVS $Id$ -! CVS $Name$ -!----------------------------------------------------------------------- -!BOP -! -! !MODULE: m_mall - A bookkeeper of user allocated memories -! -! !DESCRIPTION: -! -! !INTERFACE: - - module m_mall - implicit none - private ! except - - public :: mall_ci - public :: mall_co - public :: mall_mci - public :: mall_mco - public :: mall_flush - public :: mall_reset - - ! mall_ activity controls - - public :: mall_ison - public :: mall_set - - interface mall_ci; module procedure ci_; end interface - interface mall_co; module procedure co_; end interface - - interface mall_mci; module procedure & - ciI0_, & - ciI1_, & - ciI2_, & - ciI3_, & - ciR0_, & - ciR1_, & - ciR2_, & - ciR3_, & - ciD0_, & - ciD1_, & - ciD2_, & - ciD3_, & - ciL0_, & - ciL1_, & - ciL2_, & - ciL3_, & - ciC0_, & - ciC1_, & - ciC2_, & - ciC3_ - end interface - - interface mall_mco; module procedure & - coI0_, & - coI1_, & - coI2_, & - coI3_, & - coR0_, & - coR1_, & - coR2_, & - coR3_, & - coD0_, & - coD1_, & - coD2_, & - coD3_, & - coL0_, & - coL1_, & - coL2_, & - coL3_, & - coC0_, & - coC1_, & - coC2_, & - coC3_ - end interface - - interface mall_flush; module procedure flush_; end interface - interface mall_reset; module procedure reset_; end interface - - interface mall_ison; module procedure ison_; end interface - interface mall_set; module procedure set_; end interface - -! !REVISION HISTORY: -! 13Feb98 - Jing Guo - initial prototype/prolog/code -!EOP -!_______________________________________________________________________ - character(len=*),parameter :: myname='MCT(MPEU)::m_mall' - -#if SYSUNICOS || SYSIRIX64 || _R8_ - integer,parameter :: NBYTE_PER_WORD = 8 -#else - integer,parameter :: NBYTE_PER_WORD = 4 -#endif - - integer,parameter :: NSZ= 32 - integer,parameter :: MXL=250 - - integer, save :: nreset = 0 ! number of reset_() calls - logical, save :: started = .false. ! the module is in use - - integer, save :: n_ =0 ! number of accouting bins. - character(len=NSZ),dimension(MXL),save :: name_ - - ! integer, dimension(1) :: mall - ! names of the accouting bins - - logical,save :: mall_on=.false. ! mall activity switch - - integer,save :: mci - integer,dimension(MXL),save :: mci_ ! maximum ci_() calls - integer,save :: nci - integer,dimension(MXL),save :: nci_ ! net ci_() calls - integer,save :: hwm - integer,dimension(MXL),save :: hwm_ ! high-water-mark of allocate() - integer,save :: nwm - integer,dimension(MXL),save :: nwm_ ! net-water-mark of allocate() - -contains -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: ison_ - -! -! !DESCRIPTION: -! -! !INTERFACE: - - function ison_() - implicit none - logical :: ison_ - -! !REVISION HISTORY: -! 25Oct99 - Jing Guo -! - initial prototype/prolog/code -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::ison_' - - ison_=mall_on - -end function ison_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: set_ - set the switch on -! -! !DESCRIPTION: -! -! !INTERFACE: - - subroutine set_(on) - implicit none - logical,optional,intent(in) :: on - -! !REVISION HISTORY: -! 25Oct99 - Jing Guo -! - initial prototype/prolog/code -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::set_' - - mall_on=.true. - if(present(on)) mall_on=on - -end subroutine set_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: ciI0_ - check in as an integer scalar -! -! !DESCRIPTION: -! -! !INTERFACE: - - subroutine ciI0_(marg,thread) - implicit none - integer,intent(in) :: marg - character(len=*),intent(in) :: thread - -! !REVISION HISTORY: -! 21Oct99 - Jing Guo -! - initial prototype/prolog/code -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::ciI0_' - - if(mall_on) call ci_(1,thread) - -end subroutine ciI0_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: ciI1_ - check in as an integer rank 1 array -! -! !DESCRIPTION: -! -! !INTERFACE: - - subroutine ciI1_(marg,thread) - implicit none - integer,dimension(:),intent(in) :: marg - character(len=*),intent(in) :: thread - -! !REVISION HISTORY: -! 21Oct99 - Jing Guo -! - initial prototype/prolog/code -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::ciI1_' - - if(mall_on) call ci_(size(marg),thread) - -end subroutine ciI1_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: ciI2_ - check in as an integer rank 2 array -! -! !DESCRIPTION: -! -! !INTERFACE: - - subroutine ciI2_(marg,thread) - implicit none - integer,dimension(:,:),intent(in) :: marg - character(len=*),intent(in) :: thread - -! !REVISION HISTORY: -! 21Oct99 - Jing Guo -! - initial prototype/prolog/code -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::ciI2_' - - if(mall_on) call ci_(size(marg),thread) - -end subroutine ciI2_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: ciI3_ - check in as an integer rank 3 array -! -! !DESCRIPTION: -! -! !INTERFACE: - - subroutine ciI3_(marg,thread) - implicit none - integer,dimension(:,:,:),intent(in) :: marg - character(len=*),intent(in) :: thread - -! !REVISION HISTORY: -! 21Oct99 - Jing Guo -! - initial prototype/prolog/code -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::ciI3_' - - if(mall_on) call ci_(size(marg),thread) - -end subroutine ciI3_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: ciR0_ - check in as a real(SP) scalar -! -! !DESCRIPTION: -! -! !INTERFACE: - - subroutine ciR0_(marg,thread) - use m_realkinds, only : SP - implicit none - real(SP),intent(in) :: marg - character(len=*),intent(in) :: thread - -! !REVISION HISTORY: -! 21Oct99 - Jing Guo -! - initial prototype/prolog/code -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::ciR0_' - - if(mall_on) call ci_(1,thread) - -end subroutine ciR0_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: ciR1_ - check in as a real(SP) rank 1 array -! -! !DESCRIPTION: -! -! !INTERFACE: - - subroutine ciR1_(marg,thread) - use m_realkinds, only : SP - implicit none - real(SP),dimension(:),intent(in) :: marg - character(len=*),intent(in) :: thread - -! !REVISION HISTORY: -! 21Oct99 - Jing Guo -! - initial prototype/prolog/code -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::ciR1_' - - if(mall_on) call ci_(size(marg),thread) - -end subroutine ciR1_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: ciR2_ - check in as a real(SP) rank 2 array -! -! !DESCRIPTION: -! -! !INTERFACE: - - subroutine ciR2_(marg,thread) - use m_realkinds, only : SP - implicit none - real(SP),dimension(:,:),intent(in) :: marg - character(len=*),intent(in) :: thread - -! !REVISION HISTORY: -! 21Oct99 - Jing Guo -! - initial prototype/prolog/code -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::ciR2_' - - if(mall_on) call ci_(size(marg),thread) - -end subroutine ciR2_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: ciR3_ - check in as a real(SP) rank 3 array -! -! !DESCRIPTION: -! -! !INTERFACE: - - subroutine ciR3_(marg,thread) - use m_realkinds, only : SP - implicit none - real(SP),dimension(:,:,:),intent(in) :: marg - character(len=*),intent(in) :: thread - -! !REVISION HISTORY: -! 21Oct99 - Jing Guo -! - initial prototype/prolog/code -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::ciR3_' - - if(mall_on) call ci_(size(marg),thread) - -end subroutine ciR3_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: ciD0_ - check in as a real(DP) scalar -! -! !DESCRIPTION: -! -! !INTERFACE: - - subroutine ciD0_(marg,thread) - use m_realkinds, only : DP - implicit none - real(DP),intent(in) :: marg - character(len=*),intent(in) :: thread - -! !REVISION HISTORY: -! 21Oct99 - Jing Guo -! - initial prototype/prolog/code -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::ciD0_' - - if(mall_on) call ci_(2,thread) - -end subroutine ciD0_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: ciD1_ - check in as a real(DP) rank 1 array -! -! !DESCRIPTION: -! -! !INTERFACE: - - subroutine ciD1_(marg,thread) - use m_realkinds, only : DP - implicit none - real(DP),dimension(:),intent(in) :: marg - character(len=*),intent(in) :: thread - -! !REVISION HISTORY: -! 21Oct99 - Jing Guo -! - initial prototype/prolog/code -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::ciD1_' - - if(mall_on) call ci_(2*size(marg),thread) - -end subroutine ciD1_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: ciD2_ - check in as a real(DP) rank 2 array -! -! !DESCRIPTION: -! -! !INTERFACE: - - subroutine ciD2_(marg,thread) - use m_realkinds, only : DP - implicit none - real(DP),dimension(:,:),intent(in) :: marg - character(len=*),intent(in) :: thread - -! !REVISION HISTORY: -! 21Oct99 - Jing Guo -! - initial prototype/prolog/code -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::ciD2_' - - if(mall_on) call ci_(2*size(marg),thread) - -end subroutine ciD2_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: ciD3_ - check in as a real(DP) rank 3 array -! -! !DESCRIPTION: -! -! !INTERFACE: - - subroutine ciD3_(marg,thread) - use m_realkinds, only : DP - implicit none - real(DP),dimension(:,:,:),intent(in) :: marg - character(len=*),intent(in) :: thread - -! !REVISION HISTORY: -! 21Oct99 - Jing Guo -! - initial prototype/prolog/code -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::ciD3_' - - if(mall_on) call ci_(2*size(marg),thread) - -end subroutine ciD3_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: ciL0_ - check in as a logical scalar -! -! !DESCRIPTION: -! -! !INTERFACE: - - subroutine ciL0_(marg,thread) - implicit none - logical,intent(in) :: marg - character(len=*),intent(in) :: thread - -! !REVISION HISTORY: -! 21Oct99 - Jing Guo -! - initial prototype/prolog/code -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::ciL0_' - - if(mall_on) call ci_(1,thread) - -end subroutine ciL0_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: ciL1_ - check in as a logical rank 1 array -! -! !DESCRIPTION: -! -! !INTERFACE: - - subroutine ciL1_(marg,thread) - implicit none - logical,dimension(:),intent(in) :: marg - character(len=*),intent(in) :: thread - -! !REVISION HISTORY: -! 21Oct99 - Jing Guo -! - initial prototype/prolog/code -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::ciL1_' - - if(mall_on) call ci_(size(marg),thread) - -end subroutine ciL1_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: ciL2_ - check in as a logical rank 2 array -! -! !DESCRIPTION: -! -! !INTERFACE: - - subroutine ciL2_(marg,thread) - implicit none - logical,dimension(:,:),intent(in) :: marg - character(len=*),intent(in) :: thread - -! !REVISION HISTORY: -! 21Oct99 - Jing Guo -! - initial prototype/prolog/code -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::ciL2_' - - if(mall_on) call ci_(size(marg),thread) - -end subroutine ciL2_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: ciL3_ - check in as a logical rank 3 array -! -! !DESCRIPTION: -! -! !INTERFACE: - - subroutine ciL3_(marg,thread) - implicit none - logical,dimension(:,:,:),intent(in) :: marg - character(len=*),intent(in) :: thread - -! !REVISION HISTORY: -! 21Oct99 - Jing Guo -! - initial prototype/prolog/code -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::ciL3_' - - if(mall_on) call ci_(size(marg),thread) - -end subroutine ciL3_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: ciC0_ - check in as a character scalar -! -! !DESCRIPTION: -! -! !INTERFACE: - - subroutine ciC0_(marg,thread) - implicit none - character(len=*),intent(in) :: marg - character(len=*),intent(in) :: thread - -! !REVISION HISTORY: -! 21Oct99 - Jing Guo -! - initial prototype/prolog/code -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::ciC0_' - integer :: nw - - if(.not.mall_on) return - nw=(len(marg)+NBYTE_PER_WORD-1)/NBYTE_PER_WORD - call ci_(nw,thread) - -end subroutine ciC0_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: ciC1_ - check in as a character rank 1 array -! -! !DESCRIPTION: -! -! !INTERFACE: - - subroutine ciC1_(marg,thread) - implicit none - character(len=*),dimension(:),intent(in) :: marg - character(len=*),intent(in) :: thread - -! !REVISION HISTORY: -! 21Oct99 - Jing Guo -! - initial prototype/prolog/code -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::ciC1_' - integer :: nw - - if(.not.mall_on) return - nw=(len(marg(1))+NBYTE_PER_WORD-1)/NBYTE_PER_WORD - call ci_(size(marg)*nw,thread) - -end subroutine ciC1_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: ciC2_ - check in as a character rank 2 array -! -! !DESCRIPTION: -! -! !INTERFACE: - - subroutine ciC2_(marg,thread) - implicit none - character(len=*),dimension(:,:),intent(in) :: marg - character(len=*),intent(in) :: thread - -! !REVISION HISTORY: -! 21Oct99 - Jing Guo -! - initial prototype/prolog/code -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::ciC2_' - integer :: nw - - if(.not.mall_on) return - nw=(len(marg(1,1))+NBYTE_PER_WORD-1)/NBYTE_PER_WORD - call ci_(size(marg)*nw,thread) - -end subroutine ciC2_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: ciC3_ - check in as a character rank 3 array -! -! !DESCRIPTION: -! -! !INTERFACE: - - subroutine ciC3_(marg,thread) - implicit none - character(len=*),dimension(:,:,:),intent(in) :: marg - character(len=*),intent(in) :: thread - -! !REVISION HISTORY: -! 21Oct99 - Jing Guo -! - initial prototype/prolog/code -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::ciC3_' - integer :: nw - - if(.not.mall_on) return - nw=(len(marg(1,1,1))+NBYTE_PER_WORD-1)/NBYTE_PER_WORD - call ci_(size(marg)*nw,thread) - -end subroutine ciC3_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!----------------------------------------------------------------------- -!BOP -! -! !IROUTINE: ci_ - check-in allocate activity -! -! !DESCRIPTION: -! -! !INTERFACE: - - subroutine ci_(nword,thread) - use m_stdio, only : stderr - use m_die, only : die - implicit none - integer,intent(in) :: nword - character(len=*),intent(in) :: thread - -! !REVISION HISTORY: -! 13Feb98 - Jing Guo - initial prototype/prolog/code -!EOP -!_______________________________________________________________________ - character(len=*),parameter :: myname_=myname//'::ci_' - integer :: ith - - if(.not.mall_on) return - - if(nword < 0) then - write(stderr,'(2a,i4)') myname_, & - ': invalide argument, nword = ',nword - call die(myname_) - endif - - ith=lookup_(thread) - - ! update the account - - nci_(ith)=nci_(ith)+1 - mci_(ith)=mci_(ith)+1 - nwm_(ith)=nwm_(ith)+nword - if(hwm_(ith).lt.nwm_(ith)) hwm_(ith)=nwm_(ith) - - ! update the total budget - - nci=nci+1 - mci=mci+1 - nwm=nwm+nword - if(hwm.lt.nwm) hwm=nwm - -end subroutine ci_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: coI0_ - check in as an integer scalar -! -! !DESCRIPTION: -! -! !INTERFACE: - - subroutine coI0_(marg,thread) - implicit none - integer,intent(in) :: marg - character(len=*),intent(in) :: thread - -! !REVISION HISTORY: -! 21Oct99 - Jing Guo -! - initial prototype/prolog/code -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::coI0_' - - if(mall_on) call co_(1,thread) - -end subroutine coI0_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: coI1_ - check in as an integer rank 1 array -! -! !DESCRIPTION: -! -! !INTERFACE: - - subroutine coI1_(marg,thread) - implicit none - integer,dimension(:),intent(in) :: marg - character(len=*),intent(in) :: thread - -! !REVISION HISTORY: -! 21Oct99 - Jing Guo -! - initial prototype/prolog/code -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::coI1_' - - if(mall_on) call co_(size(marg),thread) - -end subroutine coI1_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: coI2_ - check in as an integer rank 2 array -! -! !DESCRIPTION: -! -! !INTERFACE: - - subroutine coI2_(marg,thread) - implicit none - integer,dimension(:,:),intent(in) :: marg - character(len=*),intent(in) :: thread - -! !REVISION HISTORY: -! 21Oct99 - Jing Guo -! - initial prototype/prolog/code -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::coI2_' - - if(mall_on) call co_(size(marg),thread) - -end subroutine coI2_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: coI3_ - check in as an integer rank 3 array -! -! !DESCRIPTION: -! -! !INTERFACE: - - subroutine coI3_(marg,thread) - implicit none - integer,dimension(:,:,:),intent(in) :: marg - character(len=*),intent(in) :: thread - -! !REVISION HISTORY: -! 21Oct99 - Jing Guo -! - initial prototype/prolog/code -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::coI3_' - - if(mall_on) call co_(size(marg),thread) - -end subroutine coI3_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: coR0_ - check in as a real(SP) scalar -! -! !DESCRIPTION: -! -! !INTERFACE: - - subroutine coR0_(marg,thread) - use m_realkinds, only : SP - implicit none - real(SP),intent(in) :: marg - character(len=*),intent(in) :: thread - -! !REVISION HISTORY: -! 21Oct99 - Jing Guo -! - initial prototype/prolog/code -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::coR0_' - - if(mall_on) call co_(1,thread) - -end subroutine coR0_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: coR1_ - check in as a real(SP) rank 1 array -! -! !DESCRIPTION: -! -! !INTERFACE: - - subroutine coR1_(marg,thread) - use m_realkinds, only : SP - implicit none - real(SP),dimension(:),intent(in) :: marg - character(len=*),intent(in) :: thread - -! !REVISION HISTORY: -! 21Oct99 - Jing Guo -! - initial prototype/prolog/code -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::coR1_' - - if(mall_on) call co_(size(marg),thread) - -end subroutine coR1_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: coR2_ - check in as a real(SP) rank 2 array -! -! !DESCRIPTION: -! -! !INTERFACE: - - subroutine coR2_(marg,thread) - use m_realkinds, only : SP - implicit none - real(SP),dimension(:,:),intent(in) :: marg - character(len=*),intent(in) :: thread - -! !REVISION HISTORY: -! 21Oct99 - Jing Guo -! - initial prototype/prolog/code -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::coR2_' - - if(mall_on) call co_(size(marg),thread) - -end subroutine coR2_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: coR3_ - check in as a real(SP) rank 3 array -! -! !DESCRIPTION: -! -! !INTERFACE: - - subroutine coR3_(marg,thread) - use m_realkinds, only : SP - implicit none - real(SP),dimension(:,:,:),intent(in) :: marg - character(len=*),intent(in) :: thread - -! !REVISION HISTORY: -! 21Oct99 - Jing Guo -! - initial prototype/prolog/code -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::coR3_' - - if(mall_on) call co_(size(marg),thread) - -end subroutine coR3_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: coD0_ - check in as a real(DP) scalar -! -! !DESCRIPTION: -! -! !INTERFACE: - - subroutine coD0_(marg,thread) - use m_realkinds, only : DP - implicit none - real(DP),intent(in) :: marg - character(len=*),intent(in) :: thread - -! !REVISION HISTORY: -! 21Oct99 - Jing Guo -! - initial prototype/prolog/code -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::coD0_' - - if(mall_on) call co_(2,thread) - -end subroutine coD0_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: coD1_ - check in as a real(DP) rank 1 array -! -! !DESCRIPTION: -! -! !INTERFACE: - - subroutine coD1_(marg,thread) - use m_realkinds, only : DP - implicit none - real(DP),dimension(:),intent(in) :: marg - character(len=*),intent(in) :: thread - -! !REVISION HISTORY: -! 21Oct99 - Jing Guo -! - initial prototype/prolog/code -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::coD1_' - - if(mall_on) call co_(2*size(marg),thread) - -end subroutine coD1_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: coD2_ - check in as a real(DP) rank 2 array -! -! !DESCRIPTION: -! -! !INTERFACE: - - subroutine coD2_(marg,thread) - use m_realkinds, only : DP - implicit none - real(DP),dimension(:,:),intent(in) :: marg - character(len=*),intent(in) :: thread - -! !REVISION HISTORY: -! 21Oct99 - Jing Guo -! - initial prototype/prolog/code -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::coD2_' - - if(mall_on) call co_(2*size(marg),thread) - -end subroutine coD2_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: coD3_ - check in as a real(DP) rank 3 array -! -! !DESCRIPTION: -! -! !INTERFACE: - - subroutine coD3_(marg,thread) - use m_realkinds, only : DP - implicit none - real(DP),dimension(:,:,:),intent(in) :: marg - character(len=*),intent(in) :: thread - -! !REVISION HISTORY: -! 21Oct99 - Jing Guo -! - initial prototype/prolog/code -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::coD3_' - - if(mall_on) call co_(2*size(marg),thread) - -end subroutine coD3_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: coL0_ - check in as a logical scalar -! -! !DESCRIPTION: -! -! !INTERFACE: - - subroutine coL0_(marg,thread) - implicit none - logical,intent(in) :: marg - character(len=*),intent(in) :: thread - -! !REVISION HISTORY: -! 21Oct99 - Jing Guo -! - initial prototype/prolog/code -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::coL0_' - - if(mall_on) call co_(1,thread) - -end subroutine coL0_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: coL1_ - check in as a logical rank 1 array -! -! !DESCRIPTION: -! -! !INTERFACE: - - subroutine coL1_(marg,thread) - implicit none - logical,dimension(:),intent(in) :: marg - character(len=*),intent(in) :: thread - -! !REVISION HISTORY: -! 21Oct99 - Jing Guo -! - initial prototype/prolog/code -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::coL1_' - - if(mall_on) call co_(size(marg),thread) - -end subroutine coL1_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: coL2_ - check in as a logical rank 2 array -! -! !DESCRIPTION: -! -! !INTERFACE: - - subroutine coL2_(marg,thread) - implicit none - logical,dimension(:,:),intent(in) :: marg - character(len=*),intent(in) :: thread - -! !REVISION HISTORY: -! 21Oct99 - Jing Guo -! - initial prototype/prolog/code -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::coL2_' - - if(mall_on) call co_(size(marg),thread) - -end subroutine coL2_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: coL3_ - check in as a logical rank 3 array -! -! !DESCRIPTION: -! -! !INTERFACE: - - subroutine coL3_(marg,thread) - implicit none - logical,dimension(:,:,:),intent(in) :: marg - character(len=*),intent(in) :: thread - -! !REVISION HISTORY: -! 21Oct99 - Jing Guo -! - initial prototype/prolog/code -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::coL3_' - - if(mall_on) call co_(size(marg),thread) - -end subroutine coL3_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: coC0_ - check in as a character scalar -! -! !DESCRIPTION: -! -! !INTERFACE: - - subroutine coC0_(marg,thread) - implicit none - character(len=*),intent(in) :: marg - character(len=*),intent(in) :: thread - -! !REVISION HISTORY: -! 21Oct99 - Jing Guo -! - initial prototype/prolog/code -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::coC0_' - integer :: nw - - if(.not.mall_on) return - nw=(len(marg)+NBYTE_PER_WORD-1)/NBYTE_PER_WORD - call co_(nw,thread) - -end subroutine coC0_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: coC1_ - check in as a character rank 1 array -! -! !DESCRIPTION: -! -! !INTERFACE: - - subroutine coC1_(marg,thread) - implicit none - character(len=*),dimension(:),intent(in) :: marg - character(len=*),intent(in) :: thread - -! !REVISION HISTORY: -! 21Oct99 - Jing Guo -! - initial prototype/prolog/code -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::coC1_' - integer :: nw - - if(.not.mall_on) return - nw=(len(marg(1))+NBYTE_PER_WORD-1)/NBYTE_PER_WORD - call co_(size(marg)*nw,thread) - -end subroutine coC1_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: coC2_ - check in as a character rank 2 array -! -! !DESCRIPTION: -! -! !INTERFACE: - - subroutine coC2_(marg,thread) - implicit none - character(len=*),dimension(:,:),intent(in) :: marg - character(len=*),intent(in) :: thread - -! !REVISION HISTORY: -! 21Oct99 - Jing Guo -! - initial prototype/prolog/code -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::coC2_' - integer :: nw - - if(.not.mall_on) return - nw=(len(marg(1,1))+NBYTE_PER_WORD-1)/NBYTE_PER_WORD - call co_(size(marg)*nw,thread) - -end subroutine coC2_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: coC3_ - check in as a character rank 3 array -! -! !DESCRIPTION: -! -! !INTERFACE: - - subroutine coC3_(marg,thread) - implicit none - character(len=*),dimension(:,:,:),intent(in) :: marg - character(len=*),intent(in) :: thread - -! !REVISION HISTORY: -! 21Oct99 - Jing Guo -! - initial prototype/prolog/code -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::coC3_' - integer :: nw - - if(.not.mall_on) return - nw=(len(marg(1,1,1))+NBYTE_PER_WORD-1)/NBYTE_PER_WORD - call co_(size(marg)*nw,thread) - -end subroutine coC3_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!----------------------------------------------------------------------- -!BOP -! -! !IROUTINE: co_ - check-out allocate activity -! -! !DESCRIPTION: -! -! !INTERFACE: - - subroutine co_(nword,thread) - use m_stdio, only : stderr - use m_die, only : die - implicit none - integer,intent(in) :: nword - character(len=*),intent(in) :: thread - -! !REVISION HISTORY: -! 13Feb98 - Jing Guo - initial prototype/prolog/code -!EOP -!_______________________________________________________________________ - character(len=*),parameter :: myname_=myname//'::co_' - integer :: ith - - if(.not.mall_on) return - - if(nword < 0) then - write(stderr,'(2a,i4)') myname_, & - ': invalide argument, nword = ',nword - call die(myname_) - endif - - ! if the thread is "unknown", it would be treated as a - ! new thread with net negative memory activity. - - ith=lookup_(thread) - - ! update the account - - nci_(ith)=nci_(ith)-1 - nwm_(ith)=nwm_(ith)-nword - - ! update the total budget - - nci=nci-1 - nwm=nwm-nword - -end subroutine co_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!----------------------------------------------------------------------- -!BOP -! -! !IROUTINE: cix_ - handling macro ALLOC_() error -! -! !DESCRIPTION: -! -! !INTERFACE: - - subroutine cix_(thread,stat,fnam,line) - use m_stdio, only : stderr - use m_die, only : die - implicit none - character(len=*),intent(in) :: thread - integer,intent(in) :: stat - character(len=*),intent(in) :: fnam - integer,intent(in) :: line - - -! !REVISION HISTORY: -! 13Feb98 - Jing Guo - initial prototype/prolog/code -!EOP -!_______________________________________________________________________ - character(len=*),parameter :: myname_=myname//'::cix_' - - write(stderr,'(2a,i4)') trim(thread), & - ': ALLOC_() error, stat =',stat - call die('ALLOC_',fnam,line) - -end subroutine cix_ -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!----------------------------------------------------------------------- -!BOP -! -! !IROUTINE: cox_ - handling macro DEALLOC_() error -! -! !DESCRIPTION: -! -! !INTERFACE: - - subroutine cox_(thread,stat,fnam,line) - use m_stdio, only : stderr - use m_die, only : die - implicit none - character(len=*),intent(in) :: thread - integer,intent(in) :: stat - character(len=*),intent(in) :: fnam - integer,intent(in) :: line - -! !REVISION HISTORY: -! 13Feb98 - Jing Guo - initial prototype/prolog/code -!EOP -!_______________________________________________________________________ - character(len=*),parameter :: myname_=myname//'::cox_' - - write(stderr,'(2a,i4)') trim(thread), & - ': DEALLOC_() error, stat =',stat - call die('DEALLOC_',fnam,line) - -end subroutine cox_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!----------------------------------------------------------------------- -!BOP -! -! !IROUTINE: flush_ - balancing the up-to-date ci/co calls -! -! !DESCRIPTION: -! -! !INTERFACE: - - subroutine flush_(lu) - use m_stdio, only : stderr - use m_ioutil, only : luflush - use m_die, only : die - implicit none - integer,intent(in) :: lu - -! !REVISION HISTORY: -! 17Feb98 - Jing Guo - initial prototype/prolog/code -!EOP -!_______________________________________________________________________ - character(len=*),parameter :: myname_=myname//'::flush_' - - integer,parameter :: lnmax=38 - character(len=max(lnmax,NSZ)) :: name - - character(len=6) :: hwm_wd,nwm_wd - character(len=1) :: flag_ci,flag_wm - integer :: i,ier,ln - - if(.not.mall_on) return - - if(.not.started) call reset_() - - write(lu,'(72a/)',iostat=ier) ('_',i=1,72) - if(ier /= 0) then - write(stderr,'(2a,i3)') myname_,': can not write(), unit =',lu - call die(myname_) - endif - - write(lu,'(a,t39,4(2x,a))',iostat=ier) '[MALL]', & - 'max-ci','net-ci ','max-wm','net-wm' - if(ier /= 0) then - write(stderr,'(2a,i4)') myname_,': can not write(), unit =',lu - call die(myname_) - endif - - call luflush(lu) - -!23.|....1....|....2....|....3....|....4....|....5....|....6....|....7.. -!_______________________________________________________________________ -! -![MALL] max_ci net-ci max-wm net-wm -!----------------------------------------------------------------------- -!total. ...333 ...333* ..333M ..333i* -!_______________________________________________________________________ - - write(lu,'(72a)') ('-',i=1,72) - - do i=1,min(n_,MXL) - call wcount_(hwm_(i),hwm_wd) - call wcount_(nwm_(i),nwm_wd) - - flag_ci=' ' - if(nci_(i) /= 0) flag_ci='*' - - flag_wm=' ' - if(nwm_(i) /= 0) flag_wm='*' - - name=name_(i) - ln=max(len_trim(name),lnmax) - write(lu,'(a,2(2x,i6),a,2(2x,a6),a)') name(1:ln), & - mci_(i),nci_(i),flag_ci,hwm_wd,nwm_wd,flag_wm - end do - - call wcount_(hwm,hwm_wd) - call wcount_(nwm,nwm_wd) - - flag_ci=' ' - if(nci /= 0) flag_ci='*' - flag_wm=' ' - if(nwm /= 0) flag_wm='*' - - name='.total.' - ln=max(len_trim(name),lnmax) - write(lu,'(a,2(2x,i6),a,2(2x,a6),a)') name(1:ln), & - mci,nci,flag_ci,hwm_wd,nwm_wd,flag_wm - - write(lu,'(72a/)') ('_',i=1,72) - - if(nreset /= 1) write(lu,'(2a,i3,a)') myname_, & - ': reset_ ',nreset,' times' - - call luflush(lu) -end subroutine flush_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!----------------------------------------------------------------------- -!BOP -! -! !IROUTINE: wcount_ - generate word count output with unit -! -! !DESCRIPTION: -! -! !INTERFACE: - - subroutine wcount_(wknt,cknt) - implicit none - - integer, intent(in) :: wknt ! given an integer value - character(len=6),intent(out) :: cknt ! return a string value - -! !REVISION HISTORY: -! 17Feb98 - Jing Guo - initial prototype/prolog/code -!EOP -!_______________________________________________________________________ - character(len=*),parameter :: myname_=myname//'::wcount_' - -character(len=1) :: cwd -integer,parameter :: KWD=1024 -integer,parameter :: MWD=1024*1024 -integer,parameter :: GWD=1024*1024*1024 - -integer :: iwd - -if(wknt < 0) then - cknt='------' -else - cwd='i' - iwd=wknt - if(iwd > 9999) then - cwd='K' - iwd=(wknt+KWD-1)/KWD - endif - if(iwd > 9999) then - cwd='M' - iwd=(wknt+MWD-1)/MWD - endif - if(iwd > 9999) then - cwd='G' - iwd=(wknt+GWD-1)/GWD - endif - write(cknt,'(i5,a)') iwd,cwd -endif -end subroutine wcount_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!----------------------------------------------------------------------- -!BOP -! -! !IROUTINE: lookup_ - search/insert a name in a list -! -! !DESCRIPTION: -! -! !INTERFACE: - - function lookup_(thread) - use m_chars, only : uppercase - implicit none - character(len=*),intent(in) :: thread - integer :: lookup_ - -! !REVISION HISTORY: -! 17Feb98 - Jing Guo - initial prototype/prolog/code -!EOP -!_______________________________________________________________________ - character(len=*),parameter :: myname_=myname//'::lookup_' - - logical :: found - integer :: ith - - if(.not.started) call reset_() - -!---------------------------------------- -ith=0 -found=.false. -do while(.not.found .and. ith < min(n_,MXL)) - ith=ith+1 - found= uppercase(thread) == uppercase(name_(ith)) -end do - -if(.not.found) then - if(n_==0) then - nci=0 - mci=0 - nwm=0 - hwm=0 - endif - - n_=n_+1 - if(n_ == MXL) then - ith=MXL - name_(ith)='.overflow.' - else - ith=n_ - name_(ith)=thread - endif - - nci_(ith)=0 - mci_(ith)=0 - nwm_(ith)=0 - hwm_(ith)=0 -endif - -lookup_=ith - -end function lookup_ -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!----------------------------------------------------------------------- -!BOP -! -! !IROUTINE: reset_ - initialize the module data structure -! -! !DESCRIPTION: -! -! !INTERFACE: - - subroutine reset_() - implicit none - -! !REVISION HISTORY: -! 16Mar98 - Jing Guo - initial prototype/prolog/code -!EOP -!_______________________________________________________________________ - character(len=*),parameter :: myname_=myname//'::reset_' - - if(.not.mall_on) return - - nreset=nreset+1 - started=.true. - - name_(1:n_)=' ' - - mci_(1:n_)=0 - nci_(1:n_)=0 - hwm_(1:n_)=0 - nwm_(1:n_)=0 - - n_ =0 - - mci=0 - nci=0 - hwm=0 - nwm=0 - -end subroutine reset_ -!======================================================================= -end module m_mall diff --git a/cesm/models/utils/mct/mpeu/m_mpif.F90 b/cesm/models/utils/mct/mpeu/m_mpif.F90 deleted file mode 100644 index 45b9a43..0000000 --- a/cesm/models/utils/mct/mpeu/m_mpif.F90 +++ /dev/null @@ -1,69 +0,0 @@ -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!----------------------------------------------------------------------- -! CVS $Id$ -! CVS $Name$ -!----------------------------------------------------------------------- -!BOP -! -! !MODULE: m_mpif - a portable interface to the MPI "mpif.h" COMMONs. -! -! !DESCRIPTION: -! -! The purpose of \verb"m_mpif" module is to provide a portable -! interface of \verb"mpif.h" with different MPI implementation. -! By combining module \verb"m_mpif" and \verb"m_mpif90", it may be -! possible to build a Fortran 90 MPI binding module graduately. -! -! Although it is possible to use \verb'include "mpif.h"' directly -! in individual modules, it has several problems: -! \begin{itemize} -! \item It may conflict with either the source code of a {\sl fixed} -! format or the code of a {\sl free} format; -! \item It does not provide the protection and the safety of using -! these variables as what a \verb"MODULE" would provide. -! \end{itemize} -! -! More information may be found in the module \verb"m_mpif90". -! -! !INTERFACE: - - module m_mpif - implicit none - private ! except - - public :: MPI_INTEGER - public :: MPI_REAL - public :: MPI_DOUBLE_PRECISION - public :: MPI_LOGICAL - public :: MPI_CHARACTER - - public :: MPI_REAL4 - public :: MPI_REAL8 - - public :: MPI_COMM_WORLD - public :: MPI_COMM_NULL - - public :: MPI_SUM - public :: MPI_PROD - public :: MPI_MIN - public :: MPI_MAX - - public :: MPI_MAX_ERROR_STRING - public :: MPI_STATUS_SIZE - public :: MPI_ANY_SOURCE - -#ifdef MPICH_ - public :: MPIPRIV ! the common block name -#endif - - include "mpif.h" - -! !REVISION HISTORY: -! 01Apr98 - Jing Guo - initial prototype/prolog/code -!EOP -!_______________________________________________________________________ - character(len=*),parameter :: myname='MCT(MPEU)::m_mpif' - - end module m_mpif -!. diff --git a/cesm/models/utils/mct/mpeu/m_mpif90.F90 b/cesm/models/utils/mct/mpeu/m_mpif90.F90 deleted file mode 100644 index 3bdfcf1..0000000 --- a/cesm/models/utils/mct/mpeu/m_mpif90.F90 +++ /dev/null @@ -1,719 +0,0 @@ -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!----------------------------------------------------------------------- -! CVS $Id$ -! CVS $Name$ -!----------------------------------------------------------------------- -!BOP -! -! !MODULE: m_mpif90 - a Fortran 90 style MPI module interface. -! -! !DESCRIPTION: -! -! By wrapping \verb'include "mpif.h"' into a module, \verb"m_mpif()" -! provides an easy way to -!\begin{itemize} -! \item avoid the problem with {\sl fixed} or {\sl free} formatted -! Fortran 90 files; -! \item provide protections with only a limited set of \verb"PUBLIC" -! variables; and -! \item be extended to a MPI Fortran 90 binding. -!\end{itemize} -! -! !INTERFACE: - - module m_mpif90 - use m_mpif, only : MP_INTEGER => MPI_INTEGER - use m_mpif, only : MP_REAL => MPI_REAL - use m_mpif, only : MP_DOUBLE_PRECISION & - => MPI_DOUBLE_PRECISION - use m_mpif, only : MP_LOGICAL => MPI_LOGICAL - use m_mpif, only : MP_CHARACTER => MPI_CHARACTER - - use m_mpif, only : MP_REAL4 => MPI_REAL4 - use m_mpif, only : MP_REAL8 => MPI_REAL8 - - use m_mpif, only : MP_COMM_WORLD => MPI_COMM_WORLD - use m_mpif, only : MP_COMM_NULL => MPI_COMM_NULL - use m_mpif, only : MP_SUM => MPI_SUM - use m_mpif, only : MP_PROD => MPI_PROD - use m_mpif, only : MP_MIN => MPI_MIN - use m_mpif, only : MP_MAX => MPI_MAX - use m_mpif, only : MP_MAX_ERROR_STRING & - => MPI_MAX_ERROR_STRING - use m_mpif, only : MP_STATUS_SIZE => MPI_STATUS_SIZE - use m_mpif, only : MP_ANY_SOURCE => MPI_ANY_SOURCE - - implicit none - private - - public :: MP_type - - public :: MP_INTEGER - public :: MP_REAL - public :: MP_DOUBLE_PRECISION - public :: MP_LOGICAL - public :: MP_CHARACTER - - public :: MP_REAL4 - public :: MP_REAL8 - - public :: MP_COMM_WORLD - public :: MP_COMM_NULL - - public :: MP_SUM - public :: MP_PROD - public :: MP_MIN - public :: MP_MAX - - public :: MP_ANY_SOURCE - - public :: MP_MAX_ERROR_STRING - - public :: MP_init - public :: MP_initialized - public :: MP_finalize - public :: MP_abort - - public :: MP_wtime - public :: MP_wtick - - public :: MP_comm_size - public :: MP_comm_rank - public :: MP_comm_dup - public :: MP_comm_free - - public :: MP_cart_create - public :: MP_dims_create - public :: MP_cart_coords - public :: MP_cart_rank - - public :: MP_error_string - - public :: MP_perr - - public :: MP_STATUS_SIZE - public :: MP_status - - public :: MP_log2 - -! !REVISION HISTORY: -! 09Dec97 - Jing Guo - initial prototyping/coding. -! . started with everything public, without any interface -! declaration. -! . Then limited to only variables current expected to -! be used. -! -!EOP -!_______________________________________________________________________ - -integer,dimension(MP_STATUS_SIZE) :: MP_status - - !---------------------------------------- - -interface MP_init - subroutine MPI_init(ier) - integer :: ier - end subroutine MPI_init -end interface - -interface MP_initialized - subroutine MPI_initialized(flag,ier) - logical :: flag - integer :: ier - end subroutine MPI_initialized -end interface - -interface MP_finalize - subroutine MPI_finalize(ier) - integer :: ier - end subroutine MPI_finalize -end interface - -interface MP_error_string - subroutine MPI_error_string(ierror,cerror,ln,ier) - integer :: ierror - character(len=*) :: cerror - integer :: ln - integer :: ier - end subroutine MPI_error_string -end interface - -interface MP_type; module procedure & - typeI_, & ! MPI_INTEGER - typeL_, & ! MPI_LOGICAL - typeC_, & ! MPI_CHARACTER - typeSP_, & ! MPI_REAL - typeDP_, & ! MPI_DOUBLE_PRECISION - typeI1_, & ! MPI_INTEGER - typeL1_, & ! MPI_LOGICAL - typeC1_, & ! MPI_CHARACTER - typeSP1_, & ! MPI_REAL - typeDP1_, & ! MPI_DOUBLE_PRECISION - typeI2_, & ! MPI_INTEGER - typeL2_, & ! MPI_LOGICAL - typeC2_, & ! MPI_CHARACTER - typeSP2_, & ! MPI_REAL - typeDP2_ ! MPI_DOUBLE_PRECISION -end interface - -interface MP_perr; module procedure perr_; end interface - -interface MP_abort - subroutine MPI_abort(comm,errorcode,ier) - integer :: comm - integer :: errorcode - integer :: ier - end subroutine MPI_abort -end interface - - !---------------------------------------- -interface MP_wtime - function MPI_wtime() - double precision :: MPI_wtime - end function MPI_wtime -end interface - -interface MP_wtick - function MPI_wtick() - double precision :: MPI_wtick - end function MPI_wtick -end interface - - !---------------------------------------- -interface MP_comm_size - subroutine MPI_comm_size(comm,size,ier) - integer :: comm - integer :: size - integer :: ier - end subroutine MPI_comm_size -end interface - -interface MP_comm_rank - subroutine MPI_comm_rank(comm,rank,ier) - integer :: comm - integer :: rank - integer :: ier - end subroutine MPI_comm_rank -end interface - -interface MP_comm_dup - subroutine MPI_comm_dup(comm,newcomm,ier) - integer :: comm - integer :: newcomm - integer :: ier - end subroutine MPI_comm_dup -end interface - -interface MP_comm_free - subroutine MPI_comm_free(comm,ier) - integer :: comm - integer :: ier - end subroutine MPI_comm_free -end interface - - !---------------------------------------- -interface MP_cart_create - subroutine MPI_cart_create(comm_old,ndims,dims,periods, & - reorder,comm_cart,ier) - integer :: comm_old - integer :: ndims - integer,dimension(*) :: dims - logical,dimension(*) :: periods - logical :: reorder - integer :: comm_cart - integer :: ier - end subroutine MPI_cart_create -end interface - -interface MP_dims_create - subroutine MPI_dims_create(nnodes,ndims,dims,ier) - integer :: nnodes - integer :: ndims - integer,dimension(*) :: dims - integer :: ier - end subroutine MPI_dims_create -end interface - -interface MP_cart_coords - subroutine MPI_cart_coords(comm,rank,maxdims,coords,ier) - integer :: comm - integer :: rank - integer :: maxdims - integer,dimension(*) :: coords - integer :: ier - end subroutine MPI_cart_coords -end interface - -interface MP_cart_rank - subroutine MPI_cart_rank(comm,coords,rank,ier) - integer :: comm - integer,dimension(*) :: coords - integer :: rank - integer :: ier - end subroutine MPI_cart_rank -end interface - !---------------------------------------- - - character(len=*),parameter :: myname='m_mpif90' -contains - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: typeI_ - return MPI datatype of INTEGER -! -! !DESCRIPTION: -! -! !INTERFACE: - - function typeI_(ival) - implicit none - integer,intent(in) :: ival - integer :: typeI_ - -! !REVISION HISTORY: -! 28Sep99 - Jing Guo -! - initial prototype/prolog/code -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::typeI_' - - typeI_=MP_INTEGER - -end function typeI_ -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: typeL_ - return MPI datatype of LOGICAL -! -! !DESCRIPTION: -! -! !INTERFACE: - - function typeL_(lval) - implicit none - logical,intent(in) :: lval - integer :: typeL_ - -! !REVISION HISTORY: -! 28Sep99 - Jing Guo -! - initial prototype/prolog/code -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::typeL_' - - typeL_=MP_LOGICAL - -end function typeL_ -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: typeC_ - return MPI datatype of CHARACTER -! -! !DESCRIPTION: -! -! !INTERFACE: - - function typeC_(cval) - implicit none - character(len=*),intent(in) :: cval - integer :: typeC_ - -! !REVISION HISTORY: -! 28Sep99 - Jing Guo -! - initial prototype/prolog/code -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::typeC_' - - typeC_=MP_CHARACTER - -end function typeC_ -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: typeSP_ - return MPI datatype of single precision REAL -! -! !DESCRIPTION: -! -! !INTERFACE: - - function typeSP_(rval) - use m_realkinds,only : SP - implicit none - real(SP),intent(in) :: rval - integer :: typeSP_ - -! !REVISION HISTORY: -! 28Sep99 - Jing Guo -! - initial prototype/prolog/code -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::typeSP_' - - typeSP_=MP_REAL - -end function typeSP_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: typeDP_ - return MPI datatype of double precision REAL -! -! !DESCRIPTION: -! -! !INTERFACE: - - function typeDP_(rval) - use m_realkinds,only : DP - implicit none - real(DP),intent(in) :: rval - integer :: typeDP_ - -! !REVISION HISTORY: -! 28Sep99 - Jing Guo -! - initial prototype/prolog/code -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::typeDP_' - - typeDP_=MP_DOUBLE_PRECISION - -end function typeDP_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: typeI1_ - return MPI datatype of INTEGER -! -! !DESCRIPTION: -! -! !INTERFACE: - - function typeI1_(ival) - implicit none - integer,dimension(:),intent(in) :: ival - integer :: typeI1_ - -! !REVISION HISTORY: -! 28Sep99 - Jing Guo -! - initial prototype/prolog/code -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::typeI1_' - - typeI1_=MP_INTEGER - -end function typeI1_ -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: typeL1_ - return MPI datatype of LOGICAL -! -! !DESCRIPTION: -! -! !INTERFACE: - - function typeL1_(lval) - implicit none - logical,dimension(:),intent(in) :: lval - integer :: typeL1_ - -! !REVISION HISTORY: -! 28Sep99 - Jing Guo -! - initial prototype/prolog/code -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::typeL1_' - - typeL1_=MP_LOGICAL - -end function typeL1_ -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: typeC1_ - return MPI datatype of CHARACTER -! -! !DESCRIPTION: -! -! !INTERFACE: - - function typeC1_(cval) - implicit none - character(len=*),dimension(:),intent(in) :: cval - integer :: typeC1_ - -! !REVISION HISTORY: -! 28Sep99 - Jing Guo -! - initial prototype/prolog/code -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::typeC1_' - - typeC1_=MP_CHARACTER - -end function typeC1_ -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: typeSP1_ - return MPI datatype of single precision REAL -! -! !DESCRIPTION: -! -! !INTERFACE: - - function typeSP1_(rval) - use m_realkinds,only : SP - implicit none - real(SP),dimension(:),intent(in) :: rval - integer :: typeSP1_ - -! !REVISION HISTORY: -! 28Sep99 - Jing Guo -! - initial prototype/prolog/code -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::typeSP1_' - - typeSP1_=MP_REAL - -end function typeSP1_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: typeDP1_ - return MPI datatype of double precision REAL -! -! !DESCRIPTION: -! -! !INTERFACE: - - function typeDP1_(rval) - use m_realkinds,only : DP - implicit none - real(DP),dimension(:),intent(in) :: rval - integer :: typeDP1_ - -! !REVISION HISTORY: -! 28Sep99 - Jing Guo -! - initial prototype/prolog/code -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::typeDP1_' - - typeDP1_=MP_DOUBLE_PRECISION - -end function typeDP1_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: typeI2_ - return MPI datatype of INTEGER -! -! !DESCRIPTION: -! -! !INTERFACE: - - function typeI2_(ival) - implicit none - integer,dimension(:,:),intent(in) :: ival - integer :: typeI2_ - -! !REVISION HISTORY: -! 28Sep99 - Jing Guo -! - initial prototype/prolog/code -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::typeI2_' - - typeI2_=MP_INTEGER - -end function typeI2_ -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: typeL2_ - return MPI datatype of LOGICAL -! -! !DESCRIPTION: -! -! !INTERFACE: - - function typeL2_(lval) - implicit none - logical,dimension(:,:),intent(in) :: lval - integer :: typeL2_ - -! !REVISION HISTORY: -! 28Sep99 - Jing Guo -! - initial prototype/prolog/code -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::typeL2_' - - typeL2_=MP_LOGICAL - -end function typeL2_ -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: typeC2_ - return MPI datatype of CHARACTER -! -! !DESCRIPTION: -! -! !INTERFACE: - - function typeC2_(cval) - implicit none - character(len=*),dimension(:,:),intent(in) :: cval - integer :: typeC2_ - -! !REVISION HISTORY: -! 28Sep99 - Jing Guo -! - initial prototype/prolog/code -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::typeC2_' - - typeC2_=MP_CHARACTER - -end function typeC2_ -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: typeSP2_ - return MPI datatype of single precision REAL -! -! !DESCRIPTION: -! -! !INTERFACE: - - function typeSP2_(rval) - use m_realkinds,only : SP - implicit none - real(SP),dimension(:,:),intent(in) :: rval - integer :: typeSP2_ - -! !REVISION HISTORY: -! 28Sep99 - Jing Guo -! - initial prototype/prolog/code -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::typeSP2_' - - typeSP2_=MP_REAL - -end function typeSP2_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: typeDP2_ - return MPI datatype of double precision REAL -! -! !DESCRIPTION: -! -! !INTERFACE: - - function typeDP2_(rval) - use m_realkinds,only : DP - implicit none - real(DP),dimension(:,:),intent(in) :: rval - integer :: typeDP2_ - -! !REVISION HISTORY: -! 28Sep99 - Jing Guo -! - initial prototype/prolog/code -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::typeDP2_' - - typeDP2_=MP_DOUBLE_PRECISION - -end function typeDP2_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: perr_ - MPI error information hanlder -! -! !DESCRIPTION: -! -! !INTERFACE: - - subroutine perr_(proc,MP_proc,ierror) - use m_stdio, only : stderr - implicit none - character(len=*),intent(in) :: proc - character(len=*),intent(in) :: MP_proc - integer,intent(in) :: ierror - -! !REVISION HISTORY: -! 21Apr98 - Jing Guo - initial prototype/prolog/code -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::perr_' - - character(len=MP_MAX_ERROR_STRING) :: estr - integer :: ln,ier - - call MP_error_string(ierror,estr,ln,ier) - if(ier /= 0 .or. ln<=0) then - write(stderr,'(4a,i4)') proc,': ', & - MP_proc,' error, ierror =',ierror - else - write(stderr,'(6a)') proc,': ', & - MP_proc,' error, "',estr(1:ln),'"' - endif - -end subroutine perr_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: MP_log2 - The smallest integer its power of 2 is >= nPE -! -! !DESCRIPTION: -! -! !INTERFACE: - - function MP_log2(nPE) - implicit none - integer,intent(in) :: nPE - integer :: MP_log2 - -! !REVISION HISTORY: -! 01Feb00 - Jing Guo -! - initial prototype/prolog/code -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::MP_log2' - - integer :: n2 - - MP_log2=0 - n2=1 - do while(n2 - initial prototype/prolog/code -! 28Sep99 - Jing Guo -! - Added additional calls to support the "Violet" system -! development. -! -! !DESIGN ISSUES: -! \begin{itemize} -! -! \item It might be considered useful to implement this module to be -! applicable to a given {\sl communicator}. The argument -! taken now is to only have one multiple output stream handle -! per excution. This is consistent with \verb"stdout" in the -! traditional sense. (Jing Guo, 25Feb98) -! -! \item \verb"mpout_log()" is implemented in a way producing output -! only if \verb"mpout_ison()" (being \verb".true."). The reason -! of not implementing a default output such as \verb"stdout", is -! hoping to provent too many unexpected output when the system is -! switched to a multiple PE system. The design principle for -! this module is that \verb"mpout" is basically {\sl not} the same -! module as \verb"stdout". (Jing Guo, 28Sep99) -! -! \end{itemize} -!EOP -!_______________________________________________________________________ - character(len=*),parameter :: myname='MCT(MPEU)::m_mpout' - - character(len=*),parameter :: def_pfix='mpout' - - integer,save :: isec=-1 - integer,save :: mpout=stdout - logical,save :: mpout_set=.false. - character(len=LEN_FILENAME-4),save :: upfix=def_pfix - integer,parameter :: mpout_MASK=3 ! every four PEs - -contains - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!----------------------------------------------------------------------- -!BOP -! -! !IROUTINE: open_ - open a multiple files with the same name prefix -! -! !DESCRIPTION: -! -! !INTERFACE: - - subroutine open_(mask,pfix) - use m_stdio, only : stderr,stdout - use m_ioutil, only : luavail,opntext - use m_dropdead, only : die - use m_mpif90, only : MP_comm_WORLD - use m_mpif90, only : MP_comm_rank - use m_mpif90, only : MP_perr - implicit none - integer,optional,intent(in) :: mask - character(len=*),optional,intent(in) :: pfix - -! !EXAMPLES: -! -! Examples of using mpout_MASK or mask: -! -! If the mask has all "1" in every bit, there will be no output -! on every PE, except the PE of rank 0. -! -! If the mask is 3 or "11"b, any PE of rank with any "dirty" bit -! in its rank value will not have output. -! -! !REVISION HISTORY: -! 25Feb98 - Jing Guo - initial prototype/prolog/code -!EOP -!_______________________________________________________________________ - character(len=*),parameter :: myname_=myname//'::open_' - integer :: lu - character(len=4) :: sfix - integer :: irank - integer :: ier - integer :: umask - - ! Set the filename prefix - - upfix=def_pfix - if(present(pfix)) upfix=pfix - - ! Set the mask of the PEs with mpout - - umask=mpout_MASK - if(present(mask)) umask=mask - - ! If a check is not in place, sent the outputs to stdout - - mpout=stdout - mpout_set=.false. - - call MP_comm_rank(MP_comm_world,irank,ier) - if(ier /= 0) then - call MP_perr(myname_,'MP_comm_rank()',ier) - call die(myname_) - endif - - if(iand(irank,umask) == 0) then - - lu=luavail() - if(lu > 0) mpout=lu - - write(sfix,'(a,z3.3)') '.',irank - call opntext(mpout,trim(upfix)//sfix,'unknown',ier) - if(ier /= 0) then - write(stderr,'(4a,i4)') myname_, & - ': opntext("',trim(upfix)//sfix,'") error, ier =',ier - call die(myname_) - endif - - mpout_set=.true. - - isec=0 - write(mpout,'(a,z8.8,2a)') '.BEGIN. ',isec,' ',trim(upfix) - endif - -end subroutine open_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!----------------------------------------------------------------------- -!BOP -! -! !IROUTINE: close_ - close the unit opened by open_ -! -! !DESCRIPTION: -! -! !INTERFACE: - - subroutine close_() - use m_stdio, only : stderr - use m_ioutil, only : clstext, luflush - use m_dropdead, only : die - implicit none - -! !REVISION HISTORY: -! 25Feb98 - Jing Guo - initial prototype/prolog/code -!EOP -!_______________________________________________________________________ - character(len=*),parameter :: myname_=myname//'::close_' - integer :: ier - - if(mpout_set) then - call luflush(mpout) - - isec=isec+1 - write(mpout,'(a,z8.8,2a)') '.END. ',isec,' ',trim(upfix) - endfile(mpout) - - call clstext(mpout,ier) - if(ier /= 0) then - write(stderr,'(2a,i3.3,a,i4)') myname_, & - ': clstext("',mpout,'") error, ier =',ier - call die(myname_) - endif - mpout=stdout - mpout_set=.false. - endif - - isec=-1 - -end subroutine close_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!----------------------------------------------------------------------- -!BOP -! -! !IROUTINE: sync_ - write a mark for posible later file merging -! -! !DESCRIPTION: -! -! !INTERFACE: - - subroutine sync_(tag) - use m_stdio, only : stderr - use m_dropdead, only : die - implicit none - character(len=*),intent(in) :: tag - -! !REVISION HISTORY: -! 25Feb98 - Jing Guo - initial prototype/prolog/code -! -! !DESIGN ISSUES: -! \begin{itemize} -! -! \item Should the variable \verb"tag" be implemented as an optional -! argument? Because the current implementation does not require -! actual synchronization between all threads of the multiple -! output streams, forcing the user to supply a unique \verb"tag" -! would make the final multi-stream merging verifiable. However, -! since the \verb"tag"s have not been forced to be unique, the -! synchronization operations are still symbolic. -! -! \{itemize} -!EOP -!_______________________________________________________________________ - character(len=*),parameter :: myname_=myname//'::sync_' - - if(mpout_set) then - isec=isec+1 - write(mpout,'(a,z8.8,2a)') '.SYNC. ',isec,' ',trim(tag) - endif - -end subroutine sync_ -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!----------------------------------------------------------------------- -!BOP -! -! !IROUTINE: flush_ - flush the multiple output streams -! -! !DESCRIPTION: -! -! !INTERFACE: - - subroutine flush_() - use m_stdio, only : stderr - use m_ioutil, only : luflush - use m_dropdead, only : die - implicit none - -! !REVISION HISTORY: -! 27Feb98 - Jing Guo - initial prototype/prolog/code -!EOP -!_______________________________________________________________________ - character(len=*),parameter :: myname_=myname//'::flush_' - - if(mpout_set) call luflush(mpout) - -end subroutine flush_ -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: ison_ - decide if the current PE has a defined mpout -! -! !DESCRIPTION: -! -! It needs to be checked to avoid undesired output. -! -! !INTERFACE: - - function ison_() - implicit none - logical :: ison_ - -! !REVISION HISTORY: -! 14Sep99 - Jing Guo -! - initial prototype/prolog/code -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::ison_' - - ison_=mpout_set - -end function ison_ -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! ANL/MCS Mathematics and Computer Science Division ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: log1_ - write a message to mpout -! -! !DESCRIPTION: -! -! !INTERFACE: - - subroutine log1_(message) - implicit none - character(len=*),intent(in) :: message - -! !REVISION HISTORY: -! 07Jan02 - R. Jacob (jacob@mcs.anl.gov) -! - based on log2_. -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::log1_' - - if(mpout_set) write(mpout,'(3a)') message - -end subroutine log1_ -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: log2_ - write a message to mpout with a where -! -! !DESCRIPTION: -! -! !INTERFACE: - - subroutine log2_(where,message) - implicit none - character(len=*),intent(in) :: where - character(len=*),intent(in) :: message - -! !REVISION HISTORY: -! 14Sep99 - Jing Guo -! - initial prototype/prolog/code -! 07Jan02 - R. Jacob (jacob@mcs.anl.gov) -! - change name to log2_ -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::log2_' - - if(mpout_set) write(mpout,'(3a)') where,': ',message - -end subroutine log2_ -end module m_mpout -!. diff --git a/cesm/models/utils/mct/mpeu/m_rankMerge.F90 b/cesm/models/utils/mct/mpeu/m_rankMerge.F90 deleted file mode 100644 index 951d322..0000000 --- a/cesm/models/utils/mct/mpeu/m_rankMerge.F90 +++ /dev/null @@ -1,620 +0,0 @@ -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!----------------------------------------------------------------------- -! CVS $Id$ -! CVS $Name$ -!BOP ------------------------------------------------------------------- -! -! !MODULE: m_rankMerge - A merging tool through ranking -! -! !DESCRIPTION: -! -! !INTERFACE: - - module m_rankMerge - implicit none - private ! except - - public :: rankSet ! set inital ranks - public :: rankMerge ! merge two ranks - public :: IndexedRankMerge ! index-merge two array segments - - interface rankSet; module procedure set_; end interface - - interface rankMerge; module procedure & - imerge_, & ! rank-merging two integer arrays - rmerge_, & ! rank-merging two real arrays - dmerge_, & ! rank-merging two dble arrays - uniq_ ! merging to rank arrays - end interface - - interface IndexedRankMerge; module procedure & - iindexmerge_, & ! merging two index arrays of integers - rindexmerge_, & ! merging two index arrays of reals - dindexmerge_ ! merging two index arrays of dbles - end interface - -! !REVISION HISTORY: -! 13Mar00 - Jing Guo -! - initial prototype/prolog/code -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname='MCT(MPEU)::m_rankMerge' - -contains -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: set_ - set initial ranking -! -! !DESCRIPTION: -! -! !INTERFACE: - - subroutine set_(rank) - implicit none - integer,dimension(:),intent(out) :: rank - -! !REVISION HISTORY: -! 13Mar00 - Jing Guo -! - initial prototype/prolog/code -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::set_' - integer :: i - - do i=1,size(rank) - rank(i)=0 - end do - -end subroutine set_ -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: imerge_ - merge two sorted integer arrays by ranking -! -! !DESCRIPTION: -! -! !INTERFACE: - - subroutine imerge_(value_i,value_j,krank_i,krank_j,descend) - implicit none - - integer,dimension(:),intent(in) :: value_j ! value of j-vec - integer,dimension(:),intent(in) :: value_i ! value of i-vec - - integer,dimension(:),intent(inout) :: krank_i ! rank of i-vec - integer,dimension(:),intent(inout) :: krank_j ! rank of j-vec - - logical,optional,intent(in) :: descend - -! !REVISION HISTORY: -! 13Mar00 - Jing Guo -! - initial prototype/prolog/code -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::imerge_' - - integer :: ni,nj - logical :: descend_ - logical :: geti - integer :: value_sv,value - integer :: krank - integer :: i,j - - descend_=.false. - if(present(descend)) descend_=descend - - ni=size(krank_i) - nj=size(krank_j) - - i=1 - j=1 - krank=0 ! a preset rank value - value_sv=0 - - do - geti=j>nj - if(geti) then ! .eqv. j>nj - if(i>ni) exit ! i>ni - value = value_i(i) - else ! .eqv. j<=nj - geti = i<=ni - if(geti) then ! .eqv. i<=ni - value = value_i(i) - geti = krank_i(i) <= krank_j(j) - if(krank_i(i)==krank_j(j)) then - geti = value_i(i)<=value_j(j) - if(descend_) geti = value_i(i)>=value_j(j) - endif - endif - if(.not.geti) value = value_j(j) - endif - - if(krank==0 .or. value /= value_sv) then - krank=krank+1 ! the next rank value - value_sv=value - endif - - if(geti) then - krank_i(i)=krank - i=i+1 - else - krank_j(j)=krank - j=j+1 - endif - end do - -end subroutine imerge_ -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: rmerge_ - merge two sorted real arrays by ranking -! -! !DESCRIPTION: -! -! !INTERFACE: - - subroutine rmerge_(value_i,value_j,krank_i,krank_j,descend) - use m_realkinds, only : SP - implicit none - - real(SP),dimension(:),intent(in) :: value_i ! value of i-vec - real(SP),dimension(:),intent(in) :: value_j ! value of j-vec - - integer,dimension(:),intent(inout) :: krank_i ! rank of i-vec - integer,dimension(:),intent(inout) :: krank_j ! rank of j-vec - - logical,optional,intent(in) :: descend - -! !REVISION HISTORY: -! 13Mar00 - Jing Guo -! - initial prototype/prolog/code -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::rmerge_' - - integer :: ni,nj - logical :: descend_ - logical :: geti - real(SP) :: value_sv,value - integer :: krank - integer :: i,j - - descend_=.false. - if(present(descend)) descend_=descend - - ni=size(krank_i) - nj=size(krank_j) - - i=1 - j=1 - krank=0 ! a preset rank value - value_sv=0 - - do - geti=j>nj - if(geti) then ! .eqv. j>nj - if(i>ni) exit ! i>ni - value = value_i(i) - else ! .eqv. j<=nj - geti = i<=ni - if(geti) then ! .eqv. i<=ni - value = value_i(i) - geti = krank_i(i) <= krank_j(j) - if(krank_i(i)==krank_j(j)) then - geti = value_i(i)<=value_j(j) - if(descend_) geti = value_i(i)>=value_j(j) - endif - endif - if(.not.geti) value = value_j(j) - endif - - if(krank==0 .or. value /= value_sv) then - krank=krank+1 ! the next rank value - value_sv=value - endif - - if(geti) then - krank_i(i)=krank - i=i+1 - else - krank_j(j)=krank - j=j+1 - endif - end do - -end subroutine rmerge_ -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: dmerge_ - merge two sorted real arrays by ranking -! -! !DESCRIPTION: -! -! !INTERFACE: - - subroutine dmerge_(value_i,value_j,krank_i,krank_j,descend) - use m_realkinds, only : DP - implicit none - - real(DP),dimension(:),intent(in) :: value_i ! value of i-vec - real(DP),dimension(:),intent(in) :: value_j ! value of j-vec - - integer,dimension(:),intent(inout) :: krank_i ! rank of i-vec - integer,dimension(:),intent(inout) :: krank_j ! rank of j-vec - - logical,optional,intent(in) :: descend - -! !REVISION HISTORY: -! 13Mar00 - Jing Guo -! - initial prototype/prolog/code -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::dmerge_' - - integer :: ni,nj - logical :: descend_ - logical :: geti - real(DP):: value_sv,value - integer :: krank - integer :: i,j - - descend_=.false. - if(present(descend)) descend_=descend - - ni=size(krank_i) - nj=size(krank_j) - - i=1 - j=1 - krank=0 ! a preset rank value - value_sv=0 - - do - geti=j>nj - if(geti) then ! .eqv. j>nj - if(i>ni) exit ! i>ni - value = value_i(i) - else ! .eqv. j<=nj - geti = i<=ni - if(geti) then ! .eqv. i<=ni - value = value_i(i) - geti = krank_i(i) <= krank_j(j) - if(krank_i(i)==krank_j(j)) then - geti = value_i(i)<=value_j(j) - if(descend_) geti = value_i(i)>=value_j(j) - endif - endif - if(.not.geti) value = value_j(j) - endif - - if(krank==0 .or. value /= value_sv) then - krank=krank+1 ! the next rank value - value_sv=value - endif - - if(geti) then - krank_i(i)=krank - i=i+1 - else - krank_j(j)=krank - j=j+1 - endif - end do - -end subroutine dmerge_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: iindexmerge_ - merge two sorted integer arrays by ranking -! -! !DESCRIPTION: -! -! !INTERFACE: - - subroutine iindexmerge_(indx_i,indx_j,value,krank_i,krank_j,descend) - implicit none - - integer,dimension(:),intent(in) :: indx_i ! of the i-vec - integer,dimension(:),intent(in) :: indx_j ! of the j-vec - integer,dimension(:),intent(in) :: value ! of the full - - integer,dimension(:),intent(inout) :: krank_i ! rank of i-vec - integer,dimension(:),intent(inout) :: krank_j ! rank of j-vec - - logical,optional,intent(in) :: descend - -! !REVISION HISTORY: -! 13Mar00 - Jing Guo -! - initial prototype/prolog/code -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::iindexmerge_' - - integer :: ni,nj - logical :: descend_ - logical :: geti - integer :: value_sv,value_ - integer :: krank - integer :: i,j,li,lj - - descend_=.false. - if(present(descend)) descend_=descend - - ni=size(krank_i) - nj=size(krank_j) - - i=1 - j=1 - krank=0 ! a preset rank value - value_sv=0 - - do - geti=j>nj - if(geti) then ! .eqv. j>nj - if(i>ni) exit ! i>ni - li=indx_i(i) - value_ = value(li) - else ! .eqv. j<=nj - lj=indx_j(j) - geti = i<=ni - if(geti) then ! .eqv. i<=ni - li=indx_i(i) - value_ = value(li) - geti = krank_i(i) <= krank_j(j) - if(krank_i(i)==krank_j(j)) then - geti = value(li)<=value(lj) - if(descend_) geti = value(li)>=value(lj) - endif - endif - if(.not.geti) value_ = value(lj) - endif - - if(krank==0 .or. value_ /= value_sv) then - krank=krank+1 ! the next rank value - value_sv=value_ - endif - - if(geti) then - krank_i(i)=krank - i=i+1 - else - krank_j(j)=krank - j=j+1 - endif - end do - -end subroutine iindexmerge_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: rindexmerge_ - merge two sorted real arrays by ranking -! -! !DESCRIPTION: -! -! !INTERFACE: - - subroutine rindexmerge_(indx_i,indx_j,value,krank_i,krank_j,descend) - use m_realkinds,only : SP - implicit none - - integer,dimension(:),intent(in) :: indx_i ! of the i-vec - integer,dimension(:),intent(in) :: indx_j ! of the j-vec - real(SP),dimension(:),intent(in) :: value ! of the full - - integer,dimension(:),intent(inout) :: krank_i ! rank of i-vec - integer,dimension(:),intent(inout) :: krank_j ! rank of j-vec - - logical,optional,intent(in) :: descend - -! !REVISION HISTORY: -! 13Mar00 - Jing Guo -! - initial prototype/prolog/code -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::rindexmerge_' - - integer :: ni,nj - logical :: descend_ - logical :: geti - real(SP):: value_sv,value_ - integer :: krank - integer :: i,j,li,lj - - descend_=.false. - if(present(descend)) descend_=descend - - ni=size(krank_i) - nj=size(krank_j) - - i=1 - j=1 - krank=0 ! a preset rank value - value_sv=0 - - do - geti=j>nj - if(geti) then ! .eqv. j>nj - if(i>ni) exit ! i>ni - li=indx_i(i) - value_ = value(li) - else ! .eqv. j<=nj - lj=indx_j(j) - geti = i<=ni - if(geti) then ! .eqv. i<=ni - li=indx_i(i) - value_ = value(li) - geti = krank_i(i) <= krank_j(j) - if(krank_i(i)==krank_j(j)) then - geti = value(li)<=value(lj) - if(descend_) geti = value(li)>=value(lj) - endif - endif - if(.not.geti) value_ = value(lj) - endif - - if(krank==0 .or. value_ /= value_sv) then - krank=krank+1 ! the next rank value - value_sv=value_ - endif - - if(geti) then - krank_i(i)=krank - i=i+1 - else - krank_j(j)=krank - j=j+1 - endif - end do - -end subroutine rindexmerge_ -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: dindexmerge_ - merge two sorted real arrays by ranking -! -! !DESCRIPTION: -! -! !INTERFACE: - - subroutine dindexmerge_(indx_i,indx_j,value,krank_i,krank_j,descend) - use m_realkinds,only : DP - implicit none - - integer,dimension(:),intent(in) :: indx_i ! of the i-vec - integer,dimension(:),intent(in) :: indx_j ! of the j-vec - real(DP),dimension(:),intent(in) :: value ! of the full - - integer,dimension(:),intent(inout) :: krank_i ! rank of i-vec - integer,dimension(:),intent(inout) :: krank_j ! rank of j-vec - - logical,optional,intent(in) :: descend - -! !REVISION HISTORY: -! 13Mar00 - Jing Guo -! - initial prototype/prolog/code -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::dindexmerge_' - - integer :: ni,nj - logical :: descend_ - logical :: geti - real(DP):: value_sv,value_ - integer :: krank - integer :: i,j,li,lj - - descend_=.false. - if(present(descend)) descend_=descend - - ni=size(krank_i) - nj=size(krank_j) - - i=1 - j=1 - krank=0 ! a preset rank value - value_sv=0 - - do - geti=j>nj - if(geti) then ! .eqv. j>nj - if(i>ni) exit ! i>ni - li=indx_i(i) - value_ = value(li) - else ! .eqv. j<=nj - lj=indx_j(j) - geti = i<=ni - if(geti) then ! .eqv. i<=ni - li=indx_i(i) - value_ = value(li) - geti = krank_i(i) <= krank_j(j) - if(krank_i(i)==krank_j(j)) then - geti = value(li)<=value(lj) - if(descend_) geti = value(li)>=value(lj) - endif - endif - if(.not.geti) value_ = value(lj) - endif - - if(krank==0 .or. value_ /= value_sv) then - krank=krank+1 ! the next rank value - value_sv=value_ - endif - - if(geti) then - krank_i(i)=krank - i=i+1 - else - krank_j(j)=krank - j=j+1 - endif - end do - -end subroutine dindexmerge_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: uniq_ - merge two rank arrays with unique rank values -! -! !DESCRIPTION: -! -! !INTERFACE: - - subroutine uniq_(krank_i,krank_j) - implicit none - integer,dimension(:),intent(inout) :: krank_i ! rank of i-vec - integer,dimension(:),intent(inout) :: krank_j ! rank of j-vec - -! !REVISION HISTORY: -! 13Mar00 - Jing Guo -! - initial prototype/prolog/code -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::uniq_' - - integer :: ni,nj - integer :: i,j - integer :: krank - logical :: geti - - ni=size(krank_i) - nj=size(krank_j) - - i=1 - j=1 - krank=0 - do - geti=j>nj - if(geti) then ! .eqv. j>nj - if(i>ni) exit ! i>ni - else ! .eqv. j<=nj - geti = i<=ni - if(geti) geti = krank_i(i) <= krank_j(j) ! if(i<=ni) .. - endif - - krank=krank+1 ! the next rank value - - if(geti) then - krank_i(i)=krank - i=i+1 - else - krank_j(j)=krank - j=j+1 - endif - end do - -end subroutine uniq_ - -end module m_rankMerge diff --git a/cesm/models/utils/mct/mpeu/m_realkinds.F90 b/cesm/models/utils/mct/mpeu/m_realkinds.F90 deleted file mode 100644 index 08e3ba0..0000000 --- a/cesm/models/utils/mct/mpeu/m_realkinds.F90 +++ /dev/null @@ -1,52 +0,0 @@ -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!----------------------------------------------------------------------- -! CVS $Id$ -! CVS $Name$ -!----------------------------------------------------------------------- -!BOP -! -! !MODULE: m_realkinds - real KIND definitions -! -! !DESCRIPTION: -! -! !INTERFACE: - - module m_realkinds - implicit none - private ! except - - public :: kind_r4 ! real*4 - public :: kind_r8 ! real*8 - public :: kind_r ! default real - public :: SP ! default REAL - public :: DP ! default DOUBLE_PRECISION - public :: FP ! general floating point precision - - real*4,parameter :: mpeuR4=1. - real*8,parameter :: mpeuR8=1. - real, parameter :: mpeuR =1. - -#ifdef SELECTEDREALKIND - integer,parameter :: SP = selected_real_kind( 6) ! 32-bit real, on most platforms - integer,parameter :: DP = selected_real_kind(12) ! 64-bit real, on most platforms -#else - integer,parameter :: SP = kind(1. ) - integer,parameter :: DP = kind(1.D0) -#endif - -! Set the current default floating point precision - integer,parameter :: FP = DP - - integer,parameter :: kind_r4=kind(mpeuR4) - integer,parameter :: kind_r8=kind(mpeuR8) - integer,parameter :: kind_r =kind(mpeuR ) - -! !REVISION HISTORY: -! 19Feb98 - Jing Guo - initial prototype/prolog/code -! 23Jan03 - R. Jacob - add FP -!EOP -!_______________________________________________________________________ - character(len=*),parameter :: myname='MCT(MPEU)::m_realkinds' - -end module m_realkinds diff --git a/cesm/models/utils/mct/mpeu/m_stdio.F90 b/cesm/models/utils/mct/mpeu/m_stdio.F90 deleted file mode 100644 index 444a417..0000000 --- a/cesm/models/utils/mct/mpeu/m_stdio.F90 +++ /dev/null @@ -1,53 +0,0 @@ -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!----------------------------------------------------------------------- -! CVS $Id$ -! CVS $Name$ -!----------------------------------------------------------------------- -!BOP -! -! !MODULE: m_stdio - a F90 module defines std. I/O parameters -! -! !DESCRIPTION: -! Define system dependent I/O parameters. -! -! !INTERFACE: - - module m_stdio - implicit none - private - - public :: stdin ! a unit linked to UNIX stdin - public :: stdout ! a unit linked to UNIX stdout - public :: stderr ! a unit linked to UNIX stderr - - public :: LEN_FILENAME - -! !REVISION HISTORY: -! 10oct96 - Jing G. - Defined -! 25Jul02 - J. Larson - Changed cpp define token HP-UX to -! HP_UX for compatibility with Fujitsu -! cpp. -!EOP -!_______________________________________________________________________ - -! Defines standar i/o units. - - integer, parameter :: stdin = 5 - integer, parameter :: stdout = 6 - -#ifdef sysHP_UX - ! Special setting for HP-UX - - integer, parameter :: stderr = 7 -#else - ! Generic setting for UNIX other than HP-UX - - integer, parameter :: stderr = 0 -#endif - - integer, parameter :: LEN_FILENAME = 128 - -!----------------------------------------------------------------------- -end module m_stdio -!. diff --git a/cesm/models/utils/mct/mpeu/m_zeit.F90 b/cesm/models/utils/mct/mpeu/m_zeit.F90 deleted file mode 100644 index 06ca750..0000000 --- a/cesm/models/utils/mct/mpeu/m_zeit.F90 +++ /dev/null @@ -1,1008 +0,0 @@ -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!----------------------------------------------------------------------- -! CVS $Id$ -! CVS $Name$ -!----------------------------------------------------------------------- -!BOP -! -! !MODULE: m_zeit - a multi-timer of process times and wall-clock times -! -! !DESCRIPTION: -! -! !INTERFACE: - - module m_zeit - implicit none - private ! except - - public :: zeit_ci ! push a new name to the timer - public :: zeit_co ! pop the current name on the timer - public :: zeit_flush ! print per PE timing - public :: zeit_allflush ! print all PE timing - public :: zeit_reset ! reset the timers to its initial state - - ! Flags of all printable timers - - public :: MWTIME ! MPI_Wtime() wall-clock time - public :: XWTIME ! times() wall-clock time - public :: PUTIME ! times() process user time - public :: PSTIME ! times() process system time - public :: CUTIME ! times() user time of all child-processes - public :: CSTIME ! times() system time of all child-processes - public :: ALLTIME ! all of above - public :: UWRATE ! (putime+cutime)/xwtime - - interface zeit_ci; module procedure ci_; end interface - interface zeit_co; module procedure co_; end interface - interface zeit_flush; module procedure flush_; end interface - interface zeit_allflush; module procedure allflush_; end interface - interface zeit_reset; module procedure reset_; end interface - -! !REVISION HISTORY: -! -! 22Jan01 - Jay Larson - Minor correction in -! write statements in the routines sp_balances_() and -! mp_balances_(): replaced x (single-space) descriptor -! with 1x. This is apparently strict adherance to the -! f90 standard (though the first of many, many compilers -! where it has arisen). This was for the SunOS platform. -! 05Mar98 - Jing Guo - -! . rewritten for possible MPI applications, with -! additional functionalities and new performance -! analysis information. -! . Interface names have been redefined to ensure all -! use cases to be verified. -! . removed the type(pzeit) data structure, therefore, -! limited to single _instance_ applications. -! . added additional data components for more detailed -! timing analysis. -! . used times() for the XPG4 standard conforming -! timing functions. -! . used MPI_Wtime() for the MPI standard conforming -! high-resolution timing functions. -! -! 20Feb97 - Jing Guo - -! . rewritten in Fortran 90 as the first modular -! version, with a type(pzeit) data structure. -! -! 10may96 - Jing G. - Add _TZEITS macro for the testing code -! 09may96 - Jing G. - Changed output format also modifed -! comments -! 11Oct95 - Jing G. - Removed earlier way of letting clock -! timing (clkknt and clktot) to be no less -! then the CPU timing, following a -! suggestion by James Abeles from Cray. -! This way, users may use the routings to -! timing multitasking speedup as well. -! 12May95 - Jing G. - Merged zeitCRAY.f and zeitIRIS.f. -! Before - ? - See zeitCRAY.f and zeitIRIS.f for more -! information. Authors of those files are -! not known to me. -! -! !DESIGN ISSUES: -! -! 05Mar98 - Jing Guo - -! . Removing the data structure may be consider as a -! limitation to future changes to multiple _instance_ -! applications. However, it is unlikely there will be -! any neccessary multi-_intance_ application soon, if -! ever for this module. -! . Without an additional layer with the derived -! datatype, one may worry less the tricky performance -! issues associated with ci_/co_. -! . Performance issue with the flush_() calls are not -! considered. -! -! 20Feb97 - Jing Guo - -! . Currently a single threaded module. May be easily -! extended to multi-threaded module by adding the name -! of an instance of the class to the argument list. It -! requires some but very limited interface extensions. -! Right now, the backward compatibility is the main -! issue. -! -! 10may96 - Jing Guo - -! -! + This zeit subroutine collection replaces original zeit files -! used in PSAS on both systems, UNICOS and IRIX, with following -! changes: -! -! + Removed the some bugs in zeitCRAY.f that overite the -! first user defined name entry in a special situation -! (but not being able to correct in zeitCRAY.f). -! -! + Unified both zeitCRAY.f and zeitIRIS.f in to one file -! (this file), that handles system dependency in only -! one subroutine syszeit_() with a couple of lines of -! differences. -! -! + Added system CPU time counts for system supporting -! the function. -! -! + Added some error checking and reporting functions. -! -! + According to zeitCRAY.f, "zeit" is "time" in Germen. -! The name is used through the code as another name for -! "time". -! -! + This version does not work for parallelized processes. -! -! + Elapsed time records since the first call are used. Although -! it may loose accuracy when the values of the time records -! become large, it will keep the total time values conserved. -! -! + The accuracy of the elapsed times at a IEEE real*4 accuracy -! (ffrac = 2^23 ~= 1.19e-7) should be no worse than +- 1 second -! in 97 days, if only the numerical accuracy is considered. -! -! + The precision of "wall clock" time returned by syszeit_() is -! only required to be reliable upto seconds. -! -! + The wall clock time for individual name tag (clkknt) is -! accumulated by adding the differences between two integer -! values, iclk and iclksv. Care must be taken to compute the -! differences of iclk and iclksv first. That is, doing -! -! clkknt()=clkknt() + (iclk-iclksv) -! -! not -! -! clkknt()=clkknt() + iclk-iclksv -! -! The latter statement may ignore the difference between the two -! integer values (iclk and iclksv). -! -!EOP -!_______________________________________________________________________ - character(len=*),parameter :: myname='MCT(MPEU)::m_zeit' - - integer,parameter :: MWTIME = 1 - integer,parameter :: XWTIME = 2 - integer,parameter :: PUTIME = 4 - integer,parameter :: PSTIME = 8 - integer,parameter :: CUTIME = 16 - integer,parameter :: CSTIME = 32 - integer,parameter :: ALLTIME = MWTIME + XWTIME + PUTIME + & - PSTIME + CUTIME + CSTIME - integer,parameter :: UWRATE = 64 - - integer,parameter :: MASKS(0:5) = & - (/ MWTIME,XWTIME,PUTIME,PSTIME,CUTIME,CSTIME /) - - character(len=*),parameter :: ZEIT='.zeit.' - character(len=8),parameter :: HEADER(0:5) = & - (/ '[MWTIME]','[XWTIME]','[PUTIME]', & - '[PSTIME]','[CUTIME]','[CSTIME]' /) - character(len=8),parameter :: UWRHDR = '[UWRATE]' - - integer,parameter :: MXN= 250 ! the size of a name list -! integer,parameter :: NSZ= 32 ! the size of a name -! LPC jun/6/2000 - integer,parameter :: NSZ= 36 ! the size of a name - integer,parameter :: MXS= 64 ! the depth of the timer stack - - integer,save :: nreset=0 - logical,save :: started=.false. - logical,save :: balanced=.false. - - character(len=NSZ), & - save :: ciname=' ' - character(len=NSZ), & - save :: coname=' ' - - integer,save :: mxdep=0 ! the maximum ndep value recorded - integer,save :: ndep=-1 ! depth, number of net ci_() - integer,save :: lnk_n(0:MXS) ! name index of the depth - - integer,save :: nname=-1 ! number of accounts - character(len=NSZ), & - save,dimension(0:MXN) :: name_l ! the accounts - integer,save,dimension(0:MXN) :: knt_l ! counts of ci_() calls - integer,save,dimension(0:MXN) :: level_l ! remaining ci_() counts - - real*8,save,dimension(0:5) :: zts_sv ! the last timings - - real*8,save,dimension(0:5,0:MXN) :: zts_l ! credited to a name - real*8,save,dimension(0:5,0:MXN) :: szts_l ! all under the name - real*8,save,dimension(0:5,0:MXN) :: szts_sv ! the last ci_ timings - -!======================================================================= -contains - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!----------------------------------------------------------------------- -!BOP -! -! !IROUTINE: ci_ - push an entry into the timer -! -! !DESCRIPTION: -! -! !INTERFACE: - - subroutine ci_(name) - use m_stdio, only : stderr - use m_die, only : die - use m_mpif90,only : MP_wtime - implicit none - character(len=*), intent(in) :: name - -! !REVISION HISTORY: -! 05Mar98 - Jing Guo - initial prototype/prolog/code -!EOP -!_______________________________________________________________________ - character(len=*),parameter :: myname_=myname//'::ci_' - - ! Local variables - - real*8,dimension(0:5) :: zts - integer :: lname,iname - integer :: i - - ! Encountered a limitation. Programming is required - - if(ndep >= MXS) then - write(stderr,'(2a,i4)') myname_, & - ': stack overflow with "'//trim(name)//'", ndep =',ndep - call die(myname_) - endif - - !-------------------------------------------------------- - ! Initialize the stack if it is called the first time. - - if(.not.started) call reset_() - - ! Get the current _zeits_ - - call get_zeits(zts(1)) - zts(0)=MP_wtime() - - !-------------------------------------------------------- - ! Charge the ticks since the last co_() to the current level - - lname=lnk_n(ndep) - - do i=0,5 - zts_l(i,lname)=zts_l(i,lname) + zts(i)-zts_sv(i) - end do - - do i=0,5 - zts_sv(i)=zts(i) ! update the record - end do - - !-------------------------------------------------------- - ! Is the name already in the list? Case sensitive and - ! space maybe sensitive if they are inbeded between non- - ! space characters. - ! - ! If the name is already in the list, the index of the - ! table entry is given. - ! - ! If the name is not in the list, a new entry will be added - ! to the list, if 1) there is room, and 2) - - iname=lookup_(name) - - !-------------------------------------------------------- - ! push up the stack level - - ndep=ndep+1 - if(mxdep <= ndep) mxdep=ndep - - lnk_n(ndep)=iname - knt_l(iname)=knt_l(iname)+1 - - ! Recording the check-in time, if there is no remaining - ! levels for the same name. This is used to handle - ! recursive ci_() calls for the same name. - - if(level_l(iname) == 0) then - do i=0,5 - szts_sv(i,iname)=zts_sv(i) - end do - endif - - ! open a level - - level_l(iname)=level_l(iname)+1 - -end subroutine ci_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!----------------------------------------------------------------------- -!BOP -! -! !IROUTINE: co_ - pop the current level -! -! !DESCRIPTION: -! -! !INTERFACE: - - subroutine co_(name,tms) - use m_stdio, only : stderr - use m_die, only : die - use m_mpif90,only : MP_wtime - implicit none - character(len=*), intent(in) :: name ! account name - real*8,optional,dimension(0:5,0:1),intent(out) :: tms ! timings - -! The returned variable tms(0:5,0:1) contains two sets of timing -! information. tms(0:5,0) is the NET timing data charged under the -! account name only, and tms(0:5,1) is the SCOPE timing data since -! the last ci() with the same account name and at the out most level. -! -! !REVISION HISTORY: -! 11Oct99 - J.W. Larson - explicit definition of -! tms as real*8 -! 05Mar98 - Jing Guo - initial prototype/prolog/code -!EOP -!_______________________________________________________________________ - character(len=*),parameter :: myname_=myname//'::co_' - - real*8 :: tms0,tms1 - real*8,dimension(0:5) :: zts - integer :: lname - integer :: i - - ! Encountered a limitation. Programming is required - - if(ndep <= 0) then - write(stderr,'(2a,i4)') myname_, & - ': stack underflow with "'//trim(name)//'", ndep =',ndep - call die(myname_) - endif - - !-------------------------------------------------------- - ! Initialize the stack if it is called the first time. - - if(.not.started) call reset_() - - ! Get the current _zeits_ - - call get_zeits(zts(1)) - zts(0)=MP_wtime() - - ! need special handling if ndep is too large or too small. - - lname=lnk_n(ndep) - level_l(lname)=level_l(lname)-1 ! close a level - - do i=0,5 - tms0=zts(i)- zts_sv(i) ! NET by the _account_ - tms1=zts(i)-szts_sv(i,lname) ! within its SCOPE - - zts_l(i,lname)= zts_l(i,lname) + tms0 - - if(level_l(lname) == 0) & - szts_l(i,lname)=szts_l(i,lname) + tms1 - - zts_sv(i)=zts(i) - - if(present(tms)) then - - ! Return the timings of the current call segment - ! - ! tms(:,0) is for the NET timing data, that have been charged - ! to this account. - ! - ! tms(:,1) is for the SCOPE timing data since the ci() of the - ! same account name at the out most level. - ! - - tms(i,0)=tms0 - tms(i,1)=tms1 ! only the sub-segments - endif - end do - - ! Record the unbalanced ci/co. Name .void. is supplied for - ! backward compartible calls of pzeitend() - - if(name /= '.void.'.and.balanced) then - balanced = lname == MXN .or. name == name_l(lname) - if(.not.balanced) then - ciname=name_l(lname) - coname=name - endif - endif - - ! pop (need special handling of ndep too large or too small. - - ndep=ndep-1 - -end subroutine co_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!----------------------------------------------------------------------- -!BOP -! -! !IROUTINE: reset_ - reset module m_zeit to an initial state -! -! !DESCRIPTION: -! -! !INTERFACE: - - subroutine reset_() - use m_mpif90,only : MP_wtime - implicit none - -! !REVISION HISTORY: -! 04Mar98 - Jing Guo - initial prototype/prolog/code -!EOP -!_______________________________________________________________________ - character(len=*),parameter :: myname_=myname//'::reset_' - integer :: i - - ! keep tracking the number of reset_() calls - - nreset=nreset+1 - started=.true. - balanced=.true. - - ! Start timing - - call get_zeits(zts_sv(1)) - zts_sv(0)=MP_wtime() - - ! Sign in the module name for the overheads (.eqv. ci_(ZEIT)) - - nname=0 - name_l(nname)=ZEIT - knt_l(nname)=1 - - ndep =0 - lnk_n(ndep)=nname - - ! Initialize the timers. - - do i=0,5 - zts_l(i,nname)=0. - szts_l(i,nname)=0. - szts_sv(i,nname)=zts_sv(i) - end do - level_l(nname)=1 - -end subroutine reset_ -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!----------------------------------------------------------------------- -!BOP -! -! !IROUTINE: lookup_ search/insert a name -! -! !DESCRIPTION: -! -! !INTERFACE: - - function lookup_(name) - implicit none - character(len=*),intent(in) :: name - integer :: lookup_ - -! !REVISION HISTORY: -! 04Mar98 - Jing Guo - initial prototype/prolog/code -!EOP -!_______________________________________________________________________ - character(len=*),parameter :: myname_=myname//'::lookup_' - - logical :: found - integer :: ith - integer :: i - - ith=-1 - found=.false. - do while(.not.found.and. ith < min(nname,MXN)) - ith=ith+1 - found = name == name_l(ith) - end do - - if(.not.found) then - - found = nname >= MXN ! Can not handle too many accounts? - ith=MXN ! Then use the account for ".foo." - - if(.not.found) then ! Otherwise, add a new account. - nname=nname+1 - ith=nname - - name_l(ith)=name - if(ith==MXN) name_l(ith)='.foo.' - - ! Initialize a new account - - do i=0,5 - zts_l(i,ith)=0. - szts_l(i,ith)=0. - end do - level_l(ith)=0 - - endif - endif - - lookup_=ith - -end function lookup_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!----------------------------------------------------------------------- -!BOP -! -! !IROUTINE: flush_ - print the timing data -! -! !DESCRIPTION: -! -! !INTERFACE: - - subroutine flush_(lu,umask) - use m_stdio, only : stderr - use m_ioutil, only : luflush - use m_die, only : die - use m_mpif90,only : MP_wtime - implicit none - integer,intent(in) :: lu ! logical unit for the output - integer,optional,intent(in) :: umask - -! !REVISION HISTORY: -! 05Mar98 - Jing Guo - initial prototype/prolog/code -!EOP -!_______________________________________________________________________ - character(len=*),parameter :: myname_=myname//'::flush_' - integer :: imask - - real*8,dimension(0:5) :: zts - integer :: i,ier - - ! specify which timer to print - - imask=MWTIME - if(present(umask)) imask=umask - - ! write a - - write(lu,*,iostat=ier) - if(ier /= 0) then - write(stderr,'(2a,i3)') myname_,': can not write(), unit =',lu - call die(myname_) - endif - - if(.not.balanced) write(lu,'(5a)') myname_, & - ': ci/co unbalanced, ',trim(ciname),'/',trim(coname) - - call luflush(lu) - - ! latest times, but not closing on any entry - - call get_zeits(zts(1)) - zts(0)=MP_wtime() - - ! Print selected tables - - do i=0,5 - if(iand(MASKS(i),imask) /= 0) & - call sp_balances_(lu,i,zts(i)) - end do -#ifdef TODO - if(iand(UWRATE,imask) /= 0) call sp_rate_(lu,zts) -#endif - - call luflush(lu) - -end subroutine flush_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!----------------------------------------------------------------------- -!BOP -! -! !IROUTINE: sp_balances_ - print a table of a given timer -! -! !DESCRIPTION: -! -! !INTERFACE: - - subroutine sp_balances_(lu,itm,zti) - implicit none - integer,intent(in) :: lu - integer,intent(in) :: itm - real*8,intent(in) :: zti - -! !REVISION HISTORY: -! 06Mar98 - Jing Guo - initial prototype/prolog/code -! 22Jan01 - Jay Larson - Minor correction in -! A write statement: replaced x (single-space) descriptor -! with 1x. This is apparently strict adherance to the -! f90 standard (though the first of many, many compilers -! where it has arisen). This was for the SunOS platform. -! 24Feb01 - Jay Larson - Extra decimal place in -! timing numbers (some reformatting will be necessary). -!EOP -!_______________________________________________________________________ - character(len=*),parameter :: myname_=myname//'::sp_balances_' - - real*8,parameter :: res=.001 ! (sec) - - integer,parameter :: lnmax=12 - character(len=max(NSZ,lnmax)) :: name - - character(len=1) :: tag - character(len=4) :: num - - integer :: zt_min,zt_sec - integer :: sz_min,sz_sec - integer :: l,i,ln - - real*8 :: sz0 - real*8 :: zt,zt_percent,zt_percall - real*8 :: sz,sz_percent - - ! The total time is given in the ZEIT bin - - sz0=szts_l(itm,0) - if(level_l(0) /= 0) sz0=sz0 + zti - szts_sv(itm,0) - sz0=max(res,sz0) - - write(lu,'(a,t14,a,t21,a,t31,a,t52,a)') & - HEADER(itm), 'counts','period', & - 'NET m:s %', & - 'SCOPE m:s %' - -!23.|....1....|....2....|....3....|....4....|....5....|....6....|....7.. -![MWTIME] counts period NET m:s % SCOPE m:s % -!----------------------------------------------------------------------- -!zeit. ( 3s 3d 3) 333.3 33:33 3.3+ 333.3 33:33 3.3+ -!sub 333 33.3 333.3 33:33 3.3% 333.3 33:33 3.3% - - write(lu,'(80a)') ('-',i=1,72) - do l=0,min(MXN,nname) - - zt= zts_l(itm,l) - sz=szts_l(itm,l) - tag='%' - if(level_l(l) /= 0) then - zt=zt + zti - zts_sv(itm) - sz=sz + zti - szts_sv(itm,l) - tag='+' - endif - - zt_percall=zt/max(1,knt_l(l)) - - zt_percent=100.*zt/sz0 - sz_percent=100.*sz/sz0 - - zt_sec=nint(zt) - zt_min= zt_sec/60 - zt_sec=mod(zt_sec,60) - - sz_sec=nint(sz) - sz_min= sz_sec/60 - sz_sec=mod(sz_sec,60) - - name=name_l(l) - ln=max(len_trim(name),lnmax) - - select case(l) - case(0) - write(num,'(i4)') mxdep -! write(lu,'(2(a,i3),2a,t26,2(1x,f7.1,1x,i4.2,a,i2.2,1x,f5.1,a))')& - write(lu,'(2(a,i3),2a,t26,2(1x,f8.2,1x,i4.2,a,i2.2,1x,f6.2,a))')& - name(1:ln),nreset,'s',ndep,'/',num, & - zt,zt_min,':',zt_sec,zt_percent,tag, & - sz,sz_min,':',sz_sec,sz_percent,tag - -! write(lu,'(2a,3(i3,a),t26,2(x,f7.1,x,i4.2,a,i2.2,x,f5.1,a))')& -! name(1:ln),'(',nreset,'s',ndep,'d',mxdep,')', & - - case default - if(len_trim(name) < lnmax)then -! write(lu,'(a,1x,i5,1x,f6.1,2(1x,f7.1,1x,i4.2,a,i2.2,1x,f5.1,a))') & - write(lu,'(a,1x,i5,1x,f7.2,2(1x,f8.2,1x,i4.2,a,i2.2,1x,f6.2,a))') & - name(1:ln),knt_l(l),zt_percall, & - zt,zt_min,':',zt_sec,zt_percent,tag, & - sz,sz_min,':',sz_sec,sz_percent,tag - else - write(lu,'(a)')name(1:ln) -! write(lu,'(13x,i5,1x,f6.1,2(1x,f7.1,1x,i4.2,a,i2.2,1x,f5.1,a))') & - write(lu,'(13x,i5,1x,f7.2,2(1x,f8.2,1x,i4.2,a,i2.2,1x,f6.2,a))') & - knt_l(l),zt_percall, & - zt,zt_min,':',zt_sec,zt_percent,tag, & - sz,sz_min,':',sz_sec,sz_percent,tag - endif - end select - - end do - write(lu,'(80a)') ('-',i=1,72) - -end subroutine sp_balances_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!----------------------------------------------------------------------- -!BOP -! -! !IROUTINE: allflush_ - print a summary of all PEs. -! -! !DESCRIPTION: -! -! !INTERFACE: - - subroutine allflush_(comm,root,lu,umask) - use m_stdio, only : stderr - use m_ioutil, only : luflush - use m_die, only : die - use m_mpif90,only : MP_wtime,MP_type - use m_mpif90,only : MP_comm_size,MP_comm_rank - use m_SortingTools,only : IndexSet,IndexSort - implicit none - integer,intent(in) :: comm - integer,intent(in) :: root - integer,intent(in) :: lu - integer,optional,intent(in) :: umask - -! !REVISION HISTORY: -! 09Mar98 - Jing Guo - initial prototype/prolog/code -!EOP -!_______________________________________________________________________ - character(len=*),parameter :: myname_=myname//'::allflush_' - integer myID,nPE - integer :: imask - real*8,dimension(0:5) :: zts - real*8,dimension(0:5,0:1,0:MXN) :: ztbf - real*8,dimension(:,:,:,:),allocatable :: ztmp - integer,dimension(0:MXN) :: indx_ - integer :: mnm - - integer :: i,l - integer :: nbf,ier - integer :: mp_Type_ztbf - - mp_Type_ztbf=MP_type(ztbf(0,0,0)) - - imask=MWTIME - if(present(umask)) imask=umask - - if(imask==0) return - - call get_zeits(zts(1)) - zts(0)=MP_wtime() - - ! Update the accounts and prepare for the messages - - mnm=min(MXN,nname) - do l=0,mnm - do i=0,5 - ztbf(i,0,l)= zts_l(i,l) - ztbf(i,1,l)=szts_l(i,l) - end do - - if(level_l(l) /= 0) then - ! Update the current accounts. - do i=0,5 - ztbf(i,0,l)=ztbf(i,0,l) + zts(i) - zts_sv(i ) - ztbf(i,1,l)=ztbf(i,1,l) + zts(i) -szts_sv(i,l) - end do - endif - end do - nbf=size(ztbf(0:5,0:1,0:mnm)) - - call MP_comm_rank(comm,myID,ier) - if(ier /= 0) then - write(stderr,'(2a,i3)') myname_, & - ': MP_comm_rank() error, ier =',ier - call die(myname_) - endif - - ! An urgent hack for now. Need to be fixed later. J.G. - indx_(0)=0 - call IndexSet( nname,indx_(1:mnm)) - call IndexSort(nname,indx_(1:mnm),name_l(1:mnm)) - - if(myID /= root) then - - call MPI_gather((ztbf(0:5,0:1,indx_(0:mnm))),nbf,mp_Type_ztbf, & - ztbf,nbf,mp_Type_ztbf,root,comm,ier ) - if(ier /= 0) then - write(stderr,'(2a,i3)') myname_, & - ': MPI_gather(!root) error, ier =',ier - call die(myname_) - endif - - else - - call MP_comm_size(comm,nPE,ier) - if(ier /= 0) then - write(stderr,'(2a,i3)') myname_, & - ': MP_comm_size() error, ier =',ier - call die(myname_) - endif - - allocate(ztmp(0:5,0:1,0:mnm,0:nPE-1),stat=ier) - if(ier /= 0) then - write(stderr,'(2a,i4)') myname_, & - ': allocate(zts) error, stat =',ier - call die(myname_) - endif - - call MPI_gather((ztbf(0:5,0:1,indx_(0:mnm))),nbf,mp_Type_ztbf, & - ztmp,nbf,mp_Type_ztbf,root,comm,ier ) - if(ier /= 0) then - write(stderr,'(2a,i3)') myname_, & - ': MPI_gather(root) error, ier =',ier - call die(myname_) - endif - - ! write a - - write(lu,*,iostat=ier) - if(ier /= 0) then - write(stderr,'(2a,i3)') myname_,': can not write(), unit =',lu - call die(myname_) - endif - - call luflush(lu) - - do i=0,5 - if(iand(MASKS(i),imask) /= 0) & - call mp_balances_(lu,i,nPE,ztmp,indx_) - end do -#ifdef TODO - if(iand(UWRATE,imask) /= 0) call mp_rate_(lu,nPE,ztmp) -#endif - - deallocate(ztmp,stat=ier) - if(ier /= 0) then - write(stderr,'(2a,i4)') myname_, & - ': deallocate(zts) error, stat =',ier - call die(myname_) - endif - endif - - call luflush(lu) -end subroutine allflush_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! -!----------------------------------------------------------------------- -!BOP -! -! !IROUTINE: mp_balances_ - summarize the timing data of all PEs -! -! !DESCRIPTION: -! -! \newcommand{\tb}{\overline{t}} -! -! \verb"mp_balances_"() summarizes the timing data of all PEs -! with quantified load balancing measures: -! \begin{eqnarray*} -! x &=& \frac{\max(t) - \tb}{N\tb} \times 100\% \\ -! i &=& \frac{\max(t) - \tb}{\max(t)} \times 100\% \\ -! r &=& \frac{1}{N\tb} \sum^{t>\tb}{(t-\tb)} -! \times 100\% -! \end{eqnarray*} -! where -! \begin{center} -! \begin{tabular}{rl} -! $t$: & time by any process element \\ -! $\tb$: & mean time by all process elements \\ -! $x$: & the ma{\bf x}imum percentage load deviation \\ -! $i$: & percentage {\bf i}dle process-time or -! load {\bf i}mbalance \\ -! $r$: & percentage {\bf r}elocatable loads \\ -! $N$: & {\bf n}umber of process elements -! \end{tabular} -! \end{center} -! -! !INTERFACE: - - subroutine mp_balances_(lu,itm,nPE,ztmp,indx) - implicit none - integer,intent(in) :: lu - integer,intent(in) :: itm - integer,intent(in) :: nPE - real*8,dimension(0:,0:,0:,0:),intent(in) :: ztmp - integer,dimension(0:),intent(in) :: indx - -! !REVISION HISTORY: -! 10Mar98 - Jing Guo - initial prototype/prolog/code -! 22Jan01 - Jay Larson - Minor correction in -! A write statement: replaced x (single-space) descriptor -! with 1x. This is apparently strict adherance to the -! f90 standard (though the first of many, many compilers -! where it has arisen). This was for the SunOS platform. -! 25Feb01 - R. Jacob change number of -! decimal places from 1 to 4. -!EOP -!_______________________________________________________________________ - character(len=*),parameter :: myname_=myname//'::mp_balances_' - - real*8,parameter :: res=.001 ! (sec) - - integer,parameter :: lnmax=12 - character(len=max(NSZ,lnmax)) :: name - character(len=4) :: num - - integer :: i,k,l,ln,lx - - ! NET times - integer :: ix_o - real*8 :: zts_o,zta_o,ztm_o,ztr_o - integer :: x_o,i_o,r_o - - ! SCOPE times - integer :: ix_s - real*8 :: zts_s,zta_s,ztm_s,ztr_s - integer :: x_s,i_s,r_s - - write(num,'(i4)') nPE - write(lu,'(3a,t18,a,t58,a)') & - HEADER(itm),'x',adjustl(num), & - 'NET avg max imx x% r% i%', & - 'SCP avg max imx x% r% i%' - -!23.|....1....|....2....|....3....|....4....|....5....|....6....|....7.. - -!MWTIME]x3 NET avg max imx x% r% i% SCP avg max imx x% r% i% -!----------------------------------------------------------------------- -!zeit. 333333.3 33333.3 333 33 33 33 333333.3 33333.3 333 33 33 33 - -write(lu,'(91a)') ('-',i=1,91) -do l=0,min(MXN,nname) - - ! sum() of all processes - - zts_o=0. - zts_s=0. - - ! indices of max() of all processes - - ix_o=0 - ix_s=0 - do k=0,nPE-1 - - zts_o=zts_o+ztmp(itm,0,l,k) ! compute sum() - zts_s=zts_s+ztmp(itm,1,l,k) ! compute sum() - - if(ztmp(itm,0,l,ix_o) < ztmp(itm,0,l,k)) ix_o=k - if(ztmp(itm,1,l,ix_s) < ztmp(itm,1,l,k)) ix_s=k - - end do - - zta_o=zts_o/max(1,nPE) ! compute mean() - zta_s=zts_s/max(1,nPE) ! compute mean() - - ztr_o=0. - ztr_s=0. - do k=0,nPE-1 - if(ztmp(itm,0,l,k) > zta_o) ztr_o=ztr_o+ztmp(itm,0,l,k)-zta_o - if(ztmp(itm,1,l,k) > zta_s) ztr_s=ztr_s+ztmp(itm,1,l,k)-zta_s - end do - - ztm_o=ztmp(itm,0,l,ix_o) - ztm_s=ztmp(itm,1,l,ix_s) - - lx=indx(l) - name=name_l(lx) - ln=max(len_trim(name),lnmax) - - x_o=nint(100.*(ztm_o-zta_o)/max(zts_o,res)) - r_o=nint(100.* ztr_o /max(zts_o,res)) - i_o=nint(100.*(ztm_o-zta_o)/max(ztm_o,res)) - - x_s=nint(100.*(ztm_s-zta_s)/max(zts_s,res)) - r_s=nint(100.* ztr_s /max(zts_s,res)) - i_s=nint(100.*(ztm_s-zta_s)/max(ztm_s,res)) - - write(lu,'(a,2(3x,f10.6,3x,f10.6,1x,z3.3,3i3,1x))') & - name(1:ln), & - zta_o,ztm_o,ix_o,x_o,r_o,i_o, & - zta_s,ztm_s,ix_s,x_s,r_s,i_s - -end do -write(lu,'(91a)') ('-',i=1,91) -end subroutine mp_balances_ - -!======================================================================= -end module m_zeit -!. diff --git a/cesm/models/utils/mct/mpi-serial/.gitignore b/cesm/models/utils/mct/mpi-serial/.gitignore deleted file mode 100644 index d8ae331..0000000 --- a/cesm/models/utils/mct/mpi-serial/.gitignore +++ /dev/null @@ -1 +0,0 @@ -mpif.h diff --git a/cesm/models/utils/mct/mpi-serial/Makefile b/cesm/models/utils/mct/mpi-serial/Makefile deleted file mode 100644 index 4046707..0000000 --- a/cesm/models/utils/mct/mpi-serial/Makefile +++ /dev/null @@ -1,134 +0,0 @@ -SHELL = /bin/sh -############################### -include ../Makefile.conf - -VPATH=$(SRCDIR)/mpi-serial -# SOURCE FILES - -MODULE = mpi-serial - -SRCS_F90 = fort.F90 - -SRCS_C = mpi.c \ - send.c \ - recv.c \ - collective.c \ - req.c \ - list.c \ - handles.c \ - comm.c \ - group.c \ - time.c \ - pack.c - - -OBJS_ALL = $(SRCS_C:.c=.o) \ - $(SRCS_F90:.F90=.o) - - -INCPATH:= $(INCFLAG)$(SRCDIR)/mpi-serial $(INCFLAG). $(INCFLAG)../ $(INCPATH) - -# -# The values used from Makefile.conf -# - -# ALLCFLAGS= -DFORTRAN_UNDERSCORE_ -# ALLCFLAGS= -DFORTRAN_SAME -# ALLCFLAGS= -DFORTRAN_CAPS - -# FC=pgf90 -# AR=ar rv -# CC=cc - - -############################### - -# TARGETS - -default: lib$(MODULE).a - -examples: ctest ftest - - -MPIFH= mpif.$(FORT_SIZE).h - - -mpif.h: $(MPIFH) - cp -f $< $@ - -fort.o: mpif.h - -lib: - @if [ ! "$(FORT_SIZE)" ] ; \ - then echo "Please set FORT_SIZE (e.g. real4double8 or real8double16) when you do the main MCT configure"; \ - exit 1; fi - @if [ ! -r $(MPIFH) ] ; \ - then echo "Error: there is no $(MPIFH) -" \ - "check the value of FORT_SIZE in the main MCT configure" ; \ - exit 1; fi - cp -f $(MPIFH) mpif.h - chmod -w mpif.h - $(MAKE) $(LIB) - - - -lib$(MODULE).a: $(OBJS_ALL) - echo $(OBJS_ALL) - $(RM) $@ - $(AR) $@ $(OBJS_ALL) - $(RANLIB) $@ - - -LIB = lib$(MODULE).a - - -############################### -#RULES - -.SUFFIXES: -.SUFFIXES: .F90 .c .o - -.c.o: - $(CC) -c $(INCPATH) $(CPPDEFS) $(CFLAGS) $< - -.F90.o: - $(FC) -c $(INCFLAG). $(INCPATH) $(FPPDEFS) $(FCFLAGS) $(MPEUFLAGS) $< - -MYF90FLAGS=$(INCPATH) $(DEFS) $(FCFLAGS) $(MPEUFLAGS) - -clean: - /bin/rm -f *.o ctest ftest $(LIB) mpif.h - - -install: lib - $(MKINSTALLDIRS) $(libdir) $(includedir) - $(INSTALL) lib$(MODULE).a -m 644 $(libdir) - $(INSTALL) mpi.h -m 644 $(includedir) - $(INSTALL) mpif.h -m 644 $(includedir) - - - -############################### -# -# Create mpif.realXdoubleY.h filesfrom mpif.master.h template -# - -mpif: - make-mpif 4 8 - make-mpif 8 8 - make-mpif 8 16 - - -############################### - -# -# test programs -# - - -ctest: lib ctest.c - $(CC) $(ALLCFLAGS) -o $@ ctest.c -L. -lmpi-serial - -ftest: lib ftest.F90 - $(FC) $(MYF90FLAGS) -o $@ ftest.F90 -L. -lmpi-serial - diff --git a/cesm/models/utils/mct/mpi-serial/README b/cesm/models/utils/mct/mpi-serial/README deleted file mode 100644 index d7ab7b7..0000000 --- a/cesm/models/utils/mct/mpi-serial/README +++ /dev/null @@ -1,139 +0,0 @@ - -###################################################################### - -mpi-serial - - Ray Loy (rloy@mcs.anl.gov) - -###################################################################### - - -This library provides a one-processor version of MPI. Most common MPI -calls, including all that are necessary for MCT, are supported. This -includes sends and receives (which cannot be simply stubbed out). See -below for a complete list. - - ---------------- -Configuration ---------------- - -During the MCT configure, specify the option: - - --enable-mpiserial - - -This will cause the main MCT 'make' to compile mpi-serial and use it. - -IMPORTANT: - -By default, it is assumed that Fortran programs linked with mpi-serial -(e.g. MCT) will be using REAL variables of size 4 bytes, and DOUBLE -PRECISION variables of size 8 bytes. If this is not the case -(e.g. due to hardware sizes or Fortran compiler options), you must -specify a value for FORT_SIZE, e.g.: - - --enable-mpiserial FORT_SIZE=real8double8 - - -The built-in choices for FORT_SIZE are: - - real4double8 (default) - real8double8 (use when only REALs are auto-promoted) - real8double16 (use when REALs and DOUBLEs are auto-promoted) - - -How to configure for other Fortran data sizes: ----------------------------------------------- - -The setting for FORT_SIZE is actually just a name used to choose a -pre-made mpif.h file, mpif.$(FORT_SIZE).h, whose contents set the -sizes of Fortran data types. If you need a different set of sizes, -you can copy one of these files and edit it to reflect the desired -sizes. E.g. Copy mpif.real4double8.h to mpif.mysize.h and edit these -lines: - - PARAMETER (MPI_REAL=4) ! 4 is number of bytes - - PARAMETER (MPI_DOUBLE_PRECISION=8) ! 8 is number of bytes - -then configure MCT using: - - --enable-mpiserial FORT_SIZE=mysize - - - -At runtime (within MPI_Init), there is a consistancy check of Fortran -data type sizes. If any sizes conflict with the config, there will be -an error message. - - -Advanced: The sizes of other types can be set in the same manner. -However, note that the size of a Fortran "INTEGER" must be the same as -C type specified for MPI_Status_int in mpi.h. Consult the author for -further advice. - - - --------------------------------- -Manual make targets --------------------------------- - -Note: Normally this is handled by the main MCT 'make'. - See "Configuration" above. - - -'make' - compile the mpi-serial library - -'make examples' - compile mpi-serial and its example programs - -'make clean' - get rid of all objects and executables - - - ----------------------------------- -List of MPI calls supported ----------------------------------- - - general ops - mpi_init - mpi_finalize - mpi_abort - mpi_error_string - mpi_initialized - - comm and group ops - mpi_comm_free - mpi_comm_size - mpi_comm_rank - mpi_comm_dup - mpi_comm_create - mpi_comm_split - mpi_comm_group - mpi_group_incl - mpi_group_free - - send/receive ops - mpi_irecv - mpi_recv - mpi_test - mpi_wait - mpi_waitany - mpi_waitall - mpi_isend - mpi_send - - collective operations - mpi_barrier - mpi_bcast - mpi_gather - mpi_gatherv - mpi_allgather - mpi_scatterv - mpi_reduce - mpi_allreduce - - - ------ -EOF diff --git a/cesm/models/utils/mct/mpi-serial/collective.c b/cesm/models/utils/mct/mpi-serial/collective.c deleted file mode 100644 index 16ca5c5..0000000 --- a/cesm/models/utils/mct/mpi-serial/collective.c +++ /dev/null @@ -1,428 +0,0 @@ - -#include "mpiP.h" - - - -/* - * COLLECTIVE - */ - - -FC_FUNC( mpi_barrier , MPI_BARRIER )(int *comm, int *ierror) -{ - *ierror=MPI_Barrier( *comm ); -} - - -int MPI_Barrier(MPI_Comm comm ) -{ - return(MPI_SUCCESS); -} - - -/*********/ - - -FC_FUNC( mpi_bcast , MPI_BCAST )(void *buffer, int *count, int *datatype, - int *root, int *comm, int *ierror ) -{ - *ierror=MPI_Bcast(buffer, *count, *datatype, *root, *comm); -} - - - -int MPI_Bcast(void* buffer, int count, MPI_Datatype datatype, - int root, MPI_Comm comm ) -{ - if (root==MPI_ROOT) - return(MPI_SUCCESS); - - if (root!=0) - { - fprintf(stderr,"MPI_Bcast: bad root = %d\n",root); - abort(); - } - - - return(MPI_SUCCESS); -} - - -/*********/ - - -FC_FUNC( mpi_gather , MPI_GATHER ) - (void *sendbuf, int *sendcount, int *sendtype, - void *recvbuf, int *recvcount, int *recvtype, - int *root, int *comm, int *ierror) -{ - *ierror=MPI_Gather( sendbuf, *sendcount, *sendtype, - recvbuf, *recvcount, *recvtype, - *root, *comm); -} - - -int MPI_Gather(void* sendbuf, int sendcount, MPI_Datatype sendtype, - void* recvbuf, int recvcount, MPI_Datatype recvtype, - int root, MPI_Comm comm) -{ - if (root==MPI_ROOT) - return(MPI_SUCCESS); - - if (root!=0) - { - fprintf(stderr,"MPI_Gather: bad root = %d\n",root); - abort(); - } - - memcpy(recvbuf,sendbuf,sendcount*sendtype); - - return(MPI_SUCCESS); -} - -/*********/ - - - -FC_FUNC( mpi_gatherv , MPI_GATHERV ) - ( void *sendbuf, int *sendcount, int *sendtype, - void *recvbuf, int *recvcounts, int *displs, - int *recvtype, int *root, int *comm, int *ierror) -{ - *ierror=MPI_Gatherv( sendbuf, *sendcount, *sendtype, - recvbuf, recvcounts, displs, - *recvtype, *root, *comm); -} - - -int MPI_Gatherv(void* sendbuf, int sendcount, MPI_Datatype sendtype, - void* recvbuf, int *recvcounts, int *displs, - MPI_Datatype recvtype, int root, MPI_Comm comm) -{ - int offset; - - if (root==MPI_ROOT) - return(MPI_SUCCESS); - - if (root!=0) - { - fprintf(stderr,"MPI_Gatherv: bad root = %d\n",root); - abort(); - } - - offset=displs[0]*recvtype; - memcpy( (char *)recvbuf+offset, sendbuf, recvcounts[0] * recvtype); - - return(MPI_SUCCESS); -} - - - -/*********/ - - -FC_FUNC( mpi_allgather , MPI_ALLGATHER ) - ( void *sendbuf, int *sendcount, int *sendtype, - void *recvbuf, int *recvcount, int *recvtype, - int *comm, int *ierror) -{ - *ierror=MPI_Allgather( sendbuf, *sendcount, *sendtype, - recvbuf, *recvcount, *recvtype, - *comm ); -} - - -int MPI_Allgather(void* sendbuf, int sendcount, MPI_Datatype sendtype, - void* recvbuf, int recvcount, MPI_Datatype recvtype, - MPI_Comm comm) -{ - - memcpy(recvbuf,sendbuf,sendcount * sendtype); - - return(MPI_SUCCESS); - -} - - -/*********/ - - -FC_FUNC( mpi_allgatherv , MPI_ALLGATHERV ) - ( void *sendbuf, int *sendcount, int *sendtype, - void *recvbuf, int *recvcounts, int *displs, - int *recvtype, int *comm, int *ierror) -{ - *ierror=MPI_Allgatherv( sendbuf, *sendcount, *sendtype, - recvbuf, recvcounts, displs, - *recvtype, *comm ); -} - - -int MPI_Allgatherv(void* sendbuf, int sendcount, MPI_Datatype sendtype, - void* recvbuf, int *recvcounts, int *displs, - MPI_Datatype recvtype, MPI_Comm comm) -{ - int offset; - - offset=displs[0]*recvtype; - memcpy( (char *)recvbuf+offset, sendbuf, recvcounts[0] * recvtype); - - return(MPI_SUCCESS); -} - - -/*********/ - - -FC_FUNC( mpi_scatter , MPI_SCATTER ) - ( void *sendbuf, int *sendcount, int *sendtype, - void *recvbuf, int *recvcount, int *recvtype, - int *root, int *comm, int *ierror) -{ - *ierror=MPI_Scatter( sendbuf, *sendcount, *sendtype, - recvbuf, *recvcount, *recvtype, - *root, *comm); -} - - - -int MPI_Scatter( void* sendbuf, int sendcount, MPI_Datatype sendtype, - void* recvbuf, int recvcount, MPI_Datatype recvtype, - int root, MPI_Comm comm) -{ - if (root==MPI_ROOT) - return(MPI_SUCCESS); - - if (root!=0) - { - fprintf(stderr,"MPI_Scatter: bad root = %d\n",root); - abort(); - } - - memcpy(recvbuf,sendbuf,sendcount * sendtype); - - return(MPI_SUCCESS); -} - - - -/*********/ - - -FC_FUNC( mpi_scatterv , MPI_SCATTERV ) - ( void *sendbuf, int *sendcounts, int *displs, - int *sendtype, void *recvbuf, int *recvcount, - int *recvtype, int *root, int *comm, int *ierror) -{ - *ierror=MPI_Scatterv(sendbuf, sendcounts, displs, - *sendtype, recvbuf, *recvcount, - *recvtype, *root, *comm); -} - - - -int MPI_Scatterv(void* sendbuf, int *sendcounts, int *displs, - MPI_Datatype sendtype, void* recvbuf, int recvcount, - MPI_Datatype recvtype, int root, MPI_Comm comm) -{ - int offset; - - if (root==MPI_ROOT) - return(MPI_SUCCESS); - - if (root!=0) - { - fprintf(stderr,"MPI_Scatterv: bad root = %d\n",root); - abort(); - } - - offset=displs[0]*sendtype; - memcpy(recvbuf,(char *)sendbuf+offset,sendcounts[0] * sendtype); - - return(MPI_SUCCESS); -} - - - -/*********/ - - -FC_FUNC( mpi_reduce , MPI_REDUCE ) - ( void *sendbuf, void *recvbuf, int *count, - int *datatype, int *op, int *root, int *comm, - int *ierror) -{ - *ierror=MPI_Reduce(sendbuf, recvbuf, *count, - *datatype, *op, *root, *comm); -} - - - -int MPI_Reduce(void* sendbuf, void* recvbuf, int count, - MPI_Datatype datatype, MPI_Op op, int root, MPI_Comm comm) - -{ - if (root==MPI_ROOT) - return(MPI_SUCCESS); - - if (root!=0) - { - fprintf(stderr,"MPI_Reduce: bad root = %d\n",root); - abort(); - } - - memcpy(recvbuf,sendbuf,count * datatype); - - return(MPI_SUCCESS); -} - - -/*********/ - - -FC_FUNC( mpi_allreduce , MPI_ALLREDUCE ) - ( void *sendbuf, void *recvbuf, int *count, - int *datatype, int *op, int *comm, int *ierror) -{ - *ierror=MPI_Allreduce(sendbuf, recvbuf, *count, - *datatype, *op, *comm); - -} - - -int MPI_Allreduce(void* sendbuf, void* recvbuf, int count, - MPI_Datatype datatype, MPI_Op op, MPI_Comm comm) -{ - - memcpy(recvbuf,sendbuf,count * datatype); - - return(MPI_SUCCESS); - -} - - -/*********/ - - -FC_FUNC( mpi_scan , MPI_SCAN ) - ( void *sendbuf, void *recvbuf, int *count, - int *datatype, int *op, int *comm, - int *ierror) -{ - *ierror=MPI_Scan( sendbuf, recvbuf, *count, - *datatype, *op, *comm); -} - - - -int MPI_Scan( void* sendbuf, void* recvbuf, int count, - MPI_Datatype datatype, MPI_Op op, MPI_Comm comm) - -{ - - memcpy(recvbuf,sendbuf,count * datatype); - - return(MPI_SUCCESS); -} - - -/*********/ - - -FC_FUNC( mpi_alltoall , MPI_ALLTOALL ) - ( void *sendbuf, int *sendcount, int *sendtype, - void *recvbuf, int *recvcount, int *recvtype, - int *comm, int *ierror ) -{ - *ierror=MPI_Alltoall(sendbuf, *sendcount, *sendtype, - recvbuf, *recvcount, *recvtype, - *comm); -} - - -int MPI_Alltoall(void *sendbuf, int sendcount, MPI_Datatype sendtype, - void *recvbuf, int recvcount, MPI_Datatype recvtype, - MPI_Comm comm) -{ - - memcpy(recvbuf,sendbuf,sendcount * sendtype); - - return(MPI_SUCCESS); -} - - -/*********/ - - -FC_FUNC( mpi_alltoallv , MPI_ALLTOALLV ) - ( void *sendbuf, int *sendcounts, int *sdispls, int *sendtype, - void *recvbuf, int *recvcounts, int *rdispls, int *recvtype, - int *comm, int *ierror ) -{ - - *ierror=MPI_Alltoallv(sendbuf, sendcounts, sdispls, *sendtype, - recvbuf, recvcounts, rdispls, *recvtype, - *comm); - -} - -int MPI_Alltoallv(void *sendbuf, int *sendcounts, - int *sdispls, MPI_Datatype sendtype, - void *recvbuf, int *recvcounts, - int *rdispls, MPI_Datatype recvtype, - MPI_Comm comm) - -{ - int send_offset; - int recv_offset; - - send_offset=sdispls[0]*sendtype; - recv_offset=rdispls[0]*recvtype; - - - memcpy( (char *)recvbuf+recv_offset, (char *)sendbuf+send_offset, - sendcounts[0] * sendtype); - - - return(MPI_SUCCESS); -} - - -/*********/ - - -FC_FUNC( mpi_op_create , MPI_OP_CREATE ) - ( void *function, int *commute, int *op, int *ierror ) -{ - *ierror=MPI_Op_create(function,*commute,op); -} - - - -int MPI_Op_create(MPI_User_function *function, int commute, MPI_Op *op) -{ - *op=MPI_OP_NULL; - - return(MPI_SUCCESS); - -} - - - - -/*********/ - -MPI_Op MPI_Op_f2c(MPI_Fint op) -{ - return(op); -} - - -/*********/ - - -MPI_Fint MPI_Op_c2f(MPI_Op op) -{ - return(op); -} - diff --git a/cesm/models/utils/mct/mpi-serial/comm.c b/cesm/models/utils/mct/mpi-serial/comm.c deleted file mode 100644 index 310ba58..0000000 --- a/cesm/models/utils/mct/mpi-serial/comm.c +++ /dev/null @@ -1,227 +0,0 @@ - -#include "mpiP.h" - - - -/* - * Communicators - * - */ - - - -MPI_Comm mpi_comm_new(void) -{ - MPI_Comm chandle; - Comm *cptr; - static int num=0; - - mpi_alloc_handle(&chandle,(void **) &cptr); - - cptr->sendlist=AP_list_new(); - cptr->recvlist=AP_list_new(); - - cptr->num=num++; - - return(chandle); -} - - -/*********/ - - -FC_FUNC( mpi_comm_free , MPI_COMM_FREE )(int *comm, int *ierror) -{ - *ierror=MPI_Comm_free(comm); -} - - -/* - * MPI_Comm_free() - * - * Note: will NOT free any pending MPI_Request handles - * that are allocated... correct user code should have - * already done a Wait or Test to free them. - * - */ - - -int MPI_Comm_free(MPI_Comm *comm) -{ - pList sendlist, recvlist; - int size; - Comm *mycomm; - - mycomm=mpi_handle_to_ptr(*comm); /* (Comm *)(*comm) */ - - sendlist=mycomm->sendlist; - recvlist=mycomm->recvlist; - - size=AP_list_size(sendlist); - if (size!=0) - fprintf(stderr,"MPI_Comm_free: warning: %d pending send reqs\n", - size); - AP_list_free(sendlist); - - - size=AP_list_size(recvlist); - if (size!=0) - fprintf(stderr,"MPI_Comm_free: warning: %d pending receive reqs\n", - size); - AP_list_free(recvlist); - - mpi_free_handle(*comm); /* free(mycomm); */ - *comm=MPI_COMM_NULL; - - return(MPI_SUCCESS); -} - - -/*********/ - - - -FC_FUNC( mpi_comm_size , MPI_COMM_SIZE )(int *comm, int *size, int *ierror) -{ - *ierror=MPI_Comm_size(*comm, size); -} - - - -int MPI_Comm_size(MPI_Comm comm, int *size) -{ - *size=1; - - return(MPI_SUCCESS); -} - - -/*********/ - - -FC_FUNC( mpi_comm_rank , MPI_COMM_RANK )(int *comm, int *rank, int *ierror) -{ - *ierror=MPI_Comm_rank( *comm, rank); -} - - -int MPI_Comm_rank(MPI_Comm comm, int *rank) -{ - *rank=0; - - return(MPI_SUCCESS); -} - - - -/*********/ - - -FC_FUNC( mpi_comm_dup , MPI_COMM_DUP )(int *comm, int *newcomm, int *ierror) -{ - - *ierror=MPI_Comm_dup( *comm, newcomm); - -} - - -int MPI_Comm_dup(MPI_Comm comm, MPI_Comm *newcomm) -{ - *newcomm= mpi_comm_new(); - -#ifdef INFO - fflush(stdout); - fprintf(stderr,"MPI_Comm_dup: new comm handle=%d\n",*newcomm); -#endif - - return(MPI_SUCCESS); -} - - -/*********/ - - -int FC_FUNC( mpi_comm_create, MPI_COMM_CREATE) - (int *comm, int *group, int *newcomm, int *ierror) -{ - *ierror=MPI_Comm_create(*comm,*group,newcomm); -} - - - -int MPI_Comm_create(MPI_Comm comm, MPI_Group group, MPI_Comm *newcomm) -{ - if (group==MPI_GROUP_NULL || group==MPI_GROUP_EMPTY) - *newcomm= MPI_COMM_NULL; - else - *newcomm=mpi_comm_new(); - - return(MPI_SUCCESS); -} - - - -/*********/ - - -FC_FUNC( mpi_comm_split, MPI_COMM_SPLIT ) - (int *comm, int *color, int *key, int *newcomm, int *ierror) -{ - *ierror=MPI_Comm_split(*comm,*color,*key,newcomm); - -} - - - -int MPI_Comm_split(MPI_Comm comm, int color, int key, MPI_Comm *newcomm) -{ - if (color==MPI_UNDEFINED) - *newcomm=MPI_COMM_NULL; - else - *newcomm= mpi_comm_new(); - - return(MPI_SUCCESS); -} - - -/*********/ - - -FC_FUNC( mpi_comm_group, MPI_COMM_GROUP ) - (int *comm, int *group, int *ierror) -{ - *ierror= MPI_Comm_group(*comm, group); -} - - - -int MPI_Comm_group(MPI_Comm comm, MPI_Group *group) -{ - if (comm==MPI_COMM_NULL) - *group= MPI_GROUP_NULL; - else - *group= MPI_GROUP_ONE; - - return(MPI_SUCCESS); -} - - - -/*********/ - - -MPI_Comm MPI_Comm_f2c(MPI_Fint comm) -{ - /* Comm is an integer handle used both by C and Fortran */ - return(comm); -} - - -MPI_Fint MPI_Comm_c2f(MPI_Comm comm) -{ - return(comm); -} - - - - diff --git a/cesm/models/utils/mct/mpi-serial/ctest.c b/cesm/models/utils/mct/mpi-serial/ctest.c deleted file mode 100644 index 23541cb..0000000 --- a/cesm/models/utils/mct/mpi-serial/ctest.c +++ /dev/null @@ -1,183 +0,0 @@ - -#include -#include "mpi.h" - - - - - -main(int argc, char *argv[]) -{ - MPI_Request sreq[10], sreq2[10], rreq[10], rreq2[10]; - int sbuf[10],sbuf2[10],rbuf[10],rbuf2[10]; - int tag; - MPI_Status status[10], sr_status; - int i,j; - MPI_Comm comm2; - int flag; - MPI_Group mygroup; - char pname[MPI_MAX_PROCESSOR_NAME]; - int pnamelen; - - int position, temp; - - - printf("Time: %f\n",MPI_Wtime()); - - MPI_Initialized(&flag); - printf("MPI is initialized = %d\n",flag); - - MPI_Init(NULL,NULL); - - MPI_Get_processor_name(pname,&pnamelen); - printf("Processor name: %s (len=%d)\n",pname,pnamelen); - -#if 0 - MPI_Comm_dup(MPI_COMM_WORLD,&comm2); -#endif - -#if 0 - MPI_Comm_split(MPI_COMM_WORLD,42,99,&comm2); -#endif - -#if 1 - MPI_Comm_group(MPI_COMM_WORLD,&mygroup); - MPI_Comm_create(MPI_COMM_WORLD,mygroup,&comm2); -#endif - - MPI_Initialized(&flag); - printf("MPI is initialized = %d\n",flag); - - for (i=0; i<5; i++) - { - tag=100+i; - printf("COMWORLD Post ireceive tag %d\n",tag); - - MPI_Irecv(&rbuf[2*i],1,MPI_2INT, - 0,tag,MPI_COMM_WORLD,&rreq[i]); - } - - for (i=0; i<5; i++) - { - sbuf2[i]=1000+10*i; - tag=100+i; - printf("COM2 Post isend %d tag %d\n",sbuf2[i],tag); - MPI_Isend(&sbuf2[i],1,MPI_INT,0,tag,comm2,&sreq2[i]); - } - - for (i=0; i<5; i++) - { - sbuf[2*i]=10*i; - sbuf[2*i+1]=10*i+1; - tag=100+(4-i); - printf("COMWORLD Post irsend %d tag %d\n",sbuf[i],tag); - MPI_Irsend(&sbuf[2*i],1,MPI_2INT,0,tag,MPI_COMM_WORLD,&sreq[i]); - } - - - printf("Time: %f\n",MPI_Wtime()); - MPI_Waitall(5,sreq,status); - MPI_Waitall(5,rreq,status); - - printf("Waiting for COMWORLD send/receives\n"); - - for (i=0; i<5; i++) - printf("tag %d rbuf= %d %d\n",status[i].MPI_TAG,rbuf[2*i],rbuf[2*i+1]); - - - for (i=0; i<5; i++) - { - tag=100+i; - printf("COM2 Post receive tag %d\n",tag); - - MPI_Irecv(&rbuf2[i],1,MPI_INT, - 0,tag,comm2,&rreq2[i]); - } - - - MPI_Waitall(5,sreq2,status); - MPI_Waitall(5,rreq2,status); - - printf("Waiting for COM2 send/receive\n"); - - for (i=0; i<5; i++) - printf("tag %d rbuf= %d\n",status[i].MPI_TAG,rbuf2[i]); - - - /* - * pack/unpack - */ - - position=0; - for (i=0; i<5; i++) - { - temp=100+i; - MPI_Pack(&temp, 1, MPI_INT, sbuf, 20, &position, MPI_COMM_WORLD); - } - - MPI_Isend( sbuf, position, MPI_PACKED, 0, 0, MPI_COMM_WORLD,&sreq[0]); - - MPI_Irecv( rbuf, position, MPI_PACKED, 0, 0, MPI_COMM_WORLD, &rreq[0] ); - MPI_Waitall(1,rreq,status); - - printf("Pack/send/unpack: \n"); - - position=0; - for (i=0; i<5; i++) - { - MPI_Unpack(rbuf,20,&position,&temp,1,MPI_INT,MPI_COMM_WORLD); - printf("%d\n",temp); - } - - - /* - * sendrecv - */ - - - sbuf[0]=42; - rbuf[0]=0; - sr_status.MPI_SOURCE= -1; - sr_status.MPI_TAG= -1; - - MPI_Sendrecv(sbuf,1,MPI_INT,0,127, - rbuf,1,MPI_INT,MPI_ANY_SOURCE,MPI_ANY_TAG, - MPI_COMM_WORLD,&sr_status); - - printf("Done with MPI_Sendrecv, rbuf=%d source=%d tag=%d\n", - rbuf[0],sr_status.MPI_SOURCE,sr_status.MPI_TAG); - - - /* - * Send to nowhere - */ - - - printf("Send to MPI_PROC_NULL\n"); - MPI_Send(sbuf, 1, MPI_INT, MPI_PROC_NULL, 77, MPI_COMM_WORLD); - - - printf("Receive from MPI_PROC_NULL\n"); - MPI_Recv(rbuf, 1, MPI_INT, MPI_PROC_NULL, 78, MPI_COMM_WORLD, status); - printf(" status: source=%d tag=%d\n", - status[0].MPI_SOURCE,status[0].MPI_TAG); - - - - /* - * Finish up - */ - - - MPI_Finalize(); - - - for (i=0; i<5; i++) - { - printf("Time: %f\n",MPI_Wtime()); - sleep(1); - } -} - - - diff --git a/cesm/models/utils/mct/mpi-serial/fort.F90 b/cesm/models/utils/mct/mpi-serial/fort.F90 deleted file mode 100644 index 280fe26..0000000 --- a/cesm/models/utils/mct/mpi-serial/fort.F90 +++ /dev/null @@ -1,49 +0,0 @@ - - - subroutine mpi_init(ierror) - - implicit none - include "mpif.h" - - integer fint(2) - logical flog(2) - real freal(2) - double precision fdub(2) - complex fcomp(2) - integer status(MPI_STATUS_SIZE) - - integer ierror - - - !! - !! Pass values from mpif.h to the C side - !! to check for consistency mpi.h and hardware sizes. - !! - - call mpi_init_fort( MPI_COMM_WORLD, & - MPI_ANY_SOURCE, MPI_ANY_TAG, & - MPI_PROC_NULL, MPI_ROOT, & - MPI_COMM_NULL, MPI_REQUEST_NULL, & - MPI_GROUP_NULL, MPI_GROUP_EMPTY, & - MPI_UNDEFINED, & - MPI_MAX_ERROR_STRING, & - MPI_MAX_PROCESSOR_NAME, & - MPI_STATUS_SIZE, & - MPI_SOURCE, MPI_TAG, MPI_ERROR, & - status, status(MPI_SOURCE), & - status(MPI_TAG), status(MPI_ERROR), & - MPI_INTEGER, fint(1), fint(2), & - MPI_LOGICAL, flog(1), flog(2), & - MPI_REAL, freal(1), freal(2), & - MPI_DOUBLE_PRECISION, fdub(1), fdub(2), & - MPI_COMPLEX, fcomp(1), fcomp(2), & - IERROR ) - - - return - end - - - - - diff --git a/cesm/models/utils/mct/mpi-serial/ftest.F90 b/cesm/models/utils/mct/mpi-serial/ftest.F90 deleted file mode 100644 index ddc808e..0000000 --- a/cesm/models/utils/mct/mpi-serial/ftest.F90 +++ /dev/null @@ -1,152 +0,0 @@ - - program test - implicit none - include "mpif.h" - - integer ier - - integer sreq(10), sreq2(10), rreq(10), rreq2(10) - integer sbuf(10), sbuf2(10), rbuf(10), rbuf2(10) - integer tag - integer status(MPI_STATUS_SIZE,10) - integer i - integer comm2; - logical flag; - character pname(MPI_MAX_PROCESSOR_NAME) - integer pnamesize - - integer temp,position - - external my_op_func - integer myop - - - print *, 'Time=',mpi_wtime() - - call mpi_initialized(flag,ier) - print *, 'MPI is initialized=',flag - - call mpi_init(ier) - - call mpi_get_processor_name(pname,pnamesize,ier) - print *, 'proc name: "',pname(1:pnamesize),'" size:',pnamesize - - - call mpi_comm_dup(MPI_COMM_WORLD,comm2,ier) - - call mpi_initialized(flag,ier) - print *, 'MPI is initialized=',flag - - - - - do i=1,5 - tag= 100+i - print *, 'Post receive tag ',tag - - call mpi_irecv( rbuf(i),1,MPI_INTEGER,0,tag, & - MPI_COMM_WORLD,rreq(i),ier) - - end do - do i=1,5 -! tag=1100+i -! print *, 'Post receive tag ',tag - - call mpi_irecv( rbuf2(i),1,MPI_INTEGER, & - MPI_ANY_SOURCE, MPI_ANY_TAG, & - comm2,rreq2(i),ier) - - end do - - - do i=1,5 - sbuf(i)=10*i - tag=100+i - print *, 'Send ',sbuf(i),' tag ',tag - - call mpi_isend( sbuf(i),1,MPI_INTEGER,0,tag, & - MPI_COMM_WORLD,sreq(i),ier) - end do - - - do i=1,5 - sbuf2(i)=1000+10*i - tag=1100+i - print *, 'Send ',sbuf2(i),' tag ',tag - - call mpi_isend( sbuf2(i),1,MPI_INTEGER,0,tag, & - comm2,sreq2(i),ier) - end do - - - print *, 'Time=',mpi_wtime() - call mpi_waitall(5,sreq,status,ier) - print *,'sends on MPI_COMM_WORLD done' - - call mpi_waitall(5,rreq,status,ier) - print *,'recvs on MPI_COMM_WORLD done' - - do i=1,5 - print *, 'Status source=',status(MPI_SOURCE,i), & - ' tag=',status(MPI_TAG,i) - end do - - call mpi_waitall(5,sreq2,status,ier) - print *,'sends on comm2 done' - - call mpi_waitall(5,rreq2,status,ier) - print *,'recvs on comm2 done' - - do i=1,5 - print *, 'Status source=',status(MPI_SOURCE,i), & - ' tag=',status(MPI_TAG,i) - end do - - -! pack/unpack - - position=0 - do i=1,5 - temp=100+i - call mpi_pack(temp,1,MPI_INTEGER,sbuf,20,position,MPI_COMM_WORLD,ier) - end do - - call mpi_isend(sbuf,position,MPI_PACKED,0,0,MPI_COMM_WORLD,sreq(1),ier) - call mpi_irecv(rbuf,position,MPI_PACKED,0,0,MPI_COMM_WORLD,rreq(1),ier) - call mpi_waitall(1,rreq,status,ier) - - print *,"Pack/send/unpack:" - - position=0 - do i=1,5 - call mpi_unpack( rbuf,20,position,temp,1,MPI_INTEGER, & - MPI_COMM_WORLD,ier) - print *,temp - end do - -! - print *,"Creating op" - call mpi_op_create(my_op_func,.TRUE.,myop,ier) - - - call mpi_finalize(ier) - - do i=1,5 - print *, 'Time=',mpi_wtime() - call sleep(1) - end do - - end - - - - - function my_op_func(invec,inoutvec,len,type) - integer invec(len),inoutvec(len) - integer len,type - - return - end function my_op_func - - - diff --git a/cesm/models/utils/mct/mpi-serial/group.c b/cesm/models/utils/mct/mpi-serial/group.c deleted file mode 100644 index d2a1aeb..0000000 --- a/cesm/models/utils/mct/mpi-serial/group.c +++ /dev/null @@ -1,257 +0,0 @@ - -#include "mpiP.h" - - -/*********/ - - -FC_FUNC( mpi_group_incl, MPI_GROUP_INCL ) - (int *group, int *n, int *ranks, int *newgroup, int *ierror) -{ - *ierror= MPI_Group_incl(*group, *n, ranks, newgroup); -} - - -int MPI_Group_incl(MPI_Group group, int n, int *ranks, MPI_Group *newgroup) -{ - - if (group==MPI_GROUP_NULL) - { - fprintf(stderr,"MPI_Group_incl: null group passed in\n"); - abort(); - } - - if (group==MPI_GROUP_EMPTY || n==0) - *newgroup=MPI_GROUP_EMPTY; - else - if (n==1 && ranks[0]==0) - *newgroup=MPI_GROUP_ONE; - else - { - fprintf(stderr,"MPI_Group_incl: more than 1 proc in group\n"); - abort(); - } - - return(MPI_SUCCESS); -} - - -/*********/ - - -FC_FUNC( mpi_group_range_incl, MPI_GROUP_RANGE_INCL ) - (int *group, int *n, int ranges[][3], int *newgroup, int *ierror) -{ - *ierror= MPI_Group_range_incl(*group, *n, ranges, newgroup); -} - - -int MPI_Group_range_incl(MPI_Group group, int n, int ranges[][3], - MPI_Group *newgroup) -{ - - if (group==MPI_GROUP_NULL) - { - fprintf(stderr,"MPI_Group_range_incl: null group passed in\n"); - abort(); - } - - if (group==MPI_GROUP_EMPTY || n==0) - *newgroup=MPI_GROUP_EMPTY; - else - if (n==1 && ranges[0][0]==0 && ranges[0][1]==0) - *newgroup=MPI_GROUP_ONE; - else - { - fprintf(stderr,"MPI_Group_range_incl: more than 1 proc in group\n"); - abort(); - } - - return(MPI_SUCCESS); -} - - - - -/*********/ - - - -FC_FUNC( mpi_group_union, MPI_GROUP_UNION ) - (int *group1, int *group2, int *newgroup, int *ierror) -{ - *ierror= MPI_Group_union(*group1,*group2,newgroup); -} - - - -int MPI_Group_union(MPI_Group group1, MPI_Group group2, MPI_Group *newgroup) -{ - - if (group1==MPI_GROUP_NULL || group2==MPI_GROUP_NULL) - { - fprintf(stderr,"MPI_Group_union: null group passed in\n"); - abort(); - } - - if (group1==MPI_GROUP_ONE || group2==MPI_GROUP_ONE) - *newgroup=MPI_GROUP_ONE; - else - *newgroup=MPI_GROUP_EMPTY; - - - return(MPI_SUCCESS); -} - -/*********/ - - - -FC_FUNC( mpi_group_intersection, MPI_GROUP_INTERSECTION ) - (int *group1, int *group2, int *newgroup, int *ierror) -{ - *ierror= MPI_Group_intersection(*group1,*group2,newgroup); -} - - - -int MPI_Group_intersection(MPI_Group group1, MPI_Group group2, - MPI_Group *newgroup) -{ - - if (group1==MPI_GROUP_NULL || group2==MPI_GROUP_NULL) - { - fprintf(stderr,"MPI_Group_intersection: null group passed in\n"); - abort(); - } - - if (group1==MPI_GROUP_ONE && group2==MPI_GROUP_ONE) - *newgroup=MPI_GROUP_ONE; - else - *newgroup=MPI_GROUP_EMPTY; - - - return(MPI_SUCCESS); -} - - -/*********/ - - - -FC_FUNC( mpi_group_difference, MPI_GROUP_DIFFERENCE ) - (int *group1, int *group2, int *newgroup, int *ierror) -{ - *ierror= MPI_Group_difference(*group1,*group2,newgroup); -} - - - -int MPI_Group_difference(MPI_Group group1, MPI_Group group2, - MPI_Group *newgroup) -{ - - if (group1==MPI_GROUP_NULL || group2==MPI_GROUP_NULL) - { - fprintf(stderr,"MPI_Group_intersection: null group passed in\n"); - abort(); - } - - if (group1==MPI_GROUP_EMPTY || group2==MPI_GROUP_ONE) - *newgroup=MPI_GROUP_EMPTY; - else - *newgroup=MPI_GROUP_ONE; - - return(MPI_SUCCESS); -} - - - -/*********/ - - -FC_FUNC( mpi_group_free, MPI_GROUP_FREE )(int *group, int *ierror) -{ - *ierror= MPI_Group_free(group); -} - - -int MPI_Group_free(MPI_Group *group) -{ - *group= MPI_GROUP_NULL; - - return(MPI_SUCCESS); -} - - -/*********/ - - - -FC_FUNC( mpi_group_translate_ranks, MPI_GROUP_TRANSLATE_RANKS ) - ( int *group1, int *n, int *ranks1, - int *group2, int *ranks2, int *ierror) -{ - *ierror= MPI_Group_translate_ranks(*group1,*n,ranks1,*group2,ranks2); -} - - - -int MPI_Group_translate_ranks(MPI_Group group1, int n, int *ranks1, - MPI_Group group2, int *ranks2) -{ - int i; - - if (group1==MPI_GROUP_NULL || group2==MPI_GROUP_NULL) - { - fprintf(stderr,"MPI_Group_translate_ranks: null group passed in\n"); - abort(); - } - - if (n==0) - return(MPI_SUCCESS); - - if (group1==MPI_GROUP_EMPTY) - { - fprintf(stderr,"MPI_Group_translate_ranks: empty input group\n"); - abort(); - } - - for (i=0; i simplified and store item directly in the struct - * rather than as pointer to separately allocated object. - * - * CAVEAT: - * as in mpich-1, storage will grow as needed and will - * remain at the high water mark since it is likely that - * the user code will repeat the use. - * - */ - - -typedef struct _Handleitem -{ - int handle; - struct _Handleitem *next; - - union - { - void *anything; /* At least size of void * */ - Comm comm; - Req req; - - } data; - - -} Handleitem; - - -/* - * These must be consistent with each other - * - */ - -#define BLOCK_ITEMS (256) -#define HANDLE_TO_BLOCK(x) ( (x) >> 8) -#define HANDLE_TO_INDEX(x) ( (x) & 0xff ) -#define HANDLE(block,index) ( (block << 8) | (index) ) - - -/* - * The first block of handle items will be statically allocated. - * Subsequent ones will be added if necessary. - * blocks[0..nblocks-1] are allocated at any given time. - * - * Increase MAX_BLOCKS if you *really* need more active request - * (Although probably something is wrong if you need more than 256k !!!) - * - */ - - -#define MAX_BLOCKS (1024) - -static Handleitem block0[BLOCK_ITEMS]; /* array of handleitems */ -static Handleitem *(blocks[MAX_BLOCKS]); /* array of pointers to blocks */ -static int nblocks; - - -static int need_to_init=1; -static Handleitem *nextfree; - - -/************************************************************************/ - -void *mpi_malloc(int size) -{ - void *ret; - - ret=malloc(size); - - if (!ret) - { - fprintf(stderr,"mpi_malloc: failed to allocate %d bytes\n",size); - abort(); - } - - return(ret); -} - - -void mpi_free(void *ptr) -{ - free(ptr); -} - - -/************************************************************************/ - - -/* - * initialize a block s.t. handles are set and - * 0 -> 1 -> 2 ... -> (BLOCK_ITEMS-1) -> NULL - * - */ - -static Handleitem *init_block(int block, Handleitem *b) -{ - int i; - - for (i=0; inext; /* Skip over using item 0 */ - new->next=NULL; - - /* - * initialize the array of blocks - * - */ - - blocks[0]=block0; - nblocks=1; - - for (i=1; inext; - new->next=NULL; - - *handle= new->handle; - *data= &(new->data); - - return; - } - - /* there is nothing free, so allocate a new block and add it - * to blocks[] - */ - - if (nblocks==MAX_BLOCKS) - { - fprintf(stderr,"mpi_allocate_handle: max %d active handles exceeded\n", - MAX_BLOCKS*BLOCK_ITEMS); - abort(); - } - - blocks[nblocks]= (Handleitem *)mpi_malloc(sizeof(Handleitem)* BLOCK_ITEMS); - new=init_block(nblocks,blocks[nblocks]); - - nextfree= new->next; - new->next=NULL; - - *handle= new->handle; - *data= &(new->data); - - nblocks++; /* DON'T FORGET THIS!!!! */ - -#ifdef HANDLE_INFO - fflush(stdout); - fprintf(stderr,"mpi_alloc_handle: allocation %d blocks (%d handles)\n", - nblocks,nblocks*BLOCK_ITEMS); -#endif - -} - - - - -static void verify_handle(int handle, int block, int index) -{ - if (block>=nblocks || block<0 || - index>=BLOCK_ITEMS || index<0) - { - fprintf(stderr,"mpi_verify_handle: bad handle\n"); - abort(); - } - - if (blocks[block][index].handle != handle) - { - fprintf(stderr,"mpi_verify_handle: handle mismatch\n"); - abort(); - } -} - - - -void *mpi_handle_to_ptr(int handle) -{ - int block; - int index; - - if (need_to_init) - init_handles(); - - if (!handle) /* Handle 0 -> NULL */ - return(NULL); - - block=HANDLE_TO_BLOCK(handle); - index=HANDLE_TO_INDEX(handle); - -#ifdef CHECKS - verify_handle(handle,block,index); -#endif - - return( &(blocks[block][index].data) ); -} - - - -void mpi_free_handle(int handle) -{ - int block; - int index; - Handleitem *item; - - if (!handle) /* ignore null handle */ - return; - - if (need_to_init) - { - fprintf(stderr,"mpi_free_handle: handles not initialized\n"); - abort(); - } - - block=HANDLE_TO_BLOCK(handle); - index=HANDLE_TO_INDEX(handle); - -#ifdef CHECKS - verify_handle(handle,block,index); -#endif - - item=&(blocks[block][index]); - -#ifdef CHECKS - if (item->next) - { - fprintf(stderr,"mpi_free_handle: handle still in use\n"); - abort(); - } -#endif - - - /* just return it to the free list. - * space is not reclaimed. - */ - - item->next=nextfree; - nextfree=item; -} diff --git a/cesm/models/utils/mct/mpi-serial/list.c b/cesm/models/utils/mct/mpi-serial/list.c deleted file mode 100644 index 706bfaf..0000000 --- a/cesm/models/utils/mct/mpi-serial/list.c +++ /dev/null @@ -1,710 +0,0 @@ -/* - * (C) 2000 UNIVERSITY OF CHICAGO - * See COPYRIGHT in top-level directory. - */ - - - -#ifdef SYSDARWIN - #include -#else - #include -#endif -#include -#include -#include "listops.h" -#include "listP.h" - -/* - * list management code - * - * For storing singly-linked lists of pointers. - * - */ - - -static int itemcount=0; -static int headcount=0; - - -/* - * AP_listitem_malloc() - * - * malloc a new ilist item and return a pointer to it. - * - */ - -static pListitem AP_listitem_malloc(void) -{ - pListitem item; - - itemcount++; - item=(pListitem)malloc( (unsigned) sizeof(Listitem) ); - - if (!item) - { - perror("AP_listitem_malloc: malloc failure"); - abort(); - } - - return(item); -} - - - -/* - * AP_listitem_free(listitem) - * - * Free a listitem generated by AP_listitem_malloc() - * - */ - -static void AP_listitem_free(pListitem listitem) -{ - free(listitem); - itemcount--; -} - - - -/* - * AP_listitem_verify(void) - * - * Checks to see if there are any outstanding listitems that have been - * malloc'd. Returns true if there are any. - * - */ - -int AP_listitem_verify(void) -{ - if (itemcount!=0) - fprintf(stderr,"AP_list_verify: outstanding items, count=%d\n", - itemcount); - - if (headcount!=0) - fprintf(stderr,"AP_list_verify: outstanding lists, count=%d\n", - headcount); - - return( (itemcount!=0) || (headcount!=0) ); -} - - - - -pListitem AP_listitem_prev(pListitem listitem) -{ - return(listitem->prev); -} - - - -pListitem AP_listitem_next(pListitem listitem) -{ - return(listitem->next); -} - - - - -void *AP_listitem_data(pListitem listitem) -{ - return(listitem->data ); -} - - - - -/***************************************************************/ - - - -/* - * AP_list_new(void) - * - * allocate an empty list return a pointer to it - * - */ - -pList AP_list_new(void) -{ - pList list; - - list=(pList)malloc(sizeof(List)); - - if (!list) - { - perror("AP_list_new: malloc failure\n"); - abort(); - } - - list->head=NULL; - list->tail=NULL; - list->count=0; - - headcount++; - return(list); -} - - - - - -/* - * AP_list_free(list) - * - * Free an entire list - * - */ - -void AP_list_free(pList list) -{ - pListitem next,cur; - int count; - - count=0; - cur=list->head; - - while(cur) - { - next=cur->next; - - AP_listitem_free(cur); - count++; - - cur=next; - } - - if (count!=list->count) - { - fprintf(stderr,"AP_list_free: count %d does not match actual length %d\n", - list->count,count); - abort(); - } - - headcount--; - free(list); -} - - - -/* - * AP_list_size(list) - * - * return the number of items in an ilist - * - */ - -int AP_list_size(pList list) -{ - return(list->count); -} - - - -/* - * AP_list_prepend(list,data) - * - * Prepend item to the front of list. - * - */ - -pListitem AP_list_prepend(pList list, void *data) -{ - pListitem new; - - new=AP_listitem_malloc(); - - new->data=data; - new->prev=NULL; - new->next=list->head; - -#ifdef CHECKS - new->list=list; -#endif - - if (list->head) - list->head->prev=new; - - list->head=new; - if (!list->tail) - list->tail=new; - - (list->count)++; - - return(new); -} - - - -/* - * AP_list_append(list,data) - * - * append item to end of list - * - */ - -pListitem AP_list_append(pList list, void *data) -{ - pListitem new; - - new=AP_listitem_malloc(); - new->data=data; - new->prev=list->tail; - new->next= NULL; - -#ifdef CHECKS - new->list= list; -#endif - - if (list->tail) - list->tail->next=new; - else - list->head=new; - - list->tail=new; - (list->count)++; - - return(new); -} - - - - - -/* - * AP_list_delete(list,data) - * - * delete item from list; return TRUE if successful - * - */ - -int AP_list_delete(pList list, void *data) -{ - pListitem item; - - if (item=AP_list_search(list,data)) - { - AP_list_delete_item(list,item); - return(1); - } - - return(0); -} - - - -void AP_list_delete_item(pList list, pListitem item) -{ - -#ifdef CHECKS - if (item->list != list) - { - fprintf(stderr,"AP_list_delete_item: item is not in list\n"); - abort(); - } -#endif - - /* set pointer of prior listitem */ - - if (item == list->head) - list->head = item->next; - else - item->prev->next = item->next; - - /* set pointer of following listitem */ - - if (item == list->tail) - list->tail = item->prev; - else - item->next->prev = item->prev; - - AP_listitem_free(item); - (list->count)--; -} - - - - -pListitem AP_list_head_item(pList list) -{ - return(list->head); -} - - - -int AP_list_head(pList list, void **data) -{ - if (list->head) - { - *data=list->head->data; - return(1); - } - else - return(0); -} - - - -int AP_list_tail(pList list, void **data) -{ - if (list->tail) - { - *data=list->tail->data; - return(1); - } - else - return(0); -} - - - - - -/* - * AP_list_print(str,list) - * - * Print out the message string followed by the - * items in the list - * - */ - -void AP_list_print(char *str, pList list) -{ - pListitem cur; - - printf("%s (%d items): ",str,list->count); - - cur=list->head; - while(cur) - { - printf("%d ",(int)cur->data); - cur=cur->next; - } - - printf("\n"); -} - - - - -/* - * AP_list_revprint(str,list) - * - * Print out the message string followed by the - * items in the list - * - */ - -void AP_list_revprint(char *str, pList list) -{ - pListitem cur; - - printf("%s (%d items): ",str,list->count); - - cur=list->tail; - while(cur) - { - printf("%d ",(int)cur->data); - cur=cur->prev; - } - - printf("\n"); -} - - - - -/* - * AP_list_search(list,data) - * - * Returns listitem if item appears in the list, otherwise NULL. - * - */ - - -pListitem AP_list_search(pList list, void *data) -{ - pListitem cur; - - cur=list->head; - - while (cur) - { - if (cur->data == data) - return(cur); - - cur=cur->next; - } - - return(NULL); -} - - -/* - * AP_list_search_func(list,func,data) - * - * Returns listitem if func(listitem->data,data) returns true - * - */ - - -pListitem AP_list_search_func(pList list, - int (*func)(void *item_data, void *fixed_data), - void *fixed_data) -{ - pListitem cur; - - cur=list->head; - - while (cur) - { - if ( (*func)(cur->data,fixed_data) ) - return(cur); - - cur=cur->next; - } - - return(NULL); -} - - - -/* - * AP_list_next(list,data,temp) - * - * like PList_next() except handles NULL pointers properly. - * - * initially, pass in (void **) NULL in 'temp' - * returns next list item through 'item' - * returns nonzero if there is a next item - * - */ - -int AP_list_next(pList list, void **data, void **temp) -{ - pListitem cur; - - if (*temp) /* temp is previous item */ - { - cur=(pListitem)(*temp); - cur=cur->next; - } - else /* First item */ - cur=list->head; - - if (cur) - { - *temp=(void *)cur; - *data=cur->data; - return(1); - } - else - return(0); -} - - -/* - * Compatibility routine for scorec list traversal - * Does not provide any way to differentiate - * between NULL in the list, and the end of the list - * - */ - -void *AP_list_braindead_next(pList list, void **temp) -{ - void *item; - - if (AP_list_next(list,&item,temp)) - return(item); - else - return(NULL); -} - - - -/* - * AP_list_duplicate(list) - * - * return a copy of the list - * (Note: caller is responsible for freeing this list) - * - */ - -pList AP_list_duplicate(pList list) -{ - pList newlist; - pListitem cur,new,prev; - - newlist=AP_list_new(); - prev=NULL; - - cur=list->head; - while(cur) - { - new=AP_listitem_malloc(); - new->data=cur->data; - new->prev=prev; - - if (prev) - prev->next=new; - else - newlist->head=new; - - prev=new; - - cur=cur->next; - } - - if (prev) - prev->next=NULL; - - newlist->tail=prev; - newlist->count=list->count; - return(newlist); -} - - - -int AP_list_apply(pList list, - int (*func)(void *item_data, void *fixed_data), - void *fixed_data) -{ - pListitem cur; - int total; - - total=0; - cur=list->head; - - while (cur) - { - total += (*func)(cur->data,fixed_data); - - cur=cur->next; - } - - return(total); -} - - - - -/* - * main for debugging - * - */ - - -#ifdef LISTMAIN - -int main() -{ - pList mylist, list2; - int i; - void *temp,*item; - pListitem next; - - mylist=AP_list_new(); - - for (i=1; i<10; i++) - { - AP_list_prepend(mylist,(void *)i); - AP_list_print("current",mylist); - AP_list_revprint(" rev",mylist); - } - - printf("Size %d\n",AP_list_size(mylist)); - - for (i=10; i<15; i++) - { - AP_list_append(mylist,(void *)i); - AP_list_print("new",mylist); - AP_list_revprint(" rev",mylist); - } - - AP_list_delete(mylist,(void *)5); - AP_list_print("less 5",mylist); - AP_list_revprint(" rev",mylist); - - AP_list_delete(mylist,(void *)9); - AP_list_print("less 9",mylist); - AP_list_revprint(" rev",mylist); - - AP_list_delete(mylist,(void *)14); - AP_list_print("less 14",mylist); - AP_list_revprint(" rev",mylist); - - AP_list_delete(mylist,(void *)2); - AP_list_print("less 2",mylist); - AP_list_revprint(" rev",mylist); - - if (!AP_list_delete(mylist,(void *)0)) - printf("(did not delete 0)\n"); - else - printf("ERROR - found 0\n"); - AP_list_print("less 0",mylist); - AP_list_revprint(" rev",mylist); - - if (AP_list_search(mylist,(void *)4)) - printf("Found 4\n"); - else - printf("Did not find 4\n"); - - if (AP_list_search(mylist,(void *)9)) - printf("Found 9\n"); - else - printf("Did not find 9\n"); - - printf("Traversal by AP_list_next()\n"); - temp=NULL; - while (AP_list_next(mylist,&item,&temp)) - printf(" Got item %d\n",(int)item); - - printf("Traversal by AP_listitem_next()\n"); - for (item=AP_list_head_item(mylist); item; item=AP_listitem_next(item)) - printf(" Got item %d\n",(int)(AP_listitem_data(item))); - - - list2=AP_list_duplicate(mylist); - AP_list_print("Original list",mylist); - AP_list_revprint(" rev",mylist); - AP_list_print("Duplicate ",list2); - AP_list_revprint(" rev",list2); - - AP_list_append(list2,(void *)99); - AP_list_print("Dup add 99 ",list2); - AP_list_revprint(" rev",list2); - - - printf("Traversal by AP_listitem_next(), deleting\n"); - i=0; - for (item=AP_list_head_item(list2); item; ) - { - printf(" Got item %d",(int)(AP_listitem_data(item))); - - next=AP_listitem_next(item); - - if (i%2) - { - AP_list_delete_item(list2,item); - printf(" - deleted\n"); - } - else - printf("\n"); - - item=next; - i++; - } - - AP_list_print("After delete-traversal",list2); - - AP_list_free(mylist); - AP_list_print("After del ",list2); - AP_list_revprint(" rev",list2); - - AP_list_free(list2); - - AP_listitem_verify(); - - return(0); -} -#endif diff --git a/cesm/models/utils/mct/mpi-serial/list.h b/cesm/models/utils/mct/mpi-serial/list.h deleted file mode 100644 index 34b03fa..0000000 --- a/cesm/models/utils/mct/mpi-serial/list.h +++ /dev/null @@ -1,45 +0,0 @@ -/* - * (C) 2000 UNIVERSITY OF CHICAGO - * See COPYRIGHT in top-level directory. - */ - - - - - -/****************************************************** - * WARNING: This file automatically generated. * - * Do not edit by hand. * - ****************************************************** - */ - - - - -extern int AP_listitem_verify(void); -extern pListitem AP_listitem_prev(pListitem listitem); -extern pListitem AP_listitem_next(pListitem listitem); -extern void *AP_listitem_data(pListitem listitem); -extern pList AP_list_new(void); -extern void AP_list_free(pList list); -extern int AP_list_size(pList list); -extern pListitem AP_list_prepend(pList list, void *data); -extern pListitem AP_list_append(pList list, void *data); -extern int AP_list_delete(pList list, void *data); -extern void AP_list_delete_item(pList list, pListitem item); -extern pListitem AP_list_head_item(pList list); -extern int AP_list_head(pList list, void **data); -extern int AP_list_tail(pList list, void **data); -extern void AP_list_print(char *str, pList list); -extern void AP_list_revprint(char *str, pList list); -extern pListitem AP_list_search(pList list, void *data); -extern int AP_list_next(pList list, void **data, void **temp); -extern void *AP_list_braindead_next(pList list, void **temp); -extern pList AP_list_duplicate(pList list); - - -extern pListitem AP_list_search_func(pList list, int (*func)(void *i, void *j),void *data); - -extern int AP_list_apply(pList list, int (*func)(void *item_data, void *fixed_data), void *data); - - diff --git a/cesm/models/utils/mct/mpi-serial/listP.h b/cesm/models/utils/mct/mpi-serial/listP.h deleted file mode 100644 index 77b892d..0000000 --- a/cesm/models/utils/mct/mpi-serial/listP.h +++ /dev/null @@ -1,33 +0,0 @@ -/* - * (C) 2000 UNIVERSITY OF CHICAGO - * See COPYRIGHT in top-level directory. - */ - - - -/* - * Private data structures for the list - * - */ - - -typedef struct _List -{ - pListitem head; - pListitem tail; - int count; -} List; - - -typedef struct _Listitem -{ - void *data; - pListitem prev; - pListitem next; - -#ifdef CHECKS - pList list; -#endif - -} Listitem; - diff --git a/cesm/models/utils/mct/mpi-serial/listops.h b/cesm/models/utils/mct/mpi-serial/listops.h deleted file mode 100644 index 0c28e8e..0000000 --- a/cesm/models/utils/mct/mpi-serial/listops.h +++ /dev/null @@ -1,23 +0,0 @@ -/* - * (C) 2000 UNIVERSITY OF CHICAGO - * See COPYRIGHT in top-level directory. - */ - - - - -#ifndef _listops_h -#define _listops_h - -/* - * Support for singly-linked list of pointers (or ints) - * - */ - - -typedef struct _List *pList; -typedef struct _Listitem *pListitem; - -#include "list.h" - -#endif diff --git a/cesm/models/utils/mct/mpi-serial/make-mpif b/cesm/models/utils/mct/mpi-serial/make-mpif deleted file mode 100755 index 2a28185..0000000 --- a/cesm/models/utils/mct/mpi-serial/make-mpif +++ /dev/null @@ -1,25 +0,0 @@ -#!/bin/bash - -# usage: make-mpif -# e.g. make-mpif 4 8 -# -# from the template in mpif.master.h, creates mpif.realXdoubleY.h file -# - -set -e - -if [ $# -ne 2 ] - then echo 'Usage: make-mpif ' - exit 1 -fi - -RSIZE=$1 -DSIZE=$2 - -DEST=mpif.real${RSIZE}double${DSIZE}.h -/bin/rm -f $DEST - -sed -e s/_RSIZE_/$RSIZE/ -e s/_DSIZE_/$DSIZE/ $DEST -chmod -w $DEST - - diff --git a/cesm/models/utils/mct/mpi-serial/mpi.c b/cesm/models/utils/mct/mpi-serial/mpi.c deleted file mode 100644 index d243209..0000000 --- a/cesm/models/utils/mct/mpi-serial/mpi.c +++ /dev/null @@ -1,284 +0,0 @@ - - -#include "mpiP.h" - - -/****************************************************************************/ - -static int initialized=0; - - -/****************************************************************************/ - - -/* - * INIT/FINALIZE - * - */ - - - -FC_FUNC( mpi_init_fort , MPI_INIT_FORT) - (int *f_MPI_COMM_WORLD, - int *f_MPI_ANY_SOURCE, int *f_MPI_ANY_TAG, - int *f_MPI_PROC_NULL, int *f_MPI_ROOT, - int *f_MPI_COMM_NULL, int *f_MPI_REQUEST_NULL, - int *f_MPI_GROUP_NULL, int *f_MPI_GROUP_EMPTY, - int *f_MPI_UNDEFINED, - int *f_MPI_MAX_ERROR_STRING, - int *f_MPI_MAX_PROCESSOR_NAME, - int *f_MPI_STATUS_SIZE, - int *f_MPI_SOURCE, int *f_MPI_TAG, int *f_MPI_ERROR, - int *f_status, - int *fsource, int *ftag, int *ferror, - int *f_MPI_INTEGER, void *fint1, void *fint2, - int *f_MPI_LOGICAL, void *flog1, void *flog2, - int *f_MPI_REAL, void *freal1, void *freal2, - int *f_MPI_DOUBLE_PRECISION, - void *fdub1, void *fdub2, - int *f_MPI_COMPLEX, void *fcomp1, void *fcomp2, - int *ierror) -{ - int err; - int size; - int offset; - - *ierror=MPI_Init(NULL,NULL); - - err=0; - - /* - * These 3 macros compare things from mpif.h (as passed in by the f_ - * arguments) to the values in C (from #including mpi.h). - * - * Unfortunately, this kind of thing is done most easily in a nasty - * looking macto. - * - */ - - - /* - * verify_eq - * compare value of constants in C and fortran - * i.e. compare *f_ to - */ - -#define verify_eq(name) \ - if (*f_##name != name) \ - { fprintf(stderr,"mpi-serial: mpi_init_fort: %s not consistant " \ - "between mpif.h (%d) and mpi.h (%d)\n",\ - #name,*f_##name,name); \ - err=1; } - -#define verify_eq_warn(name) \ - if (*f_##name != name) \ - { fprintf(stderr,"mpi-serial: mpi_init_fort: warning: %s not consistant " \ - "between mpif.h (%d) and mpi.h (%d)\n",\ - #name,*f_##name,name); \ - } - - - /* - * verify_size - * verify that the type name in fortran has the correct - * value (i.e. the size of that data type). - * Determine size by subtracting the pointer values of two - * consecutive array locations. - */ - -#define verify_size(name,p1,p2) \ - if ( (size=((char *)(p2) - (char *)(p1))) != *f_##name ) \ - { fprintf(stderr,"mpi-serial: mpi_init_fort: mpif.h %s (%d) " \ - "does not match actual fortran size (%d)\n", \ - #name,*f_##name,size); \ - err=1; } - - /* - * verify_field - * check the struct member offsets for MPI_Status vs. the - * fortan integer array offsets. E.g. the location of - * status->MPI_SOURCE should be the same as STATUS(MPI_SOURCE) - */ - -#define verify_field(name) \ - { offset= (char *)&((MPI_Status *)f_status)->name - (char *)f_status; \ - if ( offset != (*f_##name-1)*sizeof(int) ) \ - { fprintf(stderr,"mpi-serial: mpi_init_fort: mpif.h %s (%d) (%d bytes) " \ - "is inconsistant w/offset in MPI_Status (%d bytes)\n", \ - #name,*f_##name,(*f_##name-1)*sizeof(int),offset); \ - err=1; }} - - - - verify_eq(MPI_COMM_WORLD); - verify_eq(MPI_ANY_SOURCE); - verify_eq(MPI_ANY_TAG); - verify_eq(MPI_PROC_NULL); - verify_eq(MPI_ROOT); - verify_eq(MPI_COMM_NULL); - verify_eq(MPI_REQUEST_NULL); - verify_eq(MPI_GROUP_NULL); - verify_eq(MPI_GROUP_EMPTY); - verify_eq(MPI_UNDEFINED); - verify_eq(MPI_MAX_ERROR_STRING); - verify_eq(MPI_MAX_PROCESSOR_NAME); - - verify_eq(MPI_STATUS_SIZE); - verify_field(MPI_SOURCE); - verify_field(MPI_TAG); - verify_field(MPI_ERROR); - - verify_eq(MPI_INTEGER); - verify_size(MPI_INTEGER,fint1,fint2); - - verify_size(MPI_LOGICAL,flog1,flog2); - - verify_eq_warn(MPI_REAL); - verify_size(MPI_REAL,freal1,freal2); - - verify_eq(MPI_DOUBLE_PRECISION); - verify_size(MPI_DOUBLE_PRECISION,fdub1,fdub2); - - verify_size(MPI_COMPLEX,fcomp1,fcomp2); - - if (err) - abort(); -} - - - -int MPI_Init(int *argc, char **argv[]) -{ - MPI_Comm my_comm_world; - - if (sizeof(MPI_Aint) < sizeof(void *)) - { - fprintf(stderr, "mpi-serial: MPI_Init: " - "MPI_Aint is not large enough for void *\n"); - abort(); - } - - my_comm_world=mpi_comm_new(); - - if (my_comm_world != MPI_COMM_WORLD) - { - fprintf(stderr,"MPI_Init: conflicting MPI_COMM_WORLD\n"); - abort(); - } - - initialized=1; - return(MPI_SUCCESS); -} - - -/*********/ - - -FC_FUNC( mpi_finalize, MPI_FINALIZE )(int *ierror) -{ - *ierror=MPI_Finalize(); -} - - -/* - * MPI_Finalize() - * - * this library doesn't support re-initializing MPI, so - * the finalize will just leave everythign as it is... - * - */ - - -int MPI_Finalize(void) -{ - initialized=0; - - mpi_destroy_handles(); - - return(MPI_SUCCESS); -} - - -/*********/ - - -FC_FUNC( mpi_abort , MPI_ABORT )(int *comm, int *errorcode, int *ierror) -{ - *ierror=MPI_Abort( *comm, *errorcode); -} - - - -int MPI_Abort(MPI_Comm comm, int errorcode) -{ - fprintf(stderr,"MPI_Abort: error code = %d\n",errorcode); - exit(errorcode); -} - - -/*********/ - - - -FC_FUNC( mpi_error_string , MPI_ERROR_STRING) - (int *errorcode, char *string, - int *resultlen, int *ierror) -{ - *ierror=MPI_Error_string(*errorcode, string, resultlen); -} - - -int MPI_Error_string(int errorcode, char *string, int *resultlen) -{ - sprintf(string,"MPI Error: code %d\n",errorcode); - *resultlen=strlen(string); - - return(MPI_SUCCESS); -} - - -/*********/ - - -FC_FUNC( mpi_get_processor_name , MPI_GET_PROCESSOR_NAME ) - (char *name, int *resultlen, int *ierror) -{ - *ierror=MPI_Get_processor_name(name,resultlen); -} - - -int MPI_Get_processor_name(char *name, int *resultlen) -{ - int ret; - - ret=gethostname(name,MPI_MAX_PROCESSOR_NAME); - - if (ret!=0) - strncpy(name,"unknown host name",MPI_MAX_PROCESSOR_NAME); - - - name[MPI_MAX_PROCESSOR_NAME-1]='\0'; /* make sure NULL terminated */ - *resultlen=strlen(name); - - return(MPI_SUCCESS); -} - - -/*********/ - - -FC_FUNC( mpi_initialized , MPI_INITIALIZED )(int *flag, int *ierror) -{ - *ierror=MPI_Initialized(flag); -} - - -int MPI_Initialized(int *flag) -{ - *flag= initialized; - - return(MPI_SUCCESS); -} - - - diff --git a/cesm/models/utils/mct/mpi-serial/mpi.h b/cesm/models/utils/mct/mpi-serial/mpi.h deleted file mode 100644 index f33fa5b..0000000 --- a/cesm/models/utils/mct/mpi-serial/mpi.h +++ /dev/null @@ -1,308 +0,0 @@ - -#ifndef _MPI_H_ -#define _MPI_H_ - - -typedef int MPI_Comm; -typedef int MPI_Request; - - -#define MPI_COMM_WORLD (1) -#define MPI_COMM_NULL (0) /* handle 0 maps to NULL */ - - -typedef int MPI_Group; - -/* MPI_GROUP_EMPTY and MPI_GROUP_NULL must not conflict with MPI_GROUP_ONE */ -#define MPI_GROUP_EMPTY (-1) -#define MPI_GROUP_NULL (0) - - -/* - * Return codes - * On error, mpi-serial aborts so the values don't really matter - * as long as they are different than MPI_SUCCESS - * - */ - -#define MPI_SUCCESS (0) -#define MPI_ERR_BUFFER (-1) -#define MPI_ERR_COUNT (-1) -#define MPI_ERR_TYPE (-1) -#define MPI_ERR_TAG (-1) -#define MPI_ERR_COMM (-1) -#define MPI_ERR_RANK (-1) -#define MPI_ERR_REQUEST (-1) -#define MPI_ERR_ROOT (-1) -#define MPI_ERR_GROUP (-1) -#define MPI_ERR_OP (-1) -#define MPI_ERR_TOPOLOGY (-1) -#define MPI_ERR_DIMS (-1) -#define MPI_ERR_ARG (-1) -#define MPI_ERR_UNKNOWN (-1) -#define MPI_ERR_TRUNCATE (-1) -#define MPI_ERR_OTHER (-1) -#define MPI_ERR_INTERN (-1) -#define MPI_PENDING (-1) -#define MPI_ERR_IN_STATUS (-1) -#define MPI_ERR_LASTCODE (-1) - - -/* - * MPI_UNDEFINED - * - * Uses: - * value for "color" in e.g. comm_split - * value for rank in Group_translate_ranks - * - */ - - -#define MPI_UNDEFINED (-1) - - -/* - * Data types etc. - */ - -typedef unsigned long int MPI_Aint; -#define MPI_BOTTOM (0) -typedef int MPI_Datatype; - - -/* The type's value is its size in bytes */ - -#define MPI_DATATYPE_NULL (0) -#define MPI_BYTE (sizeof(char)) -#define MPI_CHAR (sizeof(char)) -#define MPI_UNSIGNED_CHAR (sizeof(unsigned char)) -#define MPI_SHORT (sizeof(short)) -#define MPI_UNSIGNED_SHORT (sizeof(unsigned short)) -#define MPI_INT (sizeof(int)) -#define MPI_UNSIGNED (sizeof(unsigned)) -#define MPI_LONG (sizeof(long)) -#define MPI_UNSIGNED_LONG (sizeof(unsigned long)) -#define MPI_FLOAT (sizeof(float)) -#define MPI_DOUBLE (sizeof(double)) -#define MPI_LONG_DOUBLE (sizeof(long double)) -#define MPI_PACKED (sizeof(char)) - -/* types for MINLOC and MAXLOC */ - -#define MPI_FLOAT_INT (sizeof(struct{float a; int b;})) -#define MPI_DOUBLE_INT (sizeof(struct{double a; int b;})) -#define MPI_LONG_INT (sizeof(struct{long a; int b;})) -#define MPI_2INT (sizeof(struct{int a; int b;})) -#define MPI_SHORT_INT (sizeof (struct{short a; int b;})) -#define MPI_LONG_DOUBLE_INT (sizeof (struct{long double a; int b;})) - -/* size-specific types */ - -#define MPI_INTEGER1 (1) -#define MPI_INTEGER2 (2) -#define MPI_INTEGER4 (4) -#define MPI_INTEGER8 (8) -#define MPI_INTEGER16 (16) - -#define MPI_REAL4 (4) -#define MPI_REAL8 (8) -#define MPI_REAL16 (16) - - - -/* - * Fortran int size - * - */ - -typedef int MPI_Fint; - - - -#define MPI_ANY_TAG (-1) - -#define MPI_ANY_SOURCE (-1) -#define MPI_PROC_NULL (-2) -#define MPI_ROOT (-3) - -#define MPI_REQUEST_NULL (0) - -#define MPI_MAX_ERROR_STRING (128) -#define MPI_MAX_PROCESSOR_NAME (128) - - -/* - * MPI_Status - * - * definition must be compatible with the mpif.h values for - * MPI_STATUS_SIZE, MPI_SOURCE, MPI_TAG, and MPI_ERROR. - * - * Note: The type used for MPI_Status_int must be chosen to match - * Fortran INTEGER. - * - */ - -typedef int MPI_Status_int; - -typedef struct /* Fortran: INTEGER status(MPI_STATUS_SIZE) */ -{ - MPI_Status_int MPI_SOURCE; /* Fortran: status(MPI_SOURCE) */ - MPI_Status_int MPI_TAG; /* Fortran: status(MPI_TAG) */ - MPI_Status_int MPI_ERROR; /* Fortran: status(MPI_ERROR) */ - -} MPI_Status; - - -/* - * Collective operations - */ - - -typedef int MPI_Op; - -typedef void MPI_User_function( void *invec, void *inoutvec, int *len, - MPI_Datatype *datatype); - -#define MPI_OP_NULL (0) - -#define MPI_MAX (0) -#define MPI_MIN (0) -#define MPI_SUM (0) -#define MPI_PROD (0) -#define MPI_LAND (0) -#define MPI_BAND (0) -#define MPI_LOR (0) -#define MPI_BOR (0) -#define MPI_LXOR (0) -#define MPI_BXOR (0) -#define MPI_MAXLOC (0) -#define MPI_MINLOC (0) - - - -/* - * These are provided for Fortran... - */ - - -#define MPI_INTEGER MPI_INT -#define MPI_REAL MPI_FLOAT -#define MPI_DOUBLE_PRECISION MPI_DOUBLE - -#define MPI_STATUS_SIZE (sizeof(MPI_Status) / sizeof(int)) - - -/********************************************************** - * - * Note: if you need to regenerate the prototypes below, - * you can use 'protify.awk' and paste the output here. - * - */ - - -extern int MPI_Barrier(MPI_Comm comm ); -extern int MPI_Bcast(void* buffer, int count, MPI_Datatype datatype, - int root, MPI_Comm comm ); -extern int MPI_Gather(void* sendbuf, int sendcount, MPI_Datatype sendtype, - void* recvbuf, int recvcount, MPI_Datatype recvtype, - int root, MPI_Comm comm); -extern int MPI_Gatherv(void* sendbuf, int sendcount, MPI_Datatype sendtype, - void* recvbuf, int *recvcounts, int *displs, - MPI_Datatype recvtype, int root, MPI_Comm comm); -extern int MPI_Allgather(void* sendbuf, int sendcount, MPI_Datatype sendtype, - void* recvbuf, int recvcount, MPI_Datatype recvtype, - MPI_Comm comm); -extern int MPI_Allgatherv(void* sendbuf, int sendcount, MPI_Datatype sendtype, - void* recvbuf, int *recvcounts, int *displs, - MPI_Datatype recvtype, MPI_Comm comm); -extern int MPI_Scatter( void* sendbuf, int sendcount, MPI_Datatype sendtype, - void* recvbuf, int recvcount, MPI_Datatype recvtype, - int root, MPI_Comm comm); -extern int MPI_Scatterv(void* sendbuf, int *sendcounts, int *displs, - MPI_Datatype sendtype, void* recvbuf, int recvcount, - MPI_Datatype recvtype, int root, MPI_Comm comm); -extern int MPI_Reduce(void* sendbuf, void* recvbuf, int count, - MPI_Datatype datatype, MPI_Op op, int root, MPI_Comm comm); -extern int MPI_Allreduce(void* sendbuf, void* recvbuf, int count, - MPI_Datatype datatype, MPI_Op op, MPI_Comm comm); -extern int MPI_Scan( void* sendbuf, void* recvbuf, int count, - MPI_Datatype datatype, MPI_Op op, MPI_Comm comm); -extern int MPI_Alltoall(void *sendbuf, int sendcount, MPI_Datatype sendtype, - void *recvbuf, int recvcount, MPI_Datatype recvtype, - MPI_Comm comm); -extern int MPI_Alltoallv(void *sendbuf, int *sendcounts, - int *sdispls, MPI_Datatype sendtype, - void *recvbuf, int *recvcounts, - int *rdispls, MPI_Datatype recvtype, - MPI_Comm comm) ; -extern int MPI_Op_create(MPI_User_function *function, int commute, - MPI_Op *op); -extern MPI_Op MPI_Op_f2c(MPI_Fint op); -extern MPI_Fint MPI_Op_c2f(MPI_Op op); -extern MPI_Comm mpi_comm_new(void); -extern int MPI_Comm_free(MPI_Comm *comm); -extern int MPI_Comm_size(MPI_Comm comm, int *size); -extern int MPI_Comm_rank(MPI_Comm comm, int *rank); -extern int MPI_Comm_dup(MPI_Comm comm, MPI_Comm *newcomm); -extern int MPI_Comm_create(MPI_Comm comm, MPI_Group group, MPI_Comm *newcomm); -extern int MPI_Comm_split(MPI_Comm comm, int color, int key, MPI_Comm *newcomm); -extern int MPI_Comm_group(MPI_Comm comm, MPI_Group *group); -extern MPI_Comm MPI_Comm_f2c(MPI_Fint comm); -extern MPI_Fint MPI_Comm_c2f(MPI_Comm comm); -extern int MPI_Group_incl(MPI_Group group, int n, int *ranks, MPI_Group *newgroup); -extern int MPI_Group_range_incl(MPI_Group group, int n, int ranges[][3], - MPI_Group *newgroup); -extern int MPI_Group_union(MPI_Group group1, MPI_Group group2, MPI_Group *newgroup); -extern int MPI_Group_intersection(MPI_Group group1, MPI_Group group2, - MPI_Group *newgroup); -extern int MPI_Group_difference(MPI_Group group1, MPI_Group group2, - MPI_Group *newgroup); -extern int MPI_Group_free(MPI_Group *group); -extern int MPI_Group_translate_ranks(MPI_Group group1, int n, int *ranks1, - MPI_Group group2, int *ranks2); -extern MPI_Group MPI_Group_f2c(MPI_Fint group); -extern MPI_Fint MPI_Group_c2f(MPI_Group group); - -extern int MPI_Init(int *argc, char **argv[]) ; -extern int MPI_Finalize(void); -extern int MPI_Abort(MPI_Comm comm, int errorcode); -extern int MPI_Error_string(int errorcode, char *string, int *resultlen); -extern int MPI_Get_processor_name(char *name, int *resultlen); -extern int MPI_Initialized(int *flag); -extern int MPI_Pack( void *inbuf, int incount, MPI_Datatype datatype, - void *outbuf, int outsize, int *position, MPI_Comm comm); -extern int MPI_Unpack( void *inbuf, int insize, int *position, - void *outbuf, int outcount, MPI_Datatype datatype, - MPI_Comm comm ); -extern int MPI_Irecv(void *buf, int count, MPI_Datatype datatype, - int source, int tag, MPI_Comm comm, MPI_Request *request); -extern int MPI_Recv(void *buf, int count, MPI_Datatype datatype, int source, - int tag, MPI_Comm comm, MPI_Status *status); - -extern int MPI_Test(MPI_Request *request, int *flag, MPI_Status *status); -extern int MPI_Wait(MPI_Request *request, MPI_Status *status); -extern int MPI_Waitany(int count, MPI_Request *array_of_requests, - int *index, MPI_Status *status); -extern int MPI_Waitall(int count, MPI_Request *array_of_requests, - MPI_Status *array_of_statuses); -extern MPI_Request MPI_Request_f2c(MPI_Fint request); -extern MPI_Fint MPI_Request_c2f(MPI_Request request); -extern int MPI_Isend(void *buf, int count, MPI_Datatype datatype, - int dest, int tag, MPI_Comm comm, MPI_Request *request) ; -extern int MPI_Send(void* buf, int count, MPI_Datatype datatype, - int dest, int tag, MPI_Comm comm); -extern int MPI_Ssend(void* buf, int count, MPI_Datatype datatype, - int dest, int tag, MPI_Comm comm); -extern int MPI_Rsend(void* buf, int count, MPI_Datatype datatype, - int dest, int tag, MPI_Comm comm); -extern int MPI_Irsend(void *buf, int count, MPI_Datatype datatype, - int dest, int tag, MPI_Comm comm, MPI_Request *request) ; -extern int MPI_Sendrecv(void* sendbuf, int sendcount, MPI_Datatype sendtype, - int dest, int sendtag, - void *recvbuf, int recvcount, MPI_Datatype recvtype, - int source, int recvtag, - MPI_Comm comm, MPI_Status *status); -extern double MPI_Wtime(void);; -extern double MPI_Wtime(void); - -#endif diff --git a/cesm/models/utils/mct/mpi-serial/mpiP.h b/cesm/models/utils/mct/mpi-serial/mpiP.h deleted file mode 100644 index 27eed74..0000000 --- a/cesm/models/utils/mct/mpi-serial/mpiP.h +++ /dev/null @@ -1,64 +0,0 @@ - -/* - * Private .h file for MPI - */ - - -#include -#include -#include -#include - -#include "listops.h" -#include "mpi.h" -#include "config.h" - -/* - * MPI_GROUP_ONE must not conflict with MPI_GROUP_NULL or - * MPI_GROUP_EMPTY - */ - -#define MPI_GROUP_ONE (1) - - -/****************************************************************************/ - - -typedef struct -{ - pList sendlist; - pList recvlist; - - int num; - -} Comm; - - - -typedef struct -{ - pListitem listitem; /* to allow Req to be removed from list */ - - int *buf; - int source; - int tag; - int complete; - -} Req; - - - - -/****************************************************************************/ - - -extern void *mpi_malloc(int size); -extern void mpi_free(void *ptr); - -extern MPI_Comm mpi_comm_new(void); - -extern void mpi_destroy_handles(void); -extern void mpi_alloc_handle(int *handle, void **data); -extern void *mpi_handle_to_ptr(int handle); -extern void mpi_free_handle(int handle); - diff --git a/cesm/models/utils/mct/mpi-serial/mpif.master.h b/cesm/models/utils/mct/mpi-serial/mpif.master.h deleted file mode 100644 index 47df246..0000000 --- a/cesm/models/utils/mct/mpi-serial/mpif.master.h +++ /dev/null @@ -1,291 +0,0 @@ - -!!! -!!! NOTE: The files mpif.realXdoubleY.h are generated from -!!! mpif.master.h using make-mpif and later copied to mpif.h -!!! during the library make. All modifications should be -!!! made to mpif.master.h -!!! - - -! -! MPI_COMM_WORLD -! - - INTEGER MPI_COMM_WORLD - parameter (mpi_comm_world=1) - -! -! -! - - integer MPI_BOTTOM - parameter (MPI_BOTTOM=0) - - -! -! source,tag -! - - integer MPI_ANY_SOURCE, MPI_ANY_TAG - parameter (mpi_any_source=-1, mpi_any_tag= -1) - - integer MPI_PROC_NULL, MPI_ROOT - parameter (MPI_PROC_NULL=-2, MPI_ROOT=-3) - - integer MPI_COMM_NULL, MPI_REQUEST_NULL - parameter (MPI_COMM_NULL=0, MPI_REQUEST_NULL=0) - - integer MPI_GROUP_NULL, MPI_GROUP_EMPTY - parameter (MPI_GROUP_NULL=0, MPI_GROUP_EMPTY= -1) - - integer MPI_MAX_ERROR_STRING - parameter (MPI_MAX_ERROR_STRING=128) - - integer MPI_MAX_PROCESSOR_NAME - parameter (MPI_MAX_PROCESSOR_NAME=128) - -! -! Return codes -! - - integer MPI_SUCCESS - parameter (MPI_SUCCESS=0) - - integer MPI_ERR_BUFFER - parameter (MPI_ERR_BUFFER= -1) - - integer MPI_ERR_COUNT - parameter (MPI_ERR_COUNT= -1) - - integer MPI_ERR_TYPE - parameter (MPI_ERR_TYPE= -1) - - integer MPI_ERR_TAG - parameter (MPI_ERR_TAG= -1) - - integer MPI_ERR_COMM - parameter (MPI_ERR_COMM= -1) - - integer MPI_ERR_RANK - parameter (MPI_ERR_RANK= -1) - - integer MPI_ERR_REQUEST - parameter (MPI_ERR_REQUEST= -1) - - integer MPI_ERR_ROOT - parameter (MPI_ERR_ROOT= -1) - - integer MPI_ERR_GROUP - parameter (MPI_ERR_GROUP= -1) - - integer MPI_ERR_OP - parameter (MPI_ERR_OP= -1) - - integer MPI_ERR_TOPOLOGY - parameter (MPI_ERR_TOPOLOGY= -1) - - integer MPI_ERR_DIMS - parameter (MPI_ERR_DIMS= -1) - - integer MPI_ERR_ARG - parameter (MPI_ERR_ARG= -1) - - integer MPI_ERR_UNKNOWN - parameter (MPI_ERR_UNKNOWN= -1) - - integer MPI_ERR_TRUNCATE - parameter (MPI_ERR_TRUNCATE= -1) - - integer MPI_ERR_OTHER - parameter (MPI_ERR_OTHER= -1) - - integer MPI_ERR_INTERN - parameter (MPI_ERR_INTERN= -1) - - integer MPI_PENDING - parameter (MPI_PENDING= -1) - - integer MPI_ERR_IN_STATUS - parameter (MPI_ERR_IN_STATUS= -1) - - integer MPI_ERR_LASTCODE - parameter (MPI_ERR_LASTCODE= -1) - -! -! - - - integer MPI_UNDEFINED - parameter (MPI_UNDEFINED= -1) - - -! -! MPI_Status -! -! The values in this section MUST match the struct definition -! in mpi.h -! - - - INTEGER MPI_STATUS_SIZE - PARAMETER (MPI_STATUS_SIZE=3) - - INTEGER MPI_SOURCE, MPI_TAG, MPI_ERROR - PARAMETER(MPI_SOURCE=1, MPI_TAG=2, MPI_ERROR=3) - - - -! -! MPI_Datatype values -! -! The value is the size of the datatype in bytes. -! Change if necessary for the machine in question. -! (The mpi.h file uses sizeof(), so it should be more -! portable). -! -! - - - INTEGER MPI_DATATYPE_NULL - PARAMETER (MPI_DATATYPE_NULL=0) - - INTEGER MPI_BYTE - PARAMETER (MPI_BYTE=1) - - INTEGER MPI_CHARACTER - PARAMETER (MPI_CHARACTER=1) - - INTEGER MPI_INTEGER - PARAMETER (MPI_INTEGER=4) - - INTEGER MPI_LOGICAL - PARAMETER (MPI_LOGICAL=4) - -!!!!!!! - INTEGER MPI_REAL - PARAMETER (MPI_REAL=_RSIZE_) - - INTEGER MPI_DOUBLE_PRECISION - PARAMETER (MPI_DOUBLE_PRECISION=_DSIZE_) -!!!!!!! - - integer MPI_COMPLEX - parameter (MPI_COMPLEX=2*MPI_REAL) - - integer MPI_2REAL - parameter (MPI_2REAL=2*MPI_REAL) - - integer MPI_2DOUBLE_PRECISION - parameter (MPI_2DOUBLE_PRECISION=2*MPI_DOUBLE_PRECISION) - - integer MPI_2INTEGER - parameter (MPI_2INTEGER=2*MPI_INTEGER) - - integer MPI_PACKED - parameter (MPI_PACKED=1) - - -! -! Size-specific types -! - - INTEGER MPI_REAL4 - PARAMETER (MPI_REAL4=4) - - INTEGER MPI_REAL8 - PARAMETER (MPI_REAL8=8) - - INTEGER MPI_REAL16 - PARAMETER (MPI_REAL16=16) - - - integer MPI_COMPLEX8 - parameter (MPI_COMPLEX8=8) - - integer MPI_COMPLEX16 - parameter (MPI_COMPLEX16=16) - - integer MPI_COMPLEX32 - parameter (MPI_COMPLEX32=32) - - - INTEGER MPI_INTEGER1 - PARAMETER (MPI_INTEGER1=1) - - INTEGER MPI_INTEGER2 - PARAMETER (MPI_INTEGER2=2) - - INTEGER MPI_INTEGER4 - PARAMETER (MPI_INTEGER4=4) - - INTEGER MPI_INTEGER8 - PARAMETER (MPI_INTEGER8=8) - - INTEGER MPI_INTEGER16 - PARAMETER (MPI_INTEGER16=16) - - - -! -! MPI_Op values -! -! (All are handled as no-op so no value is necessary; but provide one -! anyway just in case.) -! - - INTEGER MPI_SUM - PARAMETER (MPI_SUM=0) - INTEGER MPI_MAX - PARAMETER (MPI_MAX=0) - INTEGER MPI_MIN - PARAMETER (MPI_MIN=0) - INTEGER MPI_PROD - PARAMETER (MPI_PROD=0) - INTEGER MPI_LAND - PARAMETER (MPI_LAND=0) - INTEGER MPI_BAND - PARAMETER (MPI_BAND=0) - INTEGER MPI_LOR - PARAMETER (MPI_LOR=0) - INTEGER MPI_BOR - PARAMETER (MPI_BOR=0) - INTEGER MPI_LXOR - PARAMETER (MPI_LXOR=0) - INTEGER MPI_BXOR - PARAMETER (MPI_BXOR=0) - INTEGER MPI_MINLOC - PARAMETER (MPI_MINLOC=0) - INTEGER MPI_MAXLOC - PARAMETER (MPI_MAXLOC=0) - INTEGER MPI_OP_NULL - PARAMETER (MPI_OP_NULL=0) - -! -! MPI_Wtime -! - - DOUBLE PRECISION MPI_WTIME - EXTERNAL MPI_WTIME - - -! -! Kinds -! - - INTEGER MPI_OFFSET_KIND - PARAMETER (MPI_OFFSET_KIND=selected_int_kind(13)) - - INTEGER MPI_INFO_NULL - PARAMETER (MPI_INFO_NULL=0) - - INTEGER MPI_MODE_RDONLY - PARAMETER (MPI_MODE_RDONLY=0) - - INTEGER MPI_MODE_CREATE - PARAMETER (MPI_MODE_CREATE=1) - - INTEGER MPI_MODE_RDWR - PARAMETER (MPI_MODE_RDWR=2) - - - diff --git a/cesm/models/utils/mct/mpi-serial/mpif.real4double8.h b/cesm/models/utils/mct/mpi-serial/mpif.real4double8.h deleted file mode 100644 index 0fd9a58..0000000 --- a/cesm/models/utils/mct/mpi-serial/mpif.real4double8.h +++ /dev/null @@ -1,291 +0,0 @@ - -!!! -!!! NOTE: The files mpif.realXdoubleY.h are generated from -!!! mpif.master.h using make-mpif and later copied to mpif.h -!!! during the library make. All modifications should be -!!! made to mpif.master.h -!!! - - -! -! MPI_COMM_WORLD -! - - INTEGER MPI_COMM_WORLD - parameter (mpi_comm_world=1) - -! -! -! - - integer MPI_BOTTOM - parameter (MPI_BOTTOM=0) - - -! -! source,tag -! - - integer MPI_ANY_SOURCE, MPI_ANY_TAG - parameter (mpi_any_source=-1, mpi_any_tag= -1) - - integer MPI_PROC_NULL, MPI_ROOT - parameter (MPI_PROC_NULL=-2, MPI_ROOT=-3) - - integer MPI_COMM_NULL, MPI_REQUEST_NULL - parameter (MPI_COMM_NULL=0, MPI_REQUEST_NULL=0) - - integer MPI_GROUP_NULL, MPI_GROUP_EMPTY - parameter (MPI_GROUP_NULL=0, MPI_GROUP_EMPTY= -1) - - integer MPI_MAX_ERROR_STRING - parameter (MPI_MAX_ERROR_STRING=128) - - integer MPI_MAX_PROCESSOR_NAME - parameter (MPI_MAX_PROCESSOR_NAME=128) - -! -! Return codes -! - - integer MPI_SUCCESS - parameter (MPI_SUCCESS=0) - - integer MPI_ERR_BUFFER - parameter (MPI_ERR_BUFFER= -1) - - integer MPI_ERR_COUNT - parameter (MPI_ERR_COUNT= -1) - - integer MPI_ERR_TYPE - parameter (MPI_ERR_TYPE= -1) - - integer MPI_ERR_TAG - parameter (MPI_ERR_TAG= -1) - - integer MPI_ERR_COMM - parameter (MPI_ERR_COMM= -1) - - integer MPI_ERR_RANK - parameter (MPI_ERR_RANK= -1) - - integer MPI_ERR_REQUEST - parameter (MPI_ERR_REQUEST= -1) - - integer MPI_ERR_ROOT - parameter (MPI_ERR_ROOT= -1) - - integer MPI_ERR_GROUP - parameter (MPI_ERR_GROUP= -1) - - integer MPI_ERR_OP - parameter (MPI_ERR_OP= -1) - - integer MPI_ERR_TOPOLOGY - parameter (MPI_ERR_TOPOLOGY= -1) - - integer MPI_ERR_DIMS - parameter (MPI_ERR_DIMS= -1) - - integer MPI_ERR_ARG - parameter (MPI_ERR_ARG= -1) - - integer MPI_ERR_UNKNOWN - parameter (MPI_ERR_UNKNOWN= -1) - - integer MPI_ERR_TRUNCATE - parameter (MPI_ERR_TRUNCATE= -1) - - integer MPI_ERR_OTHER - parameter (MPI_ERR_OTHER= -1) - - integer MPI_ERR_INTERN - parameter (MPI_ERR_INTERN= -1) - - integer MPI_PENDING - parameter (MPI_PENDING= -1) - - integer MPI_ERR_IN_STATUS - parameter (MPI_ERR_IN_STATUS= -1) - - integer MPI_ERR_LASTCODE - parameter (MPI_ERR_LASTCODE= -1) - -! -! - - - integer MPI_UNDEFINED - parameter (MPI_UNDEFINED= -1) - - -! -! MPI_Status -! -! The values in this section MUST match the struct definition -! in mpi.h -! - - - INTEGER MPI_STATUS_SIZE - PARAMETER (MPI_STATUS_SIZE=3) - - INTEGER MPI_SOURCE, MPI_TAG, MPI_ERROR - PARAMETER(MPI_SOURCE=1, MPI_TAG=2, MPI_ERROR=3) - - - -! -! MPI_Datatype values -! -! The value is the size of the datatype in bytes. -! Change if necessary for the machine in question. -! (The mpi.h file uses sizeof(), so it should be more -! portable). -! -! - - - INTEGER MPI_DATATYPE_NULL - PARAMETER (MPI_DATATYPE_NULL=0) - - INTEGER MPI_BYTE - PARAMETER (MPI_BYTE=1) - - INTEGER MPI_CHARACTER - PARAMETER (MPI_CHARACTER=1) - - INTEGER MPI_INTEGER - PARAMETER (MPI_INTEGER=4) - - INTEGER MPI_LOGICAL - PARAMETER (MPI_LOGICAL=4) - -!!!!!!! - INTEGER MPI_REAL - PARAMETER (MPI_REAL=4) - - INTEGER MPI_DOUBLE_PRECISION - PARAMETER (MPI_DOUBLE_PRECISION=8) -!!!!!!! - - integer MPI_COMPLEX - parameter (MPI_COMPLEX=2*MPI_REAL) - - integer MPI_2REAL - parameter (MPI_2REAL=2*MPI_REAL) - - integer MPI_2DOUBLE_PRECISION - parameter (MPI_2DOUBLE_PRECISION=2*MPI_DOUBLE_PRECISION) - - integer MPI_2INTEGER - parameter (MPI_2INTEGER=2*MPI_INTEGER) - - integer MPI_PACKED - parameter (MPI_PACKED=1) - - -! -! Size-specific types -! - - INTEGER MPI_REAL4 - PARAMETER (MPI_REAL4=4) - - INTEGER MPI_REAL8 - PARAMETER (MPI_REAL8=8) - - INTEGER MPI_REAL16 - PARAMETER (MPI_REAL16=16) - - - integer MPI_COMPLEX8 - parameter (MPI_COMPLEX8=8) - - integer MPI_COMPLEX16 - parameter (MPI_COMPLEX16=16) - - integer MPI_COMPLEX32 - parameter (MPI_COMPLEX32=32) - - - INTEGER MPI_INTEGER1 - PARAMETER (MPI_INTEGER1=1) - - INTEGER MPI_INTEGER2 - PARAMETER (MPI_INTEGER2=2) - - INTEGER MPI_INTEGER4 - PARAMETER (MPI_INTEGER4=4) - - INTEGER MPI_INTEGER8 - PARAMETER (MPI_INTEGER8=8) - - INTEGER MPI_INTEGER16 - PARAMETER (MPI_INTEGER16=16) - - - -! -! MPI_Op values -! -! (All are handled as no-op so no value is necessary; but provide one -! anyway just in case.) -! - - INTEGER MPI_SUM - PARAMETER (MPI_SUM=0) - INTEGER MPI_MAX - PARAMETER (MPI_MAX=0) - INTEGER MPI_MIN - PARAMETER (MPI_MIN=0) - INTEGER MPI_PROD - PARAMETER (MPI_PROD=0) - INTEGER MPI_LAND - PARAMETER (MPI_LAND=0) - INTEGER MPI_BAND - PARAMETER (MPI_BAND=0) - INTEGER MPI_LOR - PARAMETER (MPI_LOR=0) - INTEGER MPI_BOR - PARAMETER (MPI_BOR=0) - INTEGER MPI_LXOR - PARAMETER (MPI_LXOR=0) - INTEGER MPI_BXOR - PARAMETER (MPI_BXOR=0) - INTEGER MPI_MINLOC - PARAMETER (MPI_MINLOC=0) - INTEGER MPI_MAXLOC - PARAMETER (MPI_MAXLOC=0) - INTEGER MPI_OP_NULL - PARAMETER (MPI_OP_NULL=0) - -! -! MPI_Wtime -! - - DOUBLE PRECISION MPI_WTIME - EXTERNAL MPI_WTIME - - -! -! Kinds -! - - INTEGER MPI_OFFSET_KIND - PARAMETER (MPI_OFFSET_KIND=selected_int_kind(13)) - - INTEGER MPI_INFO_NULL - PARAMETER (MPI_INFO_NULL=0) - - INTEGER MPI_MODE_RDONLY - PARAMETER (MPI_MODE_RDONLY=0) - - INTEGER MPI_MODE_CREATE - PARAMETER (MPI_MODE_CREATE=1) - - INTEGER MPI_MODE_RDWR - PARAMETER (MPI_MODE_RDWR=2) - - - diff --git a/cesm/models/utils/mct/mpi-serial/mpif.real8double16.h b/cesm/models/utils/mct/mpi-serial/mpif.real8double16.h deleted file mode 100644 index 16bd812..0000000 --- a/cesm/models/utils/mct/mpi-serial/mpif.real8double16.h +++ /dev/null @@ -1,291 +0,0 @@ - -!!! -!!! NOTE: The files mpif.realXdoubleY.h are generated from -!!! mpif.master.h using make-mpif and later copied to mpif.h -!!! during the library make. All modifications should be -!!! made to mpif.master.h -!!! - - -! -! MPI_COMM_WORLD -! - - INTEGER MPI_COMM_WORLD - parameter (mpi_comm_world=1) - -! -! -! - - integer MPI_BOTTOM - parameter (MPI_BOTTOM=0) - - -! -! source,tag -! - - integer MPI_ANY_SOURCE, MPI_ANY_TAG - parameter (mpi_any_source=-1, mpi_any_tag= -1) - - integer MPI_PROC_NULL, MPI_ROOT - parameter (MPI_PROC_NULL=-2, MPI_ROOT=-3) - - integer MPI_COMM_NULL, MPI_REQUEST_NULL - parameter (MPI_COMM_NULL=0, MPI_REQUEST_NULL=0) - - integer MPI_GROUP_NULL, MPI_GROUP_EMPTY - parameter (MPI_GROUP_NULL=0, MPI_GROUP_EMPTY= -1) - - integer MPI_MAX_ERROR_STRING - parameter (MPI_MAX_ERROR_STRING=128) - - integer MPI_MAX_PROCESSOR_NAME - parameter (MPI_MAX_PROCESSOR_NAME=128) - -! -! Return codes -! - - integer MPI_SUCCESS - parameter (MPI_SUCCESS=0) - - integer MPI_ERR_BUFFER - parameter (MPI_ERR_BUFFER= -1) - - integer MPI_ERR_COUNT - parameter (MPI_ERR_COUNT= -1) - - integer MPI_ERR_TYPE - parameter (MPI_ERR_TYPE= -1) - - integer MPI_ERR_TAG - parameter (MPI_ERR_TAG= -1) - - integer MPI_ERR_COMM - parameter (MPI_ERR_COMM= -1) - - integer MPI_ERR_RANK - parameter (MPI_ERR_RANK= -1) - - integer MPI_ERR_REQUEST - parameter (MPI_ERR_REQUEST= -1) - - integer MPI_ERR_ROOT - parameter (MPI_ERR_ROOT= -1) - - integer MPI_ERR_GROUP - parameter (MPI_ERR_GROUP= -1) - - integer MPI_ERR_OP - parameter (MPI_ERR_OP= -1) - - integer MPI_ERR_TOPOLOGY - parameter (MPI_ERR_TOPOLOGY= -1) - - integer MPI_ERR_DIMS - parameter (MPI_ERR_DIMS= -1) - - integer MPI_ERR_ARG - parameter (MPI_ERR_ARG= -1) - - integer MPI_ERR_UNKNOWN - parameter (MPI_ERR_UNKNOWN= -1) - - integer MPI_ERR_TRUNCATE - parameter (MPI_ERR_TRUNCATE= -1) - - integer MPI_ERR_OTHER - parameter (MPI_ERR_OTHER= -1) - - integer MPI_ERR_INTERN - parameter (MPI_ERR_INTERN= -1) - - integer MPI_PENDING - parameter (MPI_PENDING= -1) - - integer MPI_ERR_IN_STATUS - parameter (MPI_ERR_IN_STATUS= -1) - - integer MPI_ERR_LASTCODE - parameter (MPI_ERR_LASTCODE= -1) - -! -! - - - integer MPI_UNDEFINED - parameter (MPI_UNDEFINED= -1) - - -! -! MPI_Status -! -! The values in this section MUST match the struct definition -! in mpi.h -! - - - INTEGER MPI_STATUS_SIZE - PARAMETER (MPI_STATUS_SIZE=3) - - INTEGER MPI_SOURCE, MPI_TAG, MPI_ERROR - PARAMETER(MPI_SOURCE=1, MPI_TAG=2, MPI_ERROR=3) - - - -! -! MPI_Datatype values -! -! The value is the size of the datatype in bytes. -! Change if necessary for the machine in question. -! (The mpi.h file uses sizeof(), so it should be more -! portable). -! -! - - - INTEGER MPI_DATATYPE_NULL - PARAMETER (MPI_DATATYPE_NULL=0) - - INTEGER MPI_BYTE - PARAMETER (MPI_BYTE=1) - - INTEGER MPI_CHARACTER - PARAMETER (MPI_CHARACTER=1) - - INTEGER MPI_INTEGER - PARAMETER (MPI_INTEGER=4) - - INTEGER MPI_LOGICAL - PARAMETER (MPI_LOGICAL=4) - -!!!!!!! - INTEGER MPI_REAL - PARAMETER (MPI_REAL=8) - - INTEGER MPI_DOUBLE_PRECISION - PARAMETER (MPI_DOUBLE_PRECISION=16) -!!!!!!! - - integer MPI_COMPLEX - parameter (MPI_COMPLEX=2*MPI_REAL) - - integer MPI_2REAL - parameter (MPI_2REAL=2*MPI_REAL) - - integer MPI_2DOUBLE_PRECISION - parameter (MPI_2DOUBLE_PRECISION=2*MPI_DOUBLE_PRECISION) - - integer MPI_2INTEGER - parameter (MPI_2INTEGER=2*MPI_INTEGER) - - integer MPI_PACKED - parameter (MPI_PACKED=1) - - -! -! Size-specific types -! - - INTEGER MPI_REAL4 - PARAMETER (MPI_REAL4=4) - - INTEGER MPI_REAL8 - PARAMETER (MPI_REAL8=8) - - INTEGER MPI_REAL16 - PARAMETER (MPI_REAL16=16) - - - integer MPI_COMPLEX8 - parameter (MPI_COMPLEX8=8) - - integer MPI_COMPLEX16 - parameter (MPI_COMPLEX16=16) - - integer MPI_COMPLEX32 - parameter (MPI_COMPLEX32=32) - - - INTEGER MPI_INTEGER1 - PARAMETER (MPI_INTEGER1=1) - - INTEGER MPI_INTEGER2 - PARAMETER (MPI_INTEGER2=2) - - INTEGER MPI_INTEGER4 - PARAMETER (MPI_INTEGER4=4) - - INTEGER MPI_INTEGER8 - PARAMETER (MPI_INTEGER8=8) - - INTEGER MPI_INTEGER16 - PARAMETER (MPI_INTEGER16=16) - - - -! -! MPI_Op values -! -! (All are handled as no-op so no value is necessary; but provide one -! anyway just in case.) -! - - INTEGER MPI_SUM - PARAMETER (MPI_SUM=0) - INTEGER MPI_MAX - PARAMETER (MPI_MAX=0) - INTEGER MPI_MIN - PARAMETER (MPI_MIN=0) - INTEGER MPI_PROD - PARAMETER (MPI_PROD=0) - INTEGER MPI_LAND - PARAMETER (MPI_LAND=0) - INTEGER MPI_BAND - PARAMETER (MPI_BAND=0) - INTEGER MPI_LOR - PARAMETER (MPI_LOR=0) - INTEGER MPI_BOR - PARAMETER (MPI_BOR=0) - INTEGER MPI_LXOR - PARAMETER (MPI_LXOR=0) - INTEGER MPI_BXOR - PARAMETER (MPI_BXOR=0) - INTEGER MPI_MINLOC - PARAMETER (MPI_MINLOC=0) - INTEGER MPI_MAXLOC - PARAMETER (MPI_MAXLOC=0) - INTEGER MPI_OP_NULL - PARAMETER (MPI_OP_NULL=0) - -! -! MPI_Wtime -! - - DOUBLE PRECISION MPI_WTIME - EXTERNAL MPI_WTIME - - -! -! Kinds -! - - INTEGER MPI_OFFSET_KIND - PARAMETER (MPI_OFFSET_KIND=selected_int_kind(13)) - - INTEGER MPI_INFO_NULL - PARAMETER (MPI_INFO_NULL=0) - - INTEGER MPI_MODE_RDONLY - PARAMETER (MPI_MODE_RDONLY=0) - - INTEGER MPI_MODE_CREATE - PARAMETER (MPI_MODE_CREATE=1) - - INTEGER MPI_MODE_RDWR - PARAMETER (MPI_MODE_RDWR=2) - - - diff --git a/cesm/models/utils/mct/mpi-serial/mpif.real8double8.h b/cesm/models/utils/mct/mpi-serial/mpif.real8double8.h deleted file mode 100644 index 35ae3e6..0000000 --- a/cesm/models/utils/mct/mpi-serial/mpif.real8double8.h +++ /dev/null @@ -1,291 +0,0 @@ - -!!! -!!! NOTE: The files mpif.realXdoubleY.h are generated from -!!! mpif.master.h using make-mpif and later copied to mpif.h -!!! during the library make. All modifications should be -!!! made to mpif.master.h -!!! - - -! -! MPI_COMM_WORLD -! - - INTEGER MPI_COMM_WORLD - parameter (mpi_comm_world=1) - -! -! -! - - integer MPI_BOTTOM - parameter (MPI_BOTTOM=0) - - -! -! source,tag -! - - integer MPI_ANY_SOURCE, MPI_ANY_TAG - parameter (mpi_any_source=-1, mpi_any_tag= -1) - - integer MPI_PROC_NULL, MPI_ROOT - parameter (MPI_PROC_NULL=-2, MPI_ROOT=-3) - - integer MPI_COMM_NULL, MPI_REQUEST_NULL - parameter (MPI_COMM_NULL=0, MPI_REQUEST_NULL=0) - - integer MPI_GROUP_NULL, MPI_GROUP_EMPTY - parameter (MPI_GROUP_NULL=0, MPI_GROUP_EMPTY= -1) - - integer MPI_MAX_ERROR_STRING - parameter (MPI_MAX_ERROR_STRING=128) - - integer MPI_MAX_PROCESSOR_NAME - parameter (MPI_MAX_PROCESSOR_NAME=128) - -! -! Return codes -! - - integer MPI_SUCCESS - parameter (MPI_SUCCESS=0) - - integer MPI_ERR_BUFFER - parameter (MPI_ERR_BUFFER= -1) - - integer MPI_ERR_COUNT - parameter (MPI_ERR_COUNT= -1) - - integer MPI_ERR_TYPE - parameter (MPI_ERR_TYPE= -1) - - integer MPI_ERR_TAG - parameter (MPI_ERR_TAG= -1) - - integer MPI_ERR_COMM - parameter (MPI_ERR_COMM= -1) - - integer MPI_ERR_RANK - parameter (MPI_ERR_RANK= -1) - - integer MPI_ERR_REQUEST - parameter (MPI_ERR_REQUEST= -1) - - integer MPI_ERR_ROOT - parameter (MPI_ERR_ROOT= -1) - - integer MPI_ERR_GROUP - parameter (MPI_ERR_GROUP= -1) - - integer MPI_ERR_OP - parameter (MPI_ERR_OP= -1) - - integer MPI_ERR_TOPOLOGY - parameter (MPI_ERR_TOPOLOGY= -1) - - integer MPI_ERR_DIMS - parameter (MPI_ERR_DIMS= -1) - - integer MPI_ERR_ARG - parameter (MPI_ERR_ARG= -1) - - integer MPI_ERR_UNKNOWN - parameter (MPI_ERR_UNKNOWN= -1) - - integer MPI_ERR_TRUNCATE - parameter (MPI_ERR_TRUNCATE= -1) - - integer MPI_ERR_OTHER - parameter (MPI_ERR_OTHER= -1) - - integer MPI_ERR_INTERN - parameter (MPI_ERR_INTERN= -1) - - integer MPI_PENDING - parameter (MPI_PENDING= -1) - - integer MPI_ERR_IN_STATUS - parameter (MPI_ERR_IN_STATUS= -1) - - integer MPI_ERR_LASTCODE - parameter (MPI_ERR_LASTCODE= -1) - -! -! - - - integer MPI_UNDEFINED - parameter (MPI_UNDEFINED= -1) - - -! -! MPI_Status -! -! The values in this section MUST match the struct definition -! in mpi.h -! - - - INTEGER MPI_STATUS_SIZE - PARAMETER (MPI_STATUS_SIZE=3) - - INTEGER MPI_SOURCE, MPI_TAG, MPI_ERROR - PARAMETER(MPI_SOURCE=1, MPI_TAG=2, MPI_ERROR=3) - - - -! -! MPI_Datatype values -! -! The value is the size of the datatype in bytes. -! Change if necessary for the machine in question. -! (The mpi.h file uses sizeof(), so it should be more -! portable). -! -! - - - INTEGER MPI_DATATYPE_NULL - PARAMETER (MPI_DATATYPE_NULL=0) - - INTEGER MPI_BYTE - PARAMETER (MPI_BYTE=1) - - INTEGER MPI_CHARACTER - PARAMETER (MPI_CHARACTER=1) - - INTEGER MPI_INTEGER - PARAMETER (MPI_INTEGER=4) - - INTEGER MPI_LOGICAL - PARAMETER (MPI_LOGICAL=4) - -!!!!!!! - INTEGER MPI_REAL - PARAMETER (MPI_REAL=8) - - INTEGER MPI_DOUBLE_PRECISION - PARAMETER (MPI_DOUBLE_PRECISION=8) -!!!!!!! - - integer MPI_COMPLEX - parameter (MPI_COMPLEX=2*MPI_REAL) - - integer MPI_2REAL - parameter (MPI_2REAL=2*MPI_REAL) - - integer MPI_2DOUBLE_PRECISION - parameter (MPI_2DOUBLE_PRECISION=2*MPI_DOUBLE_PRECISION) - - integer MPI_2INTEGER - parameter (MPI_2INTEGER=2*MPI_INTEGER) - - integer MPI_PACKED - parameter (MPI_PACKED=1) - - -! -! Size-specific types -! - - INTEGER MPI_REAL4 - PARAMETER (MPI_REAL4=4) - - INTEGER MPI_REAL8 - PARAMETER (MPI_REAL8=8) - - INTEGER MPI_REAL16 - PARAMETER (MPI_REAL16=16) - - - integer MPI_COMPLEX8 - parameter (MPI_COMPLEX8=8) - - integer MPI_COMPLEX16 - parameter (MPI_COMPLEX16=16) - - integer MPI_COMPLEX32 - parameter (MPI_COMPLEX32=32) - - - INTEGER MPI_INTEGER1 - PARAMETER (MPI_INTEGER1=1) - - INTEGER MPI_INTEGER2 - PARAMETER (MPI_INTEGER2=2) - - INTEGER MPI_INTEGER4 - PARAMETER (MPI_INTEGER4=4) - - INTEGER MPI_INTEGER8 - PARAMETER (MPI_INTEGER8=8) - - INTEGER MPI_INTEGER16 - PARAMETER (MPI_INTEGER16=16) - - - -! -! MPI_Op values -! -! (All are handled as no-op so no value is necessary; but provide one -! anyway just in case.) -! - - INTEGER MPI_SUM - PARAMETER (MPI_SUM=0) - INTEGER MPI_MAX - PARAMETER (MPI_MAX=0) - INTEGER MPI_MIN - PARAMETER (MPI_MIN=0) - INTEGER MPI_PROD - PARAMETER (MPI_PROD=0) - INTEGER MPI_LAND - PARAMETER (MPI_LAND=0) - INTEGER MPI_BAND - PARAMETER (MPI_BAND=0) - INTEGER MPI_LOR - PARAMETER (MPI_LOR=0) - INTEGER MPI_BOR - PARAMETER (MPI_BOR=0) - INTEGER MPI_LXOR - PARAMETER (MPI_LXOR=0) - INTEGER MPI_BXOR - PARAMETER (MPI_BXOR=0) - INTEGER MPI_MINLOC - PARAMETER (MPI_MINLOC=0) - INTEGER MPI_MAXLOC - PARAMETER (MPI_MAXLOC=0) - INTEGER MPI_OP_NULL - PARAMETER (MPI_OP_NULL=0) - -! -! MPI_Wtime -! - - DOUBLE PRECISION MPI_WTIME - EXTERNAL MPI_WTIME - - -! -! Kinds -! - - INTEGER MPI_OFFSET_KIND - PARAMETER (MPI_OFFSET_KIND=selected_int_kind(13)) - - INTEGER MPI_INFO_NULL - PARAMETER (MPI_INFO_NULL=0) - - INTEGER MPI_MODE_RDONLY - PARAMETER (MPI_MODE_RDONLY=0) - - INTEGER MPI_MODE_CREATE - PARAMETER (MPI_MODE_CREATE=1) - - INTEGER MPI_MODE_RDWR - PARAMETER (MPI_MODE_RDWR=2) - - - diff --git a/cesm/models/utils/mct/mpi-serial/pack.c b/cesm/models/utils/mct/mpi-serial/pack.c deleted file mode 100644 index bcc42bb..0000000 --- a/cesm/models/utils/mct/mpi-serial/pack.c +++ /dev/null @@ -1,76 +0,0 @@ - -#include "mpiP.h" - -/* - * - */ - - -FC_FUNC( mpi_pack , MPI_PACK ) - ( void *inbuf, int *incount, int *datatype, - void *outbuf, int *outsize, int *position, int *comm, int *ierror) -{ - *ierror=MPI_Pack(inbuf, *incount,* datatype, - outbuf, *outsize, position, *comm); -} - - - -int MPI_Pack( void *inbuf, int incount, MPI_Datatype datatype, - void *outbuf, int outsize, int *position, MPI_Comm comm) -{ - int size; - - size=datatype*incount; - - if ( (*position)+size > outsize) - { - fprintf(stderr,"MPI_Pack: ran out of space in outbuf\n"); - abort(); - } - - memcpy( (char *)outbuf+(*position), inbuf, size); - (*position)+=size; - - return(MPI_SUCCESS); -} - - - -/* - * - */ - - -FC_FUNC( mpi_unpack , MPI_UNPACK ) - ( void *inbuf, int *insize, int *position, - void *outbuf, int *outcount, int *datatype, - int *comm, int *ierror ) -{ - *ierror=MPI_Unpack( inbuf, *insize, position, - outbuf, *outcount, *datatype, *comm); -} - - - -int MPI_Unpack( void *inbuf, int insize, int *position, - void *outbuf, int outcount, MPI_Datatype datatype, - MPI_Comm comm ) -{ - int size; - - size=datatype*outcount; - - if ( (*position)+size > insize ) - { - fprintf(stderr,"MPI_Unpack: ran out of data in inbuf\n"); - abort(); - } - - - memcpy(outbuf, (char *)inbuf+(*position) , size); - (*position)+=size; - - return(MPI_SUCCESS); - -} diff --git a/cesm/models/utils/mct/mpi-serial/protify.awk b/cesm/models/utils/mct/mpi-serial/protify.awk deleted file mode 100755 index 483fc2e..0000000 --- a/cesm/models/utils/mct/mpi-serial/protify.awk +++ /dev/null @@ -1,46 +0,0 @@ -#!/bin/awk -f - - -####################################################################### -# -# Because of awk problems on the sgi, this file is converted to perl -# via 'a2p' to yield 'protify'. Do not edit the perl version!!!! -# -####################################################################### - - -BEGIN { - - printf("\n"); - printf("/****************************************************** \n"); - printf(" * WARNING: This file automatically generated. * \n"); - printf(" ****************************************************** \n"); - printf(" */ \n"); - printf("\n\n\n\n"); -} - - -/[ \t]*extern/ { next } -/main\(/ { next } - -/FORT_NAME/ {next} - -# Ignore doctext comments -/\/\*[DMN@]/ { while (!match($0,/[DMN@]\*\//)) getline; next; } - - -/^[^ \t{}/*#].*[^ \t]+\(.*[^;]*$/ \ - { - if ($1=="static") - next; #continue; - - printf("extern %s",$0); - - while (!match($0,"\)")) - { - getline; - gsub("\t"," "); - printf("\n %s",$0); - } - printf(";\n"); - } diff --git a/cesm/models/utils/mct/mpi-serial/recv.c b/cesm/models/utils/mct/mpi-serial/recv.c deleted file mode 100644 index bdfc46a..0000000 --- a/cesm/models/utils/mct/mpi-serial/recv.c +++ /dev/null @@ -1,161 +0,0 @@ - -#include "mpiP.h" - - - -/* - * RECEIVING - * - */ - - - -static int mpi_match_send(void *r, void *tag) -{ - return( *((int *)tag) == MPI_ANY_TAG || - *((int *)tag) == ((Req *)r)->tag ); -} - - - -/* - * - */ - - - -FC_FUNC( mpi_irecv , MPI_IRECV )(void *buf, int *count, int *datatype, - int *source, int *tag, int *comm, - int *request, int *ierror) -{ - - *ierror=MPI_Irecv(buf,*count,*datatype,*source,*tag, - *comm, (void *)request); - -} - - - -int MPI_Irecv(void *buf, int count, MPI_Datatype datatype, - int source, int tag, MPI_Comm comm, MPI_Request *request) - -{ - pListitem match; - Comm *mycomm; - Req *rreq, *sreq; - - mycomm=mpi_handle_to_ptr(comm); /* mycomm=(Comm *)comm; */ - -#ifdef INFO - fflush(stdout); - fprintf(stderr,"MPI_Irecv: Comm=%d tag=%d count=%d type=%d\n", - mycomm->num,tag,count,datatype); -#endif - - - if (source!=0 && source!=MPI_ANY_SOURCE && source!=MPI_PROC_NULL) - { - fprintf(stderr,"MPI_Irecv: bad source %d\n",source); - abort(); - } - - mpi_alloc_handle(request,(void **)&rreq); - - if (source==MPI_PROC_NULL) - { - rreq->complete=1; - rreq->source=MPI_PROC_NULL; - rreq->tag=MPI_ANY_TAG; - - return(MPI_SUCCESS); - } - - - if ( match=AP_list_search_func(mycomm->sendlist,mpi_match_send,&tag) ) - { - sreq=(Req *)AP_listitem_data(match); - AP_list_delete_item(mycomm->sendlist,match); - - memcpy(buf,sreq->buf,count * datatype); - rreq->complete=1; - rreq->source=0; - rreq->tag=sreq->tag; /* in case tag was MPI_ANY_TAG */ - - sreq->complete=1; - -#ifdef DEBUG - printf("Completion(recv) value=%d tag=%d\n", - *((int *)buf),rreq->tag); -#endif - - return(MPI_SUCCESS); - } - - rreq->buf=buf; - rreq->tag=tag; - rreq->complete=0; - rreq->listitem=AP_list_append(mycomm->recvlist,rreq); - -#ifdef INFO - print_list(mycomm->recvlist,"recvlist for comm ",mycomm->num); -#endif - - return(MPI_SUCCESS); -} - - -/*********/ - - -FC_FUNC( mpi_recv , MPI_RECV )(void *buf, int *count, int *datatype, - int *source, int *tag, int *comm, - int *status, int *ierror) -{ - *ierror=MPI_Recv(buf,*count,*datatype,*source,*tag,*comm, - (MPI_Status *)status); -} - - - -int MPI_Recv(void *buf, int count, MPI_Datatype datatype, int source, - int tag, MPI_Comm comm, MPI_Status *status) -{ - MPI_Request request; - -#ifdef INFO - fflush(stdout); - fprintf(stderr,"MPI_Recv: "); -#endif - - - MPI_Irecv(buf,count,datatype,source,tag,comm,&request); - MPI_Wait(&request,status); - - - return(MPI_SUCCESS); -} - - - -#ifdef INFO - -int print_item(void *item, void *data) -{ - fprintf(stderr,"%d ", ((Req *)item)->tag); - return(0); -} - - -int print_list(pList list, char *msg, int num) -{ - fflush(stdout); - fprintf(stderr,"%s %d: ",msg,num); - - AP_list_apply(list,print_item,NULL); - - fprintf(stderr,"\n"); - return(0); -} - - -#endif diff --git a/cesm/models/utils/mct/mpi-serial/req.c b/cesm/models/utils/mct/mpi-serial/req.c deleted file mode 100644 index 52d2abe..0000000 --- a/cesm/models/utils/mct/mpi-serial/req.c +++ /dev/null @@ -1,156 +0,0 @@ -#include "mpiP.h" - - -/* - * COMPLETION - */ - - - -FC_FUNC( mpi_test , MPI_TEST)(int *request, int *flag, int *status, - int *ierror) -{ - *ierror=MPI_Test( (void *)request ,flag,(MPI_Status *)status); -} - - - -int MPI_Test(MPI_Request *request, int *flag, MPI_Status *status) -{ - Req *req; - - if (*request==MPI_REQUEST_NULL) - { - status->MPI_TAG= MPI_ANY_TAG; - status->MPI_SOURCE= MPI_ANY_SOURCE; - *flag=1; - return(MPI_SUCCESS); - } - - - req=mpi_handle_to_ptr(*request); - - *flag=req->complete; - - if (*flag) - { - status->MPI_SOURCE= req->source; - status->MPI_TAG= req->tag; - - mpi_free_handle(*request); - *request=MPI_REQUEST_NULL; - } - - return(MPI_SUCCESS); -} - - - -FC_FUNC( mpi_wait , MPI_WAIT )(int *request, int *status, int *ierror) -{ - *ierror=MPI_Wait( (void *)request, (MPI_Status *)status ); -} - - - -int MPI_Wait(MPI_Request *request, MPI_Status *status) -{ - int flag; - - MPI_Test(request,&flag,status); - - if (!flag) - { - fprintf(stderr,"MPI_Wait: request not complete, deadlock\n"); - abort(); - } - - return(MPI_SUCCESS); -} - - -/*********/ - - -FC_FUNC( mpi_waitany , MPI_WAITANY )(int *count, int *requests, - int *index, int *status, int *ierror) -{ - - *ierror=MPI_Waitany(*count, (void *)requests,index,(MPI_Status *)status); -} - - - -int MPI_Waitany(int count, MPI_Request *array_of_requests, - int *index, MPI_Status *status) -{ - int i; - int flag; - - for (i=0; itag == MPI_ANY_TAG || - ((Req *)r)->tag == *((int *)tag) ); -} - - -/* - * - */ - - - -FC_FUNC( mpi_isend , MPI_ISEND )(void *buf, int *count, int *datatype, - int *dest, int *tag, int *comm, int *req, int *ierror) -{ - - *ierror=MPI_Isend(buf,*count,*datatype,*dest,*tag, - *comm, (void *)req); - -} - - - -int MPI_Isend(void *buf, int count, MPI_Datatype datatype, - int dest, int tag, MPI_Comm comm, MPI_Request *request) -{ - pListitem match; - Comm *mycomm; - Req *rreq, *sreq; - - mycomm=mpi_handle_to_ptr(comm); /* (Comm *)comm; */ - -#ifdef INFO - fflush(stdout); - fprintf(stderr,"MPI_Isend: Comm=%d tag=%d count=%d type=%d\n", - mycomm->num,tag,count,datatype); -#endif - - if (dest!=0 && dest!=MPI_PROC_NULL) - { - fprintf(stderr,"MPI_Isend: send to %d\n",dest); - abort(); - } - - mpi_alloc_handle(request,(void **) &sreq); - - - if (dest==MPI_PROC_NULL) - { - sreq->complete=1; - return(MPI_SUCCESS); - } - - if ( match=AP_list_search_func(mycomm->recvlist,mpi_match_recv,&tag) ) - { - rreq=(Req *)AP_listitem_data(match); - AP_list_delete_item(mycomm->recvlist,match); - - memcpy(rreq->buf,buf,count * datatype); - rreq->complete=1; - rreq->source=0; - rreq->tag=tag; /* in case rreq->tag was MPI_ANY_TAG */ - - sreq->complete=1; - -#ifdef DEBUG - printf("Completion(send) value=%d tag=%d\n", - *((int *)buf),rreq->tag); -#endif - - return(MPI_SUCCESS); - } - - sreq->buf=buf; - sreq->tag=tag; - sreq->complete=0; - sreq->listitem=AP_list_append(mycomm->sendlist,sreq); - -#ifdef INFO - print_list(mycomm->sendlist,"sendlist for comm ",mycomm->num); -#endif - - return(MPI_SUCCESS); -} - - -/*********/ - - -FC_FUNC(mpi_send, MPI_SEND) ( void *buf, int *count, int *datatype, - int *dest, int *tag, int *comm, int *ierror) -{ - *ierror=MPI_Send(buf, *count, *datatype, *dest, *tag, *comm); -} - - - -int MPI_Send(void* buf, int count, MPI_Datatype datatype, - int dest, int tag, MPI_Comm comm) -{ - MPI_Request request; - MPI_Status status; - -#ifdef INFO - fflush(stdout); - fprintf(stderr,"MPI_Send: "); -#endif - - MPI_Isend(buf,count,datatype,dest,tag,comm,&request); - MPI_Wait(&request,&status); - - - return(MPI_SUCCESS); -} - - - - -/*********/ - - -FC_FUNC(mpi_ssend, MPI_SSEND) ( void *buf, int *count, int *datatype, - int *dest, int *tag, int *comm, int *ierror) -{ - *ierror=MPI_Send(buf, *count, *datatype, *dest, *tag, *comm); -} - - - -int MPI_Ssend(void* buf, int count, MPI_Datatype datatype, - int dest, int tag, MPI_Comm comm) -{ - return(MPI_Send(buf,count,datatype,dest,tag,comm)); -} - - - -/*********/ - - -FC_FUNC(mpi_rsend, MPI_RSEND) ( void *buf, int *count, int *datatype, - int *dest, int *tag, int *comm, int *ierror) -{ - *ierror=MPI_Send(buf, *count, *datatype, *dest, *tag, *comm); -} - - - -int MPI_Rsend(void* buf, int count, MPI_Datatype datatype, - int dest, int tag, MPI_Comm comm) -{ - return(MPI_Send(buf,count,datatype,dest,tag,comm)); -} - - - - -/*********/ - - - -FC_FUNC( mpi_irsend , MPI_IRSEND )(void *buf, int *count, int *datatype, - int *dest, int *tag, int *comm, int *req, int *ierror) -{ - - *ierror=MPI_Irsend(buf,*count,*datatype,*dest,*tag, - *comm, (void *)req); - -} - - - -int MPI_Irsend(void *buf, int count, MPI_Datatype datatype, - int dest, int tag, MPI_Comm comm, MPI_Request *request) -{ - MPI_Status status; - Req *req; - - - MPI_Isend(buf,count,datatype,dest,tag,comm,request); - - /* Ready mode implied a receive must already be posted, - * so the Isend should have completed already. - * Can't use MPI_Test here for the error check because - * it would clear the request prematurely. - */ - - req=mpi_handle_to_ptr(*request); - if ( !req->complete ) - { - fprintf(stderr,"MPI_Irsend: no matching receive found\n"); - abort(); - } - - - return(MPI_SUCCESS); -} - - - - -/*********/ - - -FC_FUNC(mpi_sendrecv, MPI_SENDRECV) ( - void *sendbuf, int *sendcount, int *sendtype, int *dest, int *sendtag, - void *recvbuf, int *recvcount, int *recvtype, int *source, int *recvtag, - int *comm, int *status, - int *ierror) -{ - *ierror=MPI_Sendrecv(sendbuf, *sendcount, *sendtype, *dest, *sendtag, - recvbuf, *recvcount, *recvtype, *source, *recvtag, - *comm, (MPI_Status *)status); -} - - - -int MPI_Sendrecv(void* sendbuf, int sendcount, MPI_Datatype sendtype, - int dest, int sendtag, - void *recvbuf, int recvcount, MPI_Datatype recvtype, - int source, int recvtag, - MPI_Comm comm, MPI_Status *status) -{ - MPI_Request request; - - - MPI_Irecv(recvbuf, recvcount, recvtype, source, recvtag, comm, &request); - - MPI_Send(sendbuf, sendcount, sendtype, dest, sendtag, comm); - - MPI_Wait(&request,status); - - - return(MPI_SUCCESS); -} - - - diff --git a/cesm/models/utils/mct/mpi-serial/time.c b/cesm/models/utils/mct/mpi-serial/time.c deleted file mode 100644 index 6170009..0000000 --- a/cesm/models/utils/mct/mpi-serial/time.c +++ /dev/null @@ -1,35 +0,0 @@ - -#include -#include - - -#include "mpiP.h" - - -double MPI_Wtime(void); - - - -double FC_FUNC( mpi_wtime, MPI_WTIME )(void) -{ - return(MPI_Wtime()); -} - - - -double MPI_Wtime(void) -{ - struct timeval tv; - - if (gettimeofday(&tv,0)) - { - fprintf(stderr,"MPI_Wtime: error calling gettimeofday()\n"); - abort(); - } - - - return((double)(tv.tv_sec) + (double)(tv.tv_usec)/1e6) ; -} - - - diff --git a/cesm/models/utils/mct/protex/protex b/cesm/models/utils/mct/protex/protex deleted file mode 100755 index 2b47a33..0000000 --- a/cesm/models/utils/mct/protex/protex +++ /dev/null @@ -1,879 +0,0 @@ -#!/usr/bin/perl -#BOP -# -# !ROUTINE: ProTeX v. 2.00 - Translates DAO Prologues to LaTeX -# -# !INTERFACE: -# protex [-hbACFS] ] [+-nlsxf] [src_file(s)] -# -# !DESCRIPTION: -# Perl filter to produce a \LaTeX compatible document -# from a DAO Fortran source code with standard Pro\TeX -# prologues. If source files are not specified it -# reads from stdin; output is always to stdout. -# -# \noindent -# {\bf Command Line Switches:} \vspace{0.2cm} -# -# \begin{center} -# \begin{tabular}{|c|l|} \hline \hline -# -h & Help mode: list command line options \\ \hline -# -b & Bare mode, meaning no preamble, etc. \\ \hline -# +/-n & New Page for each subsection (wastes paper) \\ \hline -# +/-l & Listing mode, default is prologues only \\ \hline -# +/-s & Shut-up mode, i.e., ignore any code from BOC to EOC \\ \hline -# +/-x & No LaTeX mode, i.e., put !DESCRIPTION: in verbatim mode \\ \hline -# +/-f & No source file info \\ \hline -# -A & Ada code \\ \hline -# -C & C++ code \\ \hline -# -F & F90 code (default) \\ \hline -# -S & Shell script \\ \hline \hline -# \end{tabular} -# \end{center} -# -# The options can appear in any order. The options, -h and -b, affect -# the input from all files listed on command-line input. Each of the -# remaining options effects only the input from the files listed after -# the option and prior to any overriding option. The plus sign -# turns off the option. For example, the command-line input, -# \bv -# protex -bnS File1 -F File2.f +n File3.f -# \ev -# will cause the option, {\tt -n} to affect the input from the files, -# {\tt File} and {\tt File2.f}, but not from {\tt File3.f}. The -# {\tt -S} option is implemented for {\tt File1} but is overridden by -# the {\tt -F} for files {\tt File2.f} and {\tt File3.f}. -# -# -# !SEE ALSO: -# For a more detailed description of ProTeX functionality, -# DAO Prologue and other conventions, consult: -# -# Sawyer, W., and A. da Silva, 1997: ProTeX: A Sample -# Fortran 90 Source Code Documentation System. -# DAO Office Note 97-11 -# -# -# !REVISION HISTORY: -# -# 20Dec1995 da Silva First experimental version -# 10Nov1996 da Silva First internal release (v1.01) -# 28Jun1997 da Silva Modified so that !DESCRIPTION can appear after -# !INTERFACE, and !INPUT PARAMETERS etc. changed to italics. -# 02Jul1997 Sawyer Added shut-up mode -# 20Oct1997 Sawyer Added support for shell scripts -# 11Mar1998 Sawyer Added: file name, date in header, C, script support -# 05Aug1998 Sawyer Fixed LPChang-bug-support-for-files-with-underscores -# 10Oct1998 da Silva Introduced -f option for removing source file info -# from subsection, etc. Added help (WS). -# 06Dec1999 C. Redder Added LaTeX command "\label{sec:prologues}" just -# after the beginning of the proglogue section. -# 13Dec1999 C. Redder Increased flexbility in command-line -# interface. The options can appear in any -# order which will allow the user to implement -# options for select files. -# 01Feb1999 C. Redder Added \usepackage commands to preamble of latex -# document to include the packages amsmath, epsfig -# and hangcaption. -# 10May2000 C. Redder Revised LaTeX command "\label{sec:prologues}" -# to "\label{app:ProLogues}" -# 24May2001 da Silva Added !PARAMETERS/!REURN VALUE: keywords for CAM. -# -#EOP -#---------------------------------------------------------------------------- - -# Keep this if you don't know what it does... -# ------------------------------------------- - $[ = 1; # set array base to 1 - $, = ' '; # set output field separator - $\ = "\n"; # set output record separator - -# Set valid options lists -# ----------------------- - $GlobOptions = 'hb'; # Global options (i.e for all files) - $LangOptions = 'ACFS'; # Options for setting programming languages - $SwOptions = 'flnsx'; # Options that can change for each input - # file - $RegOptions = "$GlobOptions$LangOptions"; - # Scan for global options until first first - # file is processed. - -# Scan for global options -# ----------------------- - $NFiles = 0; -Arg: - foreach $arg (@ARGV) { - $option = &CheckOpts ( $arg, $RegOptions, $SwOptions ) + 1; - if ( $option ) { - $rc = &GetOpts ( $arg, $GlobOptions ); - next Arg; } - - else { $NFiles++; -}# end if -}# end foreach - -# If all inut arguments are options, then assume the -# filename, "-", for the standard input -# -------------------------------------------------- - if ( $NFiles == 0 ) { push (@ARGV, "-"); } - -# Implement help option -# --------------------- - if ( $opt_h ) { - &print_help(); - exit(); -}#end if - -# Optional Prologue Keywords -# -------------------------- - @keys = ( "!INTERFACE:", - "!USES:", - "!PUBLIC TYPES:", - "!PUBLIC MEMBER FUNCTIONS:", - "!PUBLIC DATA MEMBERS:", - "!DEFINED PARAMETERS:", - "!PARAMETERS:", - "!INPUT PARAMETERS:", - "!INPUT/OUTPUT PARAMETERS:", - "!OUTPUT PARAMETERS:", - "!RETURN VALUE:", - "!REVISION HISTORY:", - "!BUGS:", - "!SEE ALSO:", - "!SYSTEM ROUTINES:", - "!FILES USED:", - "!REMARKS:", - "!TO DO:", - "!CALLING SEQUENCE:", - "!AUTHOR:", - "!CALLED FROM:", - "!LOCAL VARIABLES:" ); - -# Initialize these for clarity -# ---------------------------- - $intro = 0; # doing introduction? - $prologue = 0; # doing prologue? - $first = 1; # first prologue? - $source = 0; # source code mode? - $verb = 0; # verbatim mode? - $tpage = 0; # title page? - $begdoc = 0; # has \begin{document} been written? - -# Initial LaTeX stuff -# ------------------- - &print_notice(); - &print_preamble(); # \documentclass, text dimensions, etc. - &print_macros(); # short-hand LaTeX macros - -# Main loop -- for each command-line argument -# ------------------------------------------- -ARG: - foreach $arg (@ARGV) { - -# Scan for non-global command-line options -# ---------------------------------------- - $option = &CheckOpts ( $arg, $RegOptions, $SwOptions, "quiet" ) + 1; - if ( $option ) { - &GetOpts ( $arg, $SwOptions ); - &SetOpt ( $arg, $LangOptions ); - next ARG; - -}# end if - -# Determine the type of code, set corresponding search strings -# ------------------------------------------------------------ -# if ( $opt_F ) { # FORTRAN - $comment_string = '!'; # ------- - $boi_string = '!BOI'; - $eoi_string = '!EOI'; - $bop_string = '!BOP'; - $eop_string = '!EOP'; - $boc_string = '!BOC'; - $eoc_string = '!EOC'; -#}# end if - - if ( $opt_A ) { # ADA - $comment_string = '--'; # --- - $boi_string = '--BOI'; - $eoi_string = '--EOI'; - $bop_string = '--BOP'; - $eop_string = '--EOP'; - $boc_string = '--BOC'; - $eoc_string = '--EOC'; -}# end if - - if ( $opt_C ) { - $comment_string = '//'; # C - $boi_string = '//BOI'; # - - $eoi_string = '//EOI'; - $bop_string = '//BOP'; - $eop_string = '//EOP'; - $boc_string = '//BOC'; - $eoc_string = '//EOC'; -}# end if - - if ( $opt_S ) { # Script - $comment_string = '#'; # ------ - $boi_string = '#BOI'; - $eoi_string = '#EOI'; - $bop_string = '#BOP'; - $eop_string = '#EOP'; - $boc_string = '#BOC'; - $eoc_string = '#EOC'; -}# end if - -# Set file name parameters -# ------------------------ - $InputFile = $arg; - @all_path_components = split( /\//, $InputFile ); - $FileBaseName = pop ( @all_path_components ); - $FileBaseName =~ s/_/\\_/g; - if ( $InputFile eq "-" ) {$FileBaseName = "Standard Input";} - -# Set date -# -------- - $Date = `date`; - -# Open current file -# ----------------- - open ( InputFile, "$InputFile" ) - or print STDERR "Unable to open $InputFile: $!"; - -# Print page header -# ----------------- - printf "\n\\markboth{Left}{Source File: %s, Date: %s}\n\n", - $FileBaseName, $Date; - -LINE: -# Inner loop --- for processing each line of the input file -# --------------------------------------------------------- - while ( ) { - chop; # strip record separator - @Fld = split(' ', $_, 9999); - -# Straight quote -# -------------- - if ($Fld[1] eq '!QUOTE:') { - for ($i = 2; $i <= $#Fld; $i++) { - printf '%s ', $Fld[$i]; -}# end for - print " "; - next LINE; -}# end if - -# Handle optional Title Page and Introduction -# ------------------------------------------- - if ($Fld[1] eq $boi_string) { - print ' '; - $intro = 1; - next LINE; -}# end if - - if ($Fld[2] eq '!TITLE:') { - if ( $intro ) { - shift @Fld; - shift @Fld; - @title = @Fld; - $tpage = 1; - next LINE; -}# end if -}# end if - - if ($Fld[2] eq '!AUTHORS:') { - if ( $intro ) { - shift @Fld; - shift @Fld; - @author = @Fld; - $tpage = 1; - next LINE; -}# end if -}# end if - - if ($Fld[2] eq '!AFFILIATION:') { - if ( $intro ) { - shift @Fld; - shift @Fld; - @affiliation = @Fld; - $tpage = 1; - next LINE; -}# end if -}# end if - - if ($Fld[2] eq '!DATE:') { - if ( $intro ) { - shift @Fld; - shift @Fld; - @date = @Fld; - $tpage = 1; - next LINE; -}# end if -}# end if - - if ($Fld[2] eq '!INTRODUCTION:') { - if ( $intro ) { - &do_beg(); - print ' '; - print '%..............................................'; - shift @Fld; - shift @Fld; - print "\\section{@Fld}"; - next LINE; -}# end if -}# end if - - -# End of introduction -# ------------------- - if ($Fld[1] eq $eoi_string) { - print ' '; - print '%/////////////////////////////////////////////////////////////'; - print "\\newpage"; - $intro = 0; - next LINE; -}# end if - -# Beginning of prologue -# --------------------- - if ($Fld[1] eq $bop_string) { - if ( $source ) { &do_eoc(); } - print ' '; - print '%/////////////////////////////////////////////////////////////'; - &do_beg(); - if ($first == 0) { - ### print "\\newpage"; - print " "; - print "\\mbox{}\\hrulefill\\ "; - print " ";} - else { - unless($opt_b){print "\\section{Routine/Function Prologues} \\label{app:ProLogues}";} -}# end if - - $first = 0; - $prologue = 1; - $verb = 0; - $source = 0; - &set_missing(); # no required keyword yet - next LINE; -}# end if - -# A new subroutine/function -# ------------------------- - if ($Fld[2] eq '!ROUTINE:' ) { - if ($prologue) { - shift @Fld; - shift @Fld; - $_ = join(' ', @Fld); - $name_is = $_; - s/_/\\_/g; # Replace "_" with "\_" - if ( $opt_n && $not_first ) { printf "\\newpage\n"; } - unless ($opt_f) {printf "\\subsection{%s (Source File: %s)}\n\n", $_, $FileBaseName;} - else {printf "\\subsection{%s }\n\n", $_;} - $have_name = 1; - $not_first = 1; - next LINE; -}# end if -}# end if - -# A new Module -# ------------ - if ($Fld[2] eq '!MODULE:' ) { - if ($prologue) { - shift @Fld; - shift @Fld; - $_ = join(' ', @Fld); - $name_is = $_; - s/_/\\_/g; # Replace "_" with "\_" - if ( $opt_n && $not_first ) { printf "\\newpage\n"; } - unless($opt_f) {printf "\\subsection{Module %s (Source File: %s)}\n\n", $_, $FileBaseName;} - else {printf "\\subsection{Module %s }\n\n", $_;} - $have_name = 1; - $have_intf = 1; # fake it, it does not need one. - $not_first = 1; - next LINE; -}# end if -}# end if - -# A new include file -# ------------------ - if ($Fld[2] eq '!INCLUDE:' ) { - if ($prologue) { - shift @Fld; - shift @Fld; - $_ = join(' ', @Fld); - $name_is = $_; - s/_/\\_/g; # Replace "_" with "\_" - if ( $opt_n && $not_first ) { printf "\\newpage\n"; } - unless($opt_f) {printf "\\subsection{Include File %s (Source File: %s)}\n\n", $_, $FileBaseName;} - else {printf "\\subsection{Include File %s }\n\n", $_;} - $have_name = 1; - $have_intf = 1; # fake it, it does not need one. - $not_first = 1; - next LINE; -}# end if -}# end if - -# A new INTERNAL subroutine/function -# ---------------------------------- - if ($Fld[2] eq '!IROUTINE:') { # Internal routine - if ($prologue) { - shift @Fld; - shift @Fld; - $_ = join(' ', @Fld); - $name_is = $_; - s/_/\\_/g; # Replace "_" with "\_" - printf "\\subsubsection{%s}\n\n", $_; - $have_name = 1; - next LINE; -}# end if -}# end if - -# Description: what follows will be regular LaTeX (no verbatim) -# ------------------------------------------------------------- - if (/!DESCRIPTION:/) { - if ($prologue) { - if ($verb) { - printf "\\end{verbatim}"; - printf "\n{\\sf DESCRIPTION:\\\\ }\n\n"; - $verb = 0; } - else { # probably never occurs -}# end if - if ($opt_x) { - printf "\\begin{verbatim} "; - $verb = 1; - $first_verb = 1; } - else { - for ($i = 3; $i <= $#Fld; $i++) { - printf '%s ', $Fld[$i]; -}# end for -}# end if - ### print " "; - $have_desc = 1; - next LINE; -}# end if -}# end if - -# Handle optional keywords (these will appear as verbatim) -# -------------------------------------------------------- - if ($prologue) { -KEY: foreach $key ( @keys ) { - if ( /$key/ ) { - if ($verb) { - printf "\\end{verbatim}"; - $verb = 0; } - else { - printf "\n\\bigskip"; -}# end if - $k = sprintf('%s', $key); - $ln = length($k); - ###printf "\\subsubsection*{%s}\n", substr($k, 2, $ln - 1); - ###printf "{\\Large \\em %s}\n", ucfirst lc substr($k, 2, $ln - 1); - $_ = $key; - if( /USES/ || /INPUT/ || /OUTPUT/ || /PARAMETERS/ || /VALUE/ ) { - printf "{\\em %s}\n", substr($k, 2, $ln - 1); } # italics - else { - printf "{\\sf %s}\n", substr($k, 2, $ln - 1); # san serif -}# end if - - printf "\\begin{verbatim} "; - $verb = 1; - $first_verb = 1; - if ( $key eq "!INTERFACE:" ) { $have_intf = 1; } - if ( $key eq "!CALLING SEQUENCE:" ) { $have_intf = 1; } - if ( $key eq "!REVISION HISTORY:" ) { $have_hist = 1; } - next LINE; -}# end if -}# end foreach -}# end if - -# End of prologue -# --------------- - if ($Fld[1] eq $eop_string) { - if ($verb) { - print "\\end{verbatim}"; - $verb = 0; -}# end if - $prologue = 0; - &check_if_all_there(); # check if all required keyword are there. - if ( $opt_l ) { - $Fld[1] = $boc_string;} - else { next LINE; } -}# end if - - unless ( $opt_s ) { -# -# Beginning of source code section -# -------------------------------- - if ($Fld[1] eq $boc_string) { - print ' '; - print '%/////////////////////////////////////////////////////////////'; - $first = 0; - $prologue = 0; - $source = 1; - ### printf "\\subsubsection*{CONTENTS:}\n\n", $Fld[3]; - printf "{\\sf CONTENTS:}"; - printf "\n \\begin{verbatim}\n"; - $verb = 1; - next LINE; -}# end if - -# End of source code -# ------------------ - if ($Fld[1] eq $eoc_string) { - &do_eoc(); - $prologue = 0; - next LINE; -}# end if -}# end unless - -# Prologue or Introduction, print regular line (except for !) -# ----------------------------------------------------------- - if ($prologue||$intro) { - if ( $verb && $#Fld == 1 && ( $Fld[1] eq $comment_string ) ) { - next LINE; # to eliminate excessive blanks -}# end if - if ( $Fld[2] eq "\\ev" ) { # special handling - $_ = $comment_string . " \\end{verbatim}"; -}# end if - s/^$comment_string/ /; # replace comment string with blank -# $line = sprintf('%s', $_); # not necessary -- comment str is absent -# $ln = length($line); # not necessary -- comment str is absent - unless ( $first_verb ) { printf "\n "; } - printf '%s', $_; -# printf '%s', substr($line, 1, $ln - 1); # comment str is absent - $first_verb = 0; - next LINE; -}# end if - -# Source code: print the full line -# -------------------------------- - if ($source) { - print $_; - next LINE; -}# end if - -}# end inner loop for processing each line of the input file - # --------------------------------------------------------- - -}# end main loop for each command-line argument - # -------------------------------------------- - print $_; - if ( $source ) { &do_eoc(); } - print '%...............................................................'; - - unless ( $opt_b ) { - print "\\end{document}"; -}#end unless - - -#---------------------------------------------------------------------- - - sub CheckOpts -# Checks options against a given list. Outputs error message -# for any invalid option. -# -# Usage: -# $rc = &CheckOpts ( options, valid_reg_options, -# valid_sw_options, -# quiet_mode ) -# -# character: options - options to be checked. (e.g. -df+x) The -# list must begin with a positive or -# negative sign. If no sign appears at the -# beginning or by itself, then the argument -# is not recognized as a list of options. -# character: valid_reg_options - list of valid regular options. -# (i.e. options that are associated only -# eith negative sign.) -# character: valid_sw_options - list of valid switch options. -# (i.e. options that can be associated with -# either a positive or negative sign. -# logical: quiet mode (optional) If true then print no error -# messages. -# integer: rc - return code -# = -1 if the arguement, options, is -# not recognized as a list of options -# = 0 if all options are valid. -# > 0 for the number of invalid options. -# -{ local($options, - $valid_reg_options, - $valid_sw_options, - $quiet_mode ) = @_; - - if ( $options eq "+" || - $options eq "-" ) {return -1} - - local(@Options) = split( / */, $options ); - if ( $Options[ $[ ] ne "-" && - $Options[ $[ ] ne "+" ) {return -1;} - - local($option, $option_sign, $valid_list, $pos); - local($errs) = 0; - foreach $option ( @Options ) { - if ( $option eq "-" || - $option eq "+" ) {$option_sign = $option;} - else { - if ( $option_sign eq "-" ) - { $valid_list = $valid_reg_options - . $valid_sw_options; } - else - { $valid_list = $valid_sw_options; } - $pos = index ($valid_list,$option); - if ( $pos < $[ && - $quiet_mode ) { - $errs++; - print STDERR "Invalid option: $option_sign$option \n"; - -}# end if -}# end if -}# end foreach - return $errs; - -}#end sub GetOpts - - sub GetOpts -# Gets options. If an option is valid, then opt_[option] is -# set to 0 or 1 as a side effect if the option is preceeded by -# a positive or negative sign. -# -# Usage: -# $rc = &GetOpts ( options, valid_options ) -# -# character: options - options to be checked. (e.g. -df+x) The -# list must begin with a positive or -# negative sign. If no sign appears at the -# beginning or by itself, then the argument -# is not recognized as a list of options. -# character: valid_options - list of valid options (e.g. dfhx) -# integer: rc - return code -# = -1 if the arguement, options, is -# not recognized as a list of options. -# = 0 otherwise -# -{ local($options,$valid_options) = @_; - - if ( $options eq "+" || - $options eq "-" ) {return -1} - - local(@Options) = split( / */, $options ); - if ( $Options[ $[ ] ne "-" && - $Options[ $[ ] ne "+" ) {return -1;} - - local($option, $option_sign); - - foreach $option ( @Options ) { - - if ( $option eq "-" || - $option eq "+" ) { - $option_sign = $option; } - - else { - - if ( index ($valid_options,$option) >= $[ ) { - if ( $option_sign eq "-" ) {${"opt_$option"} = 1;} - if ( $option_sign eq "+" ) {${"opt_$option"} = 0;}; - -}# end if -}# end if -}# end foreach - - return 0; -}#end sub GetOpts - - sub SetOpt -# Sets option flags. For the last input option that is in a -# list, the flag opt_[option] is set to 1 as a side effect. -# For all other options in the list, opt_[option] is set to 0. -# -# Usage: -# $rc = &SetOpt ( options, valid_options ) -# -# character: options - options to be checked. (e.g. -df+x) The -# list must begin with a positive or -# negative sign. If no sign appears at the -# beginning or by itself, then the argument -# is not recognized as a list of options. -# character: valid_options - list of valid options (e.g. def ) -# integer: rc - return code -# = -1 if the arguement, options, is -# not recognized as a list of options. -# = 0 otherwise -# Note: For the examples provided for the input arguments, -# $opt_d = 0, $opt_e = 0, and $opt_f = 1, since the -# input option, -f, was the last in the argument, -# option. -# -{ local($options,$valid_options) = @_; - - if ( $options eq "+" || - $options eq "-" ) {return -1} - - local(@Options) = split( / */, $options ); - local(@ValidOptions) = split( / */, $valid_options ); - if ( $Options[ $[ ] ne "-" && - $Options[ $[ ] ne "+" ) {return -1;} - - local($option, $option_sign); - - foreach $option ( @Options ) { - if ( $option ne "-" && - $option ne "+" ) { - - if ( index ($valid_options,$option) >= $[ ) { - foreach $valid_option (@ValidOptions ) { - ${"opt_$valid_option"} = 0; - -}# end foreach - ${"opt_$option"} = 1; -}# end if -}# end if -}# end foreach - - return 0; -}#end sub SetOpt - -sub print_help { - - print "Usage: protex [-hbACFS] [+-nlsxf] [src_file(s)]"; - print " "; - print " Options:"; - print " -h Help mode: list command line options"; - print " -b Bare mode, meaning no preamble, etc."; - print " +-n New Page for each subsection (wastes paper)"; - print " +-l Listing mode, default is prologues only"; - print " +-s Shut-up mode, i.e., ignore any code from BOC to EOC"; - print " +-x No LaTeX mode, i.e., put !DESCRIPTION: in verbatim mode"; - print " +-f No source file info"; - print " -A Ada code"; - print " -C C++ code"; - print " -F F90 code"; - print " -S Shell script"; - print " "; - print " The options can appear in any order. The options, -h and -b,"; - print " affect the input from all files listed on command-line input."; - print " Each of the remaining options effects only the input from the"; - print " files listed after the option and prior to any overriding"; - print " option. The plus sign turns off the option."; -}# end sub print_help - -sub print_notice { - - print "% **** IMPORTANT NOTICE *****" ; - print "% This LaTeX file has been automatically produced by ProTeX v. 1.1"; - print "% Any changes made to this file will likely be lost next time"; - print "% this file is regenerated from its source. Send questions "; - print "% to Arlindo da Silva, dasilva\@gsfc.nasa.gov"; - print " "; - -}# sub print_notice - -sub print_preamble { - - unless ( $opt_b ) { - print "%------------------------ PREAMBLE --------------------------"; - print "\\documentclass[11pt]{article}"; - print "\\usepackage{amsmath}"; - print "\\usepackage{epsfig}"; - print "\\usepackage{hangcaption}"; - print "\\textheight 9in"; - print "\\topmargin 0pt"; - print "\\headsep 1cm"; - print "\\headheight 0pt"; - print "\\textwidth 6in"; - print "\\oddsidemargin 0in"; - print "\\evensidemargin 0in"; - print "\\marginparpush 0pt"; - print "\\pagestyle{myheadings}"; - print "\\markboth{}{}"; - print "%-------------------------------------------------------------"; -}#end unless - - print "\\parskip 0pt"; - print "\\parindent 0pt"; - print "\\baselineskip 11pt"; - -}# end sub print_preamble - -sub print_macros { - - print " "; - print "%--------------------- SHORT-HAND MACROS ----------------------"; - print "\\def\\bv{\\begin{verbatim}}"; - print "\\def\\ev\{\\end\{verbatim}}"; - print "\\def\\be{\\begin{equation}}"; - print "\\def\\ee{\\end{equation}}"; - print "\\def\\bea{\\begin{eqnarray}}"; - print "\\def\\eea{\\end{eqnarray}}"; - print "\\def\\bi{\\begin{itemize}}"; - print "\\def\\ei{\\end{itemize}}"; - print "\\def\\bn{\\begin{enumerate}}"; - print "\\def\\en{\\end{enumerate}}"; - print "\\def\\bd{\\begin{description}}"; - print "\\def\\ed{\\end{description}}"; - print "\\def\\({\\left (}"; - print "\\def\\){\\right )}"; - print "\\def\\[{\\left [}"; - print "\\def\\]{\\right ]}"; - print "\\def\\<{\\left \\langle}"; - print "\\def\\>{\\right \\rangle}"; - print "\\def\\cI{{\\cal I}}"; - print "\\def\\diag{\\mathop{\\rm diag}}"; - print "\\def\\tr{\\mathop{\\rm tr}}"; - print "%-------------------------------------------------------------"; - -}# end sub print_macros - -sub do_beg { - unless ( $opt_b ) { - if ( $begdoc == 0 ) { - if ( $tpage ) { - print "\\title{@title}"; - print "\\author{{\\sc @author}\\\\ {\\em @affiliation}}"; - print "\\date{@date}"; - } - print "\\begin{document}"; - if ( $tpage ) { - print "\\maketitle"; - } - print "\\tableofcontents"; - print "\\newpage"; - $begdoc = 1; - } - } -}# end sub do_beg - -sub do_eoc { - print ' '; - if ($verb) { - print "\\end{verbatim}"; - $verb = 0; - } - $source = 0; -}# end sub do_eoc - -sub set_missing { - - $have_name = 0; # have routine name? - $have_desc = 0; # have description? - $have_intf = 0; # have interface? - $have_hist = 0; # have revision history? - $name_is = "UNKNOWN"; - -}# end sub set_missing - - -sub check_if_all_there { - -$have_name || -die "ProTeX: invalid prologue, missing !ROUTINE: or !IROUTINE: in <$name_is>"; - -$have_desc || -die "ProTeX: invalid prologue, missing !DESCRIPTION: in <$name_is>"; - -$have_intf || -die "ProTeX: invalid prologue, missing !INTERFACE: in <$name_is>"; - -$have_hist || -die "ProTeX: invalid prologue, missing !REVISION HISTORY: in <$name_is>"; - -}# end sub check_if_all_there diff --git a/cesm/models/utils/mct/testsystem/Makefile b/cesm/models/utils/mct/testsystem/Makefile deleted file mode 100644 index b3614ef..0000000 --- a/cesm/models/utils/mct/testsystem/Makefile +++ /dev/null @@ -1,20 +0,0 @@ - -SHELL = /bin/sh - -SUBDIRS = testall - -# TARGETS -subdirs: - @for dir in $(SUBDIRS); do \ - cd $$dir; \ - $(MAKE); \ - cd ..; \ - done - -clean: - @for dir in $(SUBDIRS); do \ - cd $$dir; \ - $(MAKE) clean; \ - cd ..; \ - done - diff --git a/cesm/models/utils/mct/testsystem/testall/.gitignore b/cesm/models/utils/mct/testsystem/testall/.gitignore deleted file mode 100644 index d675e0f..0000000 --- a/cesm/models/utils/mct/testsystem/testall/.gitignore +++ /dev/null @@ -1,6 +0,0 @@ -testall -*.clog -fort.* -*.log -*testall.* -*.script diff --git a/cesm/models/utils/mct/testsystem/testall/Makefile b/cesm/models/utils/mct/testsystem/testall/Makefile deleted file mode 100644 index 8859c9a..0000000 --- a/cesm/models/utils/mct/testsystem/testall/Makefile +++ /dev/null @@ -1,60 +0,0 @@ - -SHELL = /bin/sh - -# SOURCE FILES - -MODULE = testall - -SRCS_F90 = mph.F90 m_AVTEST.F90 m_ACTEST.F90 \ - m_GGRIDTEST.F90 m_GMAPTEST.F90 \ - m_GSMAPTEST.F90 m_MCTWORLDTEST.F90 \ - m_ROUTERTEST.F90 m_SMATTEST.F90 \ - master.F90 convertgauss.F90 convertPOPT.F90 \ - cpl.F90 ccm.F90 pop.F90 \ - ReadSparseMatrixAsc.F90 - - -OBJS_ALL = $(SRCS_F90:.F90=.o) - -# MACHINE AND COMPILER FLAGS - -include ../../Makefile.conf - -# TARGETS - -all: testall - -testall: $(OBJS_ALL) - $(FC) -o $@ $(OBJS_ALL) $(UTLDFLAGS) $(MCTLIBS) $(MPILIBS) - -# ADDITIONAL FLAGS SPECIFIC FOR UTMCT COMPILATION - -MCTLIBS = -L$(MPEUPATH) -L$(MCTPATH) -lmct -lmpeu -UTLDFLAGS = $(REAL8) -UTCMPFLAGS = $(PROGFCFLAGS) $(REAL8) $(INCFLAG)$(MPEUPATH) $(INCFLAG)$(MCTPATH) - -# RULES - -.SUFFIXES: -.SUFFIXES: .F90 .o - -.F90.o: - $(FC) -c $(INCPATH) $(FPPDEFS) $(FCFLAGS) $(MCTFLAGS) $(UTCMPFLAGS) $< - -clean: - ${RM} *.o *.mod testall - -# DEPENDENCIES: - -$(OBJS_ALL): $(MCTPATH)/libmct.a - - - - - - - - - - - diff --git a/cesm/models/utils/mct/testsystem/testall/ReadSparseMatrixAsc.F90 b/cesm/models/utils/mct/testsystem/testall/ReadSparseMatrixAsc.F90 deleted file mode 100644 index 9fba6c2..0000000 --- a/cesm/models/utils/mct/testsystem/testall/ReadSparseMatrixAsc.F90 +++ /dev/null @@ -1,242 +0,0 @@ -!------------------------------------------------------------------------- -! Math + Computer Science Division / Argonne National Laboratory ! -!------------------------------------------------------------------------- -! CVS $Id: ReadSparseMatrixAsc.F90,v 1.4 2004-06-15 19:16:08 eong Exp $ -! CVS $Name: $ -!----------------------------------------------------------------------- -!BOP -! -! !ROUTINE: ReadSparseMatrixAsc - Read in a SparseMatrix -! -! !INTERFACE: - subroutine ReadSparseMatrixAsc(sMat, fileID, src_dims, dst_dims) -! -! !USES: - - use m_inpak90, only : I90_LoadF - use m_inpak90, only : I90_Label - use m_inpak90, only : I90_Gstr - use m_inpak90, only : I90_Release - use m_ioutil, only : luavail - use m_stdio, only : stdout,stderr - use m_die, only : die - - use m_List, only : List - use m_List, only : List_init => init - use m_List, only : List_clean => clean - - use m_SparseMatrix, only : SparseMatrix - use m_SparseMatrix, only : SparseMatrix_Init => init - use m_SparseMatrix, only : SparseMatrix_Clean => clean - use m_SparseMatrix, only : SparseMatrix_indexIA => indexIA - use m_SparseMatrix, only : SparseMatrix_indexRA => indexRA - use m_SparseMatrix, only : SparseMatrix_lsize => lsize - use m_SparseMatrix, only : SparseMatrix_SortPermute => SortPermute - use m_SparseMatrix, only : SMatrix_importGlobalRowInd => & - importGlobalRowIndices - use m_SparseMatrix, only : SMatrix_importGlobalColumnInd => & - importGlobalColumnIndices - use m_SparseMatrix, only : SMatrix_importMatrixElements => & - importMatrixElements - - implicit none -! -! !DESCRIPTION: This is the reader/tester driver for the Model -! Coupling Toolkit (mct) {\tt SparseMatrix} datatype. -! -! !INPUT PARAMETERS: - - character(len=*), intent(in) :: fileID - -! !OUTPUT PARAMETERS: - - type(SparseMatrix), intent(out) :: sMat - integer, dimension(2), intent(out) :: src_dims - integer, dimension(2), intent(out) :: dst_dims - -! -! -! !BUGS: -! -! !SYSTEM ROUTINES: -! -! !FILES USED: -! -! !REVISION HISTORY: -! -!EOP -!------------------------------------------------------------------------- -! - character(len=*), parameter :: myname = 'ReadSparseMatrixAsc' - - integer :: n,ierr - - integer :: mdev - character*1024 :: filename, data_dir - - integer :: num_elements, nRows, nColumns - integer, dimension(:), pointer :: rows, columns - real, dimension(:), pointer :: weights - -! VARIABLES FOR TESTING ! - -! SparseMatrix attribute indices: - integer :: igrow, igcol, iwgt -! SparseMatrix sorting key list: - type(List) :: sort_keys -! Descending order flag array for SparseMatrix Sort test 2a. - logical :: descending(2) - -!------------------------------------------------ -! Use mpeu resource file utilities to read in the name of the -! file with the weights -! - call I90_LoadF("ut_SparseMatrix.rc", ierr) - - write(stdout,*) myname, ":: loaded ut_SparseMatrix.rc" - - call I90_Label("Data_Directory:", ierr) - call I90_Gstr(data_dir, ierr) - - call I90_Label(trim(fileID), ierr) - call I90_Gstr(filename, ierr) - - filename = trim(data_dir) // "/" // trim(filename) - - write(stdout,*) myname,":: remapfile path = ", trim(filename) - - call I90_Release(ierr) - - write(stdout,*) myname, ":: unloaded ut_SparseMatrix.rc" - - -! First Activity: Input of matrix elements from a file. -!------------------------------------------------ -! Go and actually read the weights. - - ! Find an empty f90 i/o device number - - mdev = luavail() - - ! Open the matrix file - - open(mdev, file=trim(filename), status='old') - - ! LINE 1: - ! Read in the number of matrix elements, and allocate - ! input buffer space: - - read(mdev,*) num_elements - - allocate(rows(num_elements), columns(num_elements), & - weights(num_elements), stat=ierr) - if(ierr /= 0) call die(myname,"allocate(row,col... failed",ierr) - - ! LINE 2: - ! Read in the source grid dimensions - - read(mdev,*) src_dims(1), src_dims(2) - - ! LINE 3: - ! Read in the destination grid dimensions - - read(mdev,*) dst_dims(1), dst_dims(2) - - - ! Read in the row, column, and weight data: - - write(stdout,'(2a)')myname,":: Reading elements from file" - do n=1, num_elements - read(mdev,*) rows(n), columns(n), weights(n) - end do - write(stdout,'(2a)')myname,":: Done reading from file" - - ! Initialize sMat: - nRows = dst_dims(1) * dst_dims(2) - nColumns = src_dims(1) * src_dims(2) - call SparseMatrix_init(sMat, nRows, nColumns, num_elements) - - ! ...and store them. - - call SMatrix_importGlobalRowInd(sMat, rows, size(rows)) - call SMatrix_importGlobalColumnInd(sMat, columns, size(columns)) - call SMatrix_importMatrixElements(sMat, weights, size(weights)) - - deallocate(rows, columns, weights, stat=ierr) - if(ierr/=0) call die(myname,':: deallocate(rows... failed',ierr) - -!------------------------------------------------ - - - -!------------------------------------------------ -! Test features of the SparseMatrix module -! -! Was everything read without incident? -! You can answer this question by comparing the sample -! values printed below with the results of a head and tail -! on the ascii matrix file. - - igrow = SparseMatrix_indexIA(sMat, 'grow') - igcol = SparseMatrix_indexIA(sMat, 'gcol') - iwgt = SparseMatrix_indexRA(sMat, 'weight') - - num_elements = SparseMatrix_lsize(sMat) - - write(stdout,*) myname, ":: Number of sMat elements= ",num_elements - - write(stdout,*) myname, ":: sMat%data%iAttr(igrow,1) = ",sMat%data%iAttr(igrow,1) - write(stdout,*) myname, ":: sMat%data%iAttr(igcol,1) = ",sMat%data%iAttr(igcol,1) - write(stdout,*) myname, ":: sMat%data%rAttr(iwgt,1) = ",sMat%data%rAttr(iwgt,1) - - - write(stdout,*) myname, ":: sMat%data%iAttr(igrow,num_elements) = ", & - sMat%data%iAttr(igrow,num_elements) - write(stdout,*) myname, ":: sMat%data%iAttr(igcol,num_elements) = ", & - sMat%data%iAttr(igcol,num_elements) - write(stdout,*) myname, ":: sMat%data%rAttr(iwgt,num_elements) = ", & - sMat%data%rAttr(iwgt,num_elements) - -! Second Activity: Sorting - - call List_init(sort_keys,"grow:gcol") - - call SparseMatrix_SortPermute(sMat, sort_keys, descending) - -! Second Test Part a): Did it work? - - write(stdout,*) myname, ":: Index sorting test results--descending:" - - write(stdout,*) myname, ":: sMat%data%iAttr(igrow,1) = ",sMat%data%iAttr(igrow,1) - write(stdout,*) myname, ":: sMat%data%iAttr(igcol,1) = ",sMat%data%iAttr(igcol,1) - - write(stdout,*) myname, ":: sMat%data%iAttr(igrow,num_elements) = ", & - sMat%data%iAttr(igrow,num_elements) - write(stdout,*) myname, ":: sMat%data%iAttr(igcol,num_elements) = ", & - sMat%data%iAttr(igcol,num_elements) - - write(stdout,*) myname, ":: End index sorting test results part a." - - - call SparseMatrix_SortPermute(sMat,sort_keys) - -! Second Test Partb: Did it work? - - write(stdout,*) myname, ":: Index sorting test results:--ascending" - - write(stdout,*) myname, ":: sMat%data%iAttr(igrow,1) = ",sMat%data%iAttr(igrow,1) - write(stdout,*) myname, ":: sMat%data%iAttr(igcol,1) = ",sMat%data%iAttr(igcol,1) - - write(stdout,*) myname, ":: sMat%data%iAttr(igrow,num_elements) = ", & - sMat%data%iAttr(igrow,num_elements) - write(stdout,*) myname, ":: sMat%data%iAttr(igcol,num_elements) = ", & - sMat%data%iAttr(igcol,num_elements) - - write(stdout,*) myname, ":: End index sorting test results." - - call List_clean(sort_keys) - -! done testing -!------------------------------------------------ - - end subroutine ReadSparseMatrixAsc diff --git a/cesm/models/utils/mct/testsystem/testall/UNTESTED b/cesm/models/utils/mct/testsystem/testall/UNTESTED deleted file mode 100644 index 0840bdb..0000000 --- a/cesm/models/utils/mct/testsystem/testall/UNTESTED +++ /dev/null @@ -1,13 +0,0 @@ -The following routines are untested: - -m_GlobalToLocal ---> GlobalSegMapToNavigator - -m_Merge - -m_Navigator - -m_NBSend - -m_SparseMatrixComms ---> GM_gather diff --git a/cesm/models/utils/mct/testsystem/testall/ccm.F90 b/cesm/models/utils/mct/testsystem/testall/ccm.F90 deleted file mode 100644 index 1fe02dc..0000000 --- a/cesm/models/utils/mct/testsystem/testall/ccm.F90 +++ /dev/null @@ -1,835 +0,0 @@ -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!----------------------------------------------------------------------- -! CVS $Id: ccm.F90,v 1.13 2004-06-02 22:22:51 eong Exp $ -! CVS $Name: $ -!BOP ------------------------------------------------------------------- -! -! !ROUTINE: ccm3 -- dummy atmosphere model for unit tester -! -! !DESCRIPTION: -! An atmosphere model subroutine to test functionality of MPH and MCT. -! -! !INTERFACE: - subroutine ccm3 (CCM_World) -! -! !USES: -! - use MPH_all -!---Field Storage DataType and associated methods -#ifndef SYSOSF1 - use m_AttrVect,only : AttrVect_exportIListToChar => exportIListToChar - use m_AttrVect,only : AttrVect_exportRListToChar => exportRListToChar -#endif - use m_AttrVect,only : MCT_AtrVt_init => init - use m_AttrVect,only : MCT_AtrVt_clean => clean - use m_AttrVect,only : MCT_AtrVt_lsize => lsize - use m_AttrVect,only : MCT_AtrVt_nReal => nRAttr - use m_AttrVect,only : MCT_AtrVt_nInteger => nIAttr - use m_AttrVect,only : AttrVect_zero => zero - use m_AttrVect,only : AttrVect_Copy => Copy - use m_AttrVect,only : AttrVect -!---Coordinate Grid DataType and associated methods - use m_GeneralGrid,only : GeneralGrid - use m_GeneralGrid,only : MCT_GGrid_init => init - use m_GeneralGrid,only : MCT_GGrid_cart => initCartesian - use m_GeneralGrid,only : MCT_GGrid_clean => clean - use m_GeneralGrid,only : MCT_GGrid_dims => dims - use m_GeneralGrid,only : MCT_GGrid_lsize => lsize - use m_GeneralGrid,only : MCT_GGrid_indexIA => indexIA - use m_GeneralGrid,only : MCT_GGrid_indexRA => indexRA - use m_GeneralGrid,only : MCT_GGrid_exportIAttr => exportIAttr - use m_GeneralGrid,only : MCT_GGrid_importIAttr => importIAttr - use m_GeneralGrid,only : MCT_GGrid_exportRAttr => exportRAttr - use m_GeneralGrid,only : MCT_GGrid_importRAttr => importRAttr - use m_GeneralGrid,only : MCT_GGrid_SortPermute => sortpermute - use m_GeneralGridComms,only: MCT_GGrid_send => send - use m_GeneralGridComms,only: MCT_GGrid_scatter => scatter -!---MCT Spatial Integral services... - use m_SpatialIntegral,only : MCT_SpatialIntegral => SpatialIntegral - use m_SpatialIntegral,only : MCT_SpatialAverage => SpatialAverage - use m_SpatialIntegral,only : MCT_MaskedSpatialIntegral => & - MaskedSpatialIntegral - use m_SpatialIntegral,only : MCT_MaskedSpatialAverage => & - MaskedSpatialAverage -!---Domain Decomposition Descriptor DataType and associated methods - use m_GlobalSegMap,only: MCT_GSMap_init => init - use m_GlobalSegMap,only: MCT_GSMap_clean => clean - use m_GlobalSegMap,only: MCT_GSMap_gsize => gsize - use m_GlobalSegMap,only: MCT_GSMap_lsize => lsize - use m_GlobalSegMap,only: MCT_GSMap_ngseg => ngseg - use m_GlobalSegMap,only: MCT_GSMap_nlseg => nlseg - use m_GlobalSegMap,only: GlobalSegMap -!---Global-to-Local indexing services - use m_GlobalToLocal,only: MCT_GStoL => GlobalToLocalIndices - use m_GlobalToLocal,only: MCT_GStoLI => GlobalToLocalIndex -!---Component Model Registry - use m_MCTWorld,only: ThisMCTWorld - use m_MCTWorld,only: MCTComponentRootRank => ComponentRootRank - use m_MCTWorld,only: MCTWorld_init => init - use m_MCTWorld,only: MCTWorld_clean => clean -!---Intercomponent communications scheduler - use m_Router,only: Router - use m_Router,only: MCT_Router_init => init - use m_Router,only: MCT_Router_clean => clean - use m_Transfer,only: MCT_Send => send -!---mpeu List datatype - use m_List, only : List - use m_List, only : List_clean => clean - use m_List, only : List_copy => copy - use m_List, only : List_exportToChar => exportToChar -!---mpeu routines for MPI communications - use m_mpif90 -!---mpeu timers - use m_zeit -!---mpeu error handling - use m_die -!---mpeu stderr/stdout handling - use m_stdio -!---Tester Modules - use m_ACTEST, only : Accumulator_test => testall - use m_ACTEST, only : Accumulator_identical => identical - use m_AVTEST, only : AttrVect_test => testall - use m_AVTEST, only : AttrVect_identical => Identical - use m_GGRIDTEST, only : GGrid_test => testall - use m_GGRIDTEST, only : GGrid_identical => Identical - use m_GMAPTEST, only : GMap_test => testall - use m_GSMAPTEST, only : GSMap_test => testall - use m_MCTWORLDTEST, only : MCTWorld_test => testall - use m_ROUTERTEST, only : Router_test => testall - use m_SMATTEST, only : sMat_test => testall - use m_SMATTEST, only : sMat_identical => Identical - - implicit none - -! !INPUT PARAMETERS: - - integer,intent(in) :: CCM_World ! communicator for ccm - -! -! !REVISION HISTORY: -! Oct00 - Yun (Helen) He and Chris Ding, NERSC/LBNL - initial MPH-only version -! 19Nov00 - R. Jacob -- interface with mct -! 06Feb01 - J. Larson - slight mod to -! accomodate new interface to MCT_GSMap_lsize(). -! 08Feb01 - R. Jacob -- use MCT_Send -! 23Feb01 - R. Jacob -- expand size of AtrVect -! and add a check for transfer. -! 08Jun01 - R. Jacob initialize a General Grid -! 11Jun01 - Jacob/Larson Send a General Grid to cpl -! 15Feb02 - R.Jacob -- new MCTWorld_init interface. -! 13Jun02 - J. Larson - More GeneralGrid usage, -! including import/export of attributes, and sorting by -! coordinate. Also added mpeu error handling and stdout/stderr. -! 18Jun02 - J. Larson - Introduction of Spatial -! Integral/Average services. -! 18Jul02 - E. Ong - Use a gaussian atmosphere grid -!EOP ___________________________________________________________________ - character(len=*), parameter :: ccmname='ccm3' - -!----------------------- MPH vars - integer :: myProc, myProc_global, root - integer :: Global_World - integer :: coupler_id - integer :: mySize, ncomps, mycompid - -!----------------------- MCT and dummy model vars - integer :: i,j,n,k,ier - -! SparseMatrix dimensions and Processor Layout - integer :: Nax, Nay ! Atmosphere lons, lats - integer :: Nox, Noy ! Ocean lons, lats - integer :: NPROCS_LATA, NPROCS_LONA ! Processor layout - -! Number of steps to send to coupler - - integer :: steps - integer, parameter :: nsteps = 10 - -! Arrays used to initialize the MCT GlobalSegMap - integer,dimension(:),pointer :: starts - integer,dimension(:),pointer :: lengths - integer,dimension(:,:),pointer :: myglobalmap -! integer,dimension(:),pointer :: lstart,llength - -! Arrays used to test MCT import/export routines - integer, dimension(:), pointer :: dummyI - real, dimension(:), pointer :: dummyR - integer :: latindx,lonindx,gridindx,status - integer :: length - -! Index to AtmGrid area element dA - integer :: dAindx - -! Set the value of pi - real, parameter :: pi = 3.14159265359 - -! Atmosphere GSMap - type(GlobalSegMap) :: GSMap -! Router from Atm to Cpl - type(Router) :: Atm2Cpl -! AttrVect for atm data - type(AttrVect) :: a2coupler -! AttrVect for atm data used to test spatial integration services - type(AttrVect) :: a2coupler2, integratedA2CaV -! The atmosphere's grid - type(GeneralGrid) :: AtmGrid, dAtmGrid - -! Test Grids and test dummy vars - type(GeneralGrid) :: AtmGridExactCopy, dAtmGridExactCopy - type(GeneralGrid) :: AtmCartGrid - type(List) :: cartlist,cartindex,cartother,cartweight - integer,dimension(:),pointer :: cartdims - real,dimension(:),pointer :: dummyatmlats, dummyatmlons - real,dimension(:),pointer :: dummycartlats, dummycartlons - real,dimension(:,:),pointer :: cartaxis - real,dimension(:),allocatable :: gauss_wgt, gauss_lat - logical,dimension(:),pointer :: cartdescend - integer :: axlength,aylength,cxlength,cylength - real :: dlon - -! Spatial Integral Temporary Variables - -#ifdef MPE -#include "mpe.h" -#endif - -!------------------------------------------------------- - - call MPI_COMM_DUP (MPI_COMM_WORLD, Global_World, ierr) - call MPI_COMM_RANK (MPI_COMM_WORLD, myProc_global, ierr) - call MPI_COMM_RANK (CCM_World, myProc, ierr) - if (myProc==0) call MPH_redirect_output ('ccm') -! write(*,*) myProc, ' in ccm === ', myProc_global, ' in global' -! write(*,*) 'MPH_local_proc_id()=', MPH_local_proc_id_ME_SE() -! write(*,*) 'MPH_global_proc_id()=', MPH_global_proc_id() -! write(*,*) 'MPH_component_id()=', MPH_component_id_ME_SE() - -! if profiling with the MPE lib -#ifdef MPE - call mpe_logging_init(myProc_global,init_s,init_e,gsmi_s,gsmi_e,& - atri_s,atri_e,routi_s,routi_e,send_s,send_e,recv_s,recv_e,& - clean_s,clean_e) -#endif - -! Get the coupler's component id - coupler_id = MPH_get_component_id("coupler") - -!------------------------------------------------------- -! Begin using MCT - -!!!!!!!!!!!!!!!!!----------MCTWorld -! initialize the MCTWorld - ncomps=MPH_total_components() - mycompid=MPH_component_id_ME_SE() - -! all components must call this -! if(myProc==0)write(stdout,*)"Initializing MCTWorld" - - call zeit_ci('Aworldinit') - call MCTWorld_init(ncomps,MPI_COMM_WORLD,CCM_World,mycompid) - call zeit_co('Aworldinit') - - call MCTWorld_test("CCM::MCTWorld",6100+myProc) - - ! Get the Sparse Matrix dimensions and processor layout - root = MCTComponentRootRank(coupler_id,ThisMCTWorld) - call MPI_BCAST(Nax,1,MP_INTEGER,root,MPI_COMM_WORLD,ierr) - call MPI_BCAST(Nay,1,MP_INTEGER,root,MPI_COMM_WORLD,ierr) - call MPI_BCAST(Nox,1,MP_INTEGER,root,MPI_COMM_WORLD,ierr) - call MPI_BCAST(Noy,1,MP_INTEGER,root,MPI_COMM_WORLD,ierr) - call MPI_BCAST(NPROCS_LATA,1,MP_INTEGER,root,MPI_COMM_WORLD,ierr) - call MPI_BCAST(NPROCS_LONA,1,MP_INTEGER,root,MPI_COMM_WORLD,ierr) - - ! check to see if there are enough processors - call MPI_COMM_SIZE(CCM_World, mySize, ierr) - if (mySize /= NPROCS_LATA*NPROCS_LONA) then - write(*,*)'ERROR: wrong number of processors' - write(*,*)'found ',mySize,' Needed',NPROCS_LATA*NPROCS_LONA - stop - endif - -! Number the grid 1 to Nax*Nay, starting -! in the South Pole and proceeding along a latitude and -! then from south to north. -! NOTE: This may not look like much but its very important. -! This is where the numbering scheme for each grid point, -! on which all of MCT is based, is defined. The points -! are numbered from 1 to Nax*Nay starting at the south -! pole (j=1) and moving west to east and south to north - - allocate(myglobalmap(Nax,Nay),stat=ierr) - if(ierr/=0) call die(ccmname, "allocate(myglobalmap)", ierr) - n=0 - do j=1,Nay - do i= 1,Nax - n=n+1 - myglobalmap(i,j) = n - enddo - enddo - -!!!!!!!!!!!!!!!!!----------General Grid - -! Load a Gaussian atmosphere general grid -! Note: The following block of code is for the root process. - -if(myProc==0) then - - write(*,*) ccmname, ":: Initializing Atm General Grid" - - call convertgauss(AtmGrid, Nax, Nay) - - - call GGrid_test(AtmGrid,"CCM::AtmGrid",3300+myProc) - - ! Set up a copy for later on... - call MCT_GGrid_init(AtmGridExactCopy,AtmGrid,MCT_GGrid_lsize(AtmGrid)) - call AttrVect_Copy(aVin=AtmGrid%data,aVout=AtmGridExactCopy%data) - -!::::::::::::::::::::::::::::::::::::! -!:::::TEST INITCARTESIAN:::::::::::::! -!::::::::::::::::::::::::::::::::::::! - - ! Test initCartesian from AtmGrid values - - call List_copy(cartlist,AtmGrid%coordinate_list) - call List_copy(cartweight,AtmGrid%weight_list) - call List_copy(cartother,AtmGrid%other_list) - call List_copy(cartindex,AtmGrid%index_list) - - allocate(cartdims(2),cartaxis(MAX(Nay,Nax),2), & - gauss_wgt(Nay),gauss_lat(Nay),cartdescend(2),stat=ierr) - if(ierr/=0) call die(ccmname,"allocate(cart...)",ierr) - - cartdims(1) = Nay - cartdims(2) = Nax - - ! Obtain the gaussian latitudes and longitudes from convertgauss.F90 - call gquad(Nay,gauss_lat,gauss_wgt) - do i=1,Nay - cartaxis(i,1) = (0.5*pi - gauss_lat(Nay+1-i)) * 180./pi - enddo - - dlon = 360./Nax - do i=1,Nax - cartaxis(i,2) = (i-1)*dlon - enddo - - cartdescend=.false. - - call MCT_GGrid_cart(GGrid=AtmCartGrid, & - CoordChars=List_exportToChar(cartlist), & - CoordSortOrder="grid_center_lat:grid_center_lon", & - descend=cartdescend, & - WeightChars=List_exportToChar(cartweight), & - OtherChars=List_exportToChar(cartother), & - IndexChars=List_exportToChar(cartindex), & - Dims=cartdims, & - AxisData=cartaxis) - - call GGrid_test(AtmCartGrid,"CCM::AtmCartGrid",3600+myProc) - - call MCT_GGrid_SortPermute(AtmCartGrid) - call MCT_GGrid_SortPermute(AtmGrid) - - allocate(dummycartlats(MCT_GGrid_lsize(AtmCartGrid)), & - dummycartlons(MCT_GGrid_lsize(AtmCartGrid)), & - dummyatmlats(MCT_GGrid_lsize(AtmGrid)), & - dummyatmlons(MCT_GGrid_lsize(AtmGrid)), & - stat=ierr) - if(ierr/=0) call die(ccmname, "allocate(dummy...)", ierr) - - call MCT_GGrid_exportRAttr(AtmCartGrid, 'grid_center_lat', & - dummycartlats,cylength) - call MCT_GGrid_exportRAttr(AtmCartGrid, 'grid_center_lon', & - dummycartlons,cxlength) - call MCT_GGrid_exportRAttr(AtmGrid, 'grid_center_lat', & - dummyatmlats, aylength) - call MCT_GGrid_exportRAttr(AtmGrid, 'grid_center_lon', & - dummyatmlons, axlength) - - if((aylength/=cylength).or.(axlength/=cxlength)) then - call die(ccmname,"Atmosphere GeneralGrid failed the first LENGTH test") - endif - - if((aylength/=Nay*Nax).or.(axlength/=Nax*Nay)) then - call die(ccmname,"Atmosphere GeneralGrid failed the second LENGTH test") - endif - - ! The lowest limit I have found for this is 1e-5 on the Absoft compiler - ! This is not as precise as the lons because of round off - do i=1,Nay*Nax - if( abs(dummycartlats(i)-dummyatmlats(i)) > 1e-5 ) then - call die(ccmname,"GeneralGrid INITCARTESIAN failed the LAT test") - endif - enddo - do i=1,Nax*Nay - if( abs(dummycartlons(i)-dummyatmlons(i)) > 1e-8 ) then - call die(ccmname,"GeneralGrid INITCARTESIAN failed the LON test") - endif - enddo - - deallocate(cartdims,cartaxis,cartdescend,dummycartlats,dummycartlons, & - dummyatmlats,dummyatmlons,gauss_wgt,gauss_lat,stat=ierr) - if(ierr/=0) call die(ccmname,"deallocate(cart...)",ierr) - - call List_clean(cartlist) - call List_clean(cartweight) - call List_clean(cartindex) - call List_clean(cartother) -!::::::::::::::::::::::::::::::::::::! -!:::::DONE WITH INITCARTESIAN::::::::! -!::::::::::::::::::::::::::::::::::::! - -! Write out the basic things we initialized - - write(stdout,'(3a,i1)') ccmname, & - ":: Initialized Atm GeneralGrid variable AtmGrid.", & - "Number of dimensions = ", MCT_GGrid_dims(AtmGrid) - write(stdout,'(2a,i8)') ccmname, & - ":: Number of grid points in AtmGrid=", & - MCT_GGrid_lsize(AtmGrid) - write(stdout,'(2a,i8)') ccmname, & - ":: Number of latitudes Nay=", Nay - write(stdout,'(2a,i8)') ccmname, & - ":: Number of longitudes Nax=", Nax - write(stdout,'(2a,i8)') ccmname, & - ":: Number of grid points Nax*Nax=", Nay*Nax - write(stdout,'(3a)') ccmname, & - ":: AtmGrid%coordinate_list = ", & - List_exportToChar(AtmGrid%coordinate_list) - write(stdout,'(3a)') ccmname, & - ":: AtmGrid%weight_list = ", & - List_exportToChar(AtmGrid%weight_list) - write(stdout,*) ccmname, & ! * is used for SUPER_UX compatibility - ":: AtmGrid%other_list = ", & - List_exportToChar(AtmGrid%other_list) - write(stdout,'(3a)') ccmname, & - ":: AtmGrid%index_list = ", & - List_exportToChar(AtmGrid%index_list) - write(stdout,'(2a,i3)') ccmname, & - ":: Number of integer attributes stored in AtmGrid=", & - MCT_AtrVt_nInteger(AtmGrid%data) - write(stdout,'(2a,i3)') ccmname, & - ":: Total Number of real attributes stored in AtmGrid=", & - MCT_AtrVt_nReal(AtmGrid%data) - -! Get AtmGrid attribute indicies - latindx=MCT_GGrid_indexRA(AtmGrid,'grid_center_lat') - lonindx=MCT_GGrid_indexRA(AtmGrid,'grid_center_lon') - -! NOTE: The integer attribute GlobGridNum is automatically -! appended to any General Grid. Store the grid numbering -! scheme (used in the GlobalSegMap) here. - gridindx=MCT_GGrid_indexIA(AtmGrid,'GlobGridNum') - - do j=1,Nay - do i=1,Nax - n=myglobalmap(i,j) - AtmGrid%data%iAttr(gridindx,n)=n - enddo - enddo - -! Check the weight values of the grid_area attribute - - dAindx = MCT_GGrid_indexRA(AtmGrid, 'grid_area') - - write(stdout,'(2a)') ccmname, & - ':: Various checks of GeneralGrid AtmGrid Weight data...' - write(stdout,'(2a,f12.6)') ccmname, & - ':: direct ref--AtmGrid 1st dA entry=.', & - AtmGrid%data%rAttr(dAindx,1) - write(stdout,'(2a,f12.6)') ccmname, & - ':: direct ref--AtmGrid last dA entry=.', & - AtmGrid%data%rAttr(dAindx,MCT_GGrid_lsize(AtmGrid)) - write(stdout,'(2a,f12.6)') ccmname, & - ':: Sum of dA(1,...,Nax*Nay)=.', & - sum(AtmGrid%data%rAttr(dAindx,:)) - write(stdout,'(2a,f12.6)') ccmname, & - ':: Unit Sphere area 4 * pi=.', 4.*pi - -! Check on coordinate values (and check some export functions, too...) - - allocate(dummyR(MCT_GGrid_lsize(AtmGrid)), stat=ierr) - if(ierr/=0) call die(ccmname, "allocate(myglobalmap)", ierr) - - call MCT_GGrid_exportRAttr(AtmGrid, 'grid_center_lat', dummyR, length) - - write(stdout,'(2a)') ccmname, & - ':: Various checks of GeneralGrid AtmGrid coordinate data...' - write(stdout,'(2a,i8)') ccmname, & - ':: No. exported AtmGrid latitude values =.',length - write(stdout,'(2a,f12.6)') ccmname, & - ':: export--AtmGrid 1st latitude=.',dummyR(1) - write(stdout,'(2a,f12.6)') ccmname, & - ':: export--AtmGrid last latitude=.',dummyR(length) - write(stdout,'(2a,f12.6)') ccmname, & - ':: direct ref--AtmGrid 1st latitude=.', & - AtmGrid%data%rAttr(latindx,1) - write(stdout,'(2a,f12.6)') ccmname, & - ':: direct ref--AtmGrid last latitude=.', & - AtmGrid%data%rAttr(latindx,length) - write(stdout,'(2a,f12.6)') ccmname, & - ':: direct ref--AtmGrid 1st longitude=.', & - AtmGrid%data%rAttr(lonindx,1) - write(stdout,'(2a,f12.6)') ccmname, & - ':: direct ref--AtmGrid last longitude=.', & - AtmGrid%data%rAttr(lonindx,MCT_GGrid_lsize(AtmGrid)) - write(stdout,'(2a)') ccmname, & - ':: End checks of GeneralGrid AtmGrid coordinate data.' - -! Check the GlobalGridNum values: - - allocate(dummyI(MCT_GGrid_lsize(AtmGrid)), stat=ierr) - if(ierr/=0) call die(ccmname, "allocate(dummyI)", ierr) - - call MCT_GGrid_exportIAttr(AtmGrid, 'GlobGridNum', dummyI, length) - - write(stdout,'(2a,i8)') ccmname, & - ':: No. exported AtmGrid GlobalGridNum values =.',length - write(stdout,'(2a,i8)') ccmname, & - ':: export--AtmGrid 1st GlobalGridNum =.', dummyI(1) - write(stdout,'(2a,i8)') ccmname, & - ':: export--AtmGrid last GlobalGridNum =.', dummyI(length) - write(stdout,'(2a,i8)') ccmname, & - ':: direct ref--AtmGrid 1st GlobalGridNum =.', & - AtmGrid%data%iAttr(gridindx,1) - write(stdout,'(2a,i8)') ccmname, & - ':: direct ref--AtmGrid last GlobalGridNum =.', & - AtmGrid%data%iAttr(gridindx,length) - -! send the atmosphere's grid from the atmosphere's root to the -! coupler's root. 1400 is the randomly chosen tag base. - call MCT_GGrid_send(AtmGrid,coupler_id,1400,status=status) - -! Clean up arrays used for GGrid tests: - - deallocate(dummyI, dummyR, stat=ierr) - if(ierr /= 0) then - write(stderr,'(2a,i8)') ccmname, & - ':: ERROR--deallocate(dummyI,dummyR) failed with ierr=', ierr - call die(ccmname) - endif - -endif ! if(myProc==0) - -!!!!!!!!!!!!!!!!!----------GlobalSegMap -! Get ready to initialize the GlobalSegMap -! -! -! Go and define the starts and lengths according to the -! decomposition we want - - call FoldOverDecomp(myglobalmap,starts,lengths,Nax,Nay) - -! now put the information in a GlobalSegMap. -! if(myProc==0)write(*,*)"Inializing GSMap" - call zeit_ci('Agsmapinit') - call MCT_GSMap_init(GSMap,starts,lengths,0,CCM_World,mycompid) - call zeit_co('Agsmapinit') - -! Try using some GSMap functions. -! write(*,*)myProc,'number of global segs is',MCT_GSMap_ngseg(GSMap) -! write(*,*)myProc,'number of local segs is', MCT_GSMap_nlseg(GSMap,myProc) -! write(*,*)myProc,'local size is',MCT_GSMap_lsize(GSMap,CCM_World) -! write(*,*)myProc,'global size is',MCT_GSMap_gsize(GSMap) - -! call MCT_GStoL(GSMap,CCM_World,lstart,llength) -! if(myProc==0) then -! do i=1,GSMap%ngseg -! write(*,*)i,GSMap%start(i),GSMap%pe_loc(i) -! if(myProc==GSMap%pe_loc(i)) then -! point = GSMap%start(i) -! write(*,*)"MCTGStoLI",MCT_GStoLI(GSMap,point,CCM_World) -! endif -! enddo -! endif - - -!!!!!!!!!!!!!!!!!----------Attribute Vector -! intialize an attribute vector -! if(myProc==0)write(*,*)"Initializing Attrvect" - - call zeit_ci('Aatvecinit') -! declare an attrvect to hold all atm model outputs -! an identical decleration needs to be made in the coupler -! NOTE: the size of the AttrVect is set to be the local -! size of the GSMap. - call MCT_AtrVt_init(a2coupler, & - iList='gsindex', &! local GSMap values - rList=& -! height of first atm level - "alevh:& -! u wind - &uwind:& -! v wind - &vwind:& -! potential temp - &pottem:& -! specific humidity - &s_hum:& -! density - &rho:& -! barometric pressure - &barpres:& -! surface pressure - &surfp:& -! net solar radiation - &solrad:& -! downward direct visible radiation - &dirvis:& -! downward diffuse visible radiation - &difvis:& -! downward direct near-infrared radiation - &dirnif:& -! downward diffuse near-infrared radiation - &difnif:& -! downward longwave radiation - &lngwv:& -! convective precip - &precc:& -! large-scale precip - &precl",& - lsize=MCT_GSMap_lsize(GSMap, CCM_World)) - call zeit_co('Aatvecinit') - -! create a second attribute vector to test copying - call MCT_AtrVt_init(a2coupler2, rList="conpre:precl:uwind:vwind", & - lsize=MCT_GSMap_lsize(GSMap,CCM_World)) - call AttrVect_zero(a2coupler2) - -if(myProc==0)then -#ifndef SYSOSF1 - write(stdout,*) ccmname,':: a2coupler%rList = ', & - AttrVect_exportRListToChar(a2coupler) - write(stdout,*) ccmname,':: a2coupler%iList = ', & - AttrVect_exportIListToChar(a2coupler) -#endif - write(stdout,'(2a,i8)') ccmname, & - ':: a2coupler length = ', MCT_AtrVt_lsize(a2coupler) - write(stdout,'(2a,i8)') ccmname, & - ':: MCT_GSMap_lsize = ', MCT_GSMap_lsize(GSMap, CCM_World) -endif - -! load the local values of the GSMap into gsindex for checking - j=1 - do i=1,MCT_GSMap_ngseg(GSMap) - if(myProc==GSMap%pe_loc(i)) then - do k=1,GSMap%length(i) - a2coupler%iAttr(1,j)=GSMap%start(i)+k-1 - j=j+1 - enddo - endif - enddo - -! put some data in the Attribute Vector - do j=1,MCT_AtrVt_nReal(a2coupler) - do i=1,MCT_GSMap_lsize(GSMap, CCM_World) - a2coupler%rAttr(j,i)=30. - enddo - enddo - -! test Attribute vector copying -if(myProc==0)write(stdout,'(2a)') ccmname,':: Test aV copy services' -if(myProc==0)write(stdout,*) ccmname, ':: initial values', & - a2coupler2%rAttr(1,1), a2coupler2%rAttr(2,1), & - a2coupler2%rAttr(3,1), a2coupler2%rAttr(4,1) - -! copy all shared attributes -call AttrVect_Copy(a2coupler,a2coupler2) -if(myProc==0)write(stdout,*) ccmname, ':: copy shared', & - a2coupler2%rAttr(1,1), a2coupler2%rAttr(2,1), & - a2coupler2%rAttr(3,1), a2coupler2%rAttr(4,1) -call AttrVect_zero(a2coupler2) - -! copy only one attribute -call AttrVect_Copy(a2coupler,a2coupler2,"precl") -if(myProc==0)write(stdout,*) ccmname, ':: copy one real', & - a2coupler2%rAttr(1,1), a2coupler2%rAttr(2,1), & - a2coupler2%rAttr(3,1),a2coupler2%rAttr(4,1) -call AttrVect_zero(a2coupler2) - -! copy two with a translation -call AttrVect_Copy(a2coupler,a2coupler2,"precc:vwind","conpre:vwind") -if(myProc==0)write(stdout,*) ccmname, ':: copy two real, translate', & - a2coupler2%rAttr(1,1), a2coupler2%rAttr(2,1), & - a2coupler2%rAttr(3,1),a2coupler2%rAttr(4,1) - - -! Remember AtmGrid? This was created only on the root. To do -! some neat integrals, we must scatter it using MCT onto the -! same decomposition as a2coupler: - - call MCT_GGrid_scatter(AtmGrid, dAtmGrid, GSMap, 0, CCM_World) - call MCT_GGrid_scatter(AtmGridExactCopy,dAtmGridExactCopy,GSMap,0,CCM_World) - - if(myProc==0) then - if(.NOT.GGrid_identical(AtmGrid,AtmGridExactCopy,1e-5)) then - call die(ccmname,"AtmGrid unexpectedly altered!!!") - endif - endif - - if(.NOT.GGrid_identical(dAtmGrid,dAtmGridExactCopy,1e-5)) then - call die(ccmname,"dAtmGrid unexpectedly altered!!!") - endif - -! Now, Test the MCT Spatial Integration/Averaging Services... - if(myProc==0)write(stdout,'(3a)') ccmname, & - ':: on-Root test of MCT Spatial Integration Services...' - -! simple unmasked integral case: - call MCT_SpatialIntegral(a2coupler, integratedA2CaV, & - dAtmGrid, 'grid_area', comm=CCM_World) - -if(myProc==0)then - do i=1,MCT_AtrVt_nReal(integratedA2CaV) - write(stdout,'(3a,i2,a,f12.6)') ccmname, & - ':: Unmasked distributed MCT ', & - 'integral: integratedA2CaV%rAttr(',i,',1)=', & - integratedA2CaV%rAttr(i,1) - end do -endif - - call MCT_AtrVt_clean(integratedA2CaV) - -! simple unmasked average case: - call MCT_SpatialAverage(a2coupler, integratedA2CaV, & - dAtmGrid, 'grid_area', comm=CCM_World) - -if(myProc==0)then - do i=1,MCT_AtrVt_nReal(integratedA2CaV) - write(stdout,'(3a,i2,a,f12.6)') ccmname, & - ':: Unmasked distributed MCT ', & - 'average: averagedA2CaV%rAttr(',i,',1)=', & - integratedA2CaV%rAttr(i,1) - end do -endif - - call MCT_AtrVt_clean(integratedA2CaV) - -! not-so-simple masked average cases... - call MCT_MaskedSpatialAverage(inAv=a2coupler, & - outAv=integratedA2CaV, & - GGrid=dAtmGrid, & - SpatialWeightTag='grid_area', & - imaskTags='grid_imask', & - UseFastMethod=.TRUE., & - comm=CCM_World) - -if(myProc==0)then - do i=1,MCT_AtrVt_nReal(integratedA2CaV) - write(stdout,'(3a,i2,a,f12.6)') ccmname, & - ':: Masked distributed MCT ', & - 'average: averagedA2CaV%rAttr(',i,',1)=', & - integratedA2CaV%rAttr(i,1) - end do -endif - - call MCT_AtrVt_clean(integratedA2CaV) - -!!!!!!!!!!!!!!!!!----------Router -! intialize a Router to the Coupler. Call it Atm2Cpl - if(myProc==0)write(*,*) ccmname,":: Initializing Router" - call zeit_ci('Arouterinit') - call MCT_Router_init(coupler_id,GSMap,CCM_World,Atm2Cpl) - call zeit_co('Arouterinit') - if(myProc==0)write(*,*) ccmname,":: Done Initializing Router" - - call Router_test(Atm2Cpl,"CCM::Atm2Cpl",7300+myProc) - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! Endof initialization phase -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -!!!!!!!!!!!!!!!!!----------MCT_Send -! send data to the coupler. - if(myProc==0)write(*,*) ccmname,":: Doing Distributed Send" - - call AttrVect_test(a2coupler,"CCM::a2coupler",2000+myProc) - do steps=1,nsteps - call zeit_ci('Amctsend') - call MCT_Send(a2coupler,Atm2Cpl) - call zeit_co('Amctsend') - enddo - - if(myProc==0)write(*,*) ccmname,":: Done with Send" - - -!!!!!!!!!!!!!!!!!---------- all done - call zeit_ci('Acleanup') - - ! Clean MCT datatypes - if(myProc==0) then - call MCT_GGrid_clean(AtmGrid) - call MCT_GGrid_clean(AtmCartGrid) - call MCT_GGrid_clean(AtmGridExactCopy) - endif - - call MCT_GGrid_clean(dAtmGrid) - call MCT_GGrid_clean(dAtmGridExactCopy) - call MCT_GSMap_clean(GSMap) - call MCT_Router_clean(Atm2Cpl) - call MCT_AtrVt_clean(a2coupler) - call MCT_AtrVt_clean(a2coupler2) - call MCTWorld_clean() - - ! Clean temporary structures - - deallocate(starts, lengths, myglobalmap, stat=ierr) - if(ierr/=0) call die(ccmname, "deallocate(starts,lengths..)", ierr) - - call zeit_co('Acleanup') - -! write out timing info to fortran unit 45 - call zeit_allflush(CCM_World,0,45) - -contains - - subroutine FoldOverDecomp(myglobalmap,starts,lengths,nx,ny) - - integer,dimension(:,:),intent(in) :: myglobalmap - integer,dimension(:),pointer :: starts,lengths - integer, intent(in) :: nx,ny - integer :: i,j,n,row,col,plat,plon -! For this example, we will do a fold-over-the-equator -! mapping of our grid onto the cartesian processor topology: -! each row of processors handles latitudes from -! the northern and southern hemispheres. - -! -! For each processor, each seglength is plon -! -! the value of the global index at the start of each -! segment can be found from myglobalmap - -! set local latitude and longitude size - plat = ny / NPROCS_LATA - plon = nx / NPROCS_LONA - -! define a Cartesian topology by assigning -! row and column indicies to each processor. -! processor with rank 0 is (0,0) - row = myProc / NPROCS_LONA - col = mod(myProc,NPROCS_LONA) - - allocate(starts(plat),lengths(plat),stat=ierr) - if(ierr/=0) call die(ccmname, "allocate(starts..)", ierr) - -! the fist plat/2 latitudes are from the southern hemisphere - do j=1,plat/2 - starts(j)= myglobalmap(col*plon + 1,(plat/2 * row) + j) - lengths(j)=plon - enddo - -! the next plat/2 latitudes are from the northern hemisphere - n=1 - do j=plat/2 + 1,plat - starts(j)=myglobalmap(col*plon + 1,(ny - (plat/2 * (row+1))) + n) - lengths(j)=plon - n=n+1 - enddo - -end subroutine FoldOverDecomp - -end subroutine ccm3 - diff --git a/cesm/models/utils/mct/testsystem/testall/convertPOPT.F90 b/cesm/models/utils/mct/testsystem/testall/convertPOPT.F90 deleted file mode 100644 index 8c9fb12..0000000 --- a/cesm/models/utils/mct/testsystem/testall/convertPOPT.F90 +++ /dev/null @@ -1,454 +0,0 @@ -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! -! This file converts a POP grid.dat file to a remapping grid file -! in netCDF format. -! -!----------------------------------------------------------------------- -! -! CVS:$Id: convertPOPT.F90,v 1.9 2004-06-02 23:25:50 eong Exp $ -! CVS $Name: $ -! -! Copyright (c) 1997, 1998 the Regents of the University of -! California. -! -! Unless otherwise indicated, this software has been authored -! by an employee or employees of the University of California, -! operator of the Los Alamos National Laboratory under Contract -! No. W-7405-ENG-36 with the U.S. Department of Energy. The U.S. -! Government has rights to use, reproduce, and distribute this -! software. The public may copy and use this software without -! charge, provided that this Notice and any statement of authorship -! are reproduced on all copies. Neither the Government nor the -! University makes any warranty, express or implied, or assumes -! any liability or responsibility for the use of this software. -! -!*********************************************************************** - - subroutine convertPOPT(GGrid, grid_file_in, grid_topo_in, nx, ny) - -!----------------------------------------------------------------------- -! -! This file converts a POP grid.dat file to a remapping grid file. -! -!----------------------------------------------------------------------- - - use m_AttrVect,only : AttrVect - use m_GeneralGrid,only : MCT_GGrid_init => init - use m_GeneralGrid,only : MCT_GGrid_indexIA => indexIA - use m_GeneralGrid,only : MCT_GGrid_indexRA => indexRA - use m_GeneralGrid,only : GeneralGrid - use m_stdio - use m_ioutil - use m_die - - - implicit none - -!----------------------------------------------------------------------- -! -! variables that describe the grid -! 4/3 nx = 192, ny = 128 -! 2/3 (mod) nx = 384, ny = 288 -! x3p Greenland DP nx = 100, ny = 116 -! x2p Greenland DP nx = 160, ny = 192 -! x1p Greenland DP nx = 320, ny = 384 -! -!----------------------------------------------------------------------- - - type(GeneralGrid), intent(out) :: GGrid - character (len=*), intent(in) :: grid_file_in - character (len=*), intent(in) :: grid_topo_in - integer, intent(in) :: nx - integer, intent(in) :: ny - - integer :: grid_size - - integer, parameter :: & - grid_rank = 2, & - grid_corners = 4 - - integer, dimension(2) :: & - grid_dims ! size of each dimension - -!----------------------------------------------------------------------- -! -! grid coordinates and masks -! -!----------------------------------------------------------------------- - -!:: NOTE: The following kind specifiers are needed to read the proper -!:: values for the POP grid files. The subsequent type conversions -!:: on these variables may pose a risk. - - integer(kind(1)), dimension(:), allocatable :: & - grid_imask - - real, dimension(:), allocatable :: & - grid_area , &! area as computed in POP - grid_center_lat, &! lat/lon coordinates for - grid_center_lon ! each grid center in radians - - real(selected_real_kind(13)), dimension(:,:), allocatable :: & - grid_corner_lat, &! lat/lon coordinates for - grid_corner_lon ! each grid corner in radians - - real(selected_real_kind(13)), dimension(:,:), allocatable :: & - HTN, HTE ! T-cell grid lengths - -!----------------------------------------------------------------------- -! -! defined constants -! -!----------------------------------------------------------------------- - - real(selected_real_kind(13)), parameter :: & - zero = 0.0, & - one = 1.0, & - two = 2.0, & - three = 3.0, & - four = 4.0, & - five = 5.0, & - half = 0.5, & - quart = 0.25, & - bignum = 1.e+20, & - tiny = 1.e-14, & - pi = 3.14159265359, & - pi2 = two*pi, & - pih = half*pi - - real(selected_real_kind(13)), parameter :: & - radius = 6.37122e8 , & ! radius of Earth (cm) - area_norm = one/(radius*radius) - -!----------------------------------------------------------------------- -! -! other local variables -! -!----------------------------------------------------------------------- - - character(len=*),parameter :: myname_= 'convertPOPT' - - integer :: i, j, k, n, p, q, r, ier - - integer :: iunit, ocn_add, im1, jm1, np1, np2 - - integer :: center_lat, center_lon, & - corner_lat, corner_lon, & - imask, area - - real :: tmplon, dlat, dxt, dyt - - real :: x1, x2, x3, x4, & - y1, y2, y3, y4, & - z1, z2, z3, z4, & - tx, ty, tz, da - - grid_size = nx*ny - - allocate(grid_imask(grid_size), & - grid_area(grid_size), & - grid_center_lat(grid_size), & - grid_center_lon(grid_size), & - grid_corner_lat(grid_corners,grid_size), & - grid_corner_lon(grid_corners,grid_size), & - HTN(nx,ny), & - HTE(nx,ny), & - stat=ier) - - if(ier/=0) call die(myname_,"allocate(grid_imask... ", ier) - -!----------------------------------------------------------------------- -! -! read in grid info -! lat/lon info is on velocity points which correspond -! to the NE corner (in logical space) of the grid cell. -! -!----------------------------------------------------------------------- - - iunit = luavail() - - open(unit=iunit, file=trim(grid_topo_in), status='old', & - form='unformatted', access='direct', recl=grid_size*4) - - read (unit=iunit,rec=1) grid_imask - - call luflush(iunit) - - iunit = luavail() -#if SYSSUPERUX || SYSOSF1 - open(unit=iunit, file=trim(grid_file_in), status='old', & - form='unformatted', access='direct', recl=grid_size*2) -#else - open(unit=iunit, file=trim(grid_file_in), status='old', & - form='unformatted', access='direct', recl=grid_size*8) -#endif - - read (unit=iunit, rec=1) grid_corner_lat(3,:) - read (unit=iunit, rec=2) grid_corner_lon(3,:) - read (unit=iunit, rec=3) HTN - read (unit=iunit, rec=4) HTE - call luflush(iunit) - -!:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: -!::::::::::::TEST DIAGNOSTICS:::::::::::::::::::::::::::::::::: -!:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: - - k=0 - do j=1,grid_size - if(grid_imask(j)==0) k=k+1 - enddo - - write(stdout,*) "CONVERTPOPT: NUM_ZEROES(GRID_IMASK), SUM(GRID_IMASK)",& - k, sum(grid_imask) - - write(stdout,*) "CONVERTPOPT: GRID_CORNER_LAT VALUES = ", & - grid_corner_lat(3,1:10) - - write(stdout,*) "CONVERTPOPT: GRID_CORNER_LON VALUES = ", & - grid_corner_lon(3,1:10) - - write(stdout,*) "CONVERTPOPT: HTN VALUES = ", & - HTN(1,1:10) - - write(stdout,*) "CONVERTPOPT: HTE VALUES = ", & - HTE(1,1:10) - -!::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: - - grid_dims(1) = nx - grid_dims(2) = ny - -!----------------------------------------------------------------------- -! -! convert KMT field to integer grid mask -! -!----------------------------------------------------------------------- - - grid_imask = min(grid_imask, 1) - -!----------------------------------------------------------------------- -! -! compute remaining corners -! -!----------------------------------------------------------------------- - - do j=1,ny - do i=1,nx - ocn_add = (j-1)*nx + i - if (i .ne. 1) then - im1 = ocn_add - 1 - else - im1 = ocn_add + nx - 1 - endif - - grid_corner_lat(4,ocn_add) = grid_corner_lat(3,im1) - grid_corner_lon(4,ocn_add) = grid_corner_lon(3,im1) - end do - end do - - do j=2,ny - do i=1,nx - ocn_add = (j-1)*nx + i - jm1 = (j-2)*nx + i - - grid_corner_lat(2,ocn_add) = grid_corner_lat(3,jm1) - grid_corner_lat(1,ocn_add) = grid_corner_lat(4,jm1) - - grid_corner_lon(2,ocn_add) = grid_corner_lon(3,jm1) - grid_corner_lon(1,ocn_add) = grid_corner_lon(4,jm1) - end do - end do - -!----------------------------------------------------------------------- -! -! mock up the lower row boundaries -! -!----------------------------------------------------------------------- - - do i=1,nx - dlat = grid_corner_lat(1,i+2*nx) - grid_corner_lat(1,i+nx) - grid_corner_lat(1,i) = grid_corner_lat(1,i+nx) - dlat - grid_corner_lat(1,i) = max(grid_corner_lat(1,i), -pih + tiny) - - dlat = grid_corner_lat(2,i+2*nx) - grid_corner_lat(2,i+nx) - grid_corner_lat(2,i) = grid_corner_lat(2,i+nx) - dlat - grid_corner_lat(2,i) = max(grid_corner_lat(2,i), -pih + tiny) - - grid_corner_lon(1,i) = grid_corner_lon(4,i) - grid_corner_lon(2,i) = grid_corner_lon(3,i) - end do - -!----------------------------------------------------------------------- -! -! correct for 0,2pi longitude crossings -! -!----------------------------------------------------------------------- - - do ocn_add=1,grid_size - if (grid_corner_lon(1,ocn_add) > pi2) & - grid_corner_lon(1,ocn_add) = & - grid_corner_lon(1,ocn_add) - pi2 - if (grid_corner_lon(1,ocn_add) < 0.0) & - grid_corner_lon(1,ocn_add) = & - grid_corner_lon(1,ocn_add) + pi2 - do n=2,grid_corners - tmplon = grid_corner_lon(n ,ocn_add) - & - grid_corner_lon(n-1,ocn_add) - if (tmplon < -three*pih) grid_corner_lon(n,ocn_add) = & - grid_corner_lon(n,ocn_add) + pi2 - if (tmplon > three*pih) grid_corner_lon(n,ocn_add) = & - grid_corner_lon(n,ocn_add) - pi2 - end do - end do - -!----------------------------------------------------------------------- -! -! compute ocean cell centers by averaging corner values -! -!----------------------------------------------------------------------- - - do ocn_add=1,grid_size - z1 = cos(grid_corner_lat(1,ocn_add)) - x1 = cos(grid_corner_lon(1,ocn_add))*z1 - y1 = sin(grid_corner_lon(1,ocn_add))*z1 - z1 = sin(grid_corner_lat(1,ocn_add)) - - z2 = cos(grid_corner_lat(2,ocn_add)) - x2 = cos(grid_corner_lon(2,ocn_add))*z2 - y2 = sin(grid_corner_lon(2,ocn_add))*z2 - z2 = sin(grid_corner_lat(2,ocn_add)) - - z3 = cos(grid_corner_lat(3,ocn_add)) - x3 = cos(grid_corner_lon(3,ocn_add))*z3 - y3 = sin(grid_corner_lon(3,ocn_add))*z3 - z3 = sin(grid_corner_lat(3,ocn_add)) - - z4 = cos(grid_corner_lat(4,ocn_add)) - x4 = cos(grid_corner_lon(4,ocn_add))*z4 - y4 = sin(grid_corner_lon(4,ocn_add))*z4 - z4 = sin(grid_corner_lat(4,ocn_add)) - - tx = (x1+x2+x3+x4)/4.0 - ty = (y1+y2+y3+y4)/4.0 - tz = (z1+z2+z3+z4)/4.0 - da = sqrt(tx**2+ty**2+tz**2) - - tz = tz/da - ! grid_center_lon in radians - grid_center_lon(ocn_add) = 0.0 - if (tx .ne. 0.0 .or. ty .ne. 0.0) & - grid_center_lon(ocn_add) = atan2(ty,tx) - ! grid_center_lat in radians - grid_center_lat(ocn_add) = asin(tz) - - end do - - ! j=1: linear approximation - n = 0 - do i=1,nx - n = n + 1 - np1 = n + nx - np2 = n + 2*nx - grid_center_lon(n) = grid_center_lon(np1) - grid_center_lat(n) = 2.0*grid_center_lat(np1) - & - grid_center_lat(np2) - end do - - do ocn_add=1,grid_size - if (grid_center_lon(ocn_add) > pi2) & - grid_center_lon(ocn_add) = grid_center_lon(ocn_add) - pi2 - if (grid_center_lon(ocn_add) < 0.0) & - grid_center_lon(ocn_add) = grid_center_lon(ocn_add) + pi2 - enddo - -!----------------------------------------------------------------------- -! -! compute cell areas in same way as POP -! -!----------------------------------------------------------------------- - - n = 0 - do j=1,ny - if (j > 1) then - jm1 = j-1 - else - jm1 = 1 - endif - do i=1,nx - if (i > 1) then - im1 = i-1 - else - im1 = nx - endif - - n = n+1 - - dxt = half*(HTN(i,j) + HTN(i,jm1)) - dyt = half*(HTE(i,j) + HTE(im1,j)) - if (dxt == zero) dxt=one - if (dyt == zero) dyt=one - - grid_area(n) = dxt*dyt*area_norm - end do - end do - -!----------------------------------------------------------------------- -! -! intialize GeneralGrid -! -!----------------------------------------------------------------------- - - call MCT_GGrid_init(GGrid=GGrid, & - CoordChars="grid_center_lat:& - &grid_center_lon", & - WeightChars="grid_area", & - OtherChars="grid_corner_lat_1:& - &grid_corner_lat_2:& - &grid_corner_lat_3:& - &grid_corner_lat_4:& - &grid_corner_lon_1:& - &grid_corner_lon_2:& - &grid_corner_lon_3:& - &grid_corner_lon_4", & - IndexChars="grid_imask", & - lsize=grid_size) - - center_lat = MCT_GGrid_indexRA(GGrid,'grid_center_lat') - center_lon = MCT_GGrid_indexRA(GGrid,'grid_center_lon') - corner_lat = MCT_GGrid_indexRA(GGrid,'grid_corner_lat_1') - corner_lon = MCT_GGrid_indexRA(GGrid,'grid_corner_lon_1') - area = MCT_GGrid_indexRA(GGrid,'grid_area') - imask = MCT_GGrid_indexIA(GGrid,'grid_imask') - - GGrid%data%rattr(center_lat,1:grid_size) = & - grid_center_lat(1:grid_size) - GGrid%data%rattr(center_lon,1:grid_size) = & - grid_center_lon(1:grid_size) - GGrid%data%rattr(area,1:grid_size) = & - grid_area(1:grid_size) - GGrid%data%iattr(imask,1:grid_size) = & - grid_imask(1:grid_size) - - do p = 1,grid_corners - GGrid%data%rattr(corner_lat+p-1,1:grid_size) = & - grid_corner_lat(p,1:grid_size) - GGrid%data%rattr(corner_lon+p-1,1:grid_size) = & - grid_corner_lon(p,1:grid_size) - enddo - - deallocate(grid_imask, grid_area, & - grid_center_lat, grid_center_lon, & - grid_corner_lat, grid_corner_lon, & - HTN, HTE, stat=ier) - - if(ier/=0) call die(myname_,"deallocate(grid_imask... ", ier) - - -!*********************************************************************** - - end subroutine convertPOPT - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - - diff --git a/cesm/models/utils/mct/testsystem/testall/convertgauss.F90 b/cesm/models/utils/mct/testsystem/testall/convertgauss.F90 deleted file mode 100644 index 0b17659..0000000 --- a/cesm/models/utils/mct/testsystem/testall/convertgauss.F90 +++ /dev/null @@ -1,516 +0,0 @@ -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! -! This program creates a remapping grid file for Gaussian lat/lon -! grids (for spectral transform codes). -! -!----------------------------------------------------------------------- -! -! CVS:$Id: convertgauss.F90,v 1.3 2002-11-14 17:11:07 eong Exp $ -! CVS $Name: $ -! -! Copyright (c) 1997, 1998 the Regents of the University of -! California. -! -! Unless otherwise indicated, this software has been authored -! by an employee or employees of the University of California, -! operator of the Los Alamos National Laboratory under Contract -! No. W-7405-ENG-36 with the U.S. Department of Energy. The U.S. -! Government has rights to use, reproduce, and distribute this -! software. The public may copy and use this software without -! charge, provided that this Notice and any statement of authorship -! are reproduced on all copies. Neither the Government nor the -! University makes any warranty, express or implied, or assumes -! any liability or responsibility for the use of this software. -! -!*********************************************************************** - - subroutine convertgauss(GGrid, nx, ny) - -!----------------------------------------------------------------------- -! -! This file creates a remapping grid file for a Gaussian grid -! -!----------------------------------------------------------------------- - - use m_AttrVect,only : AttrVect -! use m_GeneralGrid,only : MCT_GGrid_init => init - use m_GeneralGrid,only : MCT_GGrid_initUnstructured => initUnstructured - use m_GeneralGrid,only : MCT_GGrid_indexIA => indexIA - use m_GeneralGrid,only : MCT_GGrid_indexRA => indexRA - use m_GeneralGrid,only : GeneralGrid - use m_die - use m_stdio - - implicit none - -!----------------------------------------------------------------------- -! -! variables that describe the grid -! -! T42: nx=128 ny=64 -! T62: nx=192 ny=94 -! -!----------------------------------------------------------------------- - - type(GeneralGrid), intent(out) :: GGrid - integer, intent(in) :: nx - integer, intent(in) :: ny - - integer :: grid_size - - integer, parameter :: & - grid_rank = 2, & - grid_corners = 4 - - integer, dimension(grid_rank) :: & - grid_dims - -!----------------------------------------------------------------------- -! -! grid coordinates and masks -! -!----------------------------------------------------------------------- - - integer, dimension(:), allocatable :: & - grid_imask - - real, dimension(:), allocatable :: & - grid_area , & ! area weights - grid_center_lat, & ! lat/lon coordinates for - grid_center_lon ! each grid center in degrees - - real, dimension(:,:), allocatable :: & - grid_corner_lat, & ! lat/lon coordinates for - grid_corner_lon ! each grid corner in degrees - - -!----------------------------------------------------------------------- -! -! defined constants -! -!----------------------------------------------------------------------- - - real, parameter :: & - zero = 0.0, & - one = 1.0, & - two = 2.0, & - three = 3.0, & - four = 4.0, & - five = 5.0, & - half = 0.5, & - quart = 0.25, & - bignum = 1.e+20, & - tiny = 1.e-14, & - pi = 3.14159265359, & - pi2 = two*pi, & - pih = half*pi - -!----------------------------------------------------------------------- -! -! other local variables -! -!----------------------------------------------------------------------- - - character(len=*),parameter :: myname_= 'convertgauss' - - integer :: i, j, k, p, q, r, ier, atm_add - - integer :: center_lat, center_lon, & - corner_lat, corner_lon, & - imask, area - - real :: dlon, minlon, maxlon, centerlon, & - minlat, maxlat, centerlat - - real, dimension(ny) :: gauss_root, gauss_wgt, gauss_lat - - real, dimension(:), pointer :: PointData - integer :: offset - -!----------------------------------------------------------------------- -! -! compute longitudes of cell centers and corners. set up alon -! array for search routine. -! -!----------------------------------------------------------------------- - - grid_size = nx*ny - - allocate(grid_imask(grid_size), & - grid_area(grid_size), & - grid_center_lat(grid_size), & - grid_center_lon(grid_size), & - grid_corner_lat(grid_corners,grid_size), & - grid_corner_lon(grid_corners,grid_size), stat=ier) - - if(ier/=0) call die(myname_,"allocate(grid_imask... ", ier) - - grid_dims(1) = nx - grid_dims(2) = ny - - dlon = 360./nx - - do i=1,nx - - centerlon = (i-1)*dlon - minlon = centerlon - half*dlon - maxlon = centerlon + half*dlon - - do j=1,ny - atm_add = (j-1)*nx + i - - grid_center_lon(atm_add ) = centerlon - grid_corner_lon(1,atm_add) = minlon - grid_corner_lon(2,atm_add) = maxlon - grid_corner_lon(3,atm_add) = maxlon - grid_corner_lon(4,atm_add) = minlon - end do - - end do - -!----------------------------------------------------------------------- -! -! compute Gaussian latitudes and store in gauss_wgt. -! -!----------------------------------------------------------------------- - - call gquad(ny, gauss_root, gauss_wgt) - do j=1,ny - gauss_lat(j) = pih - gauss_root(ny+1-j) - end do - -!----------------------------------------------------------------------- -! -! compute latitudes at cell centers and corners. set up alat -! array for search routine. -! -!----------------------------------------------------------------------- - - do j=1,ny - centerlat = gauss_lat(j) - - if (j .eq. 1) then - minlat = -pih - else - minlat = ATAN((COS(gauss_lat(j-1)) - & - COS(gauss_lat(j )))/ & - (SIN(gauss_lat(j )) - & - SIN(gauss_lat(j-1)))) - endif - - if (j .eq. ny) then - maxlat = pih - else - maxlat = ATAN((COS(gauss_lat(j )) - & - COS(gauss_lat(j+1)))/ & - (SIN(gauss_lat(j+1)) - & - SIN(gauss_lat(j )))) - endif - - do i=1,nx - atm_add = (j-1)*nx + i - grid_center_lat(atm_add ) = centerlat*360./pi2 - grid_corner_lat(1,atm_add) = minlat*360./pi2 - grid_corner_lat(2,atm_add) = minlat*360./pi2 - grid_corner_lat(3,atm_add) = maxlat*360./pi2 - grid_corner_lat(4,atm_add) = maxlat*360./pi2 - grid_area(atm_add) = gauss_wgt(j)*pi2/nx - end do - - end do - -!----------------------------------------------------------------------- -! -! define mask -! -!----------------------------------------------------------------------- - - grid_imask = 1 - -!----------------------------------------------------------------------- -! -! intialize GeneralGrid -! -!----------------------------------------------------------------------- - -! call MCT_GGrid_init(GGrid=GGrid, & -! CoordChars="grid_center_lat:& -! &grid_center_lon", & -! WeightChars="grid_area", & -! OtherChars="grid_corner_lat_1:& -! &grid_corner_lat_2:& -! &grid_corner_lat_3:& -! &grid_corner_lat_4:& -! &grid_corner_lon_1:& -! &grid_corner_lon_2:& -! &grid_corner_lon_3:& -! &grid_corner_lon_4", & -! IndexChars="grid_imask", & -! lsize=grid_size) - -! Create and fill PointData(:) array for unstructured-style GeneralGrid_init - - allocate(PointData(2*grid_size), stat=ier) - if(ier /= 0) then - write(stderr,'(2a,i8)') myname_, & - ':: allocate(PointData(...) failed with ier=',ier - call die(myname_) - endif - - do i=1,grid_size - offset = 2 * (i-1) - PointData(offset+1) = grid_center_lat(i) - PointData(offset+2) = grid_center_lon(i) - end do - - call MCT_GGrid_initUnstructured(GGrid=GGrid, & - CoordChars="grid_center_lat:& - &grid_center_lon", & - CoordSortOrder="grid_center_lat:& - &grid_center_lon", & - WeightChars="grid_area", & - OtherChars="grid_corner_lat_1:& - &grid_corner_lat_2:& - &grid_corner_lat_3:& - &grid_corner_lat_4:& - &grid_corner_lon_1:& - &grid_corner_lon_2:& - &grid_corner_lon_3:& - &grid_corner_lon_4", & - IndexChars="grid_imask", & - nDims=2, nPoints=grid_size, & - PointData=PointData) - - deallocate(PointData, stat=ier) - if(ier /= 0) then - write(stderr,'(2a,i8)') myname_, & - ':: deallocate(PointData...) failed with ier=',ier - call die(myname_) - endif - -! center_lat = MCT_GGrid_indexRA(GGrid,'grid_center_lat') -! center_lon = MCT_GGrid_indexRA(GGrid,'grid_center_lon') - corner_lat = MCT_GGrid_indexRA(GGrid,'grid_corner_lat_1') - corner_lon = MCT_GGrid_indexRA(GGrid,'grid_corner_lon_1') - area = MCT_GGrid_indexRA(GGrid,'grid_area') - imask = MCT_GGrid_indexIA(GGrid,'grid_imask') - -! GGrid%data%rattr(center_lat,1:grid_size) = & -! grid_center_lat(1:grid_size) -! GGrid%data%rattr(center_lon,1:grid_size) = & -! grid_center_lon(1:grid_size) - GGrid%data%rattr(area,1:grid_size) = & - grid_area(1:grid_size) - GGrid%data%iattr(imask,1:grid_size) = & - grid_imask(1:grid_size) - - do p = 1,grid_corners - GGrid%data%rattr(corner_lat+p-1,1:grid_size) = & - grid_corner_lat(p,1:grid_size) - GGrid%data%rattr(corner_lon+p-1,1:grid_size) = & - grid_corner_lon(p,1:grid_size) - enddo - - deallocate(grid_imask, grid_area, & - grid_center_lat, grid_center_lon, & - grid_corner_lat, grid_corner_lon, & - stat=ier) - - if(ier/=0) call die(myname_,"deallocate(grid_imask... ", ier) - - -!----------------------------------------------------------------------- - - end subroutine convertgauss - -!*********************************************************************** - - subroutine gquad(l,root,w) - -!----------------------------------------------------------------------- -! -! This subroutine finds the l roots (in theta) and gaussian weights -! associated with the legendre polynomial of degree l > 1. -! -!----------------------------------------------------------------------- - - use m_die - - implicit none - -!----------------------------------------------------------------------- -! -! intent(in) -! -!----------------------------------------------------------------------- - - integer, intent(in) :: l - -!----------------------------------------------------------------------- -! -! intent(out) -! -!----------------------------------------------------------------------- - - real, dimension(l), intent(out) :: root, w - -!----------------------------------------------------------------------- -! -! defined constants -! -!----------------------------------------------------------------------- - - real, parameter :: & - zero = 0.0, & - one = 1.0, & - two = 2.0, & - three = 3.0, & - four = 4.0, & - five = 5.0, & - half = 0.5, & - quart = 0.25, & - bignum = 1.e+20, & - tiny = 1.e-14, & - pi = 3.14159265359, & - pi2 = two*pi, & - pih = half*pi - -!----------------------------------------------------------------------- -! -! local -! -!----------------------------------------------------------------------- - - integer :: l1, l2, l22, l3, k, i, j, loop_counter - - real :: del,co,p1,p2,p3,t1,t2,slope,s,c,pp1,pp2,p00 - -!-----MUST adjust tolerance for newton convergence-----! - - ! Modify tolerance level to the precision of the real numbers: - ! Increase for lower precision, decrease for higher precision. - - real, parameter :: RTOL = 1.0e4*epsilon(0.) - -!------------------------------------------------------! - -!----------------------------------------------------------------------- -! -! Define useful constants. -! -!----------------------------------------------------------------------- - - del= pi/float(4*l) - l1 = l+1 - co = float(2*l+3)/float(l1**2) - p2 = 1.0 - t2 = -del - l2 = l/2 - k = 1 - p00 = one/sqrt(two) - -!----------------------------------------------------------------------- -! -! Start search for each root by looking for crossing point. -! -!----------------------------------------------------------------------- - - do i=1,l2 - 10 t1 = t2 - t2 = t1+del - p1 = p2 - s = sin(t2) - c = cos(t2) - pp1 = 1.0 - p3 = p00 - do j=1,l1 - pp2 = pp1 - pp1 = p3 - p3 = 2.0*sqrt((float(j**2)-0.250)/float(j**2))*c*pp1- & - sqrt(float((2*j+1)*(j-1)*(j-1))/ & - float((2*j-3)*j*j))*pp2 - end do - p2 = pp1 - if ((k*p2).gt.0) goto 10 - -!----------------------------------------------------------------------- -! -! Now converge using Newton-Raphson. -! -!----------------------------------------------------------------------- - - k = -k - loop_counter=0 - 20 continue - loop_counter=loop_counter+1 - slope = (t2-t1)/(p2-p1) - t1 = t2 - t2 = t2-slope*p2 - p1 = p2 - s = sin(t2) - c = cos(t2) - pp1 = 1.0 - p3 = p00 - do j=1,l1 - pp2 = pp1 - pp1 = p3 - p3 = 2.0*sqrt((float(j**2)-0.250)/float(j**2))*c*pp1- & - sqrt(float((2*j+1)*(j-1)*(j-1))/ & - float((2*j-3)*j*j))*pp2 - end do - p2 = pp1 - - if(loop_counter > 1e4) then - call die("subroutine gquad",& - "ERROR:: Precision of reals is too low. & - & Increase the magnitude of RTOL.",0) - endif - - if (abs(p2).gt.RTOL) goto 20 - root(i) = t2 - w(i) = co*(sin(t2)/p3)**2 - end do - -!----------------------------------------------------------------------- -! -! If l is odd, take care of odd point. -! -!----------------------------------------------------------------------- - - l22 = 2*l2 - if (l22 .ne. l) then - l2 = l2+1 - t2 = pi/2.0 - root(l2) = t2 - s = sin(t2) - c = cos(t2) - pp1 = 1.0 - p3 = p00 - do j=1,l1 - pp2 = pp1 - pp1 = p3 - p3 = 2.0*sqrt((float(j**2)-0.250)/float(j**2))*c*pp1- & - sqrt(float((2*j+1)*(j-1)*(j-1))/ & - float((2*j-3)*j*j))*pp2 - end do - p2 = pp1 - w(l2) = co/p3**2 - endif - -!----------------------------------------------------------------------- -! -! Use symmetry to compute remaining roots and weights. -! -!----------------------------------------------------------------------- - - l3 = l2+1 - do i=l3,l - root(i) = pi-root(l-i+1) - w(i) = w(l-i+1) - end do - -!----------------------------------------------------------------------- - - end subroutine gquad - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! diff --git a/cesm/models/utils/mct/testsystem/testall/cpl.F90 b/cesm/models/utils/mct/testsystem/testall/cpl.F90 deleted file mode 100644 index 1205992..0000000 --- a/cesm/models/utils/mct/testsystem/testall/cpl.F90 +++ /dev/null @@ -1,1270 +0,0 @@ -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!----------------------------------------------------------------------- -! CVS $Id: cpl.F90,v 1.25 2007-12-18 00:02:05 jacob Exp $ -! CVS $Name: $ -!BOP ------------------------------------------------------------------- -! -! !ROUTINE: cpl -- coupler for unit tester -! -! !DESCRIPTION: -! A coupler subroutine to test functionality of MCT. -! -! !INTERFACE: -! - subroutine cpl (CPL_World) -! -! !USES: -! - use MPH_all -!---Field Storage DataType and associated methods - use m_AttrVect,only : MCT_AtrVt_init => init - use m_AttrVect,only : MCT_AtrVt_clean => clean - use m_AttrVect,only : MCT_AtrVt_nreals => nRAttr - use m_AttrVect,only : MCT_AtrVt_nints => nIAttr - use m_AttrVect,only : MCT_AtrVt_lsize => lsize - use m_AttrVect,only : AttrVect - use m_AttrVect,only : AttrVect_exportIListToChar =>exportIListToChar - use m_AttrVect,only : AttrVect_exportRListToChar =>exportRListToChar - use m_AttrVect,only : AttrVect_Copy => Copy -!---AttrVect Communication methods - use m_AttrVectComms,only : AttrVect_Send => send - use m_AttrVectComms,only : AttrVect_Recv => recv - use m_AttrVectComms, only : AttrVect_gather => gather -!---AttrVect Reduction methods - use m_AttrVectReduce,only : AttrVect_LocalReduce => LocalReduce - use m_AttrVectReduce,only : AttrVect_LocalReduceRAttr => & - LocalReduceRAttr - use m_AttrVectReduce,only : AttrVectSUM, AttrVectMIN, AttrVectMAX -!---Coordinate Grid DataType and associated methods - use m_GeneralGrid,only: GeneralGrid - use m_GeneralGrid,only: MCT_GGrid_clean => clean - use m_GeneralGrid,only : MCT_GGrid_lsize => lsize - use m_GeneralGridComms,only: MCT_GGrid_recv => recv - use m_GeneralGridComms,only: MCT_GGrid_scatter => scatter - use m_GeneralGridComms,only: MCT_GGrid_gather => gather - use m_GeneralGridComms,only: MCT_GGrid_bcast => bcast -!---MCT Spatial Integral services... - use m_SpatialIntegral,only : MCT_PairedSpatialIntegrals => & - PairedSpatialIntegrals - use m_SpatialIntegral,only : MCT_PairedSpatialAverages => & - PairedSpatialAverages - use m_SpatialIntegral,only : MCT_PairedMaskedSpatialIntegral => & - PairedMaskedSpatialIntegrals - use m_SpatialIntegral,only : MCT_PairedMaskedSpatialAverages => & - PairedMaskedSpatialAverages -!---Domain Decomposition Descriptor DataType and associated methods - use m_GlobalSegMap,only: MCT_GSMap_init => init - use m_GlobalSegMap,only: MCT_GSMap_copy => copy ! rml - use m_GlobalSegMap,only: MCT_GSMap_clean => clean - use m_GlobalSegMap,only: MCT_GSMap_gsize => gsize - use m_GlobalSegMap,only: MCT_GSMap_lsize => lsize - use m_GlobalSegMap,only: MCT_GSMap_ngseg => ngseg - use m_GlobalSegMap,only: MCT_GSMap_nlseg => nlseg - use m_GlobalSegMap,only: GlobalSegMap - use m_GlobalMap,only : GlobalMap - use m_GlobalMap,only : GlobalMap_init => init - use m_GlobalMap,only : GlobalMap_init_remote => init_remote - use m_GlobalMap,only : GlobalMap_clean => clean -!---GlobalSegMap Communication Methods - use m_GlobalSegMapComms,only: GlobalSegMap_bcast => bcast - use m_GlobalSegMapComms,only: GlobalSegMap_send => send - use m_GlobalSegMapComms,only: GlobalSegMap_recv => recv - use m_GlobalSegMapComms,only: GlobalSegMap_isend => isend -!---Methods for Exchange of GlobalMapping Objects - use m_ExchangeMaps,only: ExchangeMap -!---Convert between GlobalSegMap and GlobalMap - use m_ConvertMaps,only:GlobalSegMapToGlobalMap -!---Global-to-Local indexing services - use m_GlobalToLocal,only: MCT_GStoL => GlobalToLocalIndices -!---Component Model Registry - use m_MCTWorld,only: ThisMCTWorld - use m_MCTWorld,only: MCTComponentRootRank => ComponentRootRank - use m_MCTWorld,only: MCTWorld_initialized => initialized - use m_MCTWorld,only: MCTWorld_init => init - use m_MCTWorld,only: MCTWorld_clean => clean -!---Intercomponent communications scheduler - use m_Router,only: Router - use m_Router,only: MCT_Router_init => init - use m_Router,only: MCT_Router_print => print ! rml - use m_Router,only: MCT_Router_clean => clean - use m_Transfer,only: MCT_Send => send - use m_Transfer,only: MCT_Recv => recv -!---Sparse Matrix DataType and associated methods - use m_SparseMatrix, only : SparseMatrix - use m_SparseMatrix, only : SparseMatrix_clean => clean - use m_SparseMatrix, only : SparseMatrix_lsize => lsize - use m_SparseMatrix, only : SMatrix_exportGlobalRowIndices => & - exportGlobalRowIndices - use m_SparseMatrix, only : SMatrix_exportGlobalColumnInd => & - exportGlobalColumnIndices - use m_SparseMatrix, only : SMatrix_exportMatrixElements => & - exportMatrixElements - - use m_SparseMatrixComms, only: SparseMatrix_ScatterByRow => ScatterByRow - use m_SparseMatrixComms, only: SparseMatrix_gather => gather - use m_SparseMatrixComms, only: SparseMatrix_bcast => bcast - use m_SparseMatrixDecomp, only : SparseMatrixDecompByRow => ByRow -!---SparseMatrixPlus DataType and associated methods - use m_SparseMatrixPlus, only : SparseMatrixPlus - use m_SparseMatrixPlus, only : SparseMatrixPlus_init => init - use m_SparseMatrixPlus, only : SparseMatrixPlus_clean => clean - use m_SparseMatrixPlus, only : SparseMatrixPlus_initialized => initialized - use m_SparseMatrixPlus, only : Xonly ! Decompose matrix by column - use m_SparseMatrixPlus, only : Yonly ! Decompose matrix by row - use m_SparseMatrixPlus, only : XandY ! Arbitrary row/column decomp -!---Accumulation data type and methods - use m_Accumulator, only : Accumulator - use m_Accumulator, only : accumulate - use m_Accumulator, only : MCT_Accumulator_init => init - use m_Accumulator, only : MCT_Accumulator_clean => clean - use m_Accumulator, only : Accumulator_lsize => lsize - use m_Accumulator, only : MCT_SUM - use m_Accumulator, only : MCT_AVG - use m_AccumulatorComms,only : MCT_Acc_scatter => scatter - use m_AccumulatorComms,only : MCT_Acc_gather => gather - use m_AccumulatorComms,only : MCT_Acc_bcast => bcast -!---Matrix-Vector multiply methods - use m_MatAttrVectMul, only: MCT_MatVecMul => sMatAvMult -!---mpeu file reading routines - use m_inpak90 -!---mpeu routines for MPI communications - use m_mpif90 -!---mpeu timers - use m_zeit -!---mpeu stdout/stderr - use m_stdio - use m_ioutil, only: luavail -!---mpeu error handling - use m_die -!---mpeu reals - use m_realkinds - -!---Tester Modules - use m_ACTEST, only : Accumulator_test => testall - use m_ACTEST, only : Accumulator_identical => identical - use m_AVTEST, only : AttrVect_test => testall - use m_AVTEST, only : AttrVect_identical => Identical - use m_AVTEST, only : AttrVect_ReduceTest => Reduce - use m_GGRIDTEST, only : GGrid_test => testall - use m_GGRIDTEST, only : GGrid_identical => Identical - use m_GMAPTEST, only : GMap_test => testall - use m_GSMAPTEST, only : GSMap_test => testall - use m_GSMAPTEST, only : GSMap_identical => Identical - use m_MCTWORLDTEST, only : MCTWorld_test => testall - use m_ROUTERTEST, only : Router_test => testall - use m_SMATTEST, only : sMat_test => testall - use m_SMATTEST, only : sMat_identical => Identical - use m_List, only : ListExportToChar => ExportToChar - - implicit none - -! !INPUT PARAMETERS: - - integer,intent(in) :: CPL_World ! communicator for coupler - -! !REVISION HISTORY: -! Oct00 - Yun (Helen) He and Chris Ding, NERSC/LBNL - initial MPH-only version -! 19Nov00 - R. Jacob -- interface with mct -! 06Feb01 - J. Larson - slight mod to -! accomodate new interface to MCT_GSMap_lsize(). -! 08Feb01 - R. Jacob -- use MCT_Recv, new interface -! to MCT_GSMap_lsize(). -! 23Feb01 - R. Jacob -- add check for transfer -! expand size of AttrVect -! 25Feb01 - R. Jacob - add mpe and mpeu -! 22Mar01 - R. Jacob - use new router init -! 27Apr01 - R. Jacob - use SparseMatrix -! 02May01 - R. Jacob - Router is now built -! between atmosphere model and sparsematrix-defined -! atmosphere globalsegmap. Recv data in aV and check. -! Add new argument to MCT_Smat2xGSMap. -! 16May01 - Larson/Jacob - only root -! needs to call ReadSparseMatrix with new Comms -! 17May01 - R. Jacob - perfrom the sparse -! matrix multiply on the received dummy data and check -! 19May01 - R. Jacob - verify that matrix -! multiply works on constant data -! 11Jun01 - Larson/Jacob - receive atmosphere's general grid from -! the atmosphere. -! 15Feb02 - R. Jacob New MCTWorld argument -! 28Mar02 - R. Jacob Use Rearranger -! 12Jun02 - J. Larson - Use SparseMatrix -! export routines. -! -!EOP ___________________________________________________________________ - - character(len=*), parameter :: cplname='cpl.F90' - -!----------------------- MPH vars - integer :: myProc, myProc_global - integer :: Global_World - integer :: atmo_id, ocn_id - integer :: ncomps,mycompid,mySize - -!----------------------- MCT and dummy model vars - - logical :: initialized - integer :: root,stat,status - integer, dimension(:,:),pointer :: sendstatus - integer, dimension(:),pointer :: sendrequest - integer, dimension(2) :: sMat_src_dims, sMat_dst_dims - -! SparseMatrix dimensions and Processor Layout - integer :: Nax, Nay ! Atmosphere lons, lats - integer :: Nox, Noy ! Ocean lons, lats - integer :: NPROCS_LATA, NPROCS_LONA ! Processor layout - -! Arrays used to initialize the MCT GlobalSegMap - integer :: asize,asize2,i,j,k - integer :: osize,osize2 - integer,dimension(1) :: start,length -! integer,dimension(:),pointer :: lstart,llength - -! Number of accumulation steps and accumulator dummy variables - integer :: steps - integer, parameter :: nsteps = 10 - character*64 :: ACCA2O_rList - integer, dimension(:), allocatable :: ACCA2O_rAction - -! Dummy arrays used for testing SparseMatrix export routines: - integer :: Num - integer, dimension(:), pointer :: DummyI - real, dimension(:), pointer :: DummyR - -! Atmosphere and Ocean GSMap - type(GlobalSegMap) :: testAGSMap ! rml - type(GlobalSegMap) :: AGSMap,OGSMap, DAGSMap - -! GSMap for testing GlobalSegMapComms - type(GlobalSegMap) :: inGSMap - -! Ocean GlobalSegMap from ocean - type(GlobalSegMap) :: OCN_OGSMap - -! Ocean GlobalMap from ocean - type(GlobalMap) :: OCN_OGMap - -! Remote GlobalMap for testing - type(GlobalMap) :: rOGMap - -! GlobalMap for Testing Accumulator Comms - type(GlobalMap) :: OGMap - -! Router from Atm to Cpl - type(Router) :: Atm2Cpl - -! Router from Cpl to Ocn - type(Router) :: Cpl2Ocn - -! Accumulator for data from atmosphere to ocean - type(Accumulator) :: ACCA2O - -! Accumulator for testing scatter and gather routines - type(Accumulator) :: scatterAcc, GgatherAcc, GSgatherAcc - -! AttrVect for data from the atm - type(AttrVect) :: fromatm - -! AttrVect for data from the atm on the ocean grid - type(AttrVect) :: fromatm_ocn - -! Coupler AttrVect for data from process 1 to process 0 - type(AttrVect) :: fromP1 - -! AttrVect for data from the ocn - type(AttrVect) :: fromocn - -! AttrVect for data from the ocn on the atmosphere's grid - type(AttrVect) :: fromocn_atm - -! AttrVects for PairedSpatialIntegral services - type(AttrVect) :: IntegratedAVect, IntegratedOVect - -! Spatial Integral Temporary Variables - integer :: VectorLength - -! AttrVects for testing mapping - type(AttrVect) :: gatherAV_ocn,gatherAV_atm - integer :: unit, unit1, unit2 - -! a2o SparseMatrix elements on root - type(SparseMatrix) :: DummySMat - -! a2o distributed SparseMatrix elements - type(SparseMatrix) :: dMat, dMat_test - -! Test sMat for gather - type(SparseMatrix) :: gathersMat - -! Test GlobalSegMap for sMat gather - type(GlobalSegMap) :: MatGSMap - -! a2o and o2a distributed SparseMatrixPlus variables - type(SparseMatrixPlus) :: A2OMatPlus, O2AMatPlus - -! The atmosphere's grid recieved from the atmosphere - type(GeneralGrid) :: AtmGrid - -! The atmosphere's distributed grid - type(GeneralGrid) :: dAtmGrid - -! The ocean's grid recieved from the ocean - type(GeneralGrid) :: OcnGrid - -! The ocean's distributed grid - type(GeneralGrid) :: dOcnGrid - -! Test grid for scatter,gather,bcast - type(GeneralGrid) :: scatterGGrid, gatherGGrid - -!::DEFINE POP REMAP MATRIX DIMENSIONS:: - -#ifdef MPE -#include "mpe.h" -#endif - - -!------------------------------------Begin code - - call MPI_COMM_DUP (MPI_COMM_WORLD, Global_World, ierr) - - call MPI_COMM_RANK (MPI_COMM_WORLD, myProc_global, ierr) - call MPI_COMM_RANK (CPL_World, myProc, ierr) -! write(*,*) myProc, ' in cpl === ', myProc_global, ' in global' -! write(*,*) 'MPH_local_proc_id()=', MPH_local_proc_id_ME_SE() -! write(*,*) 'MPH_global_proc_id()=', MPH_global_proc_id() - - call MPI_COMM_SIZE(CPL_World,mySize,ierr) - if (myProc==0) call MPH_redirect_output ('cpl') - ncomps=MPH_total_components() - mycompid=MPH_component_id_ME_SE() - -! Get the atmosphere's component id - atmo_id = MPH_get_component_id("atmosphere") - -! Get the ocean's component id - ocn_id = MPH_get_component_id("ocean") - -!------------------------------------------------------- -! Begin attempts to use MCT - -#ifdef MPE - call mpe_logging_init(myProc_global,init_s,init_e,gsmi_s,gsmi_e, & - atri_s,atri_e,routi_s,routi_e,send_s,send_e,recv_s,recv_e, & - clean_s,clean_e) -#endif - - initialized= MCTWorld_initialized() - if (myProc==0)write(stdout,*) cplname, & - ":: MCTWorld initialized=",initialized - if(initialized) call die(cplname, "mct already initialized") - - if(myProc==0)write(stdout,*) cplname, ":: Initializing MCTWorld" - call zeit_ci('Cworldinit') - call MCTWorld_init(ncomps,MPI_COMM_WORLD,CPL_World,mycompid) - call zeit_co('Cworldinit') - - initialized= MCTWorld_initialized() - if (myProc==0)write(stdout,*) cplname, & - ":: MCTWorld initialized=",initialized - if(.not. initialized) call die(cplname, "mct not initialized") - - call MCTWorld_test("CPL::MCTWorld",6000+myProc) - -! Read in Sparse Matrix dimensions and processor layout - - if(myProc==0) then - - ! Read in SparseMatrix dimensions for atmosphere and ocean - call I90_LoadF("ut_SparseMatrix.rc", ierr) - - call I90_Label("atmosphere_dimensions:", ierr) - Nax = I90_GInt(ierr) - Nay = I90_GInt(ierr) - - call I90_Label("ocean_dimensions:", ierr) - Nox = I90_GInt(ierr) - Noy = I90_GInt(ierr) - - call I90_Release(ierr) - - ! Read in processor layout information for atmosphere and ocean - call I90_LoadF("./processors_map.in", ierr) - - call I90_Label("NPROCS_ATM", ierr) - NPROCS_LATA = I90_GInt(ierr) - NPROCS_LONA = I90_GInt(ierr) - - call I90_Release(ierr) - - endif - - root = MCTComponentRootRank(mycompid,ThisMCTWorld) - call MPI_BCAST(Nax,1,MP_INTEGER,root,MPI_COMM_WORLD,ierr) - call MPI_BCAST(Nay,1,MP_INTEGER,root,MPI_COMM_WORLD,ierr) - call MPI_BCAST(Nox,1,MP_INTEGER,root,MPI_COMM_WORLD,ierr) - call MPI_BCAST(Noy,1,MP_INTEGER,root,MPI_COMM_WORLD,ierr) - call MPI_BCAST(NPROCS_LATA,1,MP_INTEGER,root,MPI_COMM_WORLD,ierr) - call MPI_BCAST(NPROCS_LONA,1,MP_INTEGER,root,MPI_COMM_WORLD,ierr) - -!::::Receive the Atmosphere's General Grid on the root process - - if(myProc==0) then - write(stdout,*) cplname, ":: Receiving Grid from atmosphere" - - call MCT_GGrid_recv(AtmGrid, atmo_id, 1400, status) - - call GGrid_test(AtmGrid,"CPL::Root AtmGrid",3000+myProc) - -! check that we can make inquiries about the atmosphere's grid. - write(stdout,*) cplname, ':: AtmGrid%coordinate_list%bf = ', & - AtmGrid%coordinate_list%bf - write(stdout,*) cplname, ':: AtmGrid%index_list%bf = ', & - AtmGrid%index_list%bf - write(stdout,*) cplname, ':: AtmGrid%data%iList%bf = ', & - AttrVect_exportIListToChar(AtmGrid%data) - write(stdout,*) cplname, ':: size(AtmGrid%data%iAttr) = ', & - size(AtmGrid%data%iAttr) - write(stdout,*) cplname, ':: AtmGrid%data%rList%bf = ', & - AttrVect_exportRListToChar(AtmGrid%data) - write(stdout,*) cplname, ':: size(AtmGrid%data%rAttr) = ', & - size(AtmGrid%data%rAttr) - -!!!!!!!!!!!!! Receive the Ocean's General Grid -! - write(stdout,*) cplname, ":: Receiving Grid from ocean" - - call MCT_GGrid_recv(OcnGrid, ocn_id, 2800, status) - - call GGrid_test(OcnGrid,"CPL::Root OcnGrid",3100+myProc) - -! check that we can make inquiries about the atmosphere's grid. - write(stdout,*) cplname, ':: OcnGrid%coordinate_list%bf = ', & - OcnGrid%coordinate_list%bf - write(stdout,*) cplname, ':: OcnGrid%index_list%bf = ', & - OcnGrid%index_list%bf - write(stdout,*) cplname, ':: OcnGrid%data%iList%bf = ', & - AttrVect_exportIListToChar(OcnGrid%data) - write(stdout,*) cplname, ':: size(OcnGrid%data%iAttr) = ', & - size(OcnGrid%data%iAttr) - write(stdout,*) cplname, ':: OcnGrid%data%rList%bf = ', & - AttrVect_exportRListToChar(OcnGrid%data) - write(stdout,*) cplname, ':: size(OcnGrid%data%rAttr) = ', & - size(OcnGrid%data%rAttr) - endif - - - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! Set a decomposition of the atmosphere in the coupler "by hand" -! For this example, the coupler will split atmosphere points -! evenly between processors. -! -! number of local atmosphere points - - asize = (Nay * Nax)/mySize - asize2 = asize - -! (Nay *Nax)/mySize isnt an integer, give extra points to last proc. - if(myProc == mySize - 1) then - asize = asize + mod(Nay*Nax,mySize) - endif - -! find starting point in the numbering scheme -! numbering scheme is same as that used in atmosphere model. - start(1) = (myProc * asize2) +1 - length(1) = asize - -! write(stdout,*)myProc,asize2,asize,start(1) - -! describe this information in a Global Map for the atmosphere. - if(myProc==0)write(stdout,*) cplname, ":: Inializing AGSMap" - call zeit_ci('Cagsmapinit') -! rml test of the copy - call MCT_GSMap_init(testAGSMap,start,length,0,CPL_World,mycompid) - call MCT_GSMap_copy(testAGSMap,AGSMap) - call MCT_GSMap_clean(testAGSMap) - print *,'Copied AGSMap' - call zeit_co('Cagsmapinit') - -! Test GlobalSegMapComms: - -! Test GlobalSegMap broadcast: - - if(myProc==0) then - - DAGSMap%comp_id = AGSMap%comp_id - DAGSMap%ngseg = AGSMap%ngseg - DAGSMap%gsize = AGSMap%gsize - - allocate(DAGSMap%start(DAGSMap%ngseg),DAGSMap%length(DAGSMap%ngseg), & - DAGSMap%pe_loc(DAGSMap%ngseg), stat=ierr) - if(ierr/=0) call die(cplname, "allocate(DAGSMap%start...)", ierr) - - do i=1,DAGSMap%ngseg - DAGSMap%start(i) = AGSMap%start(i) - DAGSMap%length(i) = AGSMap%length(i) - DAGSMap%pe_loc(i) = AGSMap%pe_loc(i) - end do - - endif - - call GlobalSegMap_bcast(DAGSMap, 0, CPL_World) - - if (.NOT.(GSMap_identical(DAGSMap,AGSMap))) then - call die(cplname,"GSMap_identical(DAGSMap,AGSMap)") - endif - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! Describe OGSMap, the ocean grid decomposed in the coupler - -! number of local oceanpoints - osize = (Noy * Nox)/mySize - osize2 = osize - -! (Noy *Nox)/mySize isnt an integer, give extra points to last proc. - if(myProc == mySize - 1) then - osize = osize + mod(Noy*Nox,mySize) - endif -! find starting point in the numbering scheme -! numbering scheme is same as that used in ocean model. - start(1) = (myProc * osize2) +1 - length(1) = osize - -! describe this information in a Global Map for the ocean. - if(myProc==0)write(stdout,*) cplname, ":: Inializing OGSMap" - call zeit_ci('Cogsmapinit') - call MCT_GSMap_init(OGSMap,start,length,0,CPL_World,mycompid) - call zeit_co('Cogsmapinit') - call GSMap_test(OGSMap,"CPL::OGSMap",CPL_World,5000+myProc) - - ! lets exchange maps with the ocean - call ExchangeMap(OGSMap,CPL_World,OCN_OGSMap,ocn_id,ierr) - if(ierr/=0) call die(cplname,"call ExchangeMap") - call GSMap_test(OCN_OGSMap,"CPL::OCN_OGSMap",CPL_World,5100+myProc) - - ! Compare this to sending and recieving maps - if(myProc==0) then - - call GlobalSegMap_send(OGSMap,ocn_id,777) - - call GlobalSegMap_isend(OGSMap,ocn_id,888,sendrequest,ierr) - if(ierr/=0) call die(cplname,"call GlobalSegMap_isend") - - ! Careful: sendrequest gets allocated with length 6 inside GSMap_isend - allocate(sendstatus(MP_STATUS_SIZE,6),stat=ierr) - if(ierr/=0) call die(cplname,"allocate(sendstatus)") - - call MPI_WAITALL(6,sendrequest,sendstatus,ierr) - if(ierr/=0) call MP_Perr_die(cplname,"call MPI_WAITALL(sendrequest)",& - ierr) - - deallocate(sendrequest,sendstatus,stat=ierr) - if(ierr/=0) call die(cplname,"deallocate(sendrequest)") - - endif - - call GlobalSegMapToGlobalMap(OCN_OGSMap,OCN_OGMap,ierr) - if(ierr/=0) call die(cplname,"GlobalSegMapToGlobalMap(OCN_OGSMap,OCN_OGMap)") - call GMap_test(GMap=OCN_OGMap,Identifier="CPL->OCN_OGMap",device=4000+myProc) - - call GlobalMap_init_remote(rOGMap,OCN_OGMap%counts,& - size(OCN_OGMap%counts),0,CPL_World,OCN_OGMap%comp_id) - call GMap_test(GMap=rOGMap,Identifier="CPL::rOGMap",device=4100+myProc) - -!!! test some GlobalSegMap functions -! write(*,*)myProc,'number of global segs is',MCT_GSMap_ngseg(OGSMap) -! write(*,*)myProc,'local size is',MCT_GSMap_lsize(OGSMap,CPL_World) -! write(*,*)myProc,'global size is',MCT_GSMap_gsize(OGSMap) - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -if(myProc==0) write(*,*) cplname, ":: Test GeneralGridComms" -call MCT_GGrid_bcast(AtmGrid,0,CPL_World) -call GGrid_test(AtmGrid,"CPL::Broadcast AtmGrid",3200+myProc) - -call MCT_GGrid_scatter(OcnGrid,scatterGGrid,OGSMap,0,CPL_World) -call MCT_GGrid_gather(scatterGGrid,gatherGGrid,OGSMap,0,CPL_World) - -if(myProc==0) then - if(.NOT. GGrid_identical(OcnGrid,gatherGGrid,0.1) ) then - call die(cplname,"GGrid Comms test failed") - endif - call MCT_GGrid_clean(gatherGGrid) -endif - - call MCT_GGrid_clean(scatterGGrid) - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!SparseMatrix Read -! read in the SparseMatrix elements onto root -! -! This example reads in a2o -! - if(myProc==0)write(stdout,*)" " - if(myProc==0)write(stdout,*) cplname, ":: Reading SparseMatrix elements" - if(myProc==0)write(stdout,*)" " - call zeit_ci('CsmatReadnTest') -if(myProc==0) then -! NOTE: this is a custom routine, will not be part of MCT - call ReadSparseMatrixAsc(DummySMat,"atmosphere_to_ocean_remap_file:", & - sMat_src_dims, sMat_dst_dims) -! Check that the values in the SparseMatrix match the values of the -! POP grid and the Gaussian grid - if(sMat_src_dims(1) /= Nax) call die(cplname, & - "sMat_src_dims(1) does not match Nax") - if(sMat_src_dims(2) /= Nay) call die(cplname, & - "sMat_src_dims(2) does not match Nay") - if(sMat_dst_dims(1) /= Nox) call die(cplname, & - "sMat_dst_dims(1) does not match Nox") - if(sMat_dst_dims(2) /= Noy) call die(cplname, & - "sMat_dst_dims(2) does not match Noy") - - nullify(DummyI) ! let first export routine create this - Num = SparseMatrix_lsize(DummySMat)+1 - allocate(DummyR(Num), stat=ierr) ! try this one pre-created - if(ierr /= 0) then - write(stderr,'(2a,i8)') cplname,':: allocate(DummyR(...) failed, ierr=',ierr - call die(cplname) - endif - - write(stdout,'(2a)') cplname,' SparseMatrix export tests. Compare with' - call SMatrix_exportGlobalRowIndices(DummySMat, DummyI, Num) - write(stdout,'(2a,i8)') cplname,':: exportGlobalRowIndices(): Num=',Num - write(stdout,'(2a,i8)') cplname,':: SparseMatrix_lsize(DummySMat)=',& - SparseMatrix_lsize(DummySMat) - write(stdout,'(2a,i8)') cplname,':: exportGlobalRowIndices() 1st Row=',DummyI(1) - write(stdout,'(2a,i8)') cplname,':: exportGlobalRowIndices() last Row=',DummyI(Num) - - call SMatrix_exportGlobalColumnInd(DummySMat, DummyI, Num) - write(stdout,'(2a,i8)') cplname,':: exportGlobalColumnIndices(): Num=',Num - write(stdout,'(2a,i8)') cplname,':: SparseMatrix_lsize(DummySMat)=',& - SparseMatrix_lsize(DummySMat) - write(stdout,'(2a,i8)') cplname,':: exportGlobalColumnIndices() 1st Col=',DummyI(1) - write(stdout,'(2a,i8)') cplname,':: exportGlobalColumnIndices() last Col=',DummyI(Num) - - call SMatrix_exportMatrixElements(DummySMat, DummyR, Num) - write(stdout,'(2a,i8)') cplname,':: exportMatrixElements(): Num=',Num - write(stdout,'(2a,i8)') cplname,':: SparseMatrix_lsize(DummySMat)=',& - SparseMatrix_lsize(DummySMat) - write(stdout,'(2a,f10.8)') cplname,':: exportMatrixElements() 1st wgt=',& - DummyR(1) - write(stdout,'(2a,f10.8)') cplname,':: exportMatrixElements() last wgt=', & - DummyR(Num) - - deallocate(DummyI, DummyR, stat=ierr) - if(ierr /= 0) then - write(stderr,'(2a,i8)') cplname,':: deallocate(DummyR(...) failed, ierr=',& - ierr - call die(cplname) - endif - -endif - - call zeit_co('CsmatReadnTest') - if(myProc==0)write(stdout,*) cplname, ":: Done Reading elements" - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!FOR TESTING ONLY:::::: -! now scatter the SparseMatrix from root to other coupler nodes -! according to the decomposition of the ocean grid (the Y) -! - root=0 - if(myProc==0)write(stdout,*) cplname, ":: Testing SparseMatrix Gather" - - ! Testing GSMap scatter and gather - call SparseMatrix_ScatterByRow(OGSMap, DummySMat, dMat, root, CPL_World, stat) - call SparseMatrixDecompByRow(OGSMap, DummySMat, MatGSMap, root, CPL_World) - call SparseMatrix_gather(dMat,gathersMat,MatGSMap,root,CPL_World) - - call MCT_GSMap_clean(MatGSMap) - - if(myProc==root) then - if(.not. sMat_identical(DummySMat,gathersMat,1e-5)) then - call die(cplname,"SMAT GATHER TEST FAILED!") - endif - call SparseMatrix_clean(gathersMat) - endif - - ! Testing broadcast - call SparseMatrix_bcast(DummySMat,root,CPL_World) - - call sMat_test(sMat=DummySMat,Identifier="CPL::Broadcast DummySMat-a2o", & - device=8000+myProc) - call sMat_test(sMat=dMat,Identifier="CPL::dMat-a2o",device=8100+myProc, & - mycomm=CPL_World) - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! Build A2OMatPlus from root-centric sMat. Specify matrix decomposition -! to be by row, following the ocean's GlobalSegMap (OGSMap) - - if(SparseMatrixPlus_initialized(A2OMatPlus)) then - call die(cplname,"SparseMatrixPlus_initialized failed!") - endif - - ! TESTING INIT_DISTRIBUTED: - call SparseMatrixPlus_init(A2OMatPlus, dMat, AGSMap, OGSMap, & - root, CPL_World, mycompid) - - if(.NOT.SparseMatrixPlus_initialized(A2OMatPlus)) then - call die(cplname,"SparseMatrixPlus_initialized failed!") - endif - - call SparseMatrix_ScatterByRow(OGSMap, DummySMat, dMat_test, root, CPL_World, stat) - - if(.not. sMat_identical(dMat,dMat_test,1e-5)) then - call die(cplname,"dMat has been unexpectedly altered by & - &SparseMatrixPlus_init!") - endif - - ! Clean the SparseMatrix - call SparseMatrix_clean(DummySMat) - call SparseMatrix_clean(dMat) - call SparseMatrix_clean(dMat_test) - - if(myProc==0) write(stdout,*) cplname,':: Reading in O2A on root.' - -! On the root, read in O2A ascii file into DummySMat: - if(myProc==0) then - call ReadSparseMatrixAsc(DummySMat,"ocean_to_atmosphere_remap_file:", & - sMat_src_dims, sMat_dst_dims) - if(sMat_src_dims(1) /= Nox) call die(cplname, & - "sMat_src_dims(1) does not match Nox") - if(sMat_src_dims(2) /= Noy) call die(cplname, & - "sMat_src_dims(2) does not match Noy") - if(sMat_dst_dims(1) /= Nax) call die(cplname, & - "sMat_dst_dims(1) does not match Nax") - if(sMat_dst_dims(2) /= Nay) call die(cplname, & - "sMat_dst_dims(2) does not match Nay") - endif - - if(myProc==0) write(stdout,*) cplname,':: Finished reading in O2A on root.' - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! Build O2AMatPlus from root-centric sMat. Specify matrix decomposition -! to be by column, following the ocean's GlobalSegMap (OGSMap) - - call SparseMatrixPlus_init(O2AMatPlus, DummySMat, OGSMap, AGSMap, Yonly, & - root, CPL_World, mycompid) - - if(.NOT.SparseMatrixPlus_initialized(A2OMatPlus)) then - call die(cplname,"O2AMatPlus has not been initialized!") - endif - - if(myProc==root) then - call sMat_test(sMat=DummySMat,Identifier="CPL::DummySMat-o2a", & - device=8300+myProc) - call SparseMatrix_clean(DummySMat) - endif - -!!!!!!!!!!!!!!!!!----------Attribute Vector for incoming Atmosphere data -! Build an Attribute Vector to hold data coming in from Atmosphere's -! decomposition to AGSMap -! - if(myProc==0)write(stdout,*) cplname, ":: Initializing Attrvect" - call zeit_ci('Catvecinit') - call MCT_AtrVt_init(fromatm, & - iList='gsindex', &! local GSMap values - rList=& -! height of first atm level - "alevh:& -! u wind - &uwind:& -! v wind - &vwind:& -! potential temp - &pottem:& -! specific humidity - &s_hum:& -! density - &rho:& -! barometric pressure - &barpres:& -! surface pressure - &surfp:& -! net solar radiation - &solrad:& -! downward direct visible radiation - &dirvis:& -! downward diffuse visible radiation - &difvis:& -! downward direct near-infrared radiation - &dirnif:& -! downward diffuse near-infrared radiation - &difnif:& -! downward longwave radiation - &lngwv:& -! convective precip - &precc:& -! large-scale precip - &precl",& - lsize=MCT_GSMap_lsize(AGSMap, Cpl_World)) - call zeit_co('Catvecinit') - -!!! declare an AttrVect to hold atmosphere data on the ocean grid -! use AtrVect already declared so that it has the same Attributes -! -if(myProc==0)write(stdout,*) cplname, ":: Init output AtrVect" - call MCT_AtrVt_init(fromatm_ocn, fromatm,MCT_GSMap_lsize(OGSMap, Cpl_World)) -if(myProc==0)write(stdout,*) cplname, ":: Done with init of output vector" - - -!!!!!!!!!!!!!!!!!----------Attribute Vector for incoming Ocean data -! Build an Attribute Vector to hold data coming in from Ocean's Decomp -! decomposition to OGSMap -! - if(myProc==0)write(stdout,*)cplname,":: Initializing Incoming Ocean Attrvect" - - call zeit_ci('fromocnAVinit') - - call MCT_AtrVt_init(fromocn, & - rList=& -! East-West Gradient of Ocean Surface Height - "dhdx:& -! North-South Gradient of Ocean Surface Height - &dhdy:& -! Heat of Fusion of Ocean Water - &Qfusion:& -! Sea Surface Temperature - &SST:& -! Salinity - &salinity:& -! East Component of the Surface Current - &Uocean:& -! East Component of the Surface Current - &Vocean",& - lsize=MCT_GSMap_lsize(OGSMap, CPL_World)) - - call zeit_co('fromocnAVinit') - -!!!!!!!!!!!!!!!!!----------Attribute Vector for Ocean data on ATM grid - - call MCT_AtrVt_init(fromocn_atm, & - rList=& -! East-West Gradient of Ocean Surface Height - "dhdx:& -! North-South Gradient of Ocean Surface Height - &dhdy:& -! Heat of Fusion of Ocean Water - &Qfusion:& -! Sea Surface Temperature - &SST:& -! Salinity - &salinity:& -! East Component of the Surface Current - &Uocean:& -! East Component of the Surface Current - &Vocean",& - lsize=MCT_GSMap_lsize(AGSMap, CPL_World)) - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!--Build Router -! -! Intialize 2 routers: -! 1.) Between atmosphere and coupler using AGSMap. -! 2.) Between coupler and ocean using OGSMap - -! These calls must be paired with similar calls in atm and ocn -! - if(myProc==0)write(stdout,*) cplname, ":: Initializing Routers" - - call zeit_ci('CAtmRouterInit') - call MCT_Router_init(atmo_id,AGSMap,CPL_World,Atm2Cpl) - call zeit_co('CAtmRouterInit') - - call zeit_ci('COcnRouterInit') - call MCT_Router_init(ocn_id,OGSMap,CPL_World,Cpl2Ocn) - call zeit_co('COcnRouterInit') - -! rml print router info - call MCT_Router_print(Atm2Cpl,CPL_World,90) - close(90) - - call Router_test(Atm2Cpl,"CPL::Atm2Cpl",7000+myProc) - call Router_test(Cpl2Ocn,"CPL::Cpl2Ocn",7100+myProc) - - if(myProc==0)write(stdout,*) cplname, ":: Done Initializing Routers" - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!--Build Accumulator - ACCA2O_rList="solrad:dirvis:difvis:dirnif:difnif:precc:precl" - - allocate(ACCA2O_rAction(7),stat=ierr) - if(ierr/=0) call die(cplname,"allocate(ACCA20_rAction)",ierr) - - ACCA2O_rAction = (/MCT_SUM,MCT_AVG,MCT_AVG,MCT_AVG, & - MCT_AVG,MCT_AVG,MCT_AVG/) - - call MCT_Accumulator_init(aC=ACCA2O, & - rList=trim(ACCA2O_rList), & - rAction=ACCA2O_rAction, & - lsize=MCT_GSMap_lsize(OGSMap,Cpl_World), & - num_steps=nsteps) - - call Accumulator_test(ACCA2O,"CPL::ACCA2O",1000+myProc) - - deallocate(ACCA2O_rAction,stat=ierr) - if(ierr/=0) call die(cplname,"deallocate(ACCA20_rAction)",ierr) - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! -! Done with Initialization Phase -! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -!:::::::BEGIN REMAPPING DATA FROM ATMOSPHERE::::::::! - -do steps = 1,nsteps - -!!!!!!!!!!!!!!!!!----------MCT_Recv -! Receive data into AGSMap associated aV fromatm -! -if((myProc==0).and.(steps==1)) then - write(stdout,*) cplname, ":: Doing Distributed Recv" -endif - call zeit_ci('Cmctrecv') - call MCT_Recv(fromatm,Atm2Cpl) - call zeit_co('Cmctrecv') -if((myProc==0).and.(steps==1)) then - write(stdout,*) cplname, ":: Done with Recv" -endif -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! Do the parallel A2O SparseMatrix-AttrVect multiply -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -if((myProc==0).and.(steps==1)) then - write(stdout,*) cplname, ":: Begin A2O sparsematrix mul" -endif - call zeit_ci('CMatMul') - call MCT_MatVecMul(fromatm, A2OMatPlus, fromatm_ocn) - call zeit_co('CMatMul') -if((myProc==0).and.(steps==1)) then - write(stdout,*) cplname, ":: Completed A2O sparsematrix mul" -endif -! Perform Accumulation -call accumulate(fromatm_ocn,ACCA2O) - -enddo -call AttrVect_test(fromatm,"CPL::fromatm",2100+myProc) -call AttrVect_test(fromatm_ocn,"CPL::fromatm_ocn",2200+myProc) - -if(myProc==1)write(stdout,*) cplname, ":: Testing point to point send and recv" - -if(mySize>1) then - - if(myProc==1) then - call AttrVect_Send(inAV=fromatm,dest=0,TagBase=123,comm=CPL_World,status=ierr) - if(ierr/=0) call die(cplname,"AttrVect_Send- p1",ierr) - - call AttrVect_Recv(outAV=fromP1,dest=0,TagBase=124,comm=CPL_World,status=ierr) - if(ierr/=0) call die(cplname,"AttrVect_Recv- p1",ierr) - - if(.not.AttrVect_identical(fromatm,fromP1,0.1)) then - call die(cplname, "point to point comms failed") - endif - - call MCT_AtrVt_clean(fromP1) - - endif - if(myProc==0) then - call AttrVect_Recv(outAV=fromP1,dest=1,TagBase=123,comm=CPL_World,status=ierr) - if(ierr/=0) call die(cplname,"AttrVect_Recv- p0",ierr) - - call AttrVect_Send(inAV=fromP1,dest=1,TagBase=124,comm=CPL_World,status=ierr) - if(ierr/=0) call die(cplname,"AttrVect_Send- p0",ierr) - - call MCT_AtrVt_clean(fromP1) - - endif - -endif - - ! Send the accumulator registers to the ocean - call zeit_ci('Cmctsend') - call MCT_Send(ACCA2O%data,Cpl2Ocn) - call zeit_co('Cmctsend') - - ! Check received globalmap values against expected ones - j=1 - do i=1,MCT_GSMap_ngseg(AGSMap) - if(myProc==AGSMap%pe_loc(i)) then - do k=1,AGSMap%length(i) - if(fromatm%iAttr(1,j) /= AGSMap%start(i)+k-1) then - write(*,*) cplname, ':: MCT GSMap mismatch. Expected', & - AGSMap%start(i)+k-1,'got ',fromatm%iAttr(1,j) - endif - j=j+1 - enddo - endif - enddo - - !::::::TESTING ACCUMULATOR COMM FUNCTIONS:::::! - if(myProc==0) write(stdout,*) cplname,":: TESTING ACCUMULATOR_COMMS" - - call GlobalMap_init(OGMap,mycompid,MCT_GSMap_lsize(OGSMap,CPL_World), & - CPL_World) - - call MCT_Acc_gather(ACCA2O,GSgatherAcc,OGSMap,0,CPL_World,ierr) - if(ierr/=0) call die(cplname,"call MCT_Acc_gather #1") - - ! TESTING COMMS USING GMAP - call MCT_Acc_scatter(GSgatherAcc,scatterAcc,OGMap,0,CPL_World,ierr) - if(ierr/=0) call die(cplname,"call MCT_Acc_scatter #2") - - call MCT_Acc_gather(scatterAcc,GgatherAcc,OGMap,0,CPL_World,ierr) - if(ierr/=0) call die(cplname,"call MCT_Acc_gather #3") - - if(myProc==0) then - if(.NOT.Accumulator_identical(GSgatherAcc,GgatherAcc,0.1)) then - call die(cplname,"ACCUMULATOR SCATTER/GATHER #4 FAILED!") - endif - endif - - call MCT_Accumulator_clean(scatterAcc) - ! DONE TESTING COMMS USING GMAP - - call MCT_Acc_scatter(GSgatherAcc,scatterAcc,OGSMap,0,CPL_World,ierr) - if(ierr/=0) call die(cplname,"call MCT_Acc_scatter #5") - - if(.NOT.Accumulator_identical(ACCA2O,scatterAcc,0.1)) then - call die(cplname,"ACCUMULATOR SCATTER/GATHER #6 FAILED!") - endif - - call MCT_Acc_bcast(GSgatherAcc,0,CPL_World,ierr) - if(ierr/=0) call die(cplname,"call MCT_Acc_bcast") - - call Accumulator_test(GSgatherAcc,"CPL::bcastAcc",1100+myProc) - - call AttrVect_test(ACCA2O%data,"CPL::ACCA2O%data",2300+myProc) - -!::::::::DONE TESTING ACCUMULATOR COMMS:::::::::::::::::! - -!::::::::TEST LOCAL REDUCE::::::::! - call AttrVect_ReduceTest(GSgatherAcc%data,"GSgatherAcc%data on Root",2700) - - ! Lets prepare to do some neat integrals using MCT. - ! First, we scatter both of the General Grids. - call MCT_GGrid_scatter(AtmGrid, dAtmGrid, AGSMap, 0, CPL_World) - call MCT_GGrid_scatter(OcnGrid, dOcnGrid, OGSMap, 0, CPL_World) - - if(myProc==0) call AttrVect_test(OcnGrid%data,"CPL::OcnGrid%data",2400+myProc) - - ! unmasked paired integral: - call MCT_PairedSpatialIntegrals(inAv1=fromatm, outAv1=integratedAVect, & - GGrid1=dAtmGrid,WeightTag1="grid_area", & - inAv2=fromatm_ocn, outAv2=integratedOVect,& - GGrid2=dOcnGrid, WeightTag2="grid_area", & - SumWeights=.true., comm=CPL_World) - if(myProc==0)then - - j=MCT_AtrVt_nreals(integratedAVect) - do i=1,j,j-1 - write(stdout,'(3a,i2,a,f12.6)') cplname,':: Paired MCT ', & - 'integral: integratedAVect%rAttr(',i,',1)=', & - integratedAVect%rAttr(i,1) - enddo - - k=MCT_AtrVt_nreals(integratedOVect) - do i=1,k,k-1 - write(stdout,'(3a,i2,a,f12.6)') cplname,':: Paired MCT ', & - 'integral: integratedOVect%rAttr(',i,',1)=', & - integratedOVect%rAttr(i,1) - end do - endif - - call MCT_AtrVt_clean(integratedAVect) - call MCT_AtrVt_clean(integratedOVect) - - ! unmasked paired average: - call MCT_PairedSpatialAverages(inAv1=fromatm, outAv1=integratedAVect, & - GGrid1=dAtmGrid,WeightTag1="grid_area", & - inAv2=fromatm_ocn, outAv2=integratedOVect,& - GGrid2=dOcnGrid, WeightTag2="grid_area", & - comm=CPL_World) - -if(myProc==0)then - - i=1 - write(stdout,'(3a,i2,a,f12.6)') cplname,':: Paired MCT ',& - 'average: averagedAVect%rAttr(',i,',1)=', & - integratedAVect%rAttr(i,1) - - write(stdout,'(3a,i2,a,f12.6)') cplname,':: Paired MCT ',& - 'average: averagedOVect%rAttr(',i,',1)=', & - integratedOVect%rAttr(i,1) - -endif - - call MCT_AtrVt_clean(integratedAVect) - call MCT_AtrVt_clean(integratedOVect) - - ! masked paired integral: - call MCT_PairedMaskedSpatialIntegral(inAv1=fromatm, & - outAv1=integratedAVect, & - GGrid1=dAtmGrid, & - SpatialWeightTag1="grid_area", & - iMaskTags1="grid_imask", & - inAv2=fromatm_ocn, & - outAv2=integratedOVect, & - GGrid2=dOcnGrid, & - SpatialWeightTag2="grid_area", & - iMaskTags2="grid_imask", & - UseFastMethod=.true., & - SumWeights=.true., & - comm=CPL_World) - -if(myProc==0)then - - j=MCT_AtrVt_nreals(integratedAVect) - do i=1,j,j-1 - write(stdout,'(3a,i2,a,f12.6)') cplname,':: Paired masked MCT ', & - 'integral: integratedAVect%rAttr(',i,',1)=', & - integratedAVect%rAttr(i,1) - end do - - k=MCT_AtrVt_nreals(integratedOVect) - do i=1,k,k-1 - write(stdout,'(3a,i2,a,f12.6)') cplname,':: Paired masked MCT ', & - 'integral: integratedOVect%rAttr(',i,',1)=', & - integratedOVect%rAttr(i,1) - end do - -endif - - call MCT_AtrVt_clean(integratedAVect) - call MCT_AtrVt_clean(integratedOVect) - - ! Masked paired average: - call MCT_PairedMaskedSpatialAverages(inAv1=fromatm, & - outAv1=integratedAVect, & - GGrid1=dAtmGrid, & - SpatialWeightTag1="grid_area", & - iMaskTags1="grid_imask", & - inAv2=fromatm_ocn, & - outAv2=integratedOVect, & - GGrid2=dOcnGrid, & - SpatialWeightTag2="grid_area", & - iMaskTags2="grid_imask", & - UseFastMethod=.true., & - comm=CPL_World) - -if(myProc==0)then - - i=1 - write(stdout,'(3a,i2,a,f12.6)') cplname,':: Paired masked MCT ', & - 'average : averagedAVect%rAttr(',i,',1)=', & - integratedAVect%rAttr(i,1) - - write(stdout,'(3a,i2,a,f12.6)') cplname,':: Paired masked MCT ', & - 'average : averagedOVect%rAttr(',i,',1)=', & - integratedOVect%rAttr(i,1) - -endif - - call AttrVect_test(integratedAVect,"CPL::integratedAVect",myProc+2500) - - call MCT_AtrVt_clean(integratedAVect) - call MCT_AtrVt_clean(integratedOVect) - - ! Now, receive Input AV from ocean (fromocn) - if(myProc==0) write(stdout,*) cplname,':: Before MCT_RECV from ocean' - call zeit_ci('RecvFromOcn') - call MCT_Recv(fromocn,Cpl2Ocn) - call zeit_co('RecvFromOcn') - if(myProc==0) write(stdout,*) cplname,':: After MCT_RECV from ocean' - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! Do the parallel O2A SparseMatrix-AttrVect multiply -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - if(myProc==0) write(stdout,*) cplname,":: Commencing O2A sparsematrix mul" - call zeit_ci('O2AMatMul') - call MCT_MatVecMul(fromocn, O2AMatPlus, fromocn_atm) - call zeit_co('O2AMatMul') - if(myProc==0) write(stdout,*) cplname,":: Completed O2A sparsematrix mul" - - ! Check the interpolated values - do i=2,MCT_AtrVt_nreals(fromocn_atm) - do j=1,MCT_AtrVt_lsize(fromocn_atm) - if(abs(fromocn_atm%rAttr(1,j)-fromocn_atm%rAttr(i,j)) > 1e-4) then - write(stderr,*) cplname, ":: Interpolation Error", & - fromocn_atm%rAttr(1,j), fromocn_atm%rAttr(i,j), i, j - call die(cplname,"Interpolation Error") - endif - enddo - enddo - - ! TEST MAPPING FOR HMV - -! call AttrVect_gather(fromocn_atm,gatherAV_atm,AGSMap, & -! 0,CPL_World,ierr) - call AttrVect_gather(fromocn_atm,gatherAV_atm,AGSMap, & - 0,CPL_World,ierr,99.0_FP) ! rml test - - if(myProc == 0) then - unit = luavail() + 9500 - write(unit,*) Nax, Nay - k=0 - do i=1,Nax - do j=1,Nay - k=k+1 - write(unit,*) gatherAV_atm%rAttr(1,k) - enddo - enddo - call MCT_AtrVt_clean(gatherAV_atm) - endif - -if(myProc==0)write(stdout,*) cplname, ":: All Done, cleanup" - call zeit_ci('Ccleanup') - - ! Clean MCT datatypes - if(myProc==0) then - call MCT_GGrid_clean(AtmGrid) - call MCT_GGrid_clean(OcnGrid) - call MCT_Accumulator_clean(GgatherAcc) - endif - - call MCT_Accumulator_clean(GSgatherAcc) - call MCT_Accumulator_clean(scatterAcc) - call GlobalMap_clean(rOGMap) - call GlobalMap_clean(OCN_OGMap) - call GlobalMap_clean(OGMap) - call MCT_GGrid_clean(dAtmGrid) - call MCT_GGrid_clean(dOcnGrid) - call MCT_GSMap_clean(AGSMap) - call MCT_GSMap_clean(OGSMap) - call MCT_GSMap_clean(DAGSMap) - call MCT_GSMap_clean(OCN_OGSMap) - call MCT_Router_clean(Atm2Cpl) - call MCT_Router_clean(Cpl2Ocn) - call SparseMatrixPlus_clean(A2OMatPlus) - call SparseMatrixPlus_clean(O2AMatPlus) - call MCT_Accumulator_clean(ACCA2O) - call MCT_AtrVt_clean(fromatm) - call MCT_AtrVt_clean(fromatm_ocn) - call MCT_AtrVt_clean(fromocn) - call MCT_AtrVt_clean(fromocn_atm) - call MCTWorld_clean() - - call zeit_co('Ccleanup') - - call zeit_allflush(CPL_World,0,46) - - initialized= MCTWorld_initialized() - if (myProc==0)write(stdout,*) cplname, & - ":: MCTWorld initialized=",initialized - if(initialized) call die(cplname, "mct still initialized") - - -end subroutine - - - - - - - - - - - - - - diff --git a/cesm/models/utils/mct/testsystem/testall/job.ut-all.jaguar b/cesm/models/utils/mct/testsystem/testall/job.ut-all.jaguar deleted file mode 100644 index ccd8b4b..0000000 --- a/cesm/models/utils/mct/testsystem/testall/job.ut-all.jaguar +++ /dev/null @@ -1,23 +0,0 @@ -#!/bin/sh -#PBS -q debug -#PBS -l walltime=5:00,size=6 -#PBS -o job.out.jaguar -#PBS -j oe -#PBS -m abe -#PBS -A CLI017dev - -# job starts in home directory, cd to the submission directory - -# IMPORTANT! after CNL upgrade, all files (input,output,pwd) -# must be in /lustre. - -cd $PBS_O_WORKDIR - - -echo '---------------------------------------------------------' - -# phoenix -# aprun -n 6 ./utmct - -# jaguar -aprun -n 6 ./utmct diff --git a/cesm/models/utils/mct/testsystem/testall/m_ACTEST.F90 b/cesm/models/utils/mct/testsystem/testall/m_ACTEST.F90 deleted file mode 100644 index af084c5..0000000 --- a/cesm/models/utils/mct/testsystem/testall/m_ACTEST.F90 +++ /dev/null @@ -1,633 +0,0 @@ -! -! !INTERFACE: - - module m_ACTEST -! -! !USES: -! - implicit none - - private ! except - -! !PUBLIC MEMBER FUNCTIONS: - - public :: testall - public :: IndexAttr - public :: Copy - public :: ImportExport - public :: Identical - - interface testall - module procedure testaC_ - end interface - interface IndexAttr - module procedure IndexTest_ - end interface - interface Copy - module procedure CopyTest_ - end interface - interface ImportExport - module procedure ImportExportTest_ - end interface - interface Identical - module procedure Identical_ - end interface - - -! !REVISION HISTORY: -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname='m_ACTEST' - - contains - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: aCtest_ - Test the functions in the Accumulator module -! -! !DESCRIPTION: -! This routine writes diagnostic information about the input -! {\tt Accumulator}. Each line of the output will be preceded by the -! character argument {\tt identifier}. The output device is specified -! by the integer argument {\tt device}. -! -! !INTERFACE: - - subroutine testaC_(aC, identifier, device) - -! -! !USES: -! - - use m_Accumulator, only : Accumulator - use m_Accumulator, only : accumulate - use m_Accumulator, only : MCT_SUM, MCT_AVG - use m_Accumulator, only : nIAttr, nRAttr - use m_Accumulator, only : lsize - use m_Accumulator, only : clean - use m_Accumulator, only : Accumulator_init => init - use m_AttrVect, only : AttrVect - use m_AttrVect, only : AttrVect_init => init - use m_AttrVect, only : AttrVect_clean => clean - use m_AttrVect, only : AttrVect_copy => Copy - use m_List, only : List_allocated => allocated - use m_List, only : ListExportToChar => exporttoChar - use m_stdio - use m_die - - implicit none - -! !INPUT PARAMETERS: - - type(Accumulator), intent(in) :: aC - character(len=*), intent(in) :: identifier - integer, intent(in) :: device - -! !REVISION HISTORY: -! 23Sep02 - E.T. Ong - initial prototype. -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::aCtest_' - - type(Accumulator) :: aCCopy1, aCCopy2, aCExactCopy - type(AttrVect) :: aVDummy - integer :: i,j,k - -!::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: -!:::::WRITE OUT INFO ABOUT THE ATTRVECT::::::::::::::::::::::::::::::::: -!::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: - - write(device,*) identifier, ":: TYPE CHECK " - write(device,*) identifier, ":: NUM_STEPS = ", aC%num_steps - write(device,*) identifier, ":: STEPS_DONE = ", aC%steps_done - - if(associated(aC%iAction)) then - write(device,*) identifier, ":: IACTION (SIZE,VALUES) = ", & - size(aC%iAction), aC%iAction - else - write(device,*) identifier, ":: IACTION NOT ASSOCIATED" - endif - - if(associated(aC%rAction)) then - write(device,*) identifier, ":: RACTION (SIZE,VALUES) = ", & - size(aC%rAction), aC%rAction - else - write(device,*) identifier, ":: RACTION NOT ASSOCIATED" - endif - - if(List_allocated(aC%data%iList)) then - write(device,*) identifier, ":: data%ILIST = ", & - ListExportToChar(aC%data%iList) - else - write(device,*) identifier, ":: data%ILIST NOT INITIALIZED" - endif - - if(List_allocated(aC%data%rList)) then - write(device,*) identifier, ":: data%RLIST = ", & - ListExportToChar(aC%data%rList) - else - write(device,*) identifier, ":: data%RLIST NOT INITIALIZED" - endif - -!::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: -!:::::TESTING ACCUMULATION:::::::::::::::::::::::::::::::::::::::::::::: -!::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: - - call Accumulator_init(aC=aCExactCopy, bC=aC, lsize=lsize(aC), & - num_steps=aC%num_steps, steps_done=aC%steps_done) - - call AttrVect_copy(aVin=aC%data,aVout=aCExactCopy%data) - - call Accumulator_init(aC=aCCopy1, bC=aC, lsize=100, & - num_steps=aC%num_steps, steps_done=0) - - call Accumulator_init(aC=aCCopy2, bC=aC, lsize=100, & - num_steps=aC%num_steps, steps_done=0) - - call AttrVect_init(aV=aVDummy, bV=aC%data, lsize=100) - - if(nIAttr(aC)>0) then - aCCopy1%iAction=MCT_AVG - aCCopy2%iAction=MCT_SUM - aVDummy%iAttr = 1 - endif - - if(nRAttr(aC)>0) then - aCCopy1%rAction=MCT_AVG - aCCopy2%rAction=MCT_SUM - aVDummy%rAttr = 1. - endif - - do i=1,aC%num_steps - call accumulate(aVDummy,ACCopy1) - call accumulate(aVDummy,ACCopy2) - enddo - - call accumulate(aVDummy,ACCopy1) - call accumulate(aVDummy,ACCopy2) - - if(.NOT. (aCCopy1%num_steps == aC%num_steps)) then - call die(myname_,"SEVERE: aCCopy1 num_steps value has changed!") - endif - - if(.NOT. (aCCopy2%num_steps == aC%num_steps)) then - call die(myname_,"SEVERE: aCCopy2 num_steps value has changed!") - endif - - if(.NOT. (aCCopy1%steps_done == aC%num_steps+1)) then - call die(myname_,"SEVERE: aCCopy1 stesp_done value is incorrect!") - endif - - if(.NOT. (aCCopy2%steps_done == aC%num_steps+1)) then - call die(myname_,"SEVERE: aCCopy2 stesp_done value is incorrect!") - endif - - do i=1,lsize(ACCopy1) - do j=1,nRAttr(aC) - if( (aCCopy1%data%rAttr(j,i) < 1.9) .or. & - (aCCopy1%data%rAttr(j,i) > 2.1) ) then - call die(myname_,"Averaging Reals failed") - endif - if( (aCCopy2%data%rAttr(j,i) < aC%num_steps+0.9) .or. & - (aCCopy2%data%rAttr(j,i) > aC%num_steps+1.1) ) then - call die(myname_,"Summing Reals failed") - endif - enddo - enddo - - do i=1,lsize(aCCopy1) - do j=1,nIAttr(aC) - if( aCCopy1%data%iAttr(j,i) /= 2 ) then - call die(myname_,"Averaging Ints failed",aCCopy1%data%iAttr(j,i)) - endif - if( aCCopy2%data%iAttr(j,i) /= aC%num_steps+1 ) then - call die(myname_,"Summing Ints failed",aCCopy1%data%iAttr(j,i)) - endif - enddo - enddo - -!::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: -!:::::TESTING INDEXIA AND GETILIST:::::::::::::::::::::::::::::::::::::: -!::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: - - call IndexTest_(aC,identifier,device) - -!::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::! -!:::::TESTING COPY AND SHAREDATTRINDEXLIST:::::::::::::::::::::::::::::! -!::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::! - - call CopyTest_(aC,identifier,device) - -!::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::! -!:::::TESTING EXPORT AND IMPORT FUNCTIONS:::::::::::::::::::::::::::::::! -!::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::! - call ImportExportTest_(aC,identifier,device) - - ! Check that aC is unchanged! - - if(.not.Identical_(ACC1=aC,ACC2=aCExactCopy,Range=1e-5)) then - call die(myname_,"aC has been unexpectedly modified!!!") - endif - - call clean(aCCopy1) - call clean(aCCopy2) - call clean(aCExactCopy) - call AttrVect_clean(aVDummy) - -end subroutine testaC_ - -!::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: -!:::::TEST FOR INDEXIA AND GETILIST:::::::::::::::::::::::::::::::::::::: -!::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: - - subroutine IndexTest_(aC,identifier,device) - - use m_Accumulator, only: nIAttr, nRAttr, getIList, getRList, indexIA, indexRA, Accumulator - use m_List, only: List_allocated => allocated - use m_String, only: String - use m_String, only: StringToChar => toChar - use m_String, only: String_clean => clean - use m_stdio - use m_die - - implicit none - - type(Accumulator), intent(in) :: aC - character(len=*), intent(in) :: identifier - integer, intent(in) :: device - - character(len=*),parameter :: myname_=myname//'::IndexTest_' - type(String) :: ItemStr - integer :: i,j,k,ierr - - if(nIAttr(aC)>0) then - write(device,*) identifier, ":: Testing indexIA and getIList::" - else - if(List_allocated(aC%data%iList)) then - call die(myname_,"iList has been allocated, :& - &but there are no atttributes. :& - &Please do not initialize a blank list.") - end if - if(associated(aC%data%iAttr)) then - if(size(aC%data%iAttr,1) /= 0) then - call die(myname_,"iAttr contains no attributes, & - &yet its size /= 0",size(aC%data%iAttr,1)) - endif - endif - end if - - do i=1,nIAttr(aC) - - call getIList(ItemStr,i,aC) - j = indexIA(aC,StringToChar(ItemStr)) - if(i/=j) call die(myname_,"Function indexIA failed!") - write(device,*) identifier, & - ":: aC Index = ", j, & - ":: Attribute Name = ", StringToChar(ItemStr) - call String_clean(ItemStr) - - enddo - - if(nRAttr(aC)>0) then - write(device,*) identifier, ":: Testing indexRA and getRList::" - else - if(List_allocated(aC%data%rList)) then - call die(myname_,"rList has been allocated, :& - &but there are no atttributes. :& - &Please do not initialize a blank list.") - end if - if(associated(aC%data%rAttr)) then - if(size(aC%data%rAttr,1) /= 0) then - call die(myname_,"rAttr contains no attributes, & - &yet its size /= 0",size(aC%data%rAttr,1)) - endif - endif - end if - - do i=1,nRAttr(aC) - - call getRList(ItemStr,i,aC) - j = indexRA(aC,StringToChar(ItemStr)) - if(i/=j) call die(myname_,"Function indexIA failed!") - write(device,*) identifier, & - "::aC Index = ", j, & - "::Attribute Name = ", StringToChar(ItemStr) - call String_clean(ItemStr) - - enddo - - end subroutine IndexTest_ - -!::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::! -!:::::TEST FOR COPY AND SHAREDATTRINDEXLIST:::::::::::::::::::::::::::::! -!::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::! - -! NOTE: SO FOR ONLY TESTING SHAREDATTRINDEX for reals - - subroutine CopyTest_(aC,identifier,device) - - use m_AttrVect, only : copy - use m_AttrVect, only : exportIListToChar,exportRListToChar - use m_AttrVect, only : AttrVect_init => init - use m_Accumulator - use m_List, only : List - use m_List, only : List_init => init - use m_List, only : List_copy => copy - use m_List, only : List_append => append - use m_List, only : ListexportToChar => exportToChar - use m_List, only : List_clean => clean - use m_String, only : String - use m_String, only : StringToChar => toChar - use m_String, only : String_clean => clean - use m_stdio - use m_die - - implicit none - - type(Accumulator), intent(in) :: aC - character(len=*), intent(in) :: identifier - integer, intent(in) :: device - - character(len=*),parameter :: myname_=myname//'::CopyTest_' - type(String) :: ItemStr1, ItemStr2 - type(Accumulator) :: aCExactCopy - integer,dimension(:), pointer :: aCaCIndices1, aCaCIndices2 - integer,dimension(:), pointer :: aVaCIndices1, aVaCIndices2 - integer :: aCaCNumShared, aVaCNumShared - integer :: i,j,k,ierr - - if( (nRAttr(aC)>0) ) then - - write(device,*) identifier, ":: Testing Copy and SharedAttrIndexList ::" - write(device,*) identifier, ":: FIRST AV ATTRIBUTES::", & - " RATTR = ", exportRListToChar(aC%data) - call init(aCExactCopy,aC,lsize(aC)) - write(device,*) identifier, ":: SECOND AV ATTRIBUTES::", & - " RATTR = ", exportRListToChar(aCExactCopy%data) - call zero(aCExactCopy) - call copy(aVin=aC%data, aVout=aCExactCopy%data) - call SharedAttrIndexList(aC,aCExactCopy,"REAL ", & - aCaCNumShared,aCaCIndices1,aCaCIndices2) - call SharedAttrIndexList(aC%data,aCExactCopy,"REAL ", & - aVaCNumShared,aVaCIndices1,aVaCIndices2) - - if(aCaCNumShared/=aVaCNumShared) then - call die(myname_,"aCaCNumShared/=aVaCNumShared") - endif - - do i=1,aCaCNumShared - if(aCaCIndices1(i)/=aVaCIndices1(i)) then - call die(myname_,"aCaCIndices1(i)/=aVaCIndices1(i)") - endif - if(aCaCIndices2(i)/=aVaCIndices2(i)) then - call die(myname_,"aCaCIndices2(i)/=aVaCIndices2(i)") - endif - enddo - - write(device,*) identifier, ":: Indices1 :: Indices2 :: & - &Attribute1 :: Attribute2" - do i=1,aCaCNumShared - call getRList(ItemStr1,aCaCIndices1(i),aC) - call getRList(ItemStr2,aCaCIndices2(i),aCExactCopy) - write(device,*) identifier,":: ", aCaCIndices1(i), "::", & - aCaCIndices2(i), "::", StringToChar(ItemStr1), "::", & - StringToChar(ItemStr2) - call String_clean(ItemStr1) - call String_clean(ItemStr2) - enddo - - do i=1,aCaCNumShared - do j=1,lsize(aC) - if(aC%data%rAttr(aCaCIndices1(i),j) /= & - aCExactCopy%data%rAttr(aCaCIndices2(i),j)) then - write(device,*) identifier,aCaCIndices1(i),aCaCIndices2(i), j - call die(myname_,"Copy function is MALFUNCTIONING", ierr) - endif - enddo - enddo - - deallocate(aCaCIndices1,aCaCIndices2,aVaCIndices1,aVaCIndices2,stat=ierr) - if(ierr/=0) call die(myname_,"deallocate(aCaCIndices,aVaCIndices)",ierr) - - call clean(aCExactCopy) - - else - - write(device,*) identifier, & - ":: NOT Testing Copy and SharedAttrIndexList ::", & - ":: Consult m_ACTest.F90 to enable this function::" - endif - - end subroutine CopyTest_ - -!::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::! -!:::::TEST FOR EXPORT AND IMPORT FUNCTIONS:::::::::::::::::::::::::::::::! -!::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::! - - subroutine ImportExportTest_(aC,identifier,device) - - use m_Accumulator - use m_AttrVect, only : exportIList, exportRList - use m_AttrVect, only : exportIListToChar, exportRListToChar - use m_List, only : List - use m_List, only : List_identical => identical - use m_List, only : List_get => get - use m_List, only : List_clean => clean - use m_String, only : String - use m_String, only : StringToChar => toChar - use m_String, only : String_clean => clean - use m_stdio - use m_die - - use m_realkinds, only : FP - - implicit none - - type(Accumulator), intent(in) :: aC - character(len=*), intent(in) :: identifier - integer, intent(in) :: device - - character(len=*),parameter :: myname_=myname//'::ImportExportTest_' - type(Accumulator) :: importAC - type(List) :: OutIList, OutRList - type(String) :: ItemStr - integer,dimension(:),pointer :: OutIVect - real(FP), dimension(:),pointer :: OutRVect - integer :: exportsize - integer :: i,j,k,ierr - - write(device,*) identifier, ":: Testing import and export functions" - - if(nIAttr(aC)>0) then - - call exportIList(aV=aC%data,outIList=outIList) - - if(.NOT. List_identical(aC%data%iList,outIList)) then - call die(myname_, "Function exportIList failed!") - endif - - call List_get(ItemStr=ItemStr,ith=nIAttr(aC),aList=aC%data%iList) - - allocate(outIVect(lsize(aC)),stat=ierr) - if(ierr/=0) call die(myname_,"allocate(outIVect)") - - call exportIAttr(aC=aC,AttrTag=StringToChar(ItemStr), & - outVect=OutIVect,lsize=exportsize) - - if(exportsize /= lsize(aC)) then - call die(myname_,"(exportsize /= lsize(aC))") - endif - - do i=1,exportsize - if(aC%data%iAttr(nIAttr(aC),i) /= outIVect(i)) then - call die(myname_,"Function exportIAttr failed!") - endif - enddo - - call init(aC=importAC,bC=aC,lsize=exportsize) - call zero(importAC) - - call importIAttr(aC=importAC,AttrTag=StringToChar(ItemStr), & - inVect=outIVect,lsize=exportsize) - - j=indexIA(importAC,StringToChar(ItemStr)) - if(j<=0) call die(myname_,"indexIA(importAC,StringToChar(ItemStr))") - do i=1,exportsize - if(importAC%data%iAttr(j,i) /= outIVect(i)) then - call die(myname_,"Function importIAttr failed!") - endif - enddo - - call clean(importAC) - call List_clean(outIList) - call String_clean(ItemStr) - - deallocate(outIVect,stat=ierr) - if(ierr/=0) call die(myname_,"deallocate(outIVect)") - - endif - - if(nRAttr(aC)>0) then - - call exportRList(aV=aC%data,outRList=outRList) - - if(.NOT. List_identical(aC%data%rList,outRList)) then - call die(myname_, "Function exportRList failed!") - endif - - call List_get(ItemStr=ItemStr,ith=nRAttr(aC),aList=aC%data%rList) - - allocate(outRVect(lsize(aC)),stat=ierr) - if(ierr/=0) call die(myname_,"allocate(outRVect)") - - call exportRAttr(aC=aC,AttrTag=StringToChar(ItemStr), & - outVect=OutRVect,lsize=exportsize) - - if(exportsize /= lsize(aC)) then - call die(myname_,"(exportsize /= lsize(aC))") - endif - - do i=1,exportsize - if(aC%data%rAttr(nRAttr(aC),i) /= outRVect(i)) then - call die(myname_,"Function exportRAttr failed!") - endif - enddo - - call init(aC=importAC,bC=aC,lsize=exportsize) - call zero(importAC) - - call importRAttr(aC=importAC,AttrTag=StringToChar(ItemStr), & - inVect=outRVect,lsize=exportsize) - - j=indexRA(importAC,StringToChar(ItemStr)) - if(j<=0) call die(myname_,"indexRA(importAC,StringToChar(ItemStr))") - do i=1,exportsize - if(importAC%data%rAttr(j,i) /= outRVect(i)) then - call die(myname_,"Function importRAttr failed!") - endif - enddo - - call clean(importAC) - call List_clean(outRList) - call String_clean(ItemStr) - - deallocate(outRVect,stat=ierr) - if(ierr/=0) call die(myname_,"deallocate(outRVect)") - - endif - - end subroutine ImportExportTest_ - - logical function Identical_(ACC1,ACC2,Range) - - use m_Accumulator - use m_AVTEST,only: AttrVect_identical => Identical - use m_stdio - use m_die - - use m_realkinds, only : FP - - implicit none - - type(Accumulator), intent(in) :: ACC1 - type(Accumulator), intent(in) :: ACC2 - real, optional, intent(in) :: Range - - character(len=*),parameter :: myname_=myname//'::Identical_' - integer :: i,j,k - - Identical_=.true. - - if(present(Range)) then - if(.NOT. AttrVect_identical(ACC1%data,ACC2%data,Range)) then - Identical_=.false. - endif - else - if(.NOT. AttrVect_identical(ACC1%data,ACC2%data)) then - Identical_=.false. - endif - endif - - if(ACC1%num_steps/=ACC2%num_steps) then - Identical_=.false. - endif - - if(ACC1%steps_done/=ACC2%steps_done) then - Identical_=.false. - endif - - j=0 - k=0 - - if(associated(ACC1%iAction).or.associated(ACC2%iAction)) then - if(size(ACC1%iAction) /= size(ACC2%iAction)) then - Identical_=.FALSE. - endif - j=size(ACC1%iAction) - endif - - if(associated(ACC1%rAction).or.associated(ACC2%rAction)) then - if(size(ACC1%rAction) /= size(ACC2%rAction)) then - Identical_=.FALSE. - endif - k=size(ACC2%rAction) - endif - - do i=1,j - if(ACC1%iAction(i)/=ACC2%iAction(i)) then - Identical_=.FALSE. - endif - enddo - - do i=1,k - if(ACC1%rAction(i)/=ACC2%rAction(i)) then - Identical_=.FALSE. - endif - enddo - - end function Identical_ - - -end module m_ACTEST diff --git a/cesm/models/utils/mct/testsystem/testall/m_AVTEST.F90 b/cesm/models/utils/mct/testsystem/testall/m_AVTEST.F90 deleted file mode 100644 index e08d281..0000000 --- a/cesm/models/utils/mct/testsystem/testall/m_AVTEST.F90 +++ /dev/null @@ -1,857 +0,0 @@ -! -! !INTERFACE: - - module m_AVTEST -! -! !USES: -! - implicit none - - private ! except - -! !PUBLIC MEMBER FUNCTIONS: - - public :: testall - public :: IndexAttr - public :: SortPermute - public :: Copy - public :: ImportExport - public :: Reduce - public :: Identical - - interface testall - module procedure testaV_ - end interface - interface IndexAttr - module procedure IndexTest_ - end interface - interface SortPermute - module procedure SortPermuteTest_ - end interface - interface Copy - module procedure CopyTest_ - end interface - interface ImportExport - module procedure ImportExportTest_ - end interface - interface Reduce - module procedure ReduceTest_ - end interface - interface Identical - module procedure Identical_ - end interface - -! !REVISION HISTORY: -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname='m_AVTest' - - contains - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: aVtest_ - Test the functions in the AttrVect module -! -! !DESCRIPTION: -! This routine writes diagnostic information about the input -! {\tt AttrVect}. Each line of the output will be preceded by the -! character argument {\tt identifier}. The output device is specified -! by the integer argument {\tt device}. -! -! !INTERFACE: - - subroutine testaV_(aV, identifier, device) - -! -! !USES: -! - use m_AttrVect ! Use all AttrVect routines - use m_stdio - use m_die - - implicit none - -! !INPUT PARAMETERS: - - type(AttrVect), intent(in) :: aV - character(len=*), intent(in) :: identifier - integer, intent(in) :: device - -! !REVISION HISTORY: -! 23Sep02 - E.T. Ong - initial prototype. -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::aVtest_' - type(AttrVect) :: aVExactCopy - -!::::MAKE A COPY::::! - - call init(aVExactCopy,aV,lsize(aV)) - call Copy(aVin=aV,aVout=aVExactCopy) - -!::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: -!:::::WRITE OUT INFO ABOUT THE ATTRVECT::::::::::::::::::::::::::::::::: -!::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: - - write(device,*) identifier, ":: lsize = ", lsize(aV) - write(device,*) identifier, ":: nIAttr = ", nIAttr(aV) - write(device,*) identifier, ":: nRAttr = ", nRAttr(aV) - - if(nIAttr(aV)>0) then - write(device,*) identifier, ":: exportIListToChar = ", & - exportIListToChar(aV) - endif - - if(nRAttr(aV)>0) then - write(device,*) identifier, ":: exportRListToChar = ", & - exportRListToChar(aV) - endif - -!::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: -!:::::TESTING INDEXIA AND GETILIST:::::::::::::::::::::::::::::::::::::: -!::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: - - call IndexTest_(aV,identifier,device) - - -!::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::! -!:::::TESTING SORT AND PERMUTE:::::::::::::::::::::::::::::::::::::::::! -!::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::! - -! NOTE: THIS IS NOT A CHECK FOR CORRECTNESS, JUST A CHECK FOR CONSISTENCY - - call SortPermuteTest_(aV,identifier,device) - -!::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::! -!:::::TESTING COPY AND SHAREDATTRINDEXLIST:::::::::::::::::::::::::::::! -!::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::! - - call CopyTest_(aV,identifier,device) - -!::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::! -!:::::TESTING EXPORT AND IMPORT FUNCTIONS::::::::::::::::::::::::::::::::! -!::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::! - - call ImportExportTest_(aV,identifier,device) - -!::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::! -!:::::TESTING LOCAL REDUCE FUNCTIONS:::::::::::::::::::::::::::::::::::::! -!::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::! - - call ReduceTest_(aV,identifier,device) - - - ! Check that aV is unchanged! - - if(.NOT.Identical_(aV,aVExactCopy,1e-5)) then - call die(myname_,"aV has been unexpectedly altered!!!") - endif - - call clean(aVExactCopy) - -end subroutine testaV_ - -!::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: -!:::::TEST FOR INDEXIA AND GETILIST:::::::::::::::::::::::::::::::::::::: -!::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: - - subroutine IndexTest_(aV,identifier,device) - - use m_AttrVect, only: AttrVect, nIattr, nRattr,getIList, getRList,indexIa,indexRA - use m_List, only: List_allocated => allocated - use m_String, only: String - use m_String, only: StringToChar => toChar - use m_String, only: String_clean => clean - use m_stdio - use m_die - - implicit none - - type(AttrVect), intent(in) :: aV - character(len=*), intent(in) :: identifier - integer, intent(in) :: device - - character(len=*),parameter :: myname_=myname//'::IndexTest_' - type(String) :: ItemStr - integer :: i,j,k,ierr - - if(nIAttr(aV)>0) then - write(device,*) identifier, ":: Testing indexIA and getIList::" - else - if(List_allocated(aV%iList)) then - call die(myname_,"iList has been allocated, :& - &but there are no atttributes. :& - &Please do not initialize a blank list.") - end if - if(associated(aV%iAttr)) then - if(size(aV%iAttr,1) /= 0) then - call die(myname_,"iAttr contains no attributes, & - &yet its size /= 0",size(aV%iAttr,1)) - endif - endif - end if - - do i=1,nIAttr(aV) - - call getIList(ItemStr,i,aV) - j = indexIA(aV,StringToChar(ItemStr)) - if(i/=j) call die(myname_,"Function indexIA failed!") - write(device,*) identifier, & - ":: aV Index = ", j, & - ":: Attribute Name = ", StringToChar(ItemStr) - call String_clean(ItemStr) - - enddo - - if(nRAttr(aV)>0) then - write(device,*) identifier, ":: Testing indexRA and getRList::" - else - if(List_allocated(aV%rList)) then - call die(myname_,"rList has been allocated, :& - &but there are no atttributes. :& - &Please do not initialize a blank list.") - end if - if(associated(aV%rAttr)) then - if(size(aV%rAttr,1) /= 0) then - call die(myname_,"rAttr contains no attributes, & - &yet its size /= 0",size(aV%rAttr,1)) - endif - endif - end if - - do i=1,nRAttr(aV) - - call getRList(ItemStr,i,aV) - j = indexRA(aV,StringToChar(ItemStr)) - if(i/=j) call die(myname_,"Function indexIA failed!") - write(device,*) identifier, & - "::aV Index = ", j, & - "::Attribute Name = ", StringToChar(ItemStr) - call String_clean(ItemStr) - - enddo - - end subroutine IndexTest_ - -!::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::! -!:::::TEST FOR SORT AND PERMUTE:::::::::::::::::::::::::::::::::::::::::! -!::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::! - -! NOTE: THIS IS NOT A CHECK FOR CORRECTNESS, JUST A CHECK FOR CONSISTENCY - - subroutine SortPermuteTest_(aV,identifier,device) - - use m_AttrVect - use m_stdio - use m_die - - implicit none - - type(AttrVect), intent(in) :: aV - character(len=*), intent(in) :: identifier - integer, intent(in) :: device - - character(len=*),parameter :: myname_=myname//'::SortPermuteTest_' - type(AttrVect) :: AVCOPY1, AVCOPY2 - logical,dimension(:), pointer :: descend - integer,dimension(:), pointer :: perm - integer :: i,j,k,ierr - real :: r - - write(device,*) identifier, ":: Testing Sort and Permute" - - call init(aV=AVCOPY1,bV=aV,lsize=100) - call init(av=AVCOPY2,bV=aV,lsize=100) - - if( (nIAttr(AVCOPY1)>0) .or. (nRAttr(AVCOPY1)>0) ) then - - if(nIAttr(AVCOPY1)>0) then - - allocate(descend(nIAttr(AVCOPY1)),stat=ierr) - if(ierr /= 0) call die(myname_,"allocate(descend)") - - call zero(AVCOPY1) - call zero(AVCOPY2) - - k=0 - do i=1,nIAttr(AVCOPY1) - do j=1,lsize(AVCOPY1) - k=k+1 - AVCOPY1%iAttr(i,j) = k - AVCOPY2%iAttr(i,j) = k - enddo - enddo - - descend=.true. - call Sort(aV=AVCOPY1,key_list=AVCOPY1%iList,perm=perm,descend=descend) - call Permute(aV=AVCOPY1,perm=perm) - - call SortPermute(aV=AVCOPY2,key_list=AVCOPY2%iList,descend=descend) - - do i=1,nIAttr(AVCOPY1) - do j=1,lsize(AVCOPY1) - if(AVCOPY1%iAttr(i,j) /= AVCOPY2%iAttr(i,j)) then - call die(myname_,"Sort Testing FAILED!") - endif - enddo - enddo - - write(device,*) identifier, ":: INTEGER AV IN DESCENDING ORDER:: ", & - AVCOPY1%iAttr(1,1:5) - - deallocate(perm,stat=ierr) - if(ierr /= 0) call die(myname_,"deallocate(perm)") - - deallocate(descend,stat=ierr) - if(ierr /= 0) call die(myname_,"deallocate(descend)") - - endif - - if(nRAttr(AVCOPY1)>0) then - - allocate(descend(nRAttr(AVCOPY1)),stat=ierr) - if(ierr /= 0) call die(myname_,"allocate(descend)") - - call zero(AVCOPY1) - call zero(AVCOPY2) - - r=0. - do i=1,nRAttr(AVCOPY1) - do j=1,lsize(AVCOPY1) - r=r+1.29 - AVCOPY1%rAttr(i,j) = r - AVCOPY2%rAttr(i,j) = r - enddo - enddo - - descend=.true. - call Sort(aV=AVCOPY1,key_list=AVCOPY1%rList,perm=perm,descend=descend) - call Permute(aV=AVCOPY1,perm=perm) - - call SortPermute(aV=AVCOPY2,key_list=AVCOPY2%rList,descend=descend) - - do i=1,nRAttr(AVCOPY1) - do j=1,lsize(AVCOPY1) - if(AVCOPY1%rAttr(i,j) /= AVCOPY2%rAttr(i,j)) then - call die(myname_,"Sort Testing FAILED!") - endif - enddo - enddo - - write(device,*) identifier, ":: REAL AV IN DESCENDING ORDER:: ", & - AVCOPY1%rAttr(1,1:5) - - deallocate(perm,stat=ierr) - if(ierr /= 0) call die(myname_,"deallocate(perm)") - - deallocate(descend,stat=ierr) - if(ierr /= 0) call die(myname_,"deallocate(descend)") - - endif - else - write(device,*) identifier, ":: NOT TESTING SORTING AND PERMUTING. CONSULT & - &SOURCE CODE TO ENABLE TESTING." - endif - - call clean(AVCOPY1) - call clean(AVCOPY2) - - end subroutine SortPermuteTest_ - -!::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::! -!:::::TEST FOR COPY AND SHAREDATTRINDEXLIST:::::::::::::::::::::::::::::! -!::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::! - -! NOTE: SO FOR ONLY TESTING SHAREDATTRINDEX for reals - - subroutine CopyTest_(aV,identifier,device) - - use m_AttrVect - use m_List, only : List - use m_List, only : List_init => init - use m_List, only : List_copy => copy - use m_List, only : List_append => append - use m_List, only : ListexportToChar => exportToChar - use m_List, only : List_clean => clean - use m_String, only : String - use m_String, only : StringToChar => toChar - use m_String, only : String_clean => clean - use m_stdio - use m_die - - implicit none - - type(AttrVect), intent(in) :: aV - character(len=*), intent(in) :: identifier - integer, intent(in) :: device - - character(len=*),parameter :: myname_=myname//'::CopyTest_' - type(String) :: ItemStr1, ItemStr2 - type(List) :: OneIList, HalfIList, FullIList - type(List) :: OneRList, HalfRList, FullRList - type(AttrVect) :: aVExactCopy, aVPartialCopy, aVOtherCopy - type(AttrVect) :: HalfAV - integer,dimension(:), pointer :: Indices1, Indices2 - integer :: NumShared - integer :: i,j,k,ierr - - if( (nIAttr(aV)>0) .and. (nRAttr(aV)>0) ) then - - !:::INITIALIZE LISTS FOR USE IN COPY TESTS:::! - do i=1,nIAttr(aV) - - call getIList(ItemStr1,i,aV) - - if(i==1) then - call List_init(HalfIList,ItemStr1) - call List_init(FullIList,ItemStr1) - else - if(mod(i,2) == 0) then ! if EVEN - call List_init(OneIList,'REPLACE_'//ACHAR(64+i)) - call List_append(FullIList,OneIList) - call List_clean(OneIList) - else ! if ODD - call List_init(OneIList,ItemStr1) - call List_append(HalfIList,OneIList) - call List_append(FullIList,OneIList) - call List_clean(OneIList) - endif - endif - - call String_clean(ItemStr1) - - enddo - - do i=1,nRAttr(aV) - - call getRList(ItemStr1,i,aV) - - if(i==1) then - call List_init(OneRList,'REPLACE_'//ACHAR(64+i)) - call List_copy(FullRList,OneRList) - call List_clean(OneRList) - else - if(mod(i,2) == 0) then ! IF EVEN - call List_init(OneRList,ItemStr1) - if(i==2) then - call List_init(HalfRList,ItemStr1) - else - call List_append(HalfRList,OneRList) - endif - call List_append(FullRList,OneRList) - call List_clean(OneRList) - else ! IF ODD - call List_init(OneRList,'REPLACE_'//ACHAR(64+i)) - call List_append(FullRList,OneRList) - call List_clean(OneRList) - endif - endif - - call String_clean(ItemStr1) - - enddo - - write(device,*) identifier, ":: Testing Copy and SharedAttrIndexList ::" - write(device,*) identifier, ":: FIRST AV ATTRIBUTES::", & - "IATTR = ", exportIListToChar(aV), & - " RATTR = ", exportRListToChar(aV) - call init(aVExactCopy,aV,lsize(aV)) - write(device,*) identifier, ":: SECOND AV ATTRIBUTES::", & - "IATTR = ", exportIListToChar(aVExactCopy), & - " RATTR = ", exportRListToChar(aVExactCopy) - call zero(aVExactCopy) - call copy(aVin=aV, aVout=aVExactCopy) - ! call copy(aVin=aV,rList=exportRListToChar(aV), & - ! iList=exportIListToChar(aV),aVout=aVExactCopy) - call SharedAttrIndexList(aV,aVExactCopy,"REAL ", & - NumShared,Indices1,Indices2) - write(device,*) identifier, ":: Indices1 :: Indices2 :: & - &Attribute1 :: Attribute2" - do i=1,NumShared - call getRList(ItemStr1,Indices1(i),aV) - call getRList(ItemStr2,Indices2(i),aVExactCopy) - write(device,*) identifier,":: ", Indices1(i), "::", Indices2(i), & - "::", StringToChar(ItemStr1), "::", StringToChar(ItemStr2) - call String_clean(ItemStr1) - call String_clean(ItemStr2) - enddo - - do i=1,NumShared - do j=1,lsize(aV) - if(aV%rAttr(Indices1(i),j) /= & - aVExactCopy%rAttr(Indices2(i),j)) then - call die(myname_,"Copy function is MALFUNCTIONING", ierr) - endif - enddo - enddo - - deallocate(Indices1,Indices2,stat=ierr) - if(ierr/=0) call die(myname_,"deallocate(Indices1,Indices2)",ierr) - -!::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: - - call init(aVPartialCopy,aV,lsize(aV)) - write(device,*) identifier, ":: FIRST AV ATTRIBUTES::", & - "IATTR = ", exportIListToChar(aVPartialCopy), & - " RATTR = ", exportRListToChar(aVPartialCopy) - call zero(aVPartialCopy) - call copy(aVin=aV,rList=ListexportToChar(HalfRList), & - iList=ListexportToChar(HalfIList),aVout=aVPartialCopy) - call init(aV=HalfAV,iList=HalfIList,rList=HalfRList,lsize=1) - write(device,*) identifier, ":: SECOND AV ATTRIBUTES::", & - "IATTR = ", exportIListToChar(HalfAV), & - " RATTR = ", exportRListToChar(HalfAV) - call SharedAttrIndexList(aV,HalfAV,"REAL ", & - NumShared,Indices1,Indices2) - write(device,*) identifier, ":: Indices1 :: Indices2 :: & - &Attribute1 :: Attribute2" - do i=1,NumShared - call getRList(ItemStr1,Indices1(i),aV) - call getRList(ItemStr2,Indices2(i),HalfAV) - write(device,*) identifier,":: ", Indices1(i), "::", Indices2(i), & - "::", StringToChar(ItemStr1), "::", StringToChar(ItemStr2) - call String_clean(ItemStr1) - call String_clean(ItemStr2) - enddo - - do i=1,NumShared - do j=1,lsize(aV) - if(aV%rAttr(Indices1(i),j) /= & - aVPartialCopy%rAttr(Indices1(i),j)) then - call die(myname_,"Copy function is MALFUNCTIONING", ierr) - endif - enddo - enddo - - call List_clean(HalfIList) - call List_clean(HalfRList) - - deallocate(Indices1,Indices2,stat=ierr) - if(ierr/=0) call die(myname_,"deallocate(Indices1,Indices2)",ierr) - -!::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: - - call init(aVOtherCopy,FullIList,FullRList,lsize(aV)) - write(device,*) identifier, ":: FIRST AV ATTRIBUTES::", & - "IATTR = ", exportIListToChar(aV), & - " RATTR = ", exportRListToChar(aV) - write(device,*) identifier, ":: SECOND AV ATTRIBUTES::", & - "IATTR = ", exportIListToChar(aVOtherCopy), & - " RATTR = ", exportRListToChar(aVOtherCopy) - call zero(aVOtherCopy) - call copy(aV,rList=exportRListToChar(aV), & - TrList=ListexportToChar(FullRList), & - iList=exportIListToChar(aV), & - TiList=ListexportToChar(FullIList), & - aVout=aVOtherCopy) - call SharedAttrIndexList(aV,aVOtherCopy,"REAL", & - NumShared,Indices1,Indices2) - write(device,*) identifier, ":: Indices1 :: Indices2 :: & - &Attribute1 :: Attribute2" - do i=1,NumShared - call getRList(ItemStr1,Indices1(i),aV) - call getRList(ItemStr2,Indices2(i),aVOtherCopy) - write(device,*) identifier,":: ", Indices1(i), "::", Indices2(i), & - "::", StringToChar(ItemStr1), "::", StringToChar(ItemStr2) - call String_clean(ItemStr1) - call String_clean(ItemStr2) - enddo - - do i=1,NumShared - do j=1,lsize(aV) - if(aV%rAttr(Indices1(i),j) /= & - aVOtherCopy%rAttr(Indices2(i),j)) then - write(device,*) identifier,Indices1(i),Indices2(i), j - call die(myname_,"Copy function is MALFUNCTIONING", ierr) - endif - enddo - enddo - - call List_clean(FullIList) - call List_clean(FullRList) - - deallocate(Indices1,Indices2,stat=ierr) - if(ierr/=0) call die(myname_,"deallocate(Indices1,Indices2)",ierr) - - call clean(aVExactCopy) - call clean(aVPartialCopy) - call clean(aVOtherCopy) - call clean(HalfAV) - - else - - write(device,*) identifier, & - ":: NOT Testing Copy and SharedAttrIndexList ::", & - ":: Consult m_MCTTest.F90 to enable this function::" - endif - - end subroutine CopyTest_ - -!::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::! -!:::::TEST FOR EXPORT AND IMPORT FUNCTIONS:::::::::::::::::::::::::::::::! -!::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::! - - subroutine ImportExportTest_(aV,identifier,device) - - use m_AttrVect - use m_List, only : List - use m_List, only : List_identical => identical - use m_List, only : List_get => get - use m_List, only : List_clean => clean - use m_String, only : String - use m_String, only : StringToChar => toChar - use m_String, only : String_clean => clean - use m_stdio - use m_die - - use m_realkinds, only : FP - - implicit none - - type(AttrVect), intent(in) :: aV - character(len=*), intent(in) :: identifier - integer, intent(in) :: device - - character(len=*),parameter :: myname_=myname//'::ImportExportTest_' - type(AttrVect) :: importAV - type(List) :: OutIList, OutRList - type(String) :: ItemStr - integer,dimension(:),pointer :: OutIVect - real(FP), dimension(:),pointer :: OutRVect - integer :: exportsize - integer :: i,j,k,ierr - - write(device,*) identifier, ":: Testing import and export functions" - - if(nIAttr(aV)>0) then - - call exportIList(aV=aV,outIList=outIList) - - if(.NOT. List_identical(aV%iList,outIList)) then - call die(myname_, "Function exportIList failed!") - endif - - call List_get(ItemStr=ItemStr,ith=nIAttr(aV),aList=aV%iList) - - allocate(outIVect(lsize(aV)),stat=ierr) - if(ierr/=0) call die(myname_,"allocate(outIVect)") - - call exportIAttr(aV=aV,AttrTag=StringToChar(ItemStr), & - outVect=OutIVect,lsize=exportsize) - - if(exportsize /= lsize(aV)) then - call die(myname_,"(exportsize /= lsize(aV))") - endif - - do i=1,exportsize - if(aV%iAttr(nIAttr(aV),i) /= outIVect(i)) then - call die(myname_,"Function exportIAttr failed!") - endif - enddo - - call init(aV=importAV,iList=exportIListToChar(aV),lsize=exportsize) - call zero(importAV) - - call importIAttr(aV=importAV,AttrTag=StringToChar(ItemStr), & - inVect=outIVect,lsize=exportsize) - - j=indexIA(importAV,StringToChar(ItemStr)) - if(j<=0) call die(myname_,"indexIA(importAV,StringToChar(ItemStr))") - do i=1,exportsize - if(importAV%iAttr(j,i) /= outIVect(i)) then - call die(myname_,"Function importIAttr failed!") - endif - enddo - - call clean(importAV) - call List_clean(outIList) - call String_clean(ItemStr) - - deallocate(outIVect,stat=ierr) - if(ierr/=0) call die(myname_,"deallocate(outIVect)") - - endif - - if(nRAttr(aV)>0) then - - call exportRList(aV=aV,outRList=outRList) - - if(.NOT. List_identical(aV%rList,outRList)) then - call die(myname_, "Function exportRList failed!") - endif - - call List_get(ItemStr=ItemStr,ith=nRAttr(aV),aList=aV%rList) - - allocate(outRVect(lsize(aV)),stat=ierr) - if(ierr/=0) call die(myname_,"allocate(outRVect)") - - call exportRAttr(aV=aV,AttrTag=StringToChar(ItemStr), & - outVect=OutRVect,lsize=exportsize) - - if(exportsize /= lsize(aV)) then - call die(myname_,"(exportsize /= lsize(aV))") - endif - - do i=1,exportsize - if(aV%rAttr(nRAttr(aV),i) /= outRVect(i)) then - call die(myname_,"Function exportRAttr failed!") - endif - enddo - - call init(aV=importAV,rList=exportRListToChar(aV),lsize=exportsize) - call zero(importAV) - - call importRAttr(aV=importAV,AttrTag=StringToChar(ItemStr), & - inVect=outRVect,lsize=exportsize) - - j=indexRA(importAV,StringToChar(ItemStr)) - if(j<=0) call die(myname_,"indexRA(importAV,StringToChar(ItemStr))") - do i=1,exportsize - if(importAV%rAttr(j,i) /= outRVect(i)) then - call die(myname_,"Function importRAttr failed!") - endif - enddo - - call clean(importAV) - call List_clean(outRList) - call String_clean(ItemStr) - - deallocate(outRVect,stat=ierr) - if(ierr/=0) call die(myname_,"deallocate(outRVect)") - - endif - - end subroutine ImportExportTest_ - - subroutine ReduceTest_(aV,identifier,device) - - use m_AttrVectReduce - use m_AttrVect - use m_List, only : ListExportToChar => ExportToChar - use m_stdio - use m_die - - implicit none - - type(AttrVect), intent(in) :: aV - character(len=*), intent(in) :: identifier - integer, intent(in) :: device - - character(len=*),parameter :: myname_=myname//'::ReduceTest_' - integer :: i,j,k,ierr - type(AttrVect) :: reducedAVsum, reducedAVmin, reducedAVmax - type(AttrVect) :: reducedAVRsum, reducedAVRmin, reducedAVRmax - - if( (nIAttr(aV)==0).and.(nRAttr(aV)>0) ) then - - call LocalReduce(aV,reducedAVsum,AttrVectSUM) - call LocalReduce(aV,reducedAVmin,AttrVectMIN) - call LocalReduce(aV,reducedAVmax,AttrVectMAX) - - call LocalReduceRAttr(aV,reducedAVRsum,AttrVectSUM) - call LocalReduceRAttr(aV,reducedAVRmin,AttrVectMIN) - call LocalReduceRAttr(aV,reducedAVRmax,AttrVectMAX) - - if(.NOT.Identical_(reducedAVsum,reducedAVRsum,1e-4)) then - call die(myname_,"LocalReduce -SUM- functions produced inconsistent & - &results!") - endif - - if(.NOT.Identical_(reducedAVmin,reducedAVRmin,1e-4)) then - call die(myname_,"LocalReduce -MIN- functions produced inconsistent & - &results!") - endif - - if(.NOT.Identical_(reducedAVmax,reducedAVRmax,1e-4)) then - call die(myname_,"LocalReduce -MAX- functions produced inconsistent & - &results!") - endif - - write(device,*) identifier,":: RESULTS OF ATTRVECT LOCAL REDUCE :: & - &(Name, rList, Values)" - write(device,*) identifier,":: REDUCEDAVSUM = ", & - ListExportToChar(reducedAVsum%rList), & - reducedAVsum%rAttr - write(device,*) identifier,":: REDUCEDAVMIN = ", & - ListExportToChar(reducedAVmin%rList), & - reducedAVmin%rAttr - write(device,*) identifier,":: REDUCEDAVMAX = ", & - ListExportToChar(reducedAVmax%rList), & - reducedAVmax%rAttr - - call clean(reducedAVsum) - call clean(reducedAVmin) - call clean(reducedAVmax) - call clean(reducedAVRsum) - call clean(reducedAVRmin) - call clean(reducedAVRmax) - - else - - write(device,*) identifier,":: NOT TESTING LOCAL REDUCE. & - &PLEASE CONSULT SOURCE CODE." - - endif - - end subroutine ReduceTest_ - - logical function Identical_(aV1,aV2,Range) - - use m_AttrVect - use m_stdio - use m_die - - use m_realkinds, only : FP - - implicit none - - type(AttrVect), intent(in) :: aV1 - type(AttrVect), intent(in) :: aV2 - real, optional, intent(in) :: Range - - integer :: i,j,k,AVSize - - Identical_=.true. - - AVSize = lsize(aV1) - - if(lsize(aV1) /= lsize(aV2)) then - AVSize=0 - Identical_=.false. - endif - - do i=1,AVSize - do j=1,nIAttr(aV1) - if(AV1%iAttr(j,i) /= AV2%iAttr(j,i)) then - Identical_=.false. - endif - enddo - enddo - - if(present(Range)) then - - do i=1,AVSize - do j=1,nRAttr(aV1) - if( ABS(AV1%rAttr(j,i)-AV2%rAttr(j,i)) > Range ) then - Identical_=.false. - endif - enddo - enddo - - else - - do i=1,AVSize - do j=1,nRAttr(aV1) - if(AV1%rAttr(j,i) /= AV2%rAttr(j,i)) then - Identical_=.false. - endif - enddo - enddo - - endif - - end function Identical_ - -end module m_AVTEST diff --git a/cesm/models/utils/mct/testsystem/testall/m_GGRIDTEST.F90 b/cesm/models/utils/mct/testsystem/testall/m_GGRIDTEST.F90 deleted file mode 100644 index a400203..0000000 --- a/cesm/models/utils/mct/testsystem/testall/m_GGRIDTEST.F90 +++ /dev/null @@ -1,636 +0,0 @@ -! -! !INTERFACE: - - module m_GGRIDTEST -! -! !USES: -! - implicit none - - private ! except - -! !PUBLIC MEMBER FUNCTIONS: - - public :: testall - public :: IndexAttr - public :: SortPermute - public :: ImportExport - public :: Identical - - interface testall - module procedure testGGrid_ - end interface - interface IndexAttr - module procedure IndexTest_ - end interface - interface SortPermute - module procedure SortPermuteTest_ - end interface - interface ImportExport - module procedure ImportExportTest_ - end interface - interface Identical - module procedure Identical_ - end interface - -! !REVISION HISTORY: -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname='m_GGridTest' - - contains - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: testGGRID_ - Test the functions in the GeneralGrid module -! -! !DESCRIPTION: -! This routine writes diagnostic information about the input -! {\tt GeneralGrid}. Each line of the output will be preceded by the -! character argument {\tt identifier}. The output device is specified -! by the integer argument {\tt device}. -! -! !INTERFACE: - - subroutine testGGrid_(GGrid, identifier, device) - -! -! !USES: -! - use m_GeneralGrid, only: GeneralGrid,init,clean,dims,lsize ! Use all GeneralGrid routines - use m_List, only : ListExportToChar => exportToChar - use m_List, only : List_allocated => allocated - use m_AttrVect, only : AttrVect_copy => copy - use m_stdio - use m_die - - implicit none - -! !INPUT PARAMETERS: - - type(GeneralGrid), intent(in) :: GGrid - character(len=*), intent(in) :: identifier - integer, intent(in) :: device - -! !REVISION HISTORY: -! 23Sep02 - E.T. Ong - initial prototype. -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::GGridtest_' - type(GeneralGrid) :: GGridExactCopy1, GGridExactCopy2 - integer :: i,j,k - logical :: calledinitl_ - -!::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: -!:::::WRITE OUT INFO ABOUT THE ATTRVECT::::::::::::::::::::::::::::::::: -!::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: - - write(device,*) identifier, ":: TYPE CHECK" - - if(List_allocated(GGrid%coordinate_list)) then - write(device,*) identifier, ":: COORDINATE_LIST = ", & - ListExportToChar(GGrid%coordinate_list) - else - call die(myname_,"COORDINATE_LIST IS NOT INITIALIZED!") - endif - - if(List_allocated(GGrid%coordinate_sort_order)) then - write(device,*) identifier, ":: COORDINATE_SORT_ORDER = ", & - ListExportToChar(GGrid%coordinate_sort_order) - else - write(device,*) identifier, ":: COORDINATE_SORT_ORDER NOT INITIALIZED" - endif - - if(associated(GGrid%descend)) then - write(device,*) identifier, ":: DESCEND = ", & - size(GGrid%descend), GGrid%descend - else - write(device,*) identifier, ":: DESCEND NOT ASSOCIATED" - endif - - if(List_allocated(GGrid%weight_list)) then - write(device,*) identifier, ":: WEIGHT_LIST = ", & - ListExportToChar(GGrid%weight_list) - else - write(device,*) identifier, ":: WEIGHT_LIST NOT INITIALIZED" - endif - - if(List_allocated(GGrid%other_list)) then - write(device,*) identifier, ":: OTHER_LIST = ", & - ListExportToChar(GGrid%other_list) - else - write(device,*) identifier, ":: OTHER_LIST NOT INITIALIZED" - endif - - if(List_allocated(GGrid%index_list)) then - write(device,*) identifier, ":: INDEX_LIST = ", & - ListExportToChar(GGrid%index_list) - else - write(device,*) identifier, ":: INDEX_LIST NOT INITIALIZED" - endif - - if(List_allocated(GGrid%data%iList)) then - write(device,*) identifier, ":: DATA%ILIST = ", & - ListExportToChar(GGrid%data%iList) - else - write(device,*) identifier, ":: DATA%ILIST NOT INITIALIZED" - endif - - if(List_allocated(GGrid%data%rList)) then - write(device,*) identifier, ":: DATA%RLIST = ", & - ListExportToChar(GGrid%data%rList) - else - write(device,*) identifier, ":: DATA%RLIST NOT INITIALIZED" - endif - - write(device,*) identifier, ":: DIMS = ", dims(GGrid) - write(device,*) identifier, ":: LSIZE = ", lsize(GGrid) - - call init(GGridExactCopy1,GGrid,lsize(GGrid)) - call AttrVect_copy(aVin=GGrid%data,aVout=GGridExactCopy1%data) - - calledinitl_=.false. - - if( ((((List_allocated(GGrid%coordinate_sort_order).AND.& - List_allocated(GGrid%weight_list)).AND.& - List_allocated(GGrid%other_list)).AND.& - List_allocated(GGrid%index_list)).AND.& - ASSOCIATED(GGrid%descend)) ) then - calledinitl_=.true. - call init(GGrid=GGridExactCopy2,& - CoordList=GGrid%coordinate_list, & - CoordSortOrder=GGrid%coordinate_sort_order, & - descend=GGrid%descend, & - WeightList=GGrid%weight_list, & - OtherList=GGrid%other_list, & - IndexList=GGrid%index_list, & - lsize=lsize(GGrid)) - call AttrVect_copy(aVin=GGrid%data,aVout=GGridExactCopy2%data) - else - write(device,*) identifier, ":: NOT TESTING INIL_. PLEASE & - &CONSULT SOURCE CODE." - endif - -!::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: -!:::::TESTING INDEXIA AND GETILIST:::::::::::::::::::::::::::::::::::::: -!::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: - - call IndexTest_(GGrid,identifier,device) - - -!::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::! -!:::::TESTING SORT AND PERMUTE:::::::::::::::::::::::::::::::::::::::::! -!::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::! - -! NOTE: THIS IS NOT A CHECK FOR CORRECTNESS, JUST A CHECK FOR CONSISTENCY - - call SortPermuteTest_(GGrid,identifier,device) - -!::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::! -!:::::TESTING EXPORT AND IMPORT FUNCTIONS::::::::::::::::::::::::::::::::! -!::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::! - - call ImportExportTest_(GGrid,identifier,device) - - ! Check that GGrid is unchanged! - - if(.NOT.Identical_(GGrid,GGridExactCopy1,1e-5)) then - call die(myname_,"GGrid has been unexpectedly altered!!!") - endif - - call clean(GGridExactCopy1) - - if(calledinitl_) then - if(.NOT.Identical_(GGrid,GGridExactCopy2,1e-5)) then - call die(myname_,"GGrid has been unexpectedly altered!!!") - endif - call clean(GGridExactCopy2) - endif - -end subroutine testGGrid_ - -!::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: -!:::::TEST FOR INDEXIA AND GETILIST:::::::::::::::::::::::::::::::::::::: -!::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: - - subroutine IndexTest_(GGrid,identifier,device) - - use m_GeneralGrid, only: GeneralGrid,indexIA,indexRA - use m_AttrVect, only : getIList, getRList - use m_AttrVect, only : nIAttr,nRAttr - use m_List, only: List_allocated => allocated - use m_String, only: String - use m_String, only: StringToChar => toChar - use m_String, only: String_clean => clean - use m_stdio - use m_die - - implicit none - - type(GeneralGrid), intent(in) :: GGrid - character(len=*), intent(in) :: identifier - integer, intent(in) :: device - - character(len=*),parameter :: myname_=myname//'::IndexTest_' - type(String) :: ItemStr - integer :: i,j,k,ierr - - if(nIAttr(GGrid%data)>0) then - write(device,*) identifier, ":: Testing indexIA and getIList::" - else - if(List_allocated(GGrid%data%iList)) then - call die(myname_,"iList has been allocated, :& - &but there are no atttributes. :& - &Please do not initialize a blank list.") - end if - if(associated(GGrid%data%iAttr)) then - if(size(GGrid%data%iAttr,1) /= 0) then - call die(myname_,"iAttr contains no attributes, & - &yet its size /= 0",size(GGrid%data%iAttr,1)) - endif - endif - end if - - do i=1,nIAttr(GGrid%data) - - call getIList(ItemStr,i,GGrid%data) - j = indexIA(GGrid,StringToChar(ItemStr)) - if(i/=j) call die(myname_,"Function indexIA failed!") - write(device,*) identifier, & - ":: GGrid Index = ", j, & - ":: Attribute Name = ", StringToChar(ItemStr) - call String_clean(ItemStr) - - enddo - - if(nRAttr(GGrid%data)>0) then - write(device,*) identifier, ":: Testing indexRA and getRList::" - else - if(List_allocated(GGrid%data%rList)) then - call die(myname_,"rList has been allocated, :& - &but there are no atttributes. :& - &Please do not initialize a blank list.") - end if - if(associated(GGrid%data%rAttr)) then - if(size(GGrid%data%rAttr,1) /= 0) then - call die(myname_,"rAttr contains no attributes, & - &yet its size /= 0",size(GGrid%data%rAttr,1)) - endif - endif - end if - - do i=1,nRAttr(GGrid%data) - - call getRList(ItemStr,i,GGrid%data) - j = indexRA(GGrid,StringToChar(ItemStr)) - if(i/=j) call die(myname_,"Function indexIA failed!") - write(device,*) identifier, & - "::GGrid Index = ", j, & - "::Attribute Name = ", StringToChar(ItemStr) - call String_clean(ItemStr) - - enddo - - end subroutine IndexTest_ - -!::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::! -!:::::TEST FOR SORT AND PERMUTE:::::::::::::::::::::::::::::::::::::::::! -!::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::! - -! NOTE: THIS IS NOT A CHECK FOR CORRECTNESS, JUST A CHECK FOR CONSISTENCY - - subroutine SortPermuteTest_(GGrid,identifier,device) - - use m_GeneralGrid - use m_AttrVect, only: nIAttr, nRAttr, Zero - use m_stdio - use m_die - - use m_realkinds, only : FP - - implicit none - - type(GeneralGrid), intent(in) :: GGrid - character(len=*), intent(in) :: identifier - integer, intent(in) :: device - - character(len=*),parameter :: myname_=myname//'::SortPermuteTest_' - type(GeneralGrid) :: GGRIDCOPY1, GGRIDCOPY2 - logical,dimension(:), pointer :: descend - integer,dimension(:), pointer :: perm - integer :: i,j,k,ierr - real :: r - - if( associated(GGrid%descend) ) then - - write(device,*) identifier, ":: Testing Sort and Permute" - - call init(oGGrid=GGRIDCOPY1,iGGrid=GGrid,lsize=100) - call init(oGGrid=GGRIDCOPY2,iGGrid=GGrid,lsize=100) - - call Zero(GGRIDCOPY1%data) - call Zero(GGRIDCOPY2%data) - - if(nIAttr(GGRIDCOPY1%data)>0) then - - k=0 - do i=1,nIAttr(GGRIDCOPY1%data) - do j=1,lsize(GGRIDCOPY1) - k=k+1 - GGRIDCOPY1%data%iAttr(i,j) = k - GGRIDCOPY2%data%iAttr(i,j) = k - enddo - enddo - endif - if(nRAttr(GGRIDCOPY1%data)>0) then - - r=0. - do i=1,nRAttr(GGRIDCOPY1%data) - do j=1,lsize(GGRIDCOPY1) - r=r+1.29 - GGRIDCOPY1%data%rAttr(i,j) = r - GGRIDCOPY2%data%rAttr(i,j) = r - enddo - enddo - endif - - call Sort(GGrid=GGRIDCOPY1,key_List=GGRIDCOPY1%coordinate_sort_order,perm=perm,descend=GGrid%descend) - call Permute(GGrid=GGRIDCOPY1,perm=perm) - - call SortPermute(GGrid=GGRIDCOPY2) - - deallocate(perm,stat=ierr) - if(ierr /= 0) call die(myname_,"deallocate(perm)") - - if(nIAttr(GGRIDCOPY1%data)>0) then - - do i=1,nIAttr(GGRIDCOPY1%data) - do j=1,lsize(GGRIDCOPY1) - if(GGRIDCOPY1%data%iAttr(i,j) /= GGRIDCOPY2%data%iAttr(i,j)) then - call die(myname_,"Sort Testing FAILED!") - endif - enddo - enddo - - write(device,*) identifier, ":: INTEGER GGRID%DATA IN ", GGrid%descend, & - " ORDER:: ", GGRIDCOPY1%data%iAttr(1,1:5) - - endif - - if(nRAttr(GGRIDCOPY1%data)>0) then - - do i=1,nRAttr(GGRIDCOPY1%data) - do j=1,lsize(GGRIDCOPY1) - if(GGRIDCOPY1%data%rAttr(i,j) /= GGRIDCOPY2%data%rAttr(i,j)) then - call die(myname_,"Sort Testing FAILED!") - endif - enddo - enddo - - write(device,*) identifier, ":: REAL GGRID%DATA IN ", GGrid%descend, & - " ORDER:: ", GGRIDCOPY1%data%rAttr(1,1:5) - - endif - - call clean(GGRIDCOPY1) - call clean(GGRIDCOPY2) - else - write(device,*) identifier, ":: NOT TESTING SORTING AND PERMUTING. CONSULT & - &SOURCE CODE TO ENABLE TESTING." - endif - - end subroutine SortPermuteTest_ - -!::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::! -!:::::TEST FOR EXPORT AND IMPORT FUNCTIONS:::::::::::::::::::::::::::::::! -!::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::! - - subroutine ImportExportTest_(GGrid,identifier,device) - - use m_GeneralGrid - use m_AttrVect, only : exportIList, exportRList - use m_AttrVect, only : AttrVect_zero => zero - use m_AttrVect, only : nIAttr, nRAttr - use m_List, only : List - use m_List, only : List_identical => identical - use m_List, only : List_get => get - use m_List, only : List_clean => clean - use m_String, only : String - use m_String, only : StringToChar => toChar - use m_String, only : String_clean => clean - use m_stdio - use m_die - - use m_realkinds, only : FP - - implicit none - - type(GeneralGrid), intent(in) :: GGrid - character(len=*), intent(in) :: identifier - integer, intent(in) :: device - - character(len=*),parameter :: myname_=myname//'::ImportExportTest_' - type(GeneralGrid) :: importGGrid - type(List) :: OutIList, OutRList - type(String) :: ItemStr - integer,dimension(:),pointer :: OutIVect - real(FP), dimension(:),pointer :: OutRVect - integer :: exportsize - integer :: i,j,k,ierr - - write(device,*) identifier, ":: Testing import and export functions" - - if(nIAttr(GGrid%data)>0) then - - call exportIList(aV=GGrid%data,outIList=outIList) - - if(.NOT. List_identical(GGrid%data%iList,outIList)) then - call die(myname_, "Function exportIList failed!") - endif - - call List_get(ItemStr=ItemStr,ith=nIAttr(GGrid%data),aList=GGrid%data%iList) - - allocate(outIVect(lsize(GGrid)),stat=ierr) - if(ierr/=0) call die(myname_,"allocate(outIVect)") - - call exportIAttr(GGrid=GGrid,AttrTag=StringToChar(ItemStr), & - outVect=OutIVect,lsize=exportsize) - - if(exportsize /= lsize(GGrid)) then - call die(myname_,"(exportsize /= lsize(GGrid))") - endif - - do i=1,exportsize - if(GGrid%data%iAttr(nIAttr(GGrid%data),i) /= outIVect(i)) then - call die(myname_,"Function exportIAttr failed!") - endif - enddo - - call init(oGGrid=importGGrid,iGGrid=GGrid,lsize=exportsize) - call AttrVect_zero(importGGrid%data) - - call importIAttr(GGrid=importGGrid,AttrTag=StringToChar(ItemStr), & - inVect=outIVect,lsize=exportsize) - - j=indexIA(importGGrid,StringToChar(ItemStr)) - if(j<=0) call die(myname_,"indexIA(importGGrid,StringToChar(ItemStr))") - do i=1,exportsize - if(importGGrid%data%iAttr(j,i) /= outIVect(i)) then - call die(myname_,"Function importIAttr failed!") - endif - enddo - - call clean(importGGrid) - call List_clean(outIList) - call String_clean(ItemStr) - - deallocate(outIVect,stat=ierr) - if(ierr/=0) call die(myname_,"deallocate(outIVect)") - - endif - - if(nRAttr(GGrid%data)>0) then - - call exportRList(aV=GGrid%data,outRList=outRList) - - if(.NOT. List_identical(GGrid%data%rList,outRList)) then - call die(myname_, "Function exportRList failed!") - endif - - call List_get(ItemStr=ItemStr,ith=nRAttr(GGrid%data),aList=GGrid%data%rList) - - allocate(outRVect(lsize(GGrid)),stat=ierr) - if(ierr/=0) call die(myname_,"allocate(outRVect)") - - call exportRAttr(GGrid=GGrid,AttrTag=StringToChar(ItemStr), & - outVect=OutRVect,lsize=exportsize) - - if(exportsize /= lsize(GGrid)) then - call die(myname_,"(exportsize /= lsize(GGrid))") - endif - - do i=1,exportsize - if(GGrid%data%rAttr(nRAttr(GGrid%data),i) /= outRVect(i)) then - call die(myname_,"Function exportRAttr failed!") - endif - enddo - - call init(oGGrid=importGGrid,iGGrid=GGrid,lsize=exportsize) - call AttrVect_zero(importGGrid%data) - - call importRAttr(GGrid=importGGrid,AttrTag=StringToChar(ItemStr), & - inVect=outRVect,lsize=exportsize) - - j=indexRA(importGGrid,StringToChar(ItemStr)) - if(j<=0) call die(myname_,"indexRA(importGGrid,StringToChar(ItemStr))") - do i=1,exportsize - if(importGGrid%data%rAttr(j,i) /= outRVect(i)) then - call die(myname_,"Function importRAttr failed!") - endif - enddo - - call clean(importGGrid) - call List_clean(outRList) - call String_clean(ItemStr) - - deallocate(outRVect,stat=ierr) - if(ierr/=0) call die(myname_,"deallocate(outRVect)") - - endif - - end subroutine ImportExportTest_ - - logical function Identical_(GGrid1,GGrid2,Range) - - use m_GeneralGrid, only: GeneralGrid - use m_AVTEST,only: AttrVect_identical => Identical - use m_List,only : List_allocated => allocated - use m_List,only : List_identical => identical - use m_stdio - use m_die - - use m_realkinds, only : FP - - implicit none - - type(GeneralGrid), intent(in) :: GGrid1 - type(GeneralGrid), intent(in) :: GGrid2 - real, optional, intent(in) :: Range - - integer :: i,j,k - - Identical_=.true. - - if(present(Range)) then - if(.NOT. AttrVect_identical(GGrid1%data,GGrid2%data,Range)) then - Identical_=.false. - endif - else - if(.NOT. AttrVect_identical(GGrid1%data,GGrid2%data)) then - Identical_=.false. - endif - endif - - if(.NOT. List_identical(GGrid1%coordinate_list, & - GGrid2%coordinate_list) ) then - Identical_=.false. - endif - - if( List_allocated(GGrid1%coordinate_sort_order) .or. & - List_allocated(GGrid2%coordinate_sort_order) ) then - if(.NOT. List_identical(GGrid1%coordinate_sort_order, & - GGrid2%coordinate_sort_order) ) then - Identical_=.false. - endif - endif - - if( List_allocated(GGrid1%weight_list) .or. & - List_allocated(GGrid2%weight_list) ) then - if(.NOT. List_identical(GGrid1%weight_list, & - GGrid2%weight_list) ) then - Identical_=.false. - endif - endif - - if( List_allocated(GGrid1%other_list) .or. & - List_allocated(GGrid2%other_list) ) then - if(.NOT. List_identical(GGrid1%other_list, & - GGrid2%other_list) ) then - Identical_=.false. - endif - endif - - if( List_allocated(GGrid1%index_list) .or. & - List_allocated(GGrid2%index_list) ) then - if(.NOT. List_identical(GGrid1%index_list, & - GGrid2%index_list) ) then - Identical_=.false. - endif - endif - - if(associated(GGrid1%descend) .and. & - associated(GGrid2%descend)) then - - if(size(GGrid1%descend) == size(GGrid2%descend)) then - do i=1,size(GGrid1%descend) - if(GGrid1%descend(i).neqv.GGrid2%descend(i)) then - Identical_=.false. - endif - enddo - else - Identical_=.false. - endif - - endif - - if((associated(GGrid1%descend).and..NOT.associated(GGrid2%descend)).or.& - (.NOT.associated(GGrid1%descend).and.associated(GGrid2%descend)))then - Identical_=.false. - endif - - end function Identical_ - - -end module m_GGRIDTEST diff --git a/cesm/models/utils/mct/testsystem/testall/m_GMAPTEST.F90 b/cesm/models/utils/mct/testsystem/testall/m_GMAPTEST.F90 deleted file mode 100644 index da42ec6..0000000 --- a/cesm/models/utils/mct/testsystem/testall/m_GMAPTEST.F90 +++ /dev/null @@ -1,160 +0,0 @@ -! -! !INTERFACE: - - module m_GMAPTEST -! -! !USES: -! - implicit none - - private ! except - -! !PUBLIC MEMBER FUNCTIONS: - - public :: testall - - interface testall - module procedure testGMap_ - end interface - - -! !REVISION HISTORY: -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname='m_GMAPTEST' - - contains - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: testGMap_ - Test the functions in the AttrVect module -! -! !DESCRIPTION: -! This routine writes diagnostic information about the input -! {\tt AttrVect}. Each line of the output will be preceded by the -! character argument {\tt identifier}. The output device is specified -! by the integer argument {\tt device}. -! -! !INTERFACE: - - subroutine testGMap_(GMap, identifier, mycomm, device) - -! -! !USES: -! - use m_GlobalMap ! Use all of MCTWorld - use m_GlobalToLocal,only : GlobalToLocalIndex - use m_stdio - use m_die - use m_mpif90 - - implicit none - -! !INPUT PARAMETERS: - - type(GlobalMap), intent(in) :: GMap - character(len=*), intent(in) :: identifier - integer, optional, intent(in) :: mycomm - integer, intent(in) :: device - -! !REVISION HISTORY: -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::testGMap_' - integer :: i,j,k,lower,upper - integer :: mySize,myProc,proc,ierr - - write(device,*) identifier, ":: TESTING GLOBALMAP ::" - - write(device,*) identifier, ":: TYPE CHECK:" - write(device,*) identifier, ":: comp_id = ", GMap%comp_id - write(device,*) identifier, ":: gsize = ", GMap%gsize - write(device,*) identifier, ":: lsize = ", GMap%lsize - - mySize = size(GMap%counts) - - if(mySize<=0) call die(myname_,"size(GMap%counts)<=0") - - if(size(GMap%counts) /= size(GMap%displs)) then - call die(myname_,"size(GMap%counts) /= size(GMap%displs)") - endif - - write(device,*) identifier, ":: counts = & - &(associated, size, counts) ", associated(GMap%counts), & - size(GMap%counts), GMap%counts - write(device,*) identifier, ":: displs = & - &(associated, size, displs) ", associated(GMap%displs), & - size(GMap%displs), GMap%displs - - write(device,*) identifier, ":: counts = ", & - GMap%counts - - write(device,*) identifier, ":: FUNCTION CHECK:" - write(device,*) identifier, ":: lsize = ", lsize(GMap) - write(device,*) identifier, ":: gsize = ", gsize(GMap) - write(device,*) identifier, ":: comp_id = ",comp_id(GMap) - - write(device,*) identifier, ":: Testing rank" - do i=0,mySize-1 - do j=1,GMap%counts(i) - call rank(GMap,GMap%displs(i)+j,proc) - if(i/=proc) then - write(device,*) identifier, ":: subroutine rank failed! ", & - i,j,mySize,GMap%counts(i), GMap%displs(i),proc - call die(myname_,"subroutine rank failed!") - endif - enddo - enddo - - write(device,*) identifier, ":: Testing bounds" - do i=0,mySize-1 - call bounds(GMap,i,lower,upper) - if(lower/=GMap%displs(i)+1) then - write(device,*) identifier, ":: subroutine bounds failed! ", & - i, lower, GMap%displs(i) - call die(myname_,"subroutine bounds failed!") - endif - if(upper/=GMap%displs(i)+GMap%counts(i)) then - write(device,*) identifier, ":: subroutine bounds failed! ", & - i,upper,GMap%displs(i)+GMap%counts(i)-1 - call die(myname_,"subroutine bounds failed!") - endif - enddo - - if(present(mycomm)) then - j=-12345 - k=-12345 - - do i=1,GMap%gsize - if(GlobalToLocalIndex(GMap,i,mycomm)/=-1) then - j=GlobalToLocalIndex(GMap,i,mycomm) - EXIT - endif - enddo - - do i=1,GMap%gsize - if(GlobalToLocalIndex(GMap,i,mycomm)/=-1) then - k=GlobalToLocalIndex(GMap,i,mycomm) - endif - enddo - - if( (j==-12345).and.(k==-12345) ) then - write(device,*) identifier, ":: GlobalMapToIndex :: & - &THIS PROCESS OWNS ZERO POINTS" - else - write(device,*) identifier, ":: GlobalMapToIndex :: & - &first, last indices = ", j, k - endif - - else - - write(device,*) identifier, ":: NOT TESTING GLOBALMAPTOLOCALINDEX. & - &PLEASE CONSULT SOURCE CODE TO ENABLE TESTING" - - endif - -end subroutine testGMap_ - -end module m_GMAPTEST diff --git a/cesm/models/utils/mct/testsystem/testall/m_GSMAPTEST.F90 b/cesm/models/utils/mct/testsystem/testall/m_GSMAPTEST.F90 deleted file mode 100644 index 179b93d..0000000 --- a/cesm/models/utils/mct/testsystem/testall/m_GSMAPTEST.F90 +++ /dev/null @@ -1,377 +0,0 @@ -! -! !INTERFACE: - - module m_GSMapTest -! -! !USES: -! - implicit none - - private ! except - -! !PUBLIC MEMBER FUNCTIONS: - - public :: testall - public :: Identical - - interface testall - module procedure testGSMap_ - end interface - - interface Identical - module procedure Identical_ - end interface - - -! !REVISION HISTORY: -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname='m_GSMapTest' - - contains - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: aVtest_ - Test the functions in the AttrVect module -! -! !DESCRIPTION: -! This routine writes diagnostic information about the input -! {\tt AttrVect}. Each line of the output will be preceded by the -! character argument {\tt identifier}. The output device is specified -! by the integer argument {\tt device}. -! -! !INTERFACE: - - subroutine testGSMap_(GSMap, identifier, mycomm, device) - -! -! !USES: -! - use m_GlobalSegMap ! Use all GlobalSegMap routines - use m_GlobalToLocal ! Use all GlobalToLocal routines - use m_stdio - use m_die - use m_mpif90 - - implicit none - -! !INPUT PARAMETERS: - - type(GlobalSegMap), intent(in) :: GSMap - character(len=*), intent(in) :: identifier - integer, intent(in) :: device - integer, intent(in) :: mycomm - -! !REVISION HISTORY: -! 23Sep02 - E.T. Ong - initial prototype. -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::testGSMap_' - integer :: myProc, mySize, ierr - integer :: i, j, k, m, n, o - integer :: first,last, owner, numlocs, nactive, npoints, proc - integer, dimension(:), pointer :: points, owners, pelist, perm, & - mystart, mylength - integer, dimension(:), allocatable :: locs, slpArray - logical :: found - - type(GlobalSegMap) :: PGSMap, P1GSMap - -!::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::! -!:::::WRITE OUT INFO ABOUT THE GLOBALSEGMAP::::::::::::::::::::::::::::! -!::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::! - - call MPI_COMM_RANK (mycomm, myProc, ierr) - call MPI_COMM_SIZE(mycomm, mySize, ierr) - - write(device,*) identifier, ":: TYPE CHECK:" - write(device,*) identifier, ":: COMP_ID = ", GSMap%comp_id - write(device,*) identifier, ":: NGSEG = ", GSMap%ngseg - write(device,*) identifier, ":: GSIZE = ", GSMap%gsize - write(device,*) identifier, ":: START:: association status, & - & size, values = ", associated(GSMap%start), size(GSMap%start) - write(device,*) identifier, ":: START = ", GSMap%start - write(device,*) identifier, ":: LENGTH:: association status, & - &size, values = ", associated(GSMap%length), size(GSMap%length) - write(device,*) identifier, ":: LENGTH = ", GSMap%length - write(device,*) identifier, ":: PE_LOC:: association status, & - &size, values = ", associated(GSMap%pe_loc), size(GSMap%pe_loc) - write(device,*) identifier, ":: PE_LOC = ", GSMap%pe_loc - - write(device,*) identifier, ":: NGSEG_ = ", ngseg(GSMap) - write(device,*) identifier, ":: NLSEG_ = ", nlseg(GSMap,myProc) - write(device,*) identifier, ":: COMP_ID_ = ", comp_id(GSMap) - write(device,*) identifier, ":: GSIZE_ = ", gsize(GSMap) - write(device,*) identifier, ":: GLOBALSTORAGE = ", GlobalStorage(GSMap) - write(device,*) identifier, ":: PROCESSSTORAGE = (PE, PE-STORAGE)" - do i=1,mySize - write(device,*) identifier, ":: PROCESSSTORAGE = ", & - i-1, ProcessStorage(GSMap,i-1) - enddo - write(device,*) identifier, ":: LSIZE_ = ", lsize(GSMap,mycomm) - write(device,*) identifier, ":: HALOED = ", haloed(GSMap) - - write(device,*) identifier, ":: SUBROUTINES CHECK:" - write(device,*) identifier, ":: ORDERED POINTS = (PE, SIZE, FIRST, LAST)" - - do i=1,mySize - - first=1 - last=0 - - proc = i-1 - - call OrderedPoints(GSMap,proc,points) - - npoints=size(points) - if(npoints>0) then - first = points(1) - last = points(npoints) - write(device,*) identifier, ":: ORDERED POINTS = ", proc, npoints, & - first, last - else - write(device,*) identifier, ":: ORDERED POINTS :: EXTREME WARNING:: & - &Process ", proc, " contains ", npoints, "points" - write(device,*) identifier, ":: AS A RESULT, & - &NOT TESTING RANK AND PELOCS::" - EXIT -! call die(myname_,"OrderedPoints may have failed ") - endif - - - !:::CHECK THE CORRECTNESS OF ROUTINE RANK1_:::! !::NOT YET PUBLIC IN MODULE::! - if(haloed(GSMap)) then - do k=first,last - call rank(GSMap,k,numlocs,owners) - found = .false. - do n=1,numlocs - if(owners(n) /= proc) then - found = .true. - endif - enddo - if(.not.found) then - call die(myname_,"SUBROUTINE RANKM_ failed!") - endif - enddo - deallocate(owners,stat=ierr) - if(ierr/=0) call die(myname_,"deallocate(owners)",ierr) - else - allocate(locs(npoints),stat=ierr) - if(ierr/=0) call die(myname_,"allocate(locs)") - call peLocs(GSMap,npoints,points,locs) - do n=1,npoints - if(locs(n) /= proc) then - call die(myname_,"SUBROUTINE PELOCS FAILED!",locs(n)) - endif - enddo - deallocate(locs,stat=ierr) - if(ierr/=0) call die(myname_,"deallocate(locs)") - do k=first,last - call rank(GSMap,k,owner) - if(owner /= proc) then - write(device,*) identifier, ":: RANK1_ FAILED:: ", owner, proc, first, last, k - call die(myname_,"SUBROUTINE RANK1_ failed!") - endif - enddo - endif - !:::::::::::::::::::::::::::::::::::::::::::::! - - deallocate(points,stat=ierr) - if(ierr/=0) call die(myname_,"deallocate(points)",ierr) - enddo - - call active_pes(GSMap, nactive, pelist) - write(device,*) identifier, ":: ACTIVE PES (NUM_ACTIVE, PE_LIST) = ", & - nactive, pelist - deallocate(pelist,stat=ierr) - if(ierr/=0) call die(myname_,"deallocate(pelist)",ierr) - - - write(device,*) identifier, ":: TESTING INITP and INITP1" - call init(PGSMAP, GSMap%comp_id, GSMap%ngseg, GSMap%gsize, GSMap%start, & - GSMap%length, GSMap%pe_loc) - - k = size(GSMap%start)+size(GSMap%length)+size(GSMap%pe_loc) - allocate(slparray(k),stat=ierr) - if(ierr/=0) call die(myname_,"allocate(slparray)",ierr) - - slpArray(1:GSMap%ngseg) = GSMap%start(1:GSMap%ngseg) - slpArray(GSMap%ngseg+1:2*GSMap%ngseg) = GSMap%length(1:GSMap%ngseg) - slpArray(2*GSMap%ngseg+1:3*GSMap%ngseg) = GSMap%pe_loc(1:GSMap%ngseg) - - call init(P1GSMap, GSMap%comp_id, GSMap%ngseg, GSMap%gsize, slpArray) - - deallocate(slpArray,stat=ierr) - if(ierr/=0) call die(myname_,"deallocate(slparray)",ierr) - - write(device,*) identifier, ":: COMPARE ALL GLOBALSEGMAPS: & - & YOU SHOULD SEE 3 IDENTICAL COLUMNS OF NUMBERS:" - write(device,*) identifier, ":: COMP_ID = ", & - GSMap%comp_id, PGSMap%comp_id, P1GSMap%comp_id - write(device,*) identifier, ":: NGSEG = ", & - GSMap%ngseg, GSMap%ngseg, GSMap%ngseg - write(device,*) identifier, ":: GSIZE = ", & - GSMap%gsize, GSMap%gsize, GSMap%gsize - write(device,*) identifier, ":: START:: association status = ", & - associated(GSMap%start), associated(PGSMap%start), & - associated(P1GSMap%start) - write(device,*) identifier, ":: START:: size = ", & - size(GSMap%start), size(PGSMap%start), size(P1GSMap%start) - - write(device,*) identifier, ":: LENGTH:: association status = ", & - associated(GSMap%length), associated(PGSMap%length), & - associated(P1GSMap%length) - write(device,*) identifier, ":: LENGTH:: size = ", & - size(GSMap%length), size(PGSMap%length), size(P1GSMap%length) - - - write(device,*) identifier, ":: PE_LOC:: association status = ", & - associated(GSMap%pe_loc), associated(PGSMap%pe_loc), & - associated(P1GSMap%pe_loc) - write(device,*) identifier, ":: PE_LOC:: size = ", & - size(GSMap%pe_loc), size(PGSMap%pe_loc), size(P1GSMap%pe_loc) - - do i=1,GSMap%ngseg - if( (GSMap%start(i) /= PGSMap%start(i)) .or. & - (GSMap%start(i) /= P1GSMap%start(i)) ) then - call die(myname_,"INITP or INITP1 failed -starts-!") - endif - if( (GSMap%length(i) /= PGSMap%length(i)) .or. & - (GSMap%length(i) /= P1GSMap%length(i)) ) then - call die(myname_,"INITP or INITP1 failed -lengths-!") - endif - if( (GSMap%pe_loc(i) /= PGSMap%pe_loc(i)) .or. & - (GSMap%pe_loc(i) /= P1GSMap%pe_loc(i)) ) then - call die(myname_,"INITP or INITP1 failed -pe_locs-!") - endif - enddo - - write(device,*) identifier, ":: TESTING SORT AND PERMUTE" - - call Sort(PGSMap,PGSMap%pe_loc,PGSMap%start,perm) - call Permute(PGSMap, perm) - - deallocate(perm,stat=ierr) - if(ierr/=0) call die(myname_,"deallocate(perm)") - - call SortPermute(P1GSMap,PGSMap%pe_loc,PGSMap%start) - - do i=1,GSMap%ngseg - if( (P1GSMap%start(i) /= PGSMap%start(i)) ) then - call die(myname_,"Sort or Permute failed -starts-!") - endif - if( (P1GSMap%length(i) /= PGSMap%length(i)) ) then - call die(myname_,"Sort or Permute failed -lengths-!") - endif - if( (P1GSMap%pe_loc(i) /= PGSMap%pe_loc(i)) ) then - call die(myname_,"Sort or Permute failed -pe_locs-!") - endif - enddo - - write(device,*) identifier, ":: TESTING GLOBALTOLOCAL FUNCTIONS ::" - - write(device,*) identifier, ":: TESTING GLOBALSEGMAPTOINDICES ::" - - call GlobalToLocalIndices(GSMap,mycomm,mystart,mylength) - - if(.NOT. (associated(mystart).and.associated(mylength)) ) then - call die(myname_, "::GLOBALSEGMAPTOINDICES::& - &mystart and/or mylength is not associated") - endif - - if(size(mystart)<0) then - call die(myname_, "::GLOBALSEGMAPTOINDICES::size(start) < 0") - endif - - if(size(mystart) /= size(mylength)) then - call die(myname_, "::GLOBALSEGMAPTOINDICES::size(start)/=size(length)") - endif - - if(size(mystart) /= nlseg(GSMap,myProc)) then - call die(myname_, "::GLOBALSEGMAPTOINDICES::size(start)/=nlseg") - endif - - if(size(mystart)>0) then - write(device,*) identifier, ":: GLOBALSEGMAPTOINDICES :: & - &start = (size, values) ", & - size(mystart), mystart - else - write(device,*) identifier, ":: GLOBALSEGMAPTOINDICES :: & - &start has zero size" - endif - - if(size(mylength)>0) then - write(device,*) identifier, ":: GLOBALSEGMAPTOINDICES :: & - &length = (size, values) ", & - size(mylength), mylength - else - write(device,*) identifier, ":: GLOBALSEGMAPTOINDICES :: & - &length has zero size" - endif - - if(size(mystart)>0) then - write(device,*) identifier, ":: GLOBALSEGMAPTOINDICES :: & - &first, last indices = ", & - mystart(1), mystart(size(mystart))+mylength(size(mylength))-1 - else - write(device,*) identifier, ":: GLOBALSEGMAPTOINDICES :: NOT TESTING& - & THIS ROUTINE BECAUSE START AND LENGTH HAVE ZERO SIZE" - endif - - deallocate(mystart,mylength,stat=ierr) - if(ierr/=0) call die(myname_,"deallocate(mystart,mylength)") - - write(device,*) identifier, ":: TESTING GLOBALSEGMAPTOINDEX" - - j=-12345 - k=-12345 - - do i=1,GlobalStorage(GSMap) - if(GlobalToLocalIndex(GSMap,i,mycomm)/=-1) then - j=GlobalToLocalIndex(GSMap,i,mycomm) - EXIT - endif - enddo - - do i=1,GlobalStorage(GSMap) - if(GlobalToLocalIndex(GSMap,i,mycomm)/=-1) then - k=GlobalToLocalIndex(GSMap,i,mycomm) - endif - enddo - - if( (j==-12345).and.(k==-12345) ) then - write(device,*) identifier, ":: GlobalSegMapToIndex :: & - &THIS PROCESS OWNS ZERO POINTS" - else - write(device,*) identifier, ":: GlobalSegMapToIndex :: & - &first, last indices = ", j, k - endif - - end subroutine testGSMap_ - - logical function Identical_(GSMap1,GSMap2) - - use m_GlobalSegMap ! Use all GlobalSegMap routines - - implicit none - - type(GlobalSegMap), intent(in) :: GSMap1, GSMap2 - - integer :: i - Identical_=.true. - - if(GSMap1%comp_id /= GSMap2%comp_id) Identical_=.false. - if(GSMap1%ngseg /= GSMap2%ngseg) Identical_=.false. - if(GSMap1%gsize /= GSMap2%gsize) Identical_=.false. - - do i=1,GSMap1%ngseg - if(GSMap1%start(i) /= GSMap2%start(i)) Identical_=.false. - if(GSMap1%length(i) /= GSMap2%length(i)) Identical_ =.false. - if(GSMap1%pe_loc(i) /= GSMap2%pe_loc(i)) Identical_ =.false. - enddo - - end function Identical_ - -end module m_GSMapTest diff --git a/cesm/models/utils/mct/testsystem/testall/m_MCTWORLDTEST.F90 b/cesm/models/utils/mct/testsystem/testall/m_MCTWORLDTEST.F90 deleted file mode 100644 index 2760964..0000000 --- a/cesm/models/utils/mct/testsystem/testall/m_MCTWORLDTEST.F90 +++ /dev/null @@ -1,121 +0,0 @@ -! -! !INTERFACE: - - module m_MCTWORLDTEST -! -! !USES: -! - implicit none - - private ! except - -! !PUBLIC MEMBER FUNCTIONS: - - public :: testall - - interface testall - module procedure testMCTWorld_ - end interface - - -! !REVISION HISTORY: -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname='m_MCTWORLDTEST' - - contains - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: aVtest_ - Test the functions in the AttrVect module -! -! !DESCRIPTION: -! This routine writes diagnostic information about the input -! {\tt AttrVect}. Each line of the output will be preceded by the -! character argument {\tt identifier}. The output device is specified -! by the integer argument {\tt device}. -! -! !INTERFACE: - - subroutine testMCTWorld_(identifier, device) - -! -! !USES: -! - use m_MCTWorld ! Use all of MCTWorld - use m_stdio - use m_die - use m_mpif90 - - implicit none - -! !INPUT PARAMETERS: - - character(len=*), intent(in) :: identifier - integer, intent(in) :: device - -! !REVISION HISTORY: -! 23Sep02 - E.T. Ong - initial prototype. -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::testMCTWorld_' - integer :: i,j,k - integer :: mySize,ierr - - write(device,*) identifier, ":: TYPE CHECK:" - - write(device,*) identifier, ":: MCT_comm = ", ThisMCTWorld%MCT_comm - write(device,*) identifier, ":: ncomps = ", ThisMCTWorld%ncomps - write(device,*) identifier, ":: mygrank = ", ThisMCTWorld%mygrank - - if(associated(ThisMCTWorld%nprocspid).and.associated(ThisMCTWorld%idGprocid)) then - - write(device,*) identifier, ":: nprocspid = & - &(compid , nprocspid(compid)) " - - do i=1,size(ThisMCTWorld%nprocspid) - write(device,*) identifier, i, ThisMCTWorld%nprocspid(i) - enddo - - write(device,*) identifier, "::idGprocid = & - &(compid , local_PID, idGprocid(compid,local_PID)) " - - do i=1,size(ThisMCTWorld%idGprocid,1) - do j=0,size(ThisMCTWorld%idGprocid,2)-1 - write(device,*) identifier, i, j, ThisMCTWorld%idGprocid(i,j) - enddo - enddo - - else - - call die(myname_, "MCTWorld pointer components are not associated!") - - endif - - write(device,*) identifier, ":: NumComponents = ", NumComponents(ThisMCTWorld) - write(device,*) identifier, ":: ComponentNumProcs = & - &(compid, ComponentNumProcs(compid)) = " - do i=1,ThisMCTWorld%ncomps - write(device,*) identifier, i, ComponentNumProcs(ThisMCTWorld, i) - enddo - - write(device,*) identifier, ":: ComponentToWorldRank = & - &(compid, local_PID, ComponentToWorldRank(local_PID,compid))" - do i=1,ThisMCTWorld%ncomps - do j=0,ThisMCTWorld%nprocspid(i)-1 - write(device,*) identifier, i, j, ComponentToWorldRank(j,i,ThisMCTWorld) - enddo - enddo - - write(device,*) identifier, ":: ComponentRootRank = (compid, & - &ComponentRootRank(compid)" - - do i=1,ThisMCTWorld%ncomps - write(device,*) identifier, i, ComponentRootRank(i,ThisMCTWorld) - enddo - -end subroutine testMCTWorld_ - -end module m_MCTWORLDTEST diff --git a/cesm/models/utils/mct/testsystem/testall/m_ROUTERTEST.F90 b/cesm/models/utils/mct/testsystem/testall/m_ROUTERTEST.F90 deleted file mode 100644 index f0f27a4..0000000 --- a/cesm/models/utils/mct/testsystem/testall/m_ROUTERTEST.F90 +++ /dev/null @@ -1,120 +0,0 @@ -! -! !INTERFACE: - - module m_ROUTERTEST -! -! !USES: -! - implicit none - - private ! except - -! !PUBLIC MEMBER FUNCTIONS: - - public :: testall - - interface testall - module procedure testRouter_ - end interface - - -! !REVISION HISTORY: -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname='m_ROUTERTEST' - - contains - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: aVtest_ - Test the functions in the AttrVect module -! -! !DESCRIPTION: -! This routine writes diagnostic information about the input -! {\tt AttrVect}. Each line of the output will be preceded by the -! character argument {\tt identifier}. The output device is specified -! by the integer argument {\tt device}. -! -! !INTERFACE: - - subroutine testRouter_(Rout, identifier, device) - -! -! !USES: -! - use m_Router ! Use all GlobalSegMap routines - use m_stdio - use m_die - use m_mpif90 - - implicit none - -! !INPUT PARAMETERS: - - type(Router), intent(in) :: Rout - character(len=*), intent(in) :: identifier - integer, intent(in) :: device - -! !REVISION HISTORY: -! 23Sep02 - E.T. Ong - initial prototype. -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::testRouter_' - integer :: proc, nseg - - write(device,*) identifier, ":: TYPE CHECK:" - write(device,*) identifier, ":: COMP1ID = ", Rout%comp1id - write(device,*) identifier, ":: COMP2ID = ", Rout%comp2id - write(device,*) identifier, ":: NPROCS = ", Rout%nprocs - write(device,*) identifier, ":: MAXSIZE = ", Rout%maxsize - - if(associated(Rout%pe_list)) then - write(device,*) identifier, ":: PE_LIST = ", Rout%pe_list - else - call die(myname_,"PE_LIST IS NOT ASSOCIATED!") - endif - - if(associated(Rout%num_segs)) then - write(device,*) identifier, ":: NUM_SEGS = ", Rout%num_segs - else - call die(myname_,"NUM_SEGS IS NOT ASSOCIATED!") - endif - - if(associated(Rout%locsize)) then - write(device,*) identifier, ":: LOCSIZE = ", Rout%locsize - else - call die(myname_,"LOCSIZE IS NOT ASSOCIATED!") - endif - - if(associated(Rout%seg_starts)) then - write(device,*) identifier, ":: SIZE OF SEG_STARTS & - &(FIRST, SECOND DIM) = ", & - size(Rout%seg_starts,1), size(Rout%seg_lengths,2) - else - call die(myname_,"SEG_STARTS IS NOT ASSOCIATED!") - endif - - if(associated(Rout%seg_lengths)) then - write(device,*) identifier, ":: SIZE OF SEG_LENGTHS = & - &(FIRST, SECOND DIM) = ", & - size(Rout%seg_lengths,1), size(Rout%seg_lengths,2) - else - call die(myname_,"SEG_LENGTHS IS NOT ASSOCIATED!") - endif - - write(device,*) identifier, ":: SEG_STARTS AND SEG_LENGTHS & - &VALUES: (PE, START, LENGTH) = " - - do proc = 1, Rout%nprocs - do nseg = 1, Rout%num_segs(proc) - write(device,*) identifier, Rout%pe_list(proc), & - Rout%seg_starts(proc,nseg), & - Rout%seg_lengths(proc,nseg) - enddo - enddo - - end subroutine testRouter_ - -end module m_ROUTERTEST diff --git a/cesm/models/utils/mct/testsystem/testall/m_SMATTEST.F90 b/cesm/models/utils/mct/testsystem/testall/m_SMATTEST.F90 deleted file mode 100644 index dd08777..0000000 --- a/cesm/models/utils/mct/testsystem/testall/m_SMATTEST.F90 +++ /dev/null @@ -1,627 +0,0 @@ -! -! !INTERFACE: - - module m_SMATTEST -! -! !USES: -! - implicit none - - private ! except - -! !PUBLIC MEMBER FUNCTIONS: - - public :: testall - public :: IndexAttr - public :: SortPermute - public :: ImportExport - public :: Identical - - interface testall - module procedure testsMat_ - end interface - interface IndexAttr - module procedure IndexTest_ - end interface - interface SortPermute - module procedure SortPermuteTest_ - end interface - interface ImportExport - module procedure ImportExportTest_ - end interface - interface Identical - module procedure Identical_ - end interface - - -! !REVISION HISTORY: -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname='m_SMATTEST' - - contains - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!BOP ------------------------------------------------------------------- -! -! !IROUTINE: sMattest_ - Test the functions in the SparseMatrix module -! -! !DESCRIPTION: -! This routine writes diagnostic information about the input -! {\tt SparseMatrix}. Each line of the output will be preceded by the -! character argument {\tt identifier}. The output device is specified -! by the integer argument {\tt device}. -! -! !INTERFACE: - - subroutine testsMat_(sMat, identifier, device, mycomm) - -! -! !USES: -! - use m_SparseMatrix ! Use all SparseMatrix routines - use m_stdio - use m_die - - use m_realkinds, only : FP - - implicit none - -! !INPUT PARAMETERS: - - type(SparseMatrix), intent(in) :: sMat - character(len=*), intent(in) :: identifier - integer, intent(in) :: device - integer, optional, intent(in) :: mycomm - -! !REVISION HISTORY: -! 23Sep02 - E.T. Ong - initial prototype. -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::sMattest_' - integer :: i,j,k,ierr - integer :: numrows, start, end - real :: sparsity - real, dimension(:), pointer :: sums - real, dimension(:), allocatable :: validsums - logical :: rowsumcheck - type(SparseMatrix) :: sMatExactCopy - -!::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: -!:::::MAKE A COPY::::::::::::::::::::::::::::::::::::::::::::::::::::::: -!::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: - - call Copy(sMat=sMat,sMatCopy=sMatExactCopy) - -!::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: -!:::::WRITE OUT INFO ABOUT THE ATTRVECT::::::::::::::::::::::::::::::::: -!::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: - write(device,*) identifier, ":: Testing SparseMatrix Routines" - write(device,*) identifier, ":: lsize = ", lsize(sMat) - write(device,*) identifier, ":: nRows = ", nRows(sMat) - write(device,*) identifier, ":: nCols = ", nCols(sMat) - write(device,*) identifier, ":: vecinit = ", sMat%vecinit - - ! Add vecinit to smat_identical - call CheckBounds(sMat,ierr) - write(device,*) identifier, ":: CheckBounds ierror = ", ierr - - call local_row_range(sMat,start,end) - - write(device,*) identifier, ":: local_row_range (start_row, end_row) = ", & - start,end - - call local_col_range(sMat,start,end) - - write(device,*) identifier, ":: local_col_ramge (start_col, end_col) = ", & - start,end - - if(present(mycomm)) then - - write(device,*) identifier, ":: SINCE THE COMMUNICATOR ARGUMENT WAS & - &PROVIDED, PLEASE ENSURE THAT THIS TEST IS BEING CALLED ON & - &ALL PROCESSORS OF THIS COMPONENT AND THAT THE SPARSEMATRIX HAS& - & BEEN SCATTERED." - - write(device,*) identifier, ":: GlobalNumElements = ", & - GlobalNumElements(sMat,mycomm) - - call ComputeSparsity(sMat,sparsity,mycomm) - write(device,*) identifier, ":: ComputeSparsity = ", sparsity - - call global_row_range(sMat,mycomm,start,end) - - write(device,*) identifier,":: global_row_range (start_row, end_row) = ",& - start,end - - call global_col_range(sMat,mycomm,start,end) - - write(device,*) identifier,":: global_col_range (start_col, end_col) = ",& - start,end - - call row_sum(sMat,numrows,sums,mycomm) - write(device,*) identifier, ":: row_sum (size(sums),numrows,& - &first,last,min,max) = ", & - size(sums), numrows, sums(1), sums(size(sums)), & - MINVAL(sums), MAXVAL(sums) - - allocate(validsums(2),stat=ierr) - if(ierr/=0) call die(myname_,"allocate(validsums)",ierr) - - validsums(1)=0. - validsums(2)=1. - - call row_sum_check(sMat=sMat,comm=mycomm,num_valid=2, & - valid_sums=validsums,abs_tol=1e-5,valid=rowsumcheck) - - write(device,*) identifier,":: row_sum_check = ", rowsumcheck - - deallocate(sums,validsums, stat=ierr) - if(ierr/=0) call die(myname_,"deallocate(sums,validsums)",ierr) - - endif - -!::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: -!:::::TESTING INDEXIA AND GETILIST:::::::::::::::::::::::::::::::::::::: -!::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: - - call IndexTest_(sMat,identifier,device) - - -!::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::! -!:::::TESTING SORT AND PERMUTE:::::::::::::::::::::::::::::::::::::::::! -!::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::! - -! NOTE: THIS IS NOT A CHECK FOR CORRECTNESS, JUST A CHECK FOR CONSISTENCY - - call SortPermuteTest_(sMat,identifier,device) - -!::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::! -!:::::TESTING EXPORT AND IMPORT FUNCTIONS:::::::::::::::::::::::::::::::! -!::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::! - call ImportExportTest_(sMat,identifier,device) - - ! Check that sMat is unchanged! - - if(.NOT.Identical(sMat,sMatExactCopy,1e-5)) then - call die(myname_,"sMat unexpectedly altered!!!") - endif - - call clean(sMatExactCopy) - -end subroutine testsMat_ - -!::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: -!:::::TEST FOR INDEXIA AND GETILIST:::::::::::::::::::::::::::::::::::::: -!::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: - - subroutine IndexTest_(sMat,identifier,device) - - use m_SparseMatrix - use m_AttrVect, only: getIList, getRList - use m_AttrVect, only: nIAttr, nRAttr - use m_List, only: List_allocated => allocated - use m_String, only: String - use m_String, only: StringToChar => toChar - use m_String, only: String_clean => clean - use m_stdio - use m_die - - implicit none - - type(SparseMatrix), intent(in) :: sMat - character(len=*), intent(in) :: identifier - integer, intent(in) :: device - - character(len=*),parameter :: myname_=myname//'::IndexTest_' - type(String) :: ItemStr - integer :: i,j,k,ierr - - if(nIAttr(sMat%data)>0) then - write(device,*) identifier, ":: Testing indexIA ::" - else - if(List_allocated(sMat%data%iList)) then - call die(myname_,"iList has been allocated, :& - &but there are no atttributes. :& - &Please do not initialize a blank list.") - end if - if(associated(sMat%data%iAttr)) then - if(size(sMat%data%iAttr,1) /= 0) then - call die(myname_,"iAttr contains no attributes, & - &yet its size /= 0",size(sMat%data%iAttr,1)) - endif - endif - end if - - do i=1,nIAttr(sMat%data) - - call getIList(ItemStr,i,sMat%data) - j = indexIA(sMat,StringToChar(ItemStr)) - if(i/=j) call die(myname_,"Function indexIA failed!") - write(device,*) identifier, & - ":: sMat Index = ", j, & - ":: Attribute Name = ", StringToChar(ItemStr) - call String_clean(ItemStr) - - enddo - - if(nRAttr(sMat%data)>0) then - write(device,*) identifier, ":: Testing indexRA::" - else - if(List_allocated(sMat%data%rList)) then - call die(myname_,"rList has been allocated, :& - &but there are no atttributes. :& - &Please do not initialize a blank list.") - end if - if(associated(sMat%data%rAttr)) then - if(size(sMat%data%rAttr,1) /= 0) then - call die(myname_,"rAttr contains no attributes, & - &yet its size /= 0",size(sMat%data%rAttr,1)) - endif - endif - end if - - do i=1,nRAttr(sMat%data) - - call getRList(ItemStr,i,sMat%data) - j = indexRA(sMat,StringToChar(ItemStr)) - if(i/=j) call die(myname_,"Function indexIA failed!") - write(device,*) identifier, & - "::sMat Index = ", j, & - "::Attribute Name = ", StringToChar(ItemStr) - call String_clean(ItemStr) - - enddo - - end subroutine IndexTest_ - -!::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::! -!:::::TEST FOR SORT AND PERMUTE:::::::::::::::::::::::::::::::::::::::::! -!::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::! - -! NOTE: THIS IS NOT A CHECK FOR CORRECTNESS, JUST A CHECK FOR CONSISTENCY - - subroutine SortPermuteTest_(sMat,identifier,device) - - use m_SparseMatrix - use m_AttrVect, only : nIAttr, nRAttr, Zero - use m_stdio - use m_die - - use m_realkinds, only : FP - - implicit none - - type(SparseMatrix), intent(in) :: sMat - character(len=*), intent(in) :: identifier - integer, intent(in) :: device - - character(len=*),parameter :: myname_=myname//'::SortPermuteTest_' - type(SparseMatrix) :: SMATCOPY1, SMATCOPY2 - logical,dimension(:), pointer :: descend - integer,dimension(:), pointer :: perm - integer :: i,j,k,ierr - real :: r - - write(device,*) identifier, ":: Testing Sort and Permute" - - call init(SMATCOPY1,sMat%nrows,sMat%ncols,lsize(sMat)) - call init(SMATCOPY2,sMat%nrows,sMat%ncols,lsize(sMat)) - - if( (nIAttr(SMATCOPY1%data)>0) .or. & - (nRAttr(SMATCOPY1%data)>0) ) then - - if(nIAttr(SMATCOPY1%data)>0) then - - allocate(descend(nIAttr(SMATCOPY1%data)),stat=ierr) - if(ierr /= 0) call die(myname_,"allocate(descend)") - - call Zero(SMATCOPY1%data) - call Zero(SMATCOPY2%data) - - k=0 - do i=1,nIAttr(SMATCOPY1%data) - do j=1,lsize(SMATCOPY1) - k=k+1 - SMATCOPY1%data%iAttr(i,j) = k - SMATCOPY2%data%iAttr(i,j) = k - enddo - enddo - - descend=.true. - call Sort(sMat=SMATCOPY1,key_list=SMATCOPY1%data%iList,perm=perm,descend=descend) - call Permute(sMat=SMATCOPY1,perm=perm) - - call SortPermute(sMat=SMATCOPY2,key_list=SMATCOPY2%data%iList,descend=descend) - - do i=1,nIAttr(SMATCOPY1%data) - do j=1,lsize(SMATCOPY1) - if(SMATCOPY1%data%iAttr(i,j) /= SMATCOPY2%data%iAttr(i,j)) then - call die(myname_,"Sort Testing FAILED!") - endif - enddo - enddo - - write(device,*) identifier, ":: Integer SparseMatrix data IN DESCENDING ORDER:: ", & - SMATCOPY1%data%iAttr(1,1:5) - - deallocate(perm,stat=ierr) - if(ierr /= 0) call die(myname_,"deallocate(perm)") - - deallocate(descend,stat=ierr) - if(ierr /= 0) call die(myname_,"deallocate(descend)") - - endif - - if(nRAttr(SMATCOPY1%data)>0) then - - allocate(descend(nRAttr(SMATCOPY1%data)),stat=ierr) - if(ierr /= 0) call die(myname_,"allocate(descend)") - - call Zero(SMATCOPY1%data) - call Zero(SMATCOPY2%data) - - r=0. - do i=1,nRAttr(SMATCOPY1%data) - do j=1,lsize(SMATCOPY1) - r=r+1.29 - SMATCOPY1%data%rAttr(i,j) = r - SMATCOPY2%data%rAttr(i,j) = r - enddo - enddo - - descend=.true. - call Sort(sMat=SMATCOPY1,key_list=SMATCOPY1%data%rList,perm=perm,descend=descend) - call Permute(sMat=SMATCOPY1,perm=perm) - - call SortPermute(sMat=SMATCOPY2,key_list=SMATCOPY2%data%rList,descend=descend) - - do i=1,nRAttr(SMATCOPY1%data) - do j=1,lsize(SMATCOPY1) - if(SMATCOPY1%data%rAttr(i,j) /= SMATCOPY2%data%rAttr(i,j)) then - call die(myname_,"Sort Testing FAILED!") - endif - enddo - enddo - - write(device,*) identifier, ":: REAL SparseMatrix data IN DESCENDING ORDER:: ", & - SMATCOPY1%data%rAttr(1,1:5) - - deallocate(perm,stat=ierr) - if(ierr /= 0) call die(myname_,"deallocate(perm)") - - deallocate(descend,stat=ierr) - if(ierr /= 0) call die(myname_,"deallocate(descend)") - - endif - else - write(device,*) identifier, ":: NOT TESTING SORTING AND PERMUTING. CONSULT & - &SOURCE CODE TO ENABLE TESTING." - endif - - call clean(SMATCOPY1) - call clean(SMATCOPY2) - - end subroutine SortPermuteTest_ - - -!::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::! -!:::::TEST FOR EXPORT AND IMPORT FUNCTIONS:::::::::::::::::::::::::::::::! -!::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::! - - subroutine ImportExportTest_(sMat,identifier,device) - - use m_SparseMatrix - - use m_List, only : List - use m_List, only : List_identical => identical - use m_List, only : List_get => get - use m_List, only : List_clean => clean - use m_String, only : String - use m_String, only : StringToChar => toChar - use m_String, only : String_clean => clean - use m_stdio - use m_die - - use m_realkinds, only : FP - - implicit none - - type(SparseMatrix), intent(in) :: sMat - character(len=*), intent(in) :: identifier - integer, intent(in) :: device - - character(len=*),parameter :: myname_=myname//'::ImportExportTest_' - integer :: i,j,k,ierr - real :: r - - type(SparseMatrix) :: sMatCopy - integer :: size - integer, dimension(:), pointer :: GlobalRows, GlobalColumns - integer, dimension(:), pointer :: LocalRows, LocalColumns - integer, dimension(:), pointer :: importIVect - real(FP), dimension(:), pointer :: importRVect - real(FP), dimension(:), pointer :: MatrixElements - - write(device,*) identifier, ":: Testing import and export functions" - - nullify(GlobalRows) - nullify(GlobalColumns) - nullify(LocalRows) - nullify(LocalColumns) - nullify(MatrixElements) - nullify(importIVect) - nullify(importRVect) - - call exportGlobalRowIndices(sMat,GlobalRows,size) - if(.NOT.aVEqualsMat_(sMat=sMat,ivector=GlobalRows,attribute="grow")) then - call die(myname_,"exportGlobalRowIndices failed") - endif - - call exportGlobalColumnIndices(sMat,GlobalColumns,size) - if(.NOT.aVEqualsMat_(sMat=sMat,ivector=GlobalColumns,attribute="gcol")) then - call die(myname_,"exportGlobalColumnIndices failed") - endif - - call exportLocalRowIndices(sMat,LocalRows,size) - if(.NOT.aVEqualsMat_(sMat=sMat,ivector=LocalRows,attribute="lrow")) then - call die(myname_,"exportLocalRowIndices failed") - endif - - call exportLocalColumnIndices(sMat,LocalColumns,size) - if(.NOT.aVEqualsMat_(sMat=sMat,ivector=LocalColumns,attribute="lcol")) then - call die(myname_,"exportLocalColumnIndices failed") - endif - - call exportMatrixElements(sMat,MatrixElements,size) - if(.NOT.aVEqualsMat_(sMat=sMat,rvector=MatrixElements,attribute="weight")) then - call die(myname_,"exportMatrixElements failed") - endif - - call init(sMatCopy,sMat%nrows,sMat%ncols,lsize(sMat)) - - allocate(importIVect(lsize(sMat)),importRVect(lsize(sMat)),stat=ierr) - if(ierr/=0) call die(myname_,"llocate(importVect)",ierr) - - r=0. - do i=1,lsize(sMat) - r=r+1.1 - importIVect(i) = i - importRVect(i) = r - enddo - - call importGlobalRowIndices(sMatCopy,importIVect,lsize(sMat)) - if(.NOT.aVEqualsMat_(sMat=sMatCopy,ivector=importIVect,attribute="grow")) then - call die(myname_,"importGlobalRowIndices failed") - endif - - call importGlobalColumnIndices(sMatCopy,importIVect,lsize(sMat)) - if(.NOT.aVEqualsMat_(sMat=sMatCopy,ivector=importIVect,attribute="gcol")) then - call die(myname_,"importGlobalColumnIndices failed") - endif - - call importLocalRowIndices(sMatCopy,importIVect,lsize(sMat)) - if(.NOT.aVEqualsMat_(sMat=sMatCopy,ivector=importIVect,attribute="lrow")) then - call die(myname_,"importLocalRowIndices failed") - endif - - call importLocalColumnIndices(sMatCopy,importIVect,lsize(sMat)) - if(.NOT.aVEqualsMat_(sMat=sMatCopy,ivector=importIVect,attribute="lcol")) then - call die(myname_,"importLocalColumnIndices failed") - endif - - call importMatrixElements(sMatCopy,importRVect,lsize(sMat)) - if(.NOT.aVEqualsMat_(sMat=sMatCopy,rvector=importRVect,attribute="weight")) then - call die(myname_,"importMatrixElements failed") - endif - - call clean(sMatCopy) - - deallocate(GlobalRows,GlobalColumns,LocalRows,LocalColumns, & - importIVect, importRVect,MatrixElements,stat=ierr) - if(ierr/=0) call die(myname_,"deallocate(Global....)",ierr) - - contains - - logical function aVEqualsMat_(sMat,ivector,rvector,attribute) - - use m_SparseMatrix - use m_stdio - use m_die - - use m_realkinds, only : FP - - implicit none - - type(SparseMatrix), intent(in) :: sMat - integer, dimension(:), pointer, optional :: ivector - real(FP), dimension(:), pointer, optional :: rvector - character(len=*), intent(in) :: attribute - - integer :: i, attribute_index - - aVEqualsMat_ = .TRUE. - - if(present(ivector)) then - - attribute_index = indexIA(sMat,trim(attribute)) - - do i=1,lsize(sMat) - if(sMat%data%iAttr(attribute_index,i) /= ivector(i)) then - aVEqualsMat_ = .FALSE. - EXIT - endif - enddo - - else - - if(present(rvector)) then - - attribute_index = indexRA(sMat,trim(attribute)) - - do i=1,lsize(sMat) - if(sMat%data%rAttr(attribute_index,i) /= rvector(i)) then - aVEqualsMat_ = .FALSE. - EXIT - endif - enddo - - else - - call die("aVEqualsMat_::","ivector or rvector must be present") - - endif - - endif - - end function aVEqualsMat_ - - end subroutine ImportExportTest_ - - logical function Identical_(SMAT1,SMAT2,Range) - - use m_SparseMatrix - use m_AVTEST,only: AttrVect_identical => Identical - use m_List,only : List_allocated => allocated - use m_List,only : List_identical => identical - use m_stdio - use m_die - - use m_realkinds, only : FP - - implicit none - - type(SparseMatrix), intent(in) :: SMAT1 - type(SparseMatrix), intent(in) :: SMAT2 - real, optional, intent(in) :: Range - - integer :: i,j,k - - Identical_=.true. - - if(present(Range)) then - if(.NOT. AttrVect_identical(SMAT1%data,SMAT2%data,Range)) then - Identical_=.false. - endif - else - if(.NOT. AttrVect_identical(SMAT1%data,SMAT2%data)) then - Identical_=.false. - endif - endif - - if(SMAT1%nrows /= SMAT2%nrows) then - Identical_=.false. - endif - - if(SMAT1%ncols /= SMAT2%ncols) then - Identical_=.false. - endif - - if(SMAT1%vecinit .neqv. SMAT2%vecinit) then - Identical_=.false. - endif - - end function Identical_ - -end module m_SMATTEST diff --git a/cesm/models/utils/mct/testsystem/testall/master.F90 b/cesm/models/utils/mct/testsystem/testall/master.F90 deleted file mode 100644 index 3ca3492..0000000 --- a/cesm/models/utils/mct/testsystem/testall/master.F90 +++ /dev/null @@ -1,39 +0,0 @@ -!----------------------------------------------------------------------- -! CVS $Id: master.F90,v 1.2 2007-10-30 20:57:16 rloy Exp $ -! CVS $Name: $ -!----------------------------------------------------------------------- -! A driver model code for Multi-Process Handshaking utility -! to facilitate a plug & play style programming using single executable. -! each processor only execute one component model once. -! Written by Yun (Helen) He and Chris Ding, NERSC/LBNL, October 2000. - - - program main - use MPH_all - implicit none - integer myProc_global - - external ccm3, cpl, pop2_2 - - call MPI_INIT(ierr) - call MPI_COMM_RANK(MPI_COMM_WORLD,myProc_global,ierr) - -! here ccm3.8, pop2.2 etc are subroutine names in component models -! you could list the components in any order or omit any of them - call MPH_setup_SE (atmosphere=ccm3, coupler=cpl, ocean=pop2_2) - -! write(*,*)'I am proc ', MPH_global_proc_id(), -! & ' of global proc ', MPH_local_proc_id_ME_SE(), ' of ', -! & MPH_myName_ME_SE() -! write(*,*)'==============================================' - - call MPI_FINALIZE(ierr) - - - if(myProc_global==0) then - write(9999,*) "End of main" - close(9999) - endif - - end program - diff --git a/cesm/models/utils/mct/testsystem/testall/mph.F90 b/cesm/models/utils/mct/testsystem/testall/mph.F90 deleted file mode 100644 index b0b9882..0000000 --- a/cesm/models/utils/mct/testsystem/testall/mph.F90 +++ /dev/null @@ -1,1068 +0,0 @@ -!----------------------------------------------------------------------- -! CVS $Id: mph.F90,v 1.3 2006-10-03 22:43:29 jacob Exp $ -! CVS $Name: $ -! ============================================================= -! Multi Program-Components Handshaking (MPH) Utility - -! This is a small utility of global handshaking among different component -! models. Each component will run on a set of nodes or processors. -! Different components could run either on different set of nodes, or -! on set of nodes that overlap. - -! There are three seperate implementations: -! 1. Multiple Components, Multiple Executables, components non-overlap -! 2. Multiple Components, Single Executable, components non-overlap -! 3. Multiple Components, Single Executable, components overlap, flexible - -! This is a combined module for all the above. -! The user only has to "use MPH_all" in their application codes. -! You may need to use MPH_help to understand the required information -! for setup, input file and inquiry functions. - -! Written by Yun He and Chris Ding, NERSC/LBL, January 2001. - - -!============================================================== -! common data used by all three versions of MPH -!============================================================== - - module comm_data123 - - use m_mpif - implicit none - - integer istatus(MPI_STATUS_SIZE), ierr - integer max_num_comps, maxProcs_comp - parameter (max_num_comps=20) ! maximum number of components - parameter (maxProcs_comp=128) ! maximum number of procs per comps - - type Acomponent - character*16 name ! component name - integer num_process ! number of processors - integer process_list(maxProcs_comp) - ! global processor_id, increasing order - end type Acomponent - - type (Acomponent) components(max_num_comps) ! allocate components - integer MPI_Acomponent - - integer global_proc_id ! proc id in the whole world - integer global_totProcs ! total # of procs for the whole world - integer COMM_master ! communicator for submaster of each component - - integer total_components - character*16 component_names(max_num_comps) - -! for timer - integer N_CHANNELS - parameter (N_CHANNELS=10) - real (kind=8) :: init_time = -1.0 - real (kind=8) :: last_time, tot_time(0:N_CHANNELS) - - end module comm_data123 - -!=============================================================== -! common data shared by MPH_Multi_Exec and MPH_Single_Exec -!=============================================================== - - module comm_data12 - use comm_data123 - integer component_id - integer local_world ! communicator for this component - integer local_proc_id ! proc id in this component - integer local_totProcs ! total # of procs for this component - end module comm_data12 - -!================================================================== -! common subroutines used by all three versions of MPH -!================================================================== - - module comm_sub123 - use comm_data123 - contains - -!--------------- subroutine MPH_init () ------------ - - subroutine MPH_init () - implicit none - - integer iblock(3), idisp(3), itype(3) - - call MPI_COMM_RANK (MPI_COMM_WORLD, global_proc_id, ierr) - call MPI_COMM_SIZE (MPI_COMM_WORLD, global_totProcs, ierr) - -! create a new MPI data type MPI_Acomponent - - iblock(1) = 16 - iblock(2) = 1 - iblock(3) = maxProcs_comp - idisp(1) = 0 - idisp(2) = 16 - idisp(3) = 20 - itype(1) = MPI_CHARACTER - itype(2) = MPI_INTEGER - itype(3) = MPI_INTEGER - call MPI_TYPE_STRUCT (3,iblock,idisp,itype,MPI_Acomponent,ierr) - call MPI_TYPE_COMMIT (MPI_Acomponent, ierr) - - end subroutine MPH_init - - -!--------- subroutine MPH_global_id (name, local_id) ---------- - - integer function MPH_global_id (name, local_id) - implicit none - - character*(*) name - integer local_id, temp - -! then find out the component rank - temp = MPH_find_name (name, component_names, total_components) - -! process_list starts from 1, while proc rank starts from 0 - MPH_global_id = components(temp) % process_list(local_id+1) - - end function MPH_global_id - - -!------ integer function MPH_find_name(name, namelist, num) ------ - - integer function MPH_find_name(name, namelist, num) - implicit none - -! find name in component_names - character*(*) name - integer i, num - character*16 namelist(num) - - do i = 1, num - if (name == namelist(i)) then -! print *, i, name, namelist(i) - goto 100 - endif - enddo - -! name is not found - MPH_find_name = -1 - print *, "ERROR: ", name, " not found in components.in" - stop - -100 MPH_find_name = i - return - end function MPH_find_name - - -!---------- subroutine MPH_redirect_output (name) --------- - - subroutine MPH_redirect_output (name) - character*(*) name - integer lenname, lenval, rcode - character*16 output_name_env - character*64 output_name, temp_value - - output_name = ' ' - output_name_env = trim (name) // "_out_env" - -#if (defined AIX) - call getenv (trim(output_name_env), temp_value) - output_name = trim (temp_value) - if (len_trim(output_name) == 0) then - write(*,*)'output file names not preset by env varibales' - write(*,*)'so output not redirected' - else - open (unit=6, file=output_name, position='append') - call flush_(6) - endif -#endif - -#if (defined SUPERUX) - call getenv (trim(output_name_env), temp_value) - output_name = trim (temp_value) - if (len_trim(output_name) == 0) then - write(*,*)'output file names not preset by env varibales' - write(*,*)'so output not redirected' - else - open (unit=6, file=output_name, position='append') - call flush(6) - endif -#endif - -#if (defined IRIX64 || defined CRAY || defined sn6711) - lenname = len_trim (output_name_env) - call pxfgetenv (output_name_env,lenname,output_name,lenval,rcode) - if (len_trim(output_name) == 0) then - write(*,*)'output file names not preset by env varibales' - write(*,*)'so output not redirected' - else - open (unit=6, file=output_name, position='append') - call flush(6) - endif -#endif - -#if (!defined AIX && !defined IRIX64 && !defined CRAY && !defined sn6711 && !defined SUPERUX) - write(*,*) 'No implementation for this architecture' - write(*,*) 'output redirect is not performed by getenv' -#endif - - end subroutine MPH_redirect_output - - -!----------- subroutine MPH_help (arg) -------------- - - subroutine MPH_help (arg) - implicit none - - character*(*) arg - write(*,*)'Message from MPH_help:' - - if (arg .eq. 'off') then - write(*,*)'off' - - else if (arg .eq. 'Multi_Exec') then - write(*,*)'Multiple executables' - write(*,*)'Required setup function for pop is: ' - write(*,*)' call MPH_setup_ME ("ocean", POP_World)' - write(*,*)'Required input file is "components.in"' - - write(*,*)'Subroutine call to join two communicators is:' - write(*,*)' MPH_comm_join_ME_SE(name1,name2,comm_joined)' - - write(*,*)'Available inquiry functions are:' - write(*,*)' character*16 MPH_component_name(id)' - write(*,*)' integer MPH_get_component_id(name)' - write(*,*)' integer MPH_total_components()' - write(*,*)' integer MPH_global_proc_id()' - write(*,*)' character*16 MPH_myName_ME_SE()' - write(*,*)' integer MPH_component_id_ME_SE()' - write(*,*)' integer MPH_local_proc_id_ME_SE()' - write(*,*)' integer MPH_local_world_ME_SE()' - - else if (arg .eq. 'Single_Exec') then - write(*,*)'Single executable, processors non-overlap' - write(*,*)'Required setup function is: ' - write(*,*)' call MPH_setup_SE (atmosphere=ccm3_8,& - & ocean=pop2_2, coupler=cpl5_1)' - write(*,*)'Required input file is "processors_map.in"' - - write(*,*)'Subroutine call to join two communicators is:' - write(*,*)' MPH_comm_join_ME_SE(name1,name2,comm_joined)' - - write(*,*)'Available inquiry functions are:' - write(*,*)' character*16 MPH_component_name(id)' - write(*,*)' integer MPH_get_component_id(name)' - write(*,*)' integer MPH_total_components()' - write(*,*)' integer MPH_global_proc_id()' - write(*,*)' character*16 MPH_myName_ME_SE()' - write(*,*)' integer MPH_component_id_ME_SE()' - write(*,*)' integer MPH_local_proc_id_ME_SE()' - write(*,*)' integer MPH_local_world_ME_SE()' - write(*,*)' integer MPH_low_proc_limit(id)' - write(*,*)' integer MPH_up_proc_limit(id)' - - else if (arg .eq. 'Single_Exec_Overlap') then - write(*,*)'Single executable, processors overlap' - write(*,*)'Required setup function is: ' - write(*,*)' call MPH_setup_SE_overlap ("atmosphere",& - & "ocean", "coupler")' - write(*,*)'Required input file is "processors_map.in"' - - write(*,*)'Subroutine call to join two communicators is:' - write(*,*)' MPH_comm_join_SE_overlap (name1, name2,& - & comm_joined)' - - write(*,*)'Available inquiry functions are:' - write(*,*)' character*16 MPH_component_name(id)' - write(*,*)' integer MPH_get_component_id(name)' - write(*,*)' integer MPH_total_components()' - write(*,*)' integer MPH_global_proc_id()' - write(*,*)' integer MPH_local_proc_id_SE_overlap(id)' - write(*,*)' integer MPH_local_world_SE_overlap(id)' - write(*,*)' integer MPH_low_proc_limit(id)' - write(*,*)' integer MPH_up_proc_limit(id)' - - else - write(*,*)'wrong argument for MPH_help' - endif - - end subroutine MPH_help - - -!----------- function MPH_timer (flag, channel) ------------ - -! Usage: - -! channel 0 is the default channel, using init_time. - -! --------------------------------------------------------- -! timer calls to walk-clock dclock(), and do the following: -! --------------------------------------------------------- -! flag=0 : Sets initial time; init all channels. -! -! flag =1 : Calculates the most recent time interval; accure it to the -! specified channel; -! Returns it to calling process. -! Channel 0 is the default channel, which is automatically accrued. - -! flag =2 : Calculates the most recent time interval; accure it to the -! specified channel; -! Returns the curent total time in the specified channel; -! Channel 0 is the default channel, which is automatically accrued. -! --------------------------------------------------------- - - real (kind=8) function MPH_timer (flag, channel) - integer flag, channel - real (kind=8) :: new_time, delta_time, MPI_Wtime - - new_time = MPI_Wtime() - - if (flag == 0) then - init_time = new_time - last_time = new_time - tot_time = 0.0 - MPH_timer = new_time - init_time - else if (init_time == -1.0) then -! Error Condition - MPH_timer = init_time - endif - -! Timer is initialized and flag != 0 - - delta_time = new_time - last_time - last_time = new_time - -! For channel=0 or other undefined channels which is treated as 0 - if ( channel < 0 .or. channel > N_CHANNELS) then - write(*,*) 'Timer channel is not properly specified!' - endif - -! channel != 0 - - if (flag == 1) then - tot_time(channel) = tot_time(channel) + delta_time - MPH_timer = delta_time - else if (flag == 2) then - tot_time(channel) = tot_time(channel) + delta_time - MPH_timer = tot_time(channel) - else -! Error Condition - MPH_timer = -1.0 - endif - - end function MPH_timer - - -!-------- common inquiry functions for MPH1, MPH2 and MPH3 ------- - - character*16 function MPH_component_name(id) - integer id - MPH_component_name = component_names (id) - end function MPH_component_name - - integer function MPH_get_component_id(name) - character*(*) name - MPH_get_component_id = MPH_find_name (name, component_names,& - total_components) - end function MPH_get_component_id - - integer function MPH_total_components() - MPH_total_components = total_components - end function MPH_total_components - - integer function MPH_global_proc_id() - MPH_global_proc_id = global_proc_id - end function MPH_global_proc_id - - end module comm_sub123 - - -! =============================================================== -! common subroutines used by MPH_Multi_Exec and MPH_Single_Exec -! =============================================================== - - module comm_sub12 - use comm_data123 - use comm_data12 - use comm_sub123 - - contains - -!--------------- subroutine MPH_global_ME_SE () ------------ - -! global hand-shaking among root processors of each component. - - subroutine MPH_global_ME_SE () - implicit none - integer sendtag, recvtag, i, color, key - -! create a MPI communicator COMM_master for all submasters -! arrange the rank of the submasters in COMM_master by their component_id -! i.e., their rank of the component model in "components.in" - if (local_proc_id == 0) then - color = 1 - else - color = 2 - endif - key = component_id - call MPI_COMM_SPLIT (MPI_COMM_WORLD,color,key,COMM_master,ierr) - -! gather Acomponents to 0th proc in COMM_master - if (local_proc_id == 0) then - call MPI_GATHER (components(component_id), 1, MPI_Acomponent,& - components, 1, MPI_Acomponent,& - 0, COMM_master, ierr) - -! 0th proc in COMM_master broadcast Acomponents to all submasters - call MPI_BCAST (components, total_components,& - MPI_Acomponent, 0, COMM_master, ierr) - endif - -! submaster broadcast AComponents to all process in the components - call MPI_BCAST (components, total_components,& - MPI_Acomponent, 0, local_world, ierr) - -! everybody lists the complete info -! write(*,*)'I am proc ', local_proc_id, ' in ', -! & component_names(component_id), ' , which is proc ', -! & global_proc_id, ' in global_world' -! write(*,*)'infos I have for all proc of all components are:' -! do i = 1, total_components -! write(*,*)' ', components(i)%name -! write(*,*)' ', components(i)%num_process -! write(*,*)' ', components(i)%process_list(1:8) ! partial list -! enddo - - end subroutine MPH_global_ME_SE - - -!------- subroutine MPH_comm_join_ME_SE (name1, name2, comm_joined) --- - - subroutine MPH_comm_join_ME_SE (name1, name2, comm_joined) - implicit none - - character*(*) name1, name2 - integer temp1, temp2 - integer comm_joined, color, key - - temp1 = MPH_find_name(name1,component_names,total_components) - temp2 = MPH_find_name(name2,component_names,total_components) - -! the order of two components does matter: first one has lower ranks in -! the new joined communicator, and second one has higher ranks. - - if (component_id==temp1 .or. component_id==temp2) then - color = 1 - if (component_id == temp1) then - key = local_proc_id - else - key = global_totProcs + local_proc_id - endif - else - color = 2 - key = 0 - endif - - call MPI_COMM_SPLIT (MPI_COMM_WORLD,color,key,comm_joined,ierr) - - end subroutine MPH_comm_join_ME_SE - - -!-------- common inquiry functions for MPH1 and MPH2 --------- - - character*16 function MPH_myName_ME_SE() - MPH_myName_ME_SE = component_names (component_id) - end function MPH_myName_ME_SE - - integer function MPH_component_id_ME_SE() - MPH_component_id_ME_SE = component_id - end function MPH_component_id_ME_SE - - integer function MPH_local_proc_id_ME_SE() - MPH_local_proc_id_ME_SE = local_proc_id - end function MPH_local_proc_id_ME_SE - - integer function MPH_local_world_ME_SE() - MPH_local_world_ME_SE = local_world - end function MPH_local_world_ME_SE - - end module comm_sub12 - - -! ============================================================== -! module MPH_Multi_Exec -! ============================================================== - -! Multi-Process Handshaking utility -! to facilitate a plug & play style programming on -! using multiple component executables. - - module MPH_Multi_Exec - use comm_data123 - use comm_data12 - use comm_sub123 - use comm_sub12 - character*16 myName - - contains - -!------------- subroutine MPH_setup_ME (name, comm_world) --------- - - subroutine MPH_setup_ME (name, comm_world) - implicit none - - character*(*) name - integer comm_world - - myName = name - call MPH_init () - call MPH_local_ME () - call MPH_global_ME_SE () - call MPI_COMM_DUP (local_world, comm_world, ierr) - - end subroutine MPH_setup_ME - - -!--------------- subroutine MPH_local_ME () ------------ - -! local hand-shaking - - subroutine MPH_local_ME () - implicit none - integer key - - total_components = MPH_read_list_ME("components.in",& - "COMPONENT_LIST", component_names, max_num_comps) - - component_id = MPH_find_name (myName, component_names,& - total_components) - key = 0 - call MPI_COMM_SPLIT (MPI_COMM_WORLD, component_id, key,& - local_world,ierr) - -! setup local_world, local_proc_id, local_totProcs - call MPI_COMM_RANK (local_world, local_proc_id, ierr) - call MPI_COMM_SIZE (local_world, local_totProcs, ierr) - - components(component_id)%name = myName - components(component_id)%num_process = local_totProcs - -! gather processor ids to 0th proc in this component. - call MPI_GATHER (global_proc_id, 1, MPI_INTEGER,& - components(component_id)%process_list,& - 1, MPI_INTEGER, 0, local_world, ierr) - - end subroutine MPH_local_ME - - -!--- function MPH_read_list_ME(filename, filetag, namelist, num) --- - - integer function MPH_read_list_ME(filename,filetag,namelist,num) - implicit none - integer i, num - character*(*) filename, filetag - character*16 namelist(num), firstline, temp - - open(10, file=filename, status='unknown') - read(10, '(a16)', end=200) firstline - if (firstline .ne. filetag) then - print *, 'ERROR: filetag inconsistent', filename - print *, 'ERROR: ', filetag, '!=', firstline - stop - endif - - read(10, '(a16)', end=200) temp - if (temp .ne. 'BEGIN') then - print *, 'ERROR: no BEGIN in ', filename - stop - endif - - do i = 1, num - read(10, '(a16)', end=100) temp - if (temp .ne. 'END') then - namelist(i) = temp - else - goto 200 - endif - enddo - -100 print *, 'ERROR: no END in ', filename - stop - -200 MPH_read_list_ME = i - 1 - close(10) - - return - end function MPH_read_list_ME - - end module MPH_Multi_Exec - - -! ============================================================== -! module MPH_Single_Exec -! ============================================================== - -! Multi-Process Handshaking utility -! to facilitate a plug & play style programming using single executable. -! each processor only execute one component model once. - - module MPH_Single_Exec - use comm_data123 - use comm_data12 - use comm_sub123 - use comm_sub12 - integer low_proc_limit(max_num_comps) - integer up_proc_limit(max_num_comps) - - contains - - -!---- subroutine MPH_setup_SE (atmosphere, ocean, coupler, land) ------ - - subroutine MPH_setup_SE (atmosphere, ocean, coupler, land,& - ice, biosphere, io) - implicit none - - optional atmosphere, ocean, coupler, land, ice, biosphere, io - external atmosphere, ocean, coupler, land, ice, biosphere, io - integer id - - call MPH_init () - - total_components = MPH_read_list_SE ("processors_map.in",& - "PROCESSORS_MAP", component_names,& - low_proc_limit, up_proc_limit, max_num_comps) - - if (present(atmosphere)) then - id=MPH_find_name("atmosphere",component_names,total_components) - if (low_proc_limit(id) .le. global_proc_id .and.& - global_proc_id .le. up_proc_limit(id)) then - call MPH_local_SE (id) - call MPH_global_ME_SE () - call atmosphere (local_world) - endif - endif - - if (present(ocean)) then - id=MPH_find_name("ocean",component_names,total_components) - if (low_proc_limit(id) .le. global_proc_id .and.& - global_proc_id .le. up_proc_limit(id)) then - call MPH_local_SE (id) - call MPH_global_ME_SE () - call ocean (local_world) - endif - endif - - if (present(coupler)) then - id=MPH_find_name("coupler",component_names,total_components) - if (low_proc_limit(id) .le. global_proc_id .and.& - global_proc_id .le. up_proc_limit(id)) then - call MPH_local_SE (id) - call MPH_global_ME_SE () - call coupler (local_world) - endif - endif - -! add more component models as follows: - if (present(land)) then - id=MPH_find_name("land",component_names,total_components) - if (low_proc_limit(id) .le. global_proc_id .and.& - global_proc_id .le. up_proc_limit(id)) then - call MPH_local_SE (id) - call MPH_global_ME_SE () - call land (local_world) - endif - endif - - if (present(ice)) then - id=MPH_find_name("ice",component_names,total_components) - if (low_proc_limit(id) .le. global_proc_id .and.& - global_proc_id .le. up_proc_limit(id)) then - call MPH_local_SE (id) - call MPH_global_ME_SE () - call ice (local_world) - endif - endif - - if (present(biosphere)) then - id=MPH_find_name("biosphere",component_names,total_components) - if (low_proc_limit(id) .le. global_proc_id .and.& - global_proc_id .le. up_proc_limit(id)) then - call MPH_local_SE (id) - call MPH_global_ME_SE () - call biosphere (local_world) - endif - endif - - if (present(io)) then - id=MPH_find_name("io",component_names,total_components) - if (low_proc_limit(id) .le. global_proc_id .and.& - global_proc_id .le. up_proc_limit(id)) then - call MPH_local_SE (id) - call MPH_global_ME_SE () - call io (local_world) - endif - endif - - end subroutine MPH_setup_SE - - -!--------------- subroutine MPH_local_SE (id) ------------ - -! local hand-shaking - - subroutine MPH_local_SE (id) - implicit none - integer id, key - - component_id = id - key = 0 - call MPI_COMM_SPLIT (MPI_COMM_WORLD, component_id,& - key, local_World, ierr) - -! setup local_world, local_proc_id, local_totProcs - call MPI_COMM_RANK (local_world, local_proc_id, ierr) - call MPI_COMM_SIZE (local_world, local_totProcs, ierr) - - components(component_id)%name = component_names(component_id) - components(component_id)%num_process = local_totProcs - -! gather processor ids to 0th proc in this component. - call MPI_GATHER (global_proc_id, 1, MPI_INTEGER,& - components(component_id)%process_list, 1,& - MPI_INTEGER, 0, local_world, ierr) - - end subroutine MPH_local_SE - - -!---- function MPH_read_list_SE (filename, filetag, namelist, -!---- low, up, num) -------- - - integer function MPH_read_list_SE (filename, filetag,& - namelist, low, up, num) - implicit none - integer i, num - character*(*) filename, filetag - character*16 namelist(num), firstline, temp - integer itemp1, itemp2 - integer low(num), up(num) - - open(10, file=filename, status='unknown') - read(10, *, end=100) firstline - if (firstline .ne. filetag) then - print *, 'ERROR: filetag inconsistent', filename - print *, 'ERROR: ', filetag, '!=', firstline - stop - endif - - read(10, *, end=200) temp - if (temp .ne. "BEGIN") then - print *, 'ERROR: no BEGIN in ', filename - stop - endif - - do i = 1, num - read(10, *, err=300, end=400) temp, itemp1, itemp2 - if (temp .eq. "END") goto 500 - namelist(i) = temp - low(i) = itemp1 - up(i) = itemp2 - enddo - -100 print *, 'ERROR: no filetag in ', filename - stop - -200 print *, 'ERROR: no BEGIN in ', filename - stop - -300 if (temp .eq. "END") then - goto 500 - else - print *, 'ERROR: either: no END in ', filename - print *, ' or: does not provide correct format as' - print *, ' in input example: ocean 11 18' - stop - endif - -400 print *, 'ERROR: no END in ', filename - stop - -500 MPH_read_list_SE = i - 1 - close(10) - - return - end function MPH_read_list_SE - - -!---- the following two functions are common for MPH2 and MPH3 ------- - - integer function MPH_low_proc_limit(id) - integer id - MPH_low_proc_limit = low_proc_limit(id) - end function MPH_low_proc_limit - - integer function MPH_up_proc_limit(id) - integer id - MPH_up_proc_limit = up_proc_limit(id) - end function MPH_up_proc_limit - - end module MPH_Single_Exec - - -! ============================================================== -! module MPH_Single_Exec_Overlap -! ============================================================== - -! Multi-Process Handshaking utility -! to facilitate a plug & play style programming using single executable. -! each processor could execute more than one component model (processor -! overlap) in any flexible way (any order). - - - module MPH_Single_Exec_Overlap - use comm_data123 - use comm_sub123 - - integer local_world(max_num_comps) ! communicator for this component - integer local_proc_id(max_num_comps) ! proc id in this component - integer local_totProcs(max_num_comps) ! total procs for this component - integer low_proc_limit(max_num_comps) - integer up_proc_limit(max_num_comps) - - contains - -!---- subroutine MPH_setup_SE_overlap (model1, model2, ...) ------ - - subroutine MPH_setup_SE_overlap (model1, model2, model3, model4,& - model5, model6, model7, model8, model9, model10) - implicit none - - character*(*) model1, model2, model3, model4, model5 - character*(*) model6, model7, model8, model9, model10 - optional model1, model2, model3, model4, model5 - optional model6, model7, model8, model9, model10 - - integer id, i - - call MPH_init () - call MPH_local_SE_overlap () - call MPH_global_SE_overlap () - - end subroutine MPH_setup_SE_overlap - - -!--------------- subroutine MPH_local_SE_overlap () ------------ - - subroutine MPH_local_SE_overlap () - implicit none - integer id, color, key - - total_components=MPH_read_list_SE_overlap("processors_map.in",& - "PROCESSORS_MAP", component_names,& - low_proc_limit, up_proc_limit, max_num_comps,& - local_totProcs) - -! setup local_world, local_proc_id, local_totProcs - do id = 1, total_components - if (low_proc_limit(id) .le. global_proc_id .and.& - global_proc_id .le. up_proc_limit(id)) then - color = 1 - else - color = 2 - endif - key = 0 - call MPI_COMM_SPLIT (MPI_COMM_WORLD, color, key,& - local_World(id), ierr) - call MPI_COMM_RANK(local_world(id),local_proc_id(id),ierr) - enddo - - end subroutine MPH_local_SE_overlap - - -!--------------- subroutine MPH_global_SE_overlap () ------------ - - subroutine MPH_global_SE_overlap() - implicit none - integer id, i - -! record Acomponent for each component - do id = 1, total_components - components(id)%name = component_names(id) - components(id)%num_process = local_totProcs(id) - do i = low_proc_limit(id), up_proc_limit(id) - components(id)%process_list(i-low_proc_limit(id)+1)=i - enddo - enddo - -! everybody lists the complete info - do id = 1, total_components - if (low_proc_limit(id) .le. global_proc_id .and.& - global_proc_id .le. up_proc_limit(id)) then - write(*,*)'I am proc ', local_proc_id(id), ' in ',& - component_names(id), ' , which is proc ',& - global_proc_id, ' in global_world' - write(*,*)'infos I have for all proc of all components are:' - do i = 1, total_components - write(*,*)' ', components(i)%name - write(*,*)' ', components(i)%num_process - write(*,*)' ', components(i)%process_list(1:9) - enddo - endif - enddo - - end subroutine MPH_global_SE_overlap - - -!----------- subroutine PE_in_component (name, comm) ------------ - - logical function PE_in_component (name, comm) - implicit none - character*(*) name - integer id, comm - - id = MPH_find_name(name, component_names, total_components) - if (low_proc_limit(id) .le. global_proc_id .and.& - global_proc_id .le. up_proc_limit(id)) then - comm = local_world(id) - PE_in_component = .true. - else - PE_in_component = .false. - endif - - end function PE_in_component - - -!------ subroutine MPH_comm_join_SE_overlap (name1, name2, comm_joined) --- - - subroutine MPH_comm_join_SE_overlap (name1, name2, comm_joined) - implicit none - integer id1, id2 - - character*(*) name1, name2 - integer comm_joined, color, key - logical con1, con2 - - id1 = MPH_find_name(name1,component_names,total_components) - id2 = MPH_find_name(name2,component_names,total_components) - -! the order of two components does matter: first one has lower ranks in -! the new joined communicator, and second one has higher ranks. - - con1 = (low_proc_limit(id1) .le. global_proc_id) .and.& - (global_proc_id .le. up_proc_limit(id1)) - con2 = (low_proc_limit(id2) .le. global_proc_id).and.& - (global_proc_id .le. up_proc_limit(id2)) - - if (con1 .or. con2) then - color = 1 - if (con1) then - key = local_proc_id(id1) - else - key = global_totProcs + local_proc_id(id2) - endif - else - color = 2 - key = 0 - endif - - call MPI_COMM_SPLIT (MPI_COMM_WORLD,color,key,comm_joined,ierr) - - end subroutine MPH_comm_join_SE_overlap - - -!---- function MPH_read_list_SE_overlap (filename, filetag, namelist, -!---- low, up, num, local_num) ------ - - integer function MPH_read_list_SE_overlap (filename, filetag,& - namelist, low, up, num, local_num) - implicit none - integer i, num - character*(*) filename, filetag - character*16 namelist(num), firstline, temp - integer itemp1, itemp2 - integer low(num), up(num), local_num(num) - - open(10, file=filename, status='unknown') - read(10, *, end=100) firstline - if (firstline .ne. filetag) then - print *, 'ERROR: filetag inconsistent', filename - print *, 'ERROR: ', filetag, '!=', firstline - stop - endif - - read(10, *, end=200) temp - if (temp .ne. "BEGIN") then - print *, 'ERROR: no BEGIN in ', filename - stop - endif - - do i = 1, num - read(10, *, err=300, end=400) temp, itemp1, itemp2 - if (temp .eq. "END") goto 500 - namelist(i) = temp - low(i) = itemp1 - up(i) = itemp2 - local_num(i) = itemp2 - itemp1 + 1 - enddo - -100 print *, 'ERROR: no filetag in ', filename - stop - -200 print *, 'ERROR: no BEGIN in ', filename - stop - -300 if (temp .eq. "END") then - goto 500 - else - print *, 'ERROR: either: no END in ', filename - print *, ' or: does not provide correct format as' - print *, ' in input example: ocean 11 18' - stop - endif - -400 print *, 'ERROR: no END in ', filename - stop - -500 MPH_read_list_SE_overlap = i - 1 - close(10) - - return - end function MPH_read_list_SE_overlap - - -!--------- some special inquiry functions for MPH3 ----------- - - integer function MPH_local_proc_id_SE_overlap(id) - integer id - MPH_local_proc_id_SE_overlap = local_proc_id(id) - end function MPH_local_proc_id_SE_overlap - - integer function MPH_local_world_SE_overlap(id) - integer id - MPH_local_world_SE_overlap = local_world(id) - end function MPH_local_world_SE_overlap - -! -- the following two functions are common for MPH2 and MPH3 - - integer function MPH_low_proc_limit(id) - integer id - MPH_low_proc_limit = low_proc_limit(id) - end function MPH_low_proc_limit - - integer function MPH_up_proc_limit(id) - integer id - MPH_up_proc_limit = up_proc_limit(id) - end function MPH_up_proc_limit - - end module MPH_Single_Exec_Overlap - - -! ============================================================== -! module MPH_all -! ============================================================== - - module MPH_all - - use MPH_Multi_Exec - use MPH_Single_Exec - use MPH_Single_Exec_Overlap - - end module MPH_all diff --git a/cesm/models/utils/mct/testsystem/testall/pop.F90 b/cesm/models/utils/mct/testsystem/testall/pop.F90 deleted file mode 100644 index 02440d3..0000000 --- a/cesm/models/utils/mct/testsystem/testall/pop.F90 +++ /dev/null @@ -1,650 +0,0 @@ -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!----------------------------------------------------------------------- -! CVS $Id: pop.F90,v 1.15 2004-03-04 20:04:17 eong Exp $ -! CVS $Name: $ -!BOP ------------------------------------------------------------------- -! -! !ROUTINE: pop2_2 -- dummy ocean model for unit tester -! -! !DESCRIPTION: -! An ocean model subroutine to test functionality of MPH and MCT. -! -! !INTERFACE: - subroutine pop2_2 (POP_World) -! -! !USES: -! - use MPH_all -!---Component Model Registry - use m_MCTWorld,only: ThisMCTWorld - use m_MCTWorld,only: MCTComponentRootRank => ComponentRootRank - use m_MCTWorld,only: MCTWorld_init => init - use m_MCTWorld,only: MCTWorld_clean => clean -!---Intercomponent communications scheduler - use m_Router,only: Router - use m_Router,only: MCT_Router_init => init - use m_Router,only: MCT_Router_clean => clean - use m_Transfer,only: MCT_Send => send - use m_Transfer,only: MCT_Recv => recv -!---Field Storage DataType and associated methods - use m_AttrVect,only : AttrVect - use m_AttrVect,only : MCT_AtrVt_init => init - use m_AttrVect,only : MCT_AtrVt_clean => clean - use m_AttrVect,only : MCT_AtrVt_lsize => lsize - use m_AttrVect,only : MCT_AtrVt_nReal => nRAttr - use m_AttrVect,only : MCT_AtrVt_nInteger => nIAttr - use m_AttrVect,only : AttrVect_zero => zero - use m_AttrVect,only : AttrVect_Copy => Copy - use m_AttrVectComms,only : AttrVect_gather => gather -!---Domain Decomposition Descriptor DataType and associated methods - use m_GlobalSegMap,only: GlobalSegMap - use m_GlobalSegMap,only: MCT_GSMap_init => init - use m_GlobalSegMap,only: MCT_GSMap_clean => clean - use m_GlobalSegMap,only: MCT_GSMap_gsize => gsize - use m_GlobalSegMap,only: MCT_GSMap_lsize => lsize - use m_GlobalSegMap,only: MCT_GSMap_ngseg => ngseg - use m_GlobalSegMap,only: MCT_GSMap_nlseg => nlseg - use m_GlobalMap,only : GlobalMap - use m_GlobalMap,only : GlobalMap_init => init - use m_GlobalMap,only : GlobalMap_clean => clean -!---GlobalSegMap Communication Methods - use m_GlobalSegMapComms,only: GlobalSegMap_bcast => bcast - use m_GlobalSegMapComms,only: GlobalSegMap_send => send - use m_GlobalSegMapComms,only: GlobalSegMap_recv => recv - use m_GlobalSegMapComms,only: GlobalSegMap_isend => isend -!---Methods for Exchange of GlobalMapping Objects - use m_ExchangeMaps,only: ExchangeMap -!---Coordinate Grid DataType and associated methods - use m_GeneralGrid,only : GeneralGrid - use m_GeneralGrid,only : MCT_GGrid_init => init - use m_GeneralGrid,only : MCT_GGrid_clean => clean - use m_GeneralGrid,only : MCT_GGrid_dims => dims - use m_GeneralGrid,only : MCT_GGrid_lsize => lsize - use m_GeneralGrid,only : MCT_GGrid_indexIA => indexIA - use m_GeneralGrid,only : MCT_GGrid_indexRA => indexRA - use m_GeneralGrid,only : MCT_GGrid_exportIAttr => exportIAttr - use m_GeneralGrid,only : MCT_GGrid_importIAttr => importIAttr - use m_GeneralGrid,only : MCT_GGrid_exportRAttr => exportRAttr - use m_GeneralGrid,only : MCT_GGrid_importRAttr => importRAttr - use m_GeneralGrid,only : MCT_GGrid_SortPermute => sortpermute - use m_GeneralGridComms,only: MCT_GGrid_send => send - use m_GeneralGridComms,only: MCT_GGrid_scatter => scatter - use m_GeneralGridComms,only: MCT_GGrid_gather => gather -!---Spatial Integral DataType and associated methods - use m_SpatialIntegral,only : MCT_SpatialIntegral => SpatialIntegral - use m_SpatialIntegral,only : MCT_SpatialAverage => SpatialAverage - use m_SpatialIntegral,only : MCT_MaskedSpatialIntegral => & - MaskedSpatialIntegral - use m_SpatialIntegral,only : MCT_MaskedSpatialAverage => & - MaskedSpatialAverage - -!---mpeu List datatype - use m_List, only : List - use m_List, only : List_clean => clean - use m_List, only : List_exportToChar => exportToChar -!---mpeu routines for MPI communications - use m_mpif90 -!---mpeu timers - use m_zeit - - use m_stdio - use m_ioutil, only: luavail - use m_die - -!---Tester Modules - use m_ACTEST, only : Accumulator_test => testall - use m_AVTEST, only : AttrVect_test => testall - use m_AVTEST, only : AttrVect_identical => Identical - use m_GGRIDTEST, only : GGrid_test => testall - use m_GGRIDTEST, only : GGrid_identical => Identical - use m_GMAPTEST, only : GMap_test => testall - use m_GSMAPTEST, only : GSMap_test => testall - use m_GSMAPTEST, only : GSMap_identical => Identical - use m_MCTWORLDTEST, only : MCTWorld_test => testall - use m_ROUTERTEST, only : Router_test => testall - use m_SMATTEST, only : sMat_test => testall - use m_SMATTEST, only : sMat_identical => Identical - -! -! !REVISION HISTORY: -! Oct00 - Yun (Helen) He and Chris Ding, NERSC/LBNL - initial version -! 19Nov00 - R. Jacob - interface with mct -! 09Feb01 - R. Jacob - add MPI_Barrier -! 25Feb01 - R. Jacob - mpeu timing and MPE -! 15Feb02 - R. Jacob - new MCTWorld_init interface -! 13Jul02 - E. Ong - introduce a POP grid -!EOP ___________________________________________________________________ - - implicit none - - character(len=*), parameter :: popname='pop2_2' - -!----------------------- MPH vars - - integer myProc, myProc_global, mySize, root - integer Global_World, POP_World - integer ncomps, mycompid, coupler_id - -! SparseMatrix dimensions and Processor Layout - integer :: Nax, Nay ! Atmosphere lons, lats - integer :: Nox, Noy ! Ocean lons, lats - integer :: NPROCS_LATA, NPROCS_LONA ! Processor layout - -!----------------------- MCT vars - - ! Variables used for GlobalSegMap - integer,dimension(1) :: starts,lengths - integer :: osize,osize2 - integer :: i,j,k,n - - ! Arrays used to test MCT import/export routines - integer,dimension(:),pointer :: MaskVector - integer, dimension(:), pointer :: dummyI - real, dimension(:), pointer :: dummyR - integer :: latindx,lonindx,gridindx,status - integer :: length - integer :: dAindx - real :: pi - - ! Ocean GeneralGrid - type(GeneralGrid) :: POPGrid, dPOPGrid - - ! Test grid for scatter,gather - type(GeneralGrid) :: scatterGGrid, gatherGGrid - - ! Ocean GlobalSegMap - type(GlobalSegMap) :: OGSMap - - ! Ocean GlobalSegMap from coupler - type(GlobalSegMap) :: CPL_OGSMap - - ! GSMap for testing GlobalSegMapComms - type(GlobalSegMap) :: inGSMap - - ! Ocean GlobalMap - type(GlobalMap) :: OGMap - - ! Router from Cpl to Ocn - type(Router) :: Cpl2Ocn - - ! Ocean Inputs from the Coupler and Integral - type(AttrVect) :: OinputAV, IntegratedOinputAV - - ! Ocean Outputs to the Coupler - type(AttrVect) :: OoutputAV - - ! Temporary Vars for hmv tests - type(AttrVect) :: gatherAV_ocn - integer :: unit - -#ifdef MPE -#include "mpe.h" -#endif - -! Set the value of pi: - pi = acos(-1.0) - -!-------------------------begin code - - call MPI_COMM_DUP (MPI_COMM_WORLD, Global_World, ierr) - call MPI_COMM_RANK (Global_World, myProc_global, ierr) - call MPI_COMM_RANK (POP_World, myProc, ierr) - call MPI_COMM_SIZE(POP_World,mySize,ierr) - - if (myProc==0) call MPH_redirect_output ('pop') -! write(*,*) myProc, ' in pop === ', myProc_global, ' in global' -! write(*,*) 'MPH_local_proc_id_ME_SE()=', MPH_local_proc_id_ME_SE() -! write(*,*) 'MPH_global_proc_id()=', MPH_global_proc_id() - - -!------------------------------------------------------- -! Begin attempts to use MCT -#ifdef MPE - call mpe_logging_init(myProc_global,init_s,init_e,gsmi_s,gsmi_e, & - atri_s,atri_e,routi_s,routi_e,send_s,send_e,recv_s,recv_e, & - clean_s,clean_e) -#endif - - ! Get the coupler's component id - coupler_id = MPH_get_component_id("coupler") - - ! Initialize MCTWorld - ncomps=MPH_total_components() - mycompid=MPH_component_id_ME_SE() - call zeit_ci('Oworldinit') - call MCTWorld_init(ncomps,MPI_COMM_WORLD,POP_World,mycompid) - call zeit_co('Oworldinit') - - call MCTWorld_test("POP::MCTWorld",6200+myProc) - - ! Get the Sparse Matrix dimensions and processor layout - root = MCTComponentRootRank(coupler_id,ThisMCTWorld) - call MPI_BCAST(Nax,1,MP_INTEGER,root,MPI_COMM_WORLD,ierr) - call MPI_BCAST(Nay,1,MP_INTEGER,root,MPI_COMM_WORLD,ierr) - call MPI_BCAST(Nox,1,MP_INTEGER,root,MPI_COMM_WORLD,ierr) - call MPI_BCAST(Noy,1,MP_INTEGER,root,MPI_COMM_WORLD,ierr) - call MPI_BCAST(NPROCS_LATA,1,MP_INTEGER,root,MPI_COMM_WORLD,ierr) - call MPI_BCAST(NPROCS_LONA,1,MP_INTEGER,root,MPI_COMM_WORLD,ierr) - - - ! Load a POP grid on the ROOT PROCESS - -if(myProc==0) then - - write(*,*) popname, ":: Initializing Ocean General Grid" - -! NOTE: Since POP grids already have a predefined order, -! do not impose a sorting order upon initialization - - call convertPOPT(POPGrid, & - "../../data/grid.320x384.da", & - "../../data/kmt_full_40.da", Nox, Noy) - - call GGrid_test(POPGrid,"POP::POPGrid",3400+myProc) - -! Write out the basic things we initialized - - write(stdout,'(3a,i1)') popname, ":: Initialized POP GeneralGrid variable POPGrid.", & - "Number of dimensions = ",MCT_GGrid_dims(POPGrid) - write(stdout,'(2a,i8)') popname, ":: Number of grid points in POPGrid=", & - MCT_GGrid_lsize(POPGrid) - write(stdout,'(2a,i8)') popname, ":: Number of latitudes Noy=", Noy - write(stdout,'(2a,i8)') popname, ":: Number of longitudes Nox=", Nox - write(stdout,'(2a,i8)') popname, ":: Number of grid points Nox*Nox=", Noy*Nox - write(stdout,'(3a)') popname, ":: POPGrid%coordinate_list = ", & - List_exportToChar(POPGrid%coordinate_list) -! write(stdout,'(3a)') popname, ":: POPGrid%coordinate_sort_order = ", & -! List_exportToChar(POPGrid%coordinate_sort_order) - write(stdout,'(3a)') popname, ":: POPGrid%weight_list = ", & - List_exportToChar(POPGrid%weight_list) - write(stdout,*) popname, ":: POPGrid%other_list = ", & - ! * is used for SUPER_UX compatibility - List_exportToChar(POPGrid%other_list) - write(stdout,'(3a)') popname, ":: POPGrid%index_list = ", & - List_exportToChar(POPGrid%index_list) - write(stdout,'(2a,i3)') popname, ":: Number of integer attributes stored in POPGrid=", & - MCT_AtrVt_nInteger(POPGrid%data) - write(stdout,'(2a,i3)') popname, ":: Total Number of real attributes stored in POPGrid=", & - MCT_AtrVt_nReal(POPGrid%data) - -! Get POPGrid attribute indicies - latindx=MCT_GGrid_indexRA(POPGrid,'grid_center_lat') - lonindx=MCT_GGrid_indexRA(POPGrid,'grid_center_lon') - -! NOTE: The integer attribute GlobGridNum is automatically -! appended to any General Grid. Store the grid numbering -! scheme (used in the GlobalSegMap) here. - gridindx=MCT_GGrid_indexIA(POPGrid,'GlobGridNum') - - do i=1,MCT_GGrid_lsize(POPGrid) - POPGrid%data%iAttr(gridindx,i)=i - enddo - -! Check the weight values of the grid_area attribute - - dAindx = MCT_GGrid_indexRA(POPGrid, 'grid_area') - - write(stdout,'(2a)') popname, & - ':: Various checks of GeneralGrid POPGrid Weight data...' - write(stdout,'(2a,f12.6)') popname, & - ':: direct ref--POPGrid 1st dA entry=.', & - POPGrid%data%rAttr(dAindx,1) - write(stdout,'(2a,f12.6)') popname, & - ':: direct ref--POPGrid last dA entry=.', & - POPGrid%data%rAttr(dAindx,MCT_GGrid_lsize(POPGrid)) - write(stdout,'(2a,f12.6)') popname, & - ':: Sum of dA(1,...,Nox*Noy)=.', sum(POPGrid%data%rAttr(dAindx,:)) - write(stdout,'(2a,f12.6)') popname, & - ':: Unit Sphere area 4 * pi=.', 4.*pi - -! Check on coordinate values (and check some export functions, too...) - - allocate(dummyR(MCT_GGrid_lsize(POPGrid)), stat=ierr) - if(ierr/=0) call die(popname, "allocate(dummyR)", ierr) - - call MCT_GGrid_exportRAttr(POPGrid, 'grid_center_lat', dummyR, length) - - write(stdout,'(2a)') popname, & - ':: Various checks of GeneralGrid POPGrid coordinate data...' - write(stdout,'(2a,i8)') popname, & - ':: No. exported POPGrid latitude values =.',length - write(stdout,'(2a,f12.6)') popname, & - ':: export--POPGrid 1st latitude=.',dummyR(1) - write(stdout,'(2a,f12.6)') popname, & - ':: export--POPGrid last latitude=.',dummyR(length) - write(stdout,'(2a,f12.6)') popname, & - ':: direct ref--POPGrid 1st latitude=.', & - POPGrid%data%rAttr(latindx,1) - write(stdout,'(2a,f12.6)') popname, & - ':: direct ref--POPGrid last latitude=.', & - POPGrid%data%rAttr(latindx,length) - write(stdout,'(2a,f12.6)') popname, & - ':: direct ref--POPGrid 1st longitude=.', & - POPGrid%data%rAttr(lonindx,1) - write(stdout,'(2a,f12.6)') popname, & - ':: direct ref--POPGrid last longitude=.', & - POPGrid%data%rAttr(lonindx,MCT_GGrid_lsize(POPGrid)) - write(stdout,'(2a)') popname, & - ':: End checks of GeneralGrid POPGrid coordinate data.' - -! Check the GlobalGridNum values: - - allocate(dummyI(MCT_GGrid_lsize(POPGrid)), stat=ierr) - if(ierr/=0) call die(popname, "allocate(dummyI)", ierr) - - call MCT_GGrid_exportIAttr(POPGrid, 'GlobGridNum', dummyI, length) - - write(stdout,'(2a,i8)') popname, & - ':: No. exported POPGrid GlobalGridNum values =.',length - write(stdout,'(2a,i8)') popname, & - ':: export--POPGrid 1st GlobalGridNum =.', dummyI(1) - write(stdout,'(2a,i8)') popname, & - ':: export--POPGrid last GlobalGridNum =.', dummyI(length) - write(stdout,'(2a,i8)') popname, & - ':: direct ref--POPGrid 1st GlobalGridNum =.', & - POPGrid%data%iAttr(gridindx,1) - write(stdout,'(2a,i8)') popname, & - ':: direct ref--POPGrid last GlobalGridNum =.', & - POPGrid%data%iAttr(gridindx,length) - -! Clean temporary structures - - deallocate(dummyI, dummyR, stat=ierr) - if(ierr/=0) call die(popname, "deallocate(dummyI...)", ierr) - -endif ! if(myProc==0) - -! send the ocean's grid from the ocean's root to the -! coupler's root. 2800 is the randomly chosen tag base. -if(myProc==0) call MCT_GGrid_send(POPGrid,coupler_id,2800,ierr) - -!:::::::::::::::::::::::::::::::::::::::::::::::::::: - - ! Describe OGSMap, the ocean grid decomposition - - ! number of local oceanpoints - osize = (Noy * Nox)/mySize - osize2 = osize - - ! (Noy *Nox)/mySize isnt an integer, give extra points to last proc. - if(myProc == mySize - 1) then - osize = osize + mod(Noy*Nox,mySize) - endif - - ! find starting point in the numbering scheme - ! numbering scheme is same as that used in ocean model. - starts(1) = (myProc * osize2) +1 - lengths(1) = osize - - ! describe this information in a Global Map for the ocean. - call zeit_ci('OGSMapinit') - call MCT_GSMap_init(OGSMap,starts,lengths,0,POP_World,mycompid) - call zeit_co('OGSMmapinit') - -!!! test some GlobalSegMap functions -! write(*,*)myProc,'number of global segs is',MCT_GSMap_ngseg(OGSMap) -! write(*,*)myProc,'local size is',MCT_GSMap_lsize(OGSMap,CPL_World) -! write(*,*)myProc,'global size is',MCT_GSMap_gsize(OGSMap) - - ! make a sample GlobalMap based on the local sizes of the GlobalSegMap - call GlobalMap_init(OGMap,mycompid,MCT_GSMap_lsize(OGSMap,POP_World), & - POP_World) - call GMap_test(GMap=OGMap,Identifier="POP::OGMap", & - mycomm=POP_World,device=4200+myProc) - - ! lets exchange maps with the coupler - call ExchangeMap(OGMap,POP_World,CPL_OGSMap,coupler_id,ierr) - if(ierr/=0) call die(popname,"call ExchangeMap") - - call GMap_test(GMap=OGMap,Identifier="POP::OGMap", & - mycomm=POP_World,device=4300+myProc) - call GSMap_test(CPL_OGSMap,"POP::CPL_OGSMap",POP_World,5200+myProc) - - ! Compare this to sending and recieving maps - if(myProc==0) then - - call GlobalSegMap_recv(inGSMap,coupler_id,777) - if (.NOT.(GSMap_identical(inGSMap,CPL_OGSMap))) then - call die(popname,"GSMap_identical(inGSMap,CPL_OGSMap)") - endif - call MCT_GSMap_clean(inGSMap) - - call GlobalSegMap_recv(inGSMap,coupler_id,888) - if (.NOT.(GSMap_identical(inGSMap,CPL_OGSMap))) then - call die(popname,"GSMap_identical(inGSMap,CPL_OGSMap)") - endif - call MCT_GSMap_clean(inGSMap) - - endif - -!:::::::GGRID COMMUNICATIONS TESTING:::::::! - - call MCT_GGrid_scatter(POPGrid,scatterGGrid,OGMap,0,POP_World) - call MCT_GGrid_gather(scatterGGrid,gatherGGrid,OGMap,0,POP_World) - - if(myProc==0) then - if(.NOT. GGrid_identical(POPGrid,gatherGGrid,0.1) ) then - call die(popname,"GGrid Comms test failed") - endif - endif - -! declare an attrvect to hold all ocean model inputs -! NOTE: the size of the AttrVect is set to be the local -! size of the GSMap. - - call zeit_ci('OInputAVinit') - - call MCT_AtrVt_init(OinputAV, & - rList=& -! net solar radiation - "solrad:& -! downward direct visible radiation - &dirvis:& -! downward diffuse visible radiation - &difvis:& -! downward direct near-infrared radiation - &dirnif:& -! downward diffuse near-infrared radiation - &difnif:& -! convective precip - &precc:& -! large-scale precip - &precl",& - lsize=MCT_GSMap_lsize(OGSMap, POP_World)) - - call zeit_co('OinputAVinit') - -! declare an attrvect to hold all ocean model outputs -! NOTE: the size of the AttrVect is set to be the local -! size of the GSMap. - - call zeit_ci('OoutputAVinit') - - call MCT_AtrVt_init(OoutputAV, & - rList=& -! East-West Gradient of Ocean Surface Height - "dhdx:& -! North-South Gradient of Ocean Surface Height - &dhdy:& -! Heat of Fusion of Ocean Water - &Qfusion:& -! Sea Surface Temperature - &SST:& -! Salinity - &salinity:& -! East Component of the Surface Current - &Uocean:& -! East Component of the Surface Current - &Vocean",& - lsize=MCT_GSMap_lsize(OGSMap, POP_World)) - - call zeit_co('OoutputAVinit') - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!--Build Router -! -! Intialize router between atmosphere and coupler using AGSMap. -! This call must be paired with a similar call in cp - call zeit_ci('OCplRouterInit') - call MCT_Router_init(coupler_id,OGSMap,POP_World,Cpl2Ocn) - call zeit_co('OCplRouterInit') - - call Router_test(Cpl2Ocn,"POP::Cpl2Ocn",7200+myProc) - -!::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: - - ! Lets prepare to do some neat integrals using MCT. - ! First, we must scatter the Ocean Grid: - - call MCT_GGrid_scatter(POPGrid, dPOPGrid, OGSMap, 0, POP_World) - - ! Then, receive the accumulated and interpolated attrvect from the coupler - if(myProc == 0) write(stdout,*) popname,':: Before MCT_RECV from CPL.' - call zeit_ci('OinputAVrecv') - call MCT_Recv(OinputAV,Cpl2Ocn) - call zeit_co('OinputAVrecv') - call AttrVect_test(OinputAV,"POP::OinputAV",2600) - if(myProc == 0) write(stdout,*) popname,':: After MCT_RECV from CPL.' - - ! Lets check the values to make sure our asci matrix file - ! corresponds to the imask in our GeneralGrid. - allocate(MaskVector(MCT_GGrid_lsize(dPOPGrid)), stat=ierr) - if(ierr/=0) call die(popname, "allocate(dPOPGrid)", ierr) - - call MCT_GGrid_exportIAttr(dPOPGrid,"grid_imask",MaskVector,k) - - if(MCT_GGrid_lsize(dPOPGrid)/=k) then - call die(popname,"MCT_GGrid_exportIAttr failed") - endif - - do i=1,k - if(MaskVector(i)==0) then - if(abs(OinputAV%rAttr(1,i)-MaskVector(i)) > 1e-4) then - call die(popname,"GeneralGrid Mask does not match & - &matrix file mask") - endif - endif - enddo - - deallocate(MaskVector,stat=ierr) - if(ierr/=0) call die(popname,"deallocate(MaskVector)",ierr) - - ! TEST MAPPING FOR HMV - - call AttrVect_gather(OinputAV,gatherAV_ocn,OGSMap, & - 0,POP_World,ierr) - - if(myProc == 0) then - unit = luavail() + 9000 - write(unit,*) Nox, Noy - k=0 - do i=1,Nox - do j=1,Noy - k=k+1 - write(unit,*) gatherAV_ocn%rAttr(1,k) - enddo - enddo - call MCT_AtrVt_clean(gatherAV_ocn) - endif - - ! Now, Test the MCT Spatial Integration/Averaging Services... - if(myProc==0)write(stdout,'(3a)') popname,':: on-Root test of MCT Spatial ', & - 'Integration Services...' - - ! simple unmasked integral case: - - call MCT_SpatialIntegral(OinputAV, integratedOinputAV, dPOPGrid, 'grid_area', & - comm=POP_World) - - if(myProc==0)then - do i=1,MCT_AtrVt_nReal(integratedOinputAV) - write(stdout,'(3a,i2,a,f12.6)') popname,':: Unmasked distributed MCT ', & - 'integral: integratedOinputAV%rAttr(',i,',1)=', & - integratedOinputAV%rAttr(i,1) - end do - endif - - call MCT_AtrVt_clean(integratedOinputAV) - - ! simple unmasked average case: - call MCT_SpatialAverage(OinputAV, integratedOinputAV, dPOPGrid, 'grid_area', & - comm=POP_World) - -if(myProc==0)then - do i=1,MCT_AtrVt_nReal(integratedOinputAV) - write(stdout,'(3a,i2,a,f12.6)') popname,':: Unmasked distributed MCT ', & - 'average: averagedOinputAV%rAttr(',i,',1)=', & - integratedOinputAV%rAttr(i,1) - end do -endif - call MCT_AtrVt_clean(integratedOinputAV) - - ! masked average case... - - call MCT_MaskedSpatialAverage(inAv=OinputAV, outAv=integratedOinputAV, & - GGrid=dPOPGrid, SpatialWeightTag='grid_area', & - iMaskTags='grid_imask', UseFastMethod=.TRUE., & - comm=POP_World) - -if(myProc==0)then - do i=1,MCT_AtrVt_nReal(integratedOinputAV) - write(stdout,'(3a,i2,a,f12.6)') popname,':: Masked distributed MCT ', & - 'average (both iMask & rMask = unity): averagedOinputAV%rAttr(',i,',1)=', & - integratedOinputAV%rAttr(i,1) - end do -endif - call MCT_AtrVt_clean(integratedOinputAV) - - call GGrid_test(dPOPGrid,"POP::dPOPGrid",3500+myProc) - - ! Fill the Ocean's output with test values: - ! the first attribute will be constant, while - ! the rest will contain interolated values from OinputAV - call AttrVect_copy(aVin=OinputAV,aVout=OoutputAV, & - rList=List_exportToChar(OinputAV%rList), & - TrList=List_exportToChar(OoutputAV%rList)) - - OoutputAV%rAttr(1,:) = 30. - - ! Now, send the Ocean's output to the Coupler... - if(myProc == 0) write(stdout,*) popname,':: Before MCT_SEND to CPL.' - call zeit_ci('OoutputAVsend') - call MCT_Send(OoutputAV,Cpl2Ocn) - call zeit_co('OoutputAVsend') - if(myProc == 0) write(stdout,*) popname,':: After MCT_SEND to CPL.' - - ! All Done - call zeit_ci('Ocleanup') - - ! Clean MCT datatypes - if(myProc==0) then - call MCT_GGrid_clean(POPGrid) - call MCT_GGrid_clean(gatherGGrid) - endif - - call MCT_GGrid_clean(scatterGGrid) - call MCT_GGrid_clean(dPOPGrid) - call MCT_AtrVt_clean(OinputAV) - call MCT_AtrVt_clean(OoutputAV) - call MCT_GSMap_clean(OGSMap) - call MCT_GSMap_clean(CPL_OGSMap) - call GlobalMap_clean(OGMap) - call MCT_Router_clean(Cpl2Ocn) - call MCTWorld_clean() - - call zeit_co('Ocleanup') - -! write out timing info to fortran unit 47 - call zeit_allflush(POP_World,0,47) - - -end subroutine - - - - - - - - - diff --git a/cesm/models/utils/mct/testsystem/testall/processors_map.in b/cesm/models/utils/mct/testsystem/testall/processors_map.in deleted file mode 100644 index 437337e..0000000 --- a/cesm/models/utils/mct/testsystem/testall/processors_map.in +++ /dev/null @@ -1,12 +0,0 @@ -PROCESSORS_MAP -BEGIN -atmosphere 0 1 -coupler 2 3 -ocean 4 5 -END -NPROCS_ATM 1 2 -ADD any comments in this line and below. -1) -ccm.3.6, ocean_POP, couple.PCM are all legitimate name, too. -2) -Order of names is irrelevant. diff --git a/cesm/models/utils/mct/testsystem/testall/script.jag b/cesm/models/utils/mct/testsystem/testall/script.jag deleted file mode 100644 index d62277c..0000000 --- a/cesm/models/utils/mct/testsystem/testall/script.jag +++ /dev/null @@ -1,18 +0,0 @@ -#!/bin/csh -#PBS -N mct -#PBS -j oe -#PBS -q debug - -#PBS -A cli017esm -##PBS -l feature=xt5 -#PBS -l size=16 -#PBS -l walltime=01:00:00 -#PBS -l gres=widow3 -#PBS -j oe -#PBS -S /bin/csh -V - - -cd $PBS_O_WORKDIR -date -setenv MPICH_NO_BUFFER_ALIAS_CHECK 1 -aprun -n 6 ./utmct diff --git a/cesm/models/utils/mct/testsystem/testall/ut_SparseMatrix.rc b/cesm/models/utils/mct/testsystem/testall/ut_SparseMatrix.rc deleted file mode 100644 index 3ae3629..0000000 --- a/cesm/models/utils/mct/testsystem/testall/ut_SparseMatrix.rc +++ /dev/null @@ -1,29 +0,0 @@ -#------------------------------------------------------------------------- -# Math + Computer Science Division / Argonne National Laboratory ! -#----------------------------------------------------------------------- -# CVS $Id: ut_SparseMatrix.rc,v 1.4 2003-08-11 23:24:25 eong Exp $ -# CVS $Name: $ -#------------------------------------------------------------------------- -# -# !FILE: ut_SparseMatrix.rc -# -# !DESCRIPTION: This is the resource file for the SparseMatrix unit -# tester. -# -# !SEE ALSO: ./ut_SparseMatrix.F90 (SparseMatrix unit tester). -# -# -# !REVISION HISTORY: -# -# 11Apr01 J.W. Larson -- Initial version. -# -#------------------------------------------------------------------------- -Data_Directory: ../../data -atmosphere_to_ocean_remap_file: t42_to_popx1_c_mat.asc -ocean_to_atmosphere_remap_file: popx1_to_t42_c_mat.asc -atmosphere_dimensions: 128 64 -ocean_dimensions: 320 384 - - - - diff --git a/cesm/models/utils/mct/testunit/AttrVect_Test.F90 b/cesm/models/utils/mct/testunit/AttrVect_Test.F90 deleted file mode 100644 index 3514597..0000000 --- a/cesm/models/utils/mct/testunit/AttrVect_Test.F90 +++ /dev/null @@ -1,1907 +0,0 @@ -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Math and Computer Science Division, Argonne National Laboratory ! -!----------------------------------------------------------------------- -!BOP ------------------------------------------------------------------- -! -! !ROUTINE: AttrVectTest.F90 -- Unit tests for MCT Attribute Vector -! -! !DESCRIPTION: Unit tests for all subroutines in mct/m_AttrVect.F90 -! and a top level program to call them all. -! -! !REVISION HISTORY: -! 11Jan11 - Sheri Mickelson - Initial version. -!EOP ___________________________________________________________________ - -!#################################### -!# -!# Call of of the tests for m_AttrVect -!# -!#################################### - -subroutine testAttrVect(mypid, AVui) - -implicit none - -integer mypid -integer AVui - -call testAttrVect_lsize(mypid,AVui) - -call testAttrVect_clean(mypid,AVui) - -call testAttrVect_init(mypid,AVui) - -call testAttrVect_zero(mypid,AVui) - -call testAttrVect_nIAttr(mypid,AVui) - -call testAttrVect_nRAttr(mypid,AVui) - -call testAttrVect_indexIA(mypid,AVui) - -call testAttrVect_indexRA(mypid,AVui) - -call testAttrVect_getIList(mypid,AVui) - -call testAttrVect_getRList(mypid,AVui) - -call testAttrVect_exportIList(mypid,AVui) - -call testAttrVect_exportRList(mypid,AVui) - -call testAttrVect_exportIListToChar(mypid,AVui) - -call testAttrVect_exportRListToChar(mypid,AVui) - -call testAttrVect_appendIAttr(mypid,AVui) - -call testAttrVect_appendRAttr(mypid,AVui) - -call testAttrVect_exportIAttr(mypid,AVui) - -call testAttrVect_exportRAttr(mypid,AVui) - -call testAttrVect_importIAttr(mypid,AVui) - -call testAttrVect_importRAttr(mypid,AVui) - -call testAttrVect_copy(mypid,AVui) - -call testAttrVect_sort(mypid,AVui) - -call testAttrVect_permute(mypid,AVui) - -call testAttrVect_unpermute(mypid,AVui) - -call testAttrVect_sortPermute(mypid,AVui) - -call testAttrVect_sharedAttrIndexList(mypid,Avui) - -end subroutine - -!#################################### -!# -!# Test AttrVect_lsize -!# -!#################################### -subroutine testAttrVect_lsize(mypid,AVui) - -use m_AttrVect,only : MCT_AtrVt_init => init -use m_AttrVect,only : MCT_AtrVt_lsize => lsize -use m_AttrVect,only : MCT_AtrVt_clean => clean -use m_AttrVect - -implicit none - -integer mypid -integer AVui -integer length -integer returnedLength - -type(AttrVect) :: av - -length = 3 - -! initialize vector -call MCT_AtrVt_init(av,iList="lat:lon:time",lsize=length) - -! get the size of the new vector -returnedLength = MCT_AtrVt_lsize(av) - -! test to see if the size is correct -if(returnedLength == length) then - if(mypid .eq. 0) call outputTestStatus(AVui,"AttrVect_lsize",1,"PASS") - if(mypid .eq. 0) call outputRoutineStatus(AVui,"AttrVect_lsize","PASS") -else - if(mypid .eq. 0) call outputTestStatus(AVui,"AttrVect_lsize",1,"FAIL") - if(mypid .eq. 0) call outputRoutineStatus(AVui,"AttrVect_lsize","FAIL") -endif - -call MCT_AtrVt_clean(av) - -end subroutine - -!#################################### -!# -!# Test AttrVect_clean -!# -!#################################### -subroutine testAttrVect_clean(mypid,AVui) - -use m_AttrVect,only : MCT_AtrVt_init => init -use m_AttrVect,only : MCT_AtrVt_clean => clean -use m_AttrVect,only : MCT_AtrVt_lsize => lsize -use m_AttrVect - -implicit none - -integer mypid -integer AVui - -type(AttrVect) :: av -integer ier, result - -result = 0 - -! test the different optional args to make sure all combos work -! first initializes new vector -! second, clean the vector -! finally, check to make sure size is zero - -call MCT_AtrVt_init(av,iList="lat:lon:time") -call MCT_AtrVt_clean(av, ier) -if(MCT_AtrVt_lsize(av) == 0 .AND. ier == 0) then - if(mypid .eq. 0) call outputTestStatus(AVui,"AttrVect_clean",1,"PASS") -else - if(mypid .eq. 0) call outputTestStatus(AVui,"AttrVect_clean",1,"FAIL") - result = 1 -endif - -call MCT_AtrVt_init(av,iList="lat:lon:time") -call MCT_AtrVt_clean(av) -if(MCT_AtrVt_lsize(av) == 0) then - if(mypid .eq. 0) call outputTestStatus(AVui,"AttrVect_clean",2,"PASS") -else - if(mypid .eq. 0) call outputTestStatus(AVui,"AttrVect_clean",2,"FAIL") - result = 1 -endif - -if (result == 0)then - if(mypid .eq. 0) call outputRoutineStatus(AVui,"AttrVect_clean","PASS") -else - if(mypid .eq. 0) call outputRoutineStatus(AVui,"AttrVect_clean","FAIL") -endif -end subroutine - -!#################################### -!# -!# Test AttrVect_init -!# -!#################################### -subroutine testAttrVect_init(mypid,AVui) - -use m_AttrVect,only : MCT_AtrVt_init => init -use m_AttrVect,only : MCT_AtrVt_clean => clean -use m_AttrVect - -implicit none - -integer mypid -integer AVui - -type(AttrVect) :: av -integer ier - -! test all of the combinations of optional args -! first, try an initialization -! then write out a pass staement if returned successfully -! fianlly, clean the vector - -call MCT_AtrVt_init(av) -if(mypid .eq. 0) call outputTestStatus(AVui,"AttrVect_init",1,"PASS") -call MCT_AtrVt_clean(av, ier) - -call MCT_AtrVt_init(av,iList='index') -if(mypid .eq. 0) call outputTestStatus(AVui,"AttrVect_init",2,"PASS") -call MCT_AtrVt_clean(av, ier) - -call MCT_AtrVt_init(av,rList='value') -if(mypid .eq. 0) call outputTestStatus(AVui,"AttrVect_init",3,"PASS") -call MCT_AtrVt_clean(av, ier) - -call MCT_AtrVt_init(av,iList='index',rList='value') -if(mypid .eq. 0) call outputTestStatus(AVui,"AttrVect_init",4,"PASS") -call MCT_AtrVt_clean(av, ier) - -call MCT_AtrVt_init(av,iList='index',lsize=1) -if(mypid .eq. 0) call outputTestStatus(AVui,"AttrVect_init",5,"PASS") -call MCT_AtrVt_clean(av, ier) - -call MCT_AtrVt_init(av,rList='value',lsize=1) -if(mypid .eq. 0) call outputTestStatus(AVui,"AttrVect_init",6,"PASS") -call MCT_AtrVt_clean(av, ier) - -call MCT_AtrVt_init(av,iList='index',rList='value',lsize=1) -if(mypid .eq. 0) call outputTestStatus(AVui,"AttrVect_init",7,"PASS") -call MCT_AtrVt_clean(av, ier) - -call MCT_AtrVt_init(av,lsize=1) -if(mypid .eq. 0) call outputTestStatus(AVui,"AttrVect_init",8,"PASS") -call MCT_AtrVt_clean(av, ier) - -if(mypid .eq. 0) call outputRoutineStatus(AVui,"AttrVect_init","PASS") -end subroutine - -!#################################### -!# -!# Test AttrVect_zero -!# -!#################################### -subroutine testAttrVect_zero(mypid,AVui) - -use m_AttrVect,only : MCT_AtrVt_init => init -use m_AttrVect,only : MCT_AtrVt_zero => zero -use m_AttrVect,only : MCT_AtrVt_clean => clean -use m_AttrVect,only : MCT_AtrVt_lsize => lsize -use m_AttrVect -use m_realkinds,only : SP,DP,FP - -implicit none - -integer mypid -integer AVui - -integer result, localResult - -type(AttrVect) :: av - -integer i,x,y,totalSize - -integer intSize,realSize,listTotal - -real r - -totalSize = 32 -intSize = 3 -realSize = 3 -!listTotal = intSize+realSize -listTotal = 3 - -result = 0 -localResult = 0 -r = .09_FP -i = 4 - -call MCT_AtrVt_init(av,iList="lat:lon:time",rList="T:P:Q",lsize=totalSize) -av%iAttr=i -av%rAttr=r -call MCT_AtrVt_zero(av) -do x=1,listTotal -do y=1,totalSize -if(av%iAttr(x,y) /= 0 .OR. av%rAttr(x,y) /= 0._FP)then - localResult = 1 -endif -enddo -enddo -if(localResult == 0)then - if(mypid .eq. 0) call outputTestStatus(AVui,"AttrVect_zero",1,"PASS") -else - if(mypid .eq. 0) call outputTestStatus(AVui,"AttrVect_zero",1,"FAIL") - result = 1 - localResult = 0 -endif -call MCT_AtrVt_clean(av) - -call MCT_AtrVt_init(av,iList="lat:lon:time",rList="T:P:Q",lsize=totalSize) -av%iAttr=i -av%rAttr=r -call MCT_AtrVt_zero(av,zeroReals=.TRUE.,zeroInts=.TRUE.) -do x=1,listTotal -do y=1,totalSize -if(av%iAttr(x,y) /= 0 .OR. av%rAttr(x,y) /= 0._FP)then - localResult = 1 -endif -enddo -enddo -if(localResult == 0)then - if(mypid .eq. 0) call outputTestStatus(AVui,"AttrVect_zero",2,"PASS") -else - if(mypid .eq. 0) call outputTestStatus(AVui,"AttrVect_zero",2,"FAIL") - result = 1 - localResult = 0 -endif -call MCT_AtrVt_clean(av) - -call MCT_AtrVt_init(av,iList="lat:lon:time",rList="T:P:Q",lsize=totalSize) -av%iAttr=i -av%rAttr=r -call MCT_AtrVt_zero(av,zeroReals=.TRUE.,zeroInts=.FALSE.) -do x=1,listTotal -do y=1,totalSize -if(av%iAttr(x,y) == 0 .OR. av%rAttr(x,y) /= 0._FP)then - localResult = 1 -endif -enddo -enddo -if(localResult == 0)then - if(mypid .eq. 0) call outputTestStatus(AVui,"AttrVect_zero",3,"PASS") -else - if(mypid .eq. 0) call outputTestStatus(AVui,"AttrVect_zero",3,"FAIL") - result = 1 - localResult = 0 -endif -call MCT_AtrVt_clean(av) - -call MCT_AtrVt_init(av,iList="lat:lon:time",rList="T:P:Q",lsize=totalSize) -av%iAttr=i -av%rAttr=r -call MCT_AtrVt_zero(av,zeroReals=.FALSE.,zeroInts=.TRUE.) -do x=1,listTotal -do y=1,totalSize -if(av%iAttr(x,y) /= 0 .OR. av%rAttr(x,y) == 0._FP)then - localResult = 1 -endif -enddo -enddo -if(localResult == 0)then - if(mypid .eq. 0) call outputTestStatus(AVui,"AttrVect_zero",4,"PASS") -else - if(mypid .eq. 0) call outputTestStatus(AVui,"AttrVect_zero",4,"FAIL") - result = 1 - localResult = 0 -endif -call MCT_AtrVt_clean(av) - -call MCT_AtrVt_init(av,iList="lat:lon:time",rList="T:P:Q",lsize=totalSize) -av%iAttr=i -av%rAttr=r -call MCT_AtrVt_zero(av,zeroReals=.FALSE.,zeroInts=.FALSE.) -do x=1,listTotal -do y=1,totalSize -if(av%iAttr(x,y) == 0 .OR. av%rAttr(x,y) == 0._FP)then - localResult = 1 -endif -enddo -enddo -if(localResult == 0)then - if(mypid .eq. 0) call outputTestStatus(AVui,"AttrVect_zero",5,"PASS") -else - if(mypid .eq. 0) call outputTestStatus(AVui,"AttrVect_zero",5,"FAIL") - result = 1 - localResult = 0 -endif -call MCT_AtrVt_clean(av) - -if (result == 0) then - if(mypid .eq. 0) call outputRoutineStatus(AVui,"AttrVect_zero","PASS") -else - if(mypid .eq. 0) call outputRoutineStatus(AVui,"AttrVect_zero","FAIL") -endif - -end subroutine - -!#################################### -!# -!# Test AttrVect_nIAttr -!# -!#################################### -subroutine testAttrVect_nIAttr(mypid,AVui) - -use m_AttrVect,only : MCT_AtrVt_init => init -use m_AttrVect,only : MCT_AtrVt_clean => clean -use m_AttrVect,only : MCT_AtrVt_nIAttr => nIAttr -use m_AttrVect - -implicit none - -integer mypid -integer AVui - -integer length, argLength, returnedLength - -type(AttrVect) :: av - -length = 32 -argLength = 3 - -! initialize vector -call MCT_AtrVt_init(av,iList="lat:lon:time",lsize=length) - -returnedLength = MCT_AtrVt_nIAttr(av) - -if (argLength == returnedLength) then - if(mypid .eq. 0) call outputTestStatus(AVui,"AttrVect_nIAttr",1,"PASS") - if(mypid .eq. 0) call outputRoutineStatus(AVui,"AttrVect_nIAttr","PASS") -else - if(mypid .eq. 0) call outputTestStatus(AVui,"AttrVect_nIAttr",1,"FAIL") - if(mypid .eq. 0) call outputRoutineStatus(AVui,"AttrVect_nIAttr","FAIL") -endif - -call MCT_AtrVt_clean(av) - -end subroutine - -!#################################### -!# -!# Test AttrVect_nRAttr -!# -!#################################### -subroutine testAttrVect_nRAttr(mypid,AVui) - -use m_AttrVect,only : MCT_AtrVt_init => init -use m_AttrVect,only : MCT_AtrVt_clean => clean -use m_AttrVect,only : MCT_AtrVt_nRAttr => nRAttr -use m_AttrVect - -implicit none - -integer mypid -integer AVui - -integer length, argLength, returnedLength - -type(AttrVect) :: av - -length = 32 -argLength = 3 - -! initialize vector -call MCT_AtrVt_init(av,rList="T:Q:P",lsize=length) - -returnedLength = MCT_AtrVt_nRAttr(av) - -if (argLength == returnedLength) then - if(mypid .eq. 0) call outputTestStatus(AVui,"AttrVect_nRAttr",1,"PASS") - if(mypid .eq. 0) call outputRoutineStatus(AVui,"AttrVect_nRAttr","PASS") -else - if(mypid .eq. 0) call outputTestStatus(AVui,"AttrVect_nRAttr",1,"FAIL") - if(mypid .eq. 0) call outputRoutineStatus(AVui,"AttrVect_nRAttr","FAIL") -endif - -call MCT_AtrVt_clean(av) - -end subroutine - - -!#################################### -!# -!# Test AttrVect_indexIA -!# -!#################################### -subroutine testAttrVect_indexIA(mypid,AVui) - -use m_AttrVect,only : MCT_AtrVt_init => init -use m_AttrVect,only : MCT_AtrVt_clean => clean -use m_AttrVect,only : MCT_AtrVt_indexIA => indexIA -use m_AttrVect - -implicit none - -integer mypid -integer AVui - -integer length, indexFound, index - -integer result - -character(len=4) var -character(len=18) variables - -type(AttrVect) :: av - -result = 0 - -length = 32 -var = "date" -variables = "lat:lon:"//var//":time" -index = 3 !This must match the location of 'var' in above line - -! initialize vector -call MCT_AtrVt_init(av,iList=variables,lsize=length) - -indexFound = MCT_AtrVt_indexIA(av,var) -if(index == indexFound) then - if(mypid .eq. 0) call outputTestStatus(AVui,"AttrVect_indexIA",1,"PASS") -else - if(mypid .eq. 0) call outputTestStatus(AVui,"AttrVect_indexIA",1,"FAIL") - result = 1 -endif - -indexFound = MCT_AtrVt_indexIA(av,var,perrWith="ERROR") -if(index == indexFound) then - if(mypid .eq. 0) call outputTestStatus(AVui,"AttrVect_indexIA",2,"PASS") -else - if(mypid .eq. 0) call outputTestStatus(AVui,"AttrVect_indexIA",2,"FAIL") - result = 1 -endif - -indexFound = MCT_AtrVt_indexIA(av,var,perrWith="ERROR",dieWith="KILLED JOB") -if(index == indexFound) then - if(mypid .eq. 0) call outputTestStatus(AVui,"AttrVect_indexIA",3,"PASS") -else - if(mypid .eq. 0) call outputTestStatus(AVui,"AttrVect_indexIA",3,"FAIL") - result = 1 -endif - -indexFound = MCT_AtrVt_indexIA(av,var,dieWith="KILLED JOB") -if(index == indexFound) then - if(mypid .eq. 0) call outputTestStatus(AVui,"AttrVect_indexIA",4,"PASS") -else - if(mypid .eq. 0) call outputTestStatus(AVui,"AttrVect_indexIA",4,"FAIL") - result = 1 -endif - -! Check for a name that is not in the list. With 'perrwith' it should -! return 0 as an index -indexFound = MCT_AtrVt_indexIA(av,"foo",perrWith="quiet") -if(indexFound == 0) then - if(mypid .eq. 0) call outputTestStatus(AVui,"AttrVect_indexIA",5,"PASS") -else - if(mypid .eq. 0) call outputTestStatus(AVui,"AttrVect_indexIA",5,"FAIL") - result = 1 -endif - -if (result == 0) then - if(mypid .eq. 0) call outputRoutineStatus(AVui,"AttrVect_indexIA","PASS") -else - if(mypid .eq. 0) call outputRoutineStatus(AVui,"AttrVect_indexIA","FAIL") -endif - -call MCT_AtrVt_clean(av) - -end subroutine - - -!#################################### -!# -!# Test AttrVect_indexRA -!# -!#################################### -subroutine testAttrVect_indexRA(mypid,AVui) - -use m_AttrVect,only : MCT_AtrVt_init => init -use m_AttrVect,only : MCT_AtrVt_clean => clean -use m_AttrVect,only : MCT_AtrVt_indexRA => indexRA -use m_AttrVect - -implicit none - -integer mypid -integer AVui - -integer length, indexFound, index - -integer result - -character(len=1) var -character(len=8) variables - -type(AttrVect) :: av - -result = 0 - -length = 32 -var = "U" -variables = "T:Q:"//var//":P" -index = 3 !This must match the location of 'var' in above line - -! initialize vector -call MCT_AtrVt_init(av,rList=variables,lsize=length) - -indexFound = MCT_AtrVt_indexRA(av,var) -if(index == indexFound) then - if(mypid .eq. 0) call outputTestStatus(AVui,"AttrVect_indexRA",1,"PASS") -else - if(mypid .eq. 0) call outputTestStatus(AVui,"AttrVect_indexRA",1,"FAIL") - result = 1 -endif - -indexFound = MCT_AtrVt_indexRA(av,var,perrWith="ERROR") -if(index == indexFound) then - if(mypid .eq. 0) call outputTestStatus(AVui,"AttrVect_indexRA",2,"PASS") -else - if(mypid .eq. 0) call outputTestStatus(AVui,"AttrVect_indexRA",2,"FAIL") - result = 1 -endif - -indexFound = MCT_AtrVt_indexRA(av,var,perrWith="ERROR",dieWith="KILLED JOB") -if(index == indexFound) then - if(mypid .eq. 0) call outputTestStatus(AVui,"AttrVect_indexRA",3,"PASS") -else - if(mypid .eq. 0) call outputTestStatus(AVui,"AttrVect_indexRA",3,"FAIL") - result = 1 -endif - -indexFound = MCT_AtrVt_indexRA(av,var,dieWith="KILLED JOB") -if(index == indexFound) then - if(mypid .eq. 0) call outputTestStatus(AVui,"AttrVect_indexRA",4,"PASS") -else - if(mypid .eq. 0) call outputTestStatus(AVui,"AttrVect_indexRA",4,"FAIL") - result = 1 -endif - -! Check for a name that is not in the list. With 'perrwith' it should -! return 0 as an index -indexFound = MCT_AtrVt_indexRA(av,"foo",perrWith="quiet") -if(indexFound == 0) then - if(mypid .eq. 0) call outputTestStatus(AVui,"AttrVect_indexRA",5,"PASS") -else - if(mypid .eq. 0) call outputTestStatus(AVui,"AttrVect_indexRA",5,"FAIL") - result = 1 -endif - -if (result == 0) then - if(mypid .eq. 0) call outputRoutineStatus(AVui,"AttrVect_indexRA","PASS") -else - if(mypid .eq. 0) call outputRoutineStatus(AVui,"AttrVect_indexRA","FAIL") -endif - -call MCT_AtrVt_clean(av) - -end subroutine - -!#################################### -!# -!# Test AttrVect_getIList -!# -!#################################### -subroutine testAttrVect_getIList(mypid,AVui) - -use m_AttrVect,only : MCT_AtrVt_init => init -use m_AttrVect,only : MCT_AtrVt_clean => clean -use m_AttrVect,only : MCT_AtrVt_getIList => getIList -use m_AttrVect -use m_String,only : String -use m_String,only : ptr_chars - -implicit none - -integer mypid -integer AVui - -integer result, length, index - -type(String) returnVar -character(len=20)temp1 -character(len=20) var -character(len=35) variables - - -type(AttrVect) :: av - -result = 0 - -var = "date" -length = 32 -variables = "lat:lon:"//var//":time" -index = 3 !This must match the location of 'var' in above line - -! initialize vector -call MCT_AtrVt_init(av,iList=variables,lsize=length) -call MCT_AtrVt_getIList(returnVar, index, av) -write(temp1,*)ptr_chars(returnVar) -if (verify(temp1,var)==0) then - if(mypid .eq. 0) call outputTestStatus(AVui,"AttrVect_getIList",1,"PASS") -else - if(mypid .eq. 0) call outputTestStatus(AVui,"AttrVect_getIList",1,"FAIL") - result = 1 -endif - -if (result == 0) then - if(mypid .eq. 0) call outputRoutineStatus(AVui,"AttrVect_getIList","PASS") -else - if(mypid .eq. 0) call outputRoutineStatus(AVui,"AttrVect_getIList","FAIL") -endif - -call MCT_AtrVt_clean(av) - -end subroutine - - -!#################################### -!# -!# Test AttrVect_getRList -!# -!#################################### -subroutine testAttrVect_getRList(mypid,AVui) - -use m_AttrVect,only : MCT_AtrVt_init => init -use m_AttrVect,only : MCT_AtrVt_clean => clean -use m_AttrVect,only : MCT_AtrVt_getRList => getRList -use m_AttrVect -use m_String,only : String -use m_String,only : ptr_chars - -implicit none - -integer mypid -integer AVui - -integer result, length, index - -type(String) returnVar -character(len=20)temp1 -character(len=20) var -character(len=35) variables - - -type(AttrVect) :: av - -result = 0 - -var = "P" -length = 32 -variables = "T:Q:"//var//":U" -index = 3 !This must match the location of 'var' in above line - -! initialize vector -call MCT_AtrVt_init(av,rList=variables,lsize=length) -call MCT_AtrVt_getRList(returnVar, index, av) -write(temp1,*)ptr_chars(returnVar) -if (verify(temp1,var)==0) then - if(mypid .eq. 0) call outputTestStatus(AVui,"AttrVect_getRList",1,"PASS") -else - if(mypid .eq. 0) call outputTestStatus(AVui,"AttrVect_getRList",1,"FAIL") - result = 1 -endif - -if (result == 0) then - if(mypid .eq. 0) call outputRoutineStatus(AVui,"AttrVect_getRList","PASS") -else - if(mypid .eq. 0) call outputRoutineStatus(AVui,"AttrVect_getRList","FAIL") -endif - -call MCT_AtrVt_clean(av) - -end subroutine - -!#################################### -!# -!# Test AttrVect_exportIList -!# -!#################################### -subroutine testAttrVect_exportIList(mypid,AVui) - -use m_AttrVect,only : MCT_AtrVt_init => init -use m_AttrVect,only : MCT_AtrVt_clean => clean -use m_AttrVect,only : MCT_AtrVt_exportIList => exportIList -use m_AttrVect -use m_List,only : List - -implicit none - -integer mypid -integer AVui - -integer result, length - -character(len=35) variables - -type(AttrVect) :: av - -type(List) vList - -length = 32 -write(variables,*) "lat:lon:time" - -! initialize vector -call MCT_AtrVt_init(av,iList=variables,lsize=length) - -call MCT_AtrVt_exportIList(av,vList,result) - -if (result == 0) then - if(mypid .eq. 0) call outputTestStatus(AVui,"AttrVect_exportIList",1,"PASS") - if(mypid .eq. 0) call outputRoutineStatus(AVui,"AttrVect_exportIList","PASS") -else - if(mypid .eq. 0) call outputTestStatus(AVui,"AttrVect_exportIList",1,"FAIL") - if(mypid .eq. 0) call outputRoutineStatus(AVui,"AttrVect_exportIList","FAIL") -endif - -call MCT_AtrVt_clean(av) - -end subroutine - -!#################################### -!# -!# Test AttrVect_exportRList -!# -!#################################### -subroutine testAttrVect_exportRList(mypid,AVui) - -use m_AttrVect,only : MCT_AtrVt_init => init -use m_AttrVect,only : MCT_AtrVt_clean => clean -use m_AttrVect,only : MCT_AtrVt_exportRList => exportRList -use m_AttrVect -use m_List,only : List - -implicit none - -integer mypid -integer AVui - -integer result, length - -character(len=35) variables - -type(AttrVect) :: av - -type(List) vList - -length = 32 -write(variables,*) "T:P:Q" - -! initialize vector -call MCT_AtrVt_init(av,rList=variables,lsize=length) - -call MCT_AtrVt_exportRList(av,vList,result) - -if (result == 0) then - if(mypid .eq. 0) call outputTestStatus(AVui,"AttrVect_exportRList",1,"PASS") - if(mypid .eq. 0) call outputRoutineStatus(AVui,"AttrVect_exportRList","PASS") -else - if(mypid .eq. 0) call outputTestStatus(AVui,"AttrVect_exportRList",1,"FAIL") - if(mypid .eq. 0) call outputRoutineStatus(AVui,"AttrVect_exportRList","FAIL") -endif - -call MCT_AtrVt_clean(av) - -end subroutine - - -!#################################### -!# -!# Test AttrVect_exportIListToChar -!# -!#################################### -subroutine testAttrVect_exportIListToChar(mypid,AVui) - -use m_AttrVect,only : MCT_AtrVt_init => init -use m_AttrVect,only : MCT_AtrVt_clean => clean -use m_AttrVect,only : MCT_AtrVt_exportIListToChar => exportIListToChar -use m_AttrVect -use m_List,only : List - -implicit none - -integer mypid -integer AVui - -integer result, length - -character(len=35) variables -character(len=35) returnVariables - -type(AttrVect) :: av - -type(List) vList - -length = 32 -write(variables,*) "lat:lon:time" - -! initialize vector -call MCT_AtrVt_init(av,iList=variables,lsize=length) - -write(returnVariables,*) MCT_AtrVt_exportIListToChar(av) - -result = verify(variables,returnVariables) - -if (result == 0) then - if(mypid .eq. 0) call outputTestStatus(AVui,"AttrVect_exportIListToChar",1,"PASS") - if(mypid .eq. 0) call outputRoutineStatus(AVui,"AttrVect_exportIListToChar","PASS") -else - if(mypid .eq. 0) call outputTestStatus(AVui,"AttrVect_exportIListToChar",1,"FAIL") - if(mypid .eq. 0) call outputRoutineStatus(AVui,"AttrVect_exportIListToChar","FAIL") -endif - -call MCT_AtrVt_clean(av) - -end subroutine - -!#################################### -!# -!# Test AttrVect_exportRListToChar -!# -!#################################### -subroutine testAttrVect_exportRListToChar(mypid,AVui) - -use m_AttrVect,only : MCT_AtrVt_init => init -use m_AttrVect,only : MCT_AtrVt_clean => clean -use m_AttrVect,only : MCT_AtrVt_exportRListToChar => exportRListToChar -use m_AttrVect -use m_List,only : List - -implicit none - -integer mypid -integer AVui - -integer result, length - -character(len=35) variables -character(len=35) returnVariables - -type(AttrVect) :: av - -type(List) vList - -length = 32 -write(variables,*) "T:Q:P" - -! initialize vector -call MCT_AtrVt_init(av,rList=variables,lsize=length) - -write(returnVariables,*) MCT_AtrVt_exportRListToChar(av) - -result = verify(variables,returnVariables) - -if (result == 0) then - if(mypid .eq. 0) call outputTestStatus(AVui,"AttrVect_exportRListToChar",1,"PASS") - if(mypid .eq. 0) call outputRoutineStatus(AVui,"AttrVect_exportRListToChar","PASS") -else - if(mypid .eq. 0) call outputTestStatus(AVui,"AttrVect_exportRListToChar",1,"FAIL") - if(mypid .eq. 0) call outputRoutineStatus(AVui,"AttrVect_exportRListToChar","FAIL") -endif - -call MCT_AtrVt_clean(av) - -end subroutine - -!#################################### -!# -!# Test AttrVect_appendIAttr -!# -!#################################### -subroutine testAttrVect_appendIAttr(mypid,AVui) - -use m_AttrVect,only : MCT_AtrVt_init => init -use m_AttrVect,only : MCT_AtrVt_clean => clean -use m_AttrVect,only : MCT_AtrVt_appendIAttr => appendIAttr -use m_AttrVect - -implicit none - -integer mypid -integer AVui - -integer result, localResult, length - -character(len=35) variables -character(len=35) appendVariables - -type(AttrVect) :: av - -result = 0 - -length = 32 -write(variables,*) "lat:lon" -write(appendVariables,*) "year:month:day" - -call MCT_AtrVt_init(av,iList=variables,lsize=length) -call MCT_AtrVt_appendIAttr(av, appendVariables, localResult) -if(mypid .eq. 0) call outputTestStatus(AVui,"AttrVect_appendIAttr",1,"PASS") -call MCT_AtrVt_clean(av) - -call MCT_AtrVt_init(av,iList=variables,lsize=length) -call MCT_AtrVt_appendIAttr(av, appendVariables, localResult) -if (localResult == 0) then - if(mypid .eq. 0) call outputTestStatus(AVui,"AttrVect_appendIAttr",2,"PASS") -else - if(mypid .eq. 0) call outputTestStatus(AVui,"AttrVect_appendIAttr",2,"FAIL") - result = 1 -endif -call MCT_AtrVt_clean(av) - -if (result == 0) then - if(mypid .eq. 0) call outputRoutineStatus(AVui,"AttrVect_appendIAttr","PASS") -else - if(mypid .eq. 0) call outputRoutineStatus(AVui,"AttrVect_appendIAttr","FAIL") -endif - -end subroutine - -!#################################### -!# -!# Test AttrVect_appendRAttr -!# -!#################################### -subroutine testAttrVect_appendRAttr(mypid,AVui) - -use m_AttrVect,only : MCT_AtrVt_init => init -use m_AttrVect,only : MCT_AtrVt_clean => clean -use m_AttrVect,only : MCT_AtrVt_appendRAttr => appendRAttr -use m_AttrVect - -implicit none - -integer mypid -integer AVui - -integer result, localResult, length - -character(len=35) variables -character(len=35) appendVariables - -type(AttrVect) :: av - -result = 0 - -length = 32 -write(variables,*) "T:Q:P" -write(appendVariables,*) "U:W" - -call MCT_AtrVt_init(av,rList=variables,lsize=length) -call MCT_AtrVt_appendRAttr(av, appendVariables, localResult) -if(mypid .eq. 0) call outputTestStatus(AVui,"AttrVect_appendRAttr",1,"PASS") -call MCT_AtrVt_clean(av) - -call MCT_AtrVt_init(av,rList=variables,lsize=length) -call MCT_AtrVt_appendRAttr(av, appendVariables, localResult) -if (localResult == 0) then - if(mypid .eq. 0) call outputTestStatus(AVui,"AttrVect_appendRAttr",2,"PASS") -else - if(mypid .eq. 0) call outputTestStatus(AVui,"AttrVect_appendRAttr",2,"FAIL") - result = 1 -endif -call MCT_AtrVt_clean(av) - -if (result == 0) then - if(mypid .eq. 0) call outputRoutineStatus(AVui,"AttrVect_appendRAttr","PASS") -else - if(mypid .eq. 0) call outputRoutineStatus(AVui,"AttrVect_appendRAttr","FAIL") -endif - - -end subroutine - -!#################################### -!# -!# Test AttrVect_exportIAttr -!# -!#################################### -subroutine testAttrVect_exportIAttr(mypid,AVui) - -use m_AttrVect,only : MCT_AtrVt_init => init -use m_AttrVect,only : MCT_AtrVt_clean => clean -use m_AttrVect,only : MCT_AtrVt_exportIAttr => exportIAttr -use m_AttrVect - -implicit none - -integer mypid -integer AVui - -integer result, localResult, length - -character(len=35) variables -character(len=4) keyVar - -integer, dimension(:),pointer :: out - -integer size, i, y - -type(AttrVect) :: av - -result = 0 -localResult = 0 - -length = 32 -keyVar="date" -write(variables,*) "lat:",keyVar,":lon" - -i = 4 - -call MCT_AtrVt_init(av,iList=variables,lsize=length) -av%iAttr=i - -nullify(out) -call MCT_AtrVt_exportIAttr(av, keyVar,out) -do y=1,length -if(out(y) /= i)then - localResult = 1 -endif -out(y) = 0 -enddo -if(localResult == 0)then - if(mypid .eq. 0) call outputTestStatus(AVui,"AttrVect_exportIAttr",1,"PASS") -else - if(mypid .eq. 0) call outputTestStatus(AVui,"AttrVect_exportIAttr",1,"FAIL") - localResult = 0 - result = 1 -endif - -deallocate(out) - -call MCT_AtrVt_exportIAttr(av, keyVar,out,size) -do y=1,length -if(out(y) /= i)then - localResult = 1 -endif -out(y) = 0 -enddo -if(localResult == 0)then - if(mypid .eq. 0) call outputTestStatus(AVui,"AttrVect_exportIAttr",2,"PASS") -else - if(mypid .eq. 0) call outputTestStatus(AVui,"AttrVect_exportIAttr",2,"FAIL") - localResult = 0 - result = 1 -endif - -!!! bug? --> call MCT_AtrVt_exportIAttr(av, AttrTag="foo",outVect=out, perrWith="quiet") -if (result == 0) then - if(mypid .eq. 0) call outputRoutineStatus(AVui,"AttrVect_exportIAttr","PASS") -else - if(mypid .eq. 0) call outputRoutineStatus(AVui,"AttrVect_exportIAttr","FAIL") -endif -call MCT_AtrVt_clean(av) - -end subroutine - -!#################################### -!# -!# Test AttrVect_exportRAttr -!# -!#################################### -subroutine testAttrVect_exportRAttr(mypid,AVui) - -use m_AttrVect,only : MCT_AtrVt_init => init -use m_AttrVect,only : MCT_AtrVt_clean => clean -use m_AttrVect,only : MCT_AtrVt_exportRAttr => exportRAttr -use m_AttrVect -use m_realkinds,only : SP,DP,FP - -implicit none - -integer mypid -integer AVui - -integer result, localResult, length - -character(len=35) variables -character(len=1) keyVar - -real, dimension(:),pointer :: out - -integer size, y - -real r - -type(AttrVect) :: av - -result = 0 -localResult = 0 - -length = 32 -keyVar="T" -variables = "P:"//keyVar//":Q" - -r = .09_FP - -call MCT_AtrVt_init(av,rList=variables,lsize=length) -av%rAttr=r - -nullify(out) -call MCT_AtrVt_exportRAttr(av, keyVar,out) -do y=1,length -if(out(y) /= r)then - localResult = 1 -endif -out(y) = 0 -enddo -if(localResult == 0)then - if(mypid .eq. 0) call outputTestStatus(AVui,"AttrVect_exportRAttr",1,"PASS") -else - if(mypid .eq. 0) call outputTestStatus(AVui,"AttrVect_exportRAttr",1,"FAIL") - localResult = 0 - result = 1 -endif - -deallocate(out) - -call MCT_AtrVt_exportRAttr(av, keyVar,out,size) -do y=1,length -if(out(y) /= r)then - localResult = 1 -endif -out(y) = 0 -enddo -if(localResult == 0)then - if(mypid .eq. 0) call outputTestStatus(AVui,"AttrVect_exportRAttr",2,"PASS") -else - if(mypid .eq. 0) call outputTestStatus(AVui,"AttrVect_exportRAttr",2,"FAIL") - localResult = 0 - result = 1 -endif - -!!! bug? --> call MCT_AtrVt_exportRAttr(av, AttrTag="foo",outVect=out, perrWith="quiet") -if (result == 0) then - if(mypid .eq. 0) call outputRoutineStatus(AVui,"AttrVect_exportRAttr","PASS") -else - if(mypid .eq. 0) call outputRoutineStatus(AVui,"AttrVect_exportRAttr","FAIL") -endif -call MCT_AtrVt_clean(av) - -end subroutine - - -!#################################### -!# -!# Test AttrVect_importIAttr -!# -!#################################### -subroutine testAttrVect_importIAttr(mypid,AVui) - -use m_AttrVect,only : MCT_AtrVt_init => init -use m_AttrVect,only : MCT_AtrVt_clean => clean -use m_AttrVect,only : MCT_AtrVt_importIAttr => importIAttr -use m_AttrVect,only : MCT_AtrVt_exportIAttr => exportIAttr -use m_AttrVect - -implicit none - -integer mypid -integer AVui - -integer result, localResult, length - -character(len=35) variables -character(len=12) keyVar - -integer size, y, i, index - -integer,pointer :: importVectP(:) -integer,target :: importVect(32) -integer, dimension(:),pointer :: out - -type(AttrVect) :: av - -result = 0 -localResult = 0 - -length = 32 -keyVar="date" -variables="lat:lon:"//keyVar - -i=4 -importVect = i -importVectP => importVect - -call MCT_AtrVt_init(av,iList=variables,lsize=length) -call MCT_AtrVt_importIAttr(av,TRIM(keyVar),importVectP) - -nullify(out) -call MCT_AtrVt_exportIAttr(av,TRIM(keyVar),out) -do y=1,length -if(out(y) /= i)then - localResult = 1 -endif -end do -if (localResult == 0) then - if(mypid .eq. 0) call outputTestStatus(AVui,"AttrVect_importIAttr",1,"PASS") -else - if(mypid .eq. 0) call outputTestStatus(AVui,"AttrVect_importIAttr",1,"FAIL") - localResult = 0 - result = 1 -endif - -deallocate(out) - -i=6 -importVect = i -importVectP => importVect - -call MCT_AtrVt_importIAttr(av,TRIM(keyVar),importVectP,length) -call MCT_AtrVt_exportIAttr(av,TRIM(keyVar),out) -do y=1,length -if(out(y) /= i)then - localResult = 1 -endif -end do -if (localResult == 0) then - if(mypid .eq. 0) call outputTestStatus(AVui,"AttrVect_importIAttr",2,"PASS") -else - if(mypid .eq. 0) call outputTestStatus(AVui,"AttrVect_importIAttr",2,"FAIL") - result = 1 -endif - -if (result == 0) then - if(mypid .eq. 0) call outputRoutineStatus(AVui,"AttrVect_importIAttr","PASS") -else - if(mypid .eq. 0) call outputRoutineStatus(AVui,"AttrVect_importIAttr","FAIL") -endif - -call MCT_AtrVt_clean(av) - -end subroutine - - -!#################################### -!# -!# Test AttrVect_importRAttr -!# -!#################################### -subroutine testAttrVect_importRAttr(mypid,AVui) - -use m_AttrVect,only : MCT_AtrVt_init => init -use m_AttrVect,only : MCT_AtrVt_clean => clean -use m_AttrVect,only : MCT_AtrVt_importRAttr => importRAttr -use m_AttrVect,only : MCT_AtrVt_exportRAttr => exportRAttr -use m_AttrVect -use m_realkinds,only : SP,DP,FP - -implicit none - -integer mypid -integer AVui - -integer result, localResult, length - -character(len=35) variables -character(len=12) keyVar - -integer size, y, index -real r - -real,pointer :: importVectP(:) -real,target :: importVect(32) -real, dimension(:),pointer :: out - -type(AttrVect) :: av - -result = 0 -localResult = 0 - -length = 32 -keyVar="T" -variables="Q:P:U:W:"//keyVar - -r=0.04_FP -importVect = r -importVectP => importVect - -call MCT_AtrVt_init(av,rList=variables,lsize=length) -call MCT_AtrVt_importRAttr(av,TRIM(keyVar),importVectP) -nullify(out) -call MCT_AtrVt_exportRAttr(av,TRIM(keyVar),out) -do y=1,length -if(out(y) /= r)then - localResult = 1 -endif -end do -if (localResult == 0) then - if(mypid .eq. 0) call outputTestStatus(AVui,"AttrVect_importRAttr",1,"PASS") -else - if(mypid .eq. 0) call outputTestStatus(AVui,"AttrVect_importRAttr",1,"FAIL") - localResult = 0 - result = 1 -endif - -deallocate(out) - -r=0.06_FP -importVect = r -importVectP => importVect - -call MCT_AtrVt_importRAttr(av,TRIM(keyVar),importVectP,length) -call MCT_AtrVt_exportRAttr(av,TRIM(keyVar),out) -do y=1,length -if(out(y) /= r)then - localResult = 1 -endif -end do -if (localResult == 0) then - if(mypid .eq. 0) call outputTestStatus(AVui,"AttrVect_importRAttr",2,"PASS") -else - if(mypid .eq. 0) call outputTestStatus(AVui,"AttrVect_importRAttr",2,"FAIL") - result = 1 -endif - -if (result == 0) then - if(mypid .eq. 0) call outputRoutineStatus(AVui,"AttrVect_importRAttr","PASS") -else - if(mypid .eq. 0) call outputRoutineStatus(AVui,"AttrVect_importRAttr","FAIL") -endif - -call MCT_AtrVt_clean(av) - -end subroutine - -!#################################### -!# -!# Test AttrVect_Copy -!# -!#################################### -subroutine testAttrVect_copy(mypid,AVui) - -use m_AttrVect,only : MCT_AtrVt_init => init -use m_AttrVect,only : MCT_AtrVt_clean => clean -use m_AttrVect,only : MCT_AtrVt_copy => copy -use m_AttrVect - -implicit none - -integer mypid -integer AVui - -character(len=35) Rvariables, RvariablesOUT -character(len=35) Ivariables, IvariablesOUT - -integer result,localResult,length - -type(AttrVect) :: avIN, avOUT - -result = 0 - -length = 32 -Rvariables="Q:P:U:W" -RvariablesOUT="q:p:u:w" -Ivariables="date:lat:lon" -IvariablesOUT="DATE:LAT:LON" - -call MCT_AtrVt_init(avIN,iList=Ivariables,rList=Rvariables,lsize=length) -call MCT_AtrVt_init(avOUT,iList=Ivariables,rList=Rvariables,lsize=length) - -call MCT_AtrVt_copy(avIN,avOUT) -if(mypid .eq. 0) call outputTestStatus(AVui,"AttrVect_copy",1,"PASS") -call MCT_AtrVt_clean(avOUT) - -call MCT_AtrVt_init(avOUT,iList=IvariablesOUT,rList=RvariablesOUT,lsize=length) -call MCT_AtrVt_Copy(avIN,avOUT,iList=Ivariables,TiList=IvariablesOUT) -if(mypid .eq. 0) call outputTestStatus(AVui,"AttrVect_copy",2,"PASS") -call MCT_AtrVt_clean(avOUT) - -call MCT_AtrVt_init(avOUT,iList=IvariablesOUT,rList=RvariablesOUT,lsize=length) -call MCT_AtrVt_Copy(avIN,avOUT,rList=Rvariables,TrList=RvariablesOUT) -if(mypid .eq. 0) call outputTestStatus(AVui,"AttrVect_copy",3,"PASS") -call MCT_AtrVt_clean(avOUT) - -call MCT_AtrVt_init(avOUT,iList=IvariablesOUT,rList=RvariablesOUT,lsize=length) -call MCT_AtrVt_Copy(avIN,avOUT,iList=Ivariables,TiList=IvariablesOUT,rList=Rvariables,TrList=RvariablesOUT) -if(mypid .eq. 0) call outputTestStatus(AVui,"AttrVect_copy",4,"PASS") -call MCT_AtrVt_clean(avOUT) - -call MCT_AtrVt_init(avOUT,iList=IvariablesOUT,rList=RvariablesOUT,lsize=length) -call MCT_AtrVt_Copy(avIN,avOUT,iList=Ivariables,TiList=IvariablesOUT,rList=Rvariables,TrList=RvariablesOUT,vector=.false.) -if(mypid .eq. 0) call outputTestStatus(AVui,"AttrVect_copy",5,"PASS") -call MCT_AtrVt_clean(avOUT) - -call MCT_AtrVt_init(avOUT,iList=IvariablesOUT,rList=RvariablesOUT,lsize=length) -call MCT_AtrVt_Copy(avIN,avOUT,iList=Ivariables,TiList=IvariablesOUT,rList=Rvariables,TrList=RvariablesOUT,vector=.true.) -if(mypid .eq. 0) call outputTestStatus(AVui,"AttrVect_copy",6,"PASS") -call MCT_AtrVt_clean(avOUT) - -call MCT_AtrVt_init(avOUT,iList=Ivariables,rList=Rvariables,lsize=length) -call MCT_AtrVt_copy(avIN,avOUT,vector=.true.) -if(mypid .eq. 0) call outputTestStatus(AVui,"AttrVect_copy",7,"PASS") -call MCT_AtrVt_clean(avOUT) - -call MCT_AtrVt_init(avOUT,iList=Ivariables,rList=Rvariables,lsize=length) -call MCT_AtrVt_copy(avIN,avOUT,vector=.false.) -if(mypid .eq. 0) call outputTestStatus(AVui,"AttrVect_copy",8,"PASS") -call MCT_AtrVt_clean(avOUT) - -if(mypid .eq. 0) call outputRoutineStatus(AVui,"AttrVect_copy","PASS") - -end subroutine - -!#################################### -!# -!# Test AttrVect_sort -!# -!#################################### -subroutine testAttrVect_sort(mypid,AVui) - -use m_AttrVect,only : MCT_AtrVt_init => init -use m_AttrVect,only : MCT_AtrVt_clean => clean -use m_AttrVect,only : MCT_AtrVt_sort => sort -use m_AttrVect,only : MCT_AtrVt_nIAttr => nIAttr -use m_AttrVect - -implicit none - -integer mypid -integer AVui - -type(AttrVect) :: av -logical,dimension(:), pointer :: des -integer,dimension(:), pointer :: perm - -character(len=35) Ivariables - -integer result,length - -result = 0 - -length = 32 -Ivariables="date:lat:lon" - -call MCT_AtrVt_init(av,iList=Ivariables,lsize=length) -call MCT_AtrVt_sort(av=av,key_list=av%iList,perm=perm) -call MCT_AtrVt_clean(av) -if(mypid .eq. 0) call outputTestStatus(AVui,"AttrVect_sort",1,"PASS") - -call MCT_AtrVt_init(av,iList=Ivariables,lsize=length) -allocate(des(MCT_AtrVt_nIAttr(av)),stat=result) -if(result /= 0)then -if(mypid .eq. 0) write(AVui,*)"ERROR: Could not allocate des in the AttrVect_sort test." -endif -des = .true. -call MCT_AtrVt_sort(av=av,key_list=av%iList,perm=perm,descend=des) -call MCT_AtrVt_clean(av) -deallocate(perm,stat=result) -if(result /= 0)then -if(mypid .eq. 0) write(AVui,*)"ERROR: Could not deallocate perm in the AttrVect_sort test." -endif -if(mypid .eq. 0) call outputTestStatus(AVui,"AttrVect_sort",2,"PASS") - -call MCT_AtrVt_init(av,iList=Ivariables,lsize=length) -des = .false. -call MCT_AtrVt_sort(av=av,key_list=av%iList,perm=perm,descend=des) -call MCT_AtrVt_clean(av) -deallocate(perm,stat=result) -if(result /= 0)then -if(mypid .eq. 0) write(AVui,*)"ERROR: Could not deallocate perm in the AttrVect_sort test." -endif -if(mypid .eq. 0) call outputTestStatus(AVui,"AttrVect_sort",3,"PASS") - -call MCT_AtrVt_init(av,iList=Ivariables,lsize=length) -des = .true. -call MCT_AtrVt_sort(av=av,key_list=av%iList,perm=perm,descend=des,perrWith="ERROR") -call MCT_AtrVt_clean(av) -deallocate(perm,stat=result) -if(result /= 0)then -if(mypid .eq. 0) write(AVui,*)"ERROR: Could not deallocate perm in the AttrVect_sort test." -endif -if(mypid .eq. 0) call outputTestStatus(AVui,"AttrVect_sort",4,"PASS") - -call MCT_AtrVt_init(av,iList=Ivariables,lsize=length) -des = .true. -call MCT_AtrVt_sort(av=av,key_list=av%iList,perm=perm,descend=des,perrWith="ERROR",& - dieWith="KILLED JOB") -call MCT_AtrVt_clean(av) -deallocate(perm,stat=result) -if(result /= 0)then -if(mypid .eq. 0) write(AVui,*)"ERROR: Could not deallocate perm in the AttrVect_sort test." -endif -if(mypid .eq. 0) call outputTestStatus(AVui,"AttrVect_sort",5,"PASS") - -call MCT_AtrVt_init(av,iList=Ivariables,lsize=length) -des = .true. -call MCT_AtrVt_sort(av=av,key_list=av%iList,perm=perm,descend=des,dieWith="KILLED JOB") -call MCT_AtrVt_clean(av) -deallocate(perm,stat=result) -if(result /= 0)then -if(mypid .eq. 0) write(AVui,*)"ERROR: Could not deallocate perm in the AttrVect_sort test." -endif -if(mypid .eq. 0) call outputTestStatus(AVui,"AttrVect_sort",6,"PASS") - -call MCT_AtrVt_init(av,iList=Ivariables,lsize=length) -call MCT_AtrVt_sort(av=av,key_list=av%iList,perm=perm,perrWith="ERROR") -call MCT_AtrVt_clean(av) -deallocate(perm,stat=result) -if(result /= 0)then -if(mypid .eq. 0) write(AVui,*)"ERROR: Could not deallocate perm in the AttrVect_sort test." -endif -if(mypid .eq. 0) call outputTestStatus(AVui,"AttrVect_sort",7,"PASS") - -call MCT_AtrVt_init(av,iList=Ivariables,lsize=length) -call MCT_AtrVt_sort(av=av,key_list=av%iList,perm=perm,dieWith="KILLED JOB") -call MCT_AtrVt_clean(av) -deallocate(perm,stat=result) -if(result /= 0)then -if(mypid .eq. 0) write(AVui,*)"ERROR: Could not deallocate perm in the AttrVect_sort test." -endif -if(mypid .eq. 0) call outputTestStatus(AVui,"AttrVect_sort",8,"PASS") - -call MCT_AtrVt_init(av,iList=Ivariables,lsize=length) -call MCT_AtrVt_sort(av=av,key_list=av%iList,perm=perm,perrWith="ERROR",dieWith="KILLED JOB") -call MCT_AtrVt_clean(av) -deallocate(perm,stat=result) -if(result /= 0)then -if(mypid .eq. 0) write(AVui,*)"ERROR: Could not deallocate perm in the AttrVect_sort test." -endif -if(mypid .eq. 0) call outputTestStatus(AVui,"AttrVect_sort",9,"PASS") - -deallocate(des,stat=result) -if(result /= 0)then -if(mypid .eq. 0) write(AVui,*)"ERROR: Could not deallocate des in the AttrVect_sort test." -endif - -if(mypid .eq. 0) call outputRoutineStatus(AVui,"AttrVect_sort","PASS") - -end subroutine - -!#################################### -!# -!# Test AttrVect_permute -!# -!#################################### -subroutine testAttrVect_permute(mypid,AVui) - -use m_AttrVect,only : MCT_AtrVt_init => init -use m_AttrVect,only : MCT_AtrVt_clean => clean -use m_AttrVect,only : MCT_AtrVt_sort => sort -use m_AttrVect,only : MCT_AtrVt_permute => permute -use m_AttrVect - -implicit none - -integer mypid -integer AVui - -type(AttrVect) :: av -integer,dimension(:), pointer :: perm - -character(len=35) Ivariables - -integer result,length - -result = 0 - -length = 32 -Ivariables="date:lat:lon" - -call MCT_AtrVt_init(av,iList=Ivariables,lsize=length) -call MCT_AtrVt_sort(av=av,key_list=av%iList,perm=perm) -call MCT_AtrVt_permute(av,perm) -call MCT_AtrVt_clean(av) -deallocate(perm,stat=result) -if(result /= 0)then -if(mypid .eq. 0) write(AVui,*)"ERROR: Could not deallocate perm in the AttrVect_permute test." -endif -if(mypid .eq. 0) call outputTestStatus(AVui,"AttrVect_permute",1,"PASS") - -call MCT_AtrVt_init(av,iList=Ivariables,lsize=length) -call MCT_AtrVt_sort(av=av,key_list=av%iList,perm=perm) -call MCT_AtrVt_permute(av,perm,perrWith="ERROR") -call MCT_AtrVt_clean(av) -deallocate(perm,stat=result) -if(result /= 0)then -if(mypid .eq. 0) write(AVui,*)"ERROR: Could not deallocate perm in the AttrVect_permute test." -endif -if(mypid .eq. 0) call outputTestStatus(AVui,"AttrVect_permute",2,"PASS") - -call MCT_AtrVt_init(av,iList=Ivariables,lsize=length) -call MCT_AtrVt_sort(av=av,key_list=av%iList,perm=perm) -call MCT_AtrVt_permute(av,perm,perrWith="ERROR",dieWith="KILLED JOB") -call MCT_AtrVt_clean(av) -deallocate(perm,stat=result) -if(result /= 0)then -if(mypid .eq. 0) write(AVui,*)"ERROR: Could not deallocate perm in the AttrVect_permute test." -endif -if(mypid .eq. 0) call outputTestStatus(AVui,"AttrVect_permute",3,"PASS") - -call MCT_AtrVt_init(av,iList=Ivariables,lsize=length) -call MCT_AtrVt_sort(av=av,key_list=av%iList,perm=perm) -call MCT_AtrVt_permute(av,perm,dieWith="KILLED JOB") -call MCT_AtrVt_clean(av) -deallocate(perm,stat=result) -if(result /= 0)then -if(mypid .eq. 0) write(AVui,*)"ERROR: Could not deallocate perm in the AttrVect_permute test." -endif -if(mypid .eq. 0) call outputTestStatus(AVui,"AttrVect_permute",4,"PASS") - -if(mypid .eq. 0) call outputRoutineStatus(AVui,"AttrVect_permute","PASS") - -end subroutine - - -!#################################### -!# -!# Test AttrVect_unpermute -!# -!#################################### -subroutine testAttrVect_unpermute(mypid,AVui) - -use m_AttrVect,only : MCT_AtrVt_init => init -use m_AttrVect,only : MCT_AtrVt_clean => clean -use m_AttrVect,only : MCT_AtrVt_sort => sort -use m_AttrVect,only : MCT_AtrVt_unpermute => unpermute -use m_AttrVect - -implicit none - -integer mypid -integer AVui - -type(AttrVect) :: av -integer,dimension(:), pointer :: perm - -character(len=35) Ivariables - -integer result,length - -result = 0 - -length = 32 -Ivariables="date:lat:lon" - -call MCT_AtrVt_init(av,iList=Ivariables,lsize=length) -call MCT_AtrVt_sort(av=av,key_list=av%iList,perm=perm) -call MCT_AtrVt_unpermute(av,perm) -call MCT_AtrVt_clean(av) -deallocate(perm,stat=result) -if(result /= 0)then -if(mypid .eq. 0) write(AVui,*)"ERROR: Could not deallocate perm in the AttrVect_unpermute test." -endif -if(mypid .eq. 0) call outputTestStatus(AVui,"AttrVect_unpermute",1,"PASS") - -call MCT_AtrVt_init(av,iList=Ivariables,lsize=length) -call MCT_AtrVt_sort(av=av,key_list=av%iList,perm=perm) -call MCT_AtrVt_unpermute(av,perm,perrWith="ERROR") -call MCT_AtrVt_clean(av) -deallocate(perm,stat=result) -if(result /= 0)then -if(mypid .eq. 0) write(AVui,*)"ERROR: Could not deallocate perm in the AttrVect_unpermute test." -endif -if(mypid .eq. 0) call outputTestStatus(AVui,"AttrVect_unpermute",2,"PASS") - -call MCT_AtrVt_init(av,iList=Ivariables,lsize=length) -call MCT_AtrVt_sort(av=av,key_list=av%iList,perm=perm) -call MCT_AtrVt_unpermute(av,perm,perrWith="ERROR",dieWith="KILLED JOB") -call MCT_AtrVt_clean(av) -deallocate(perm,stat=result) -if(result /= 0)then -if(mypid .eq. 0) write(AVui,*)"ERROR: Could not deallocate perm in the AttrVect_unpermute test." -endif -if(mypid .eq. 0) call outputTestStatus(AVui,"AttrVect_unpermute",3,"PASS") - -call MCT_AtrVt_init(av,iList=Ivariables,lsize=length) -call MCT_AtrVt_sort(av=av,key_list=av%iList,perm=perm) -call MCT_AtrVt_unpermute(av,perm,dieWith="KILLED JOB") -call MCT_AtrVt_clean(av) -deallocate(perm,stat=result) -if(result /= 0)then -if(mypid .eq. 0) write(AVui,*)"ERROR: Could not deallocate perm in the AttrVect_unpermute test." -endif -if(mypid .eq. 0) call outputTestStatus(AVui,"AttrVect_unpermute",4,"PASS") - -if(mypid .eq. 0) call outputRoutineStatus(AVui,"AttrVect_unpermute","PASS") - -end subroutine - -!#################################### -!# -!# Test AttrVect_sortPermute -!# -!#################################### -subroutine testAttrVect_sortPermute(mypid,AVui) - -use m_AttrVect,only : MCT_AtrVt_init => init -use m_AttrVect,only : MCT_AtrVt_clean => clean -use m_AttrVect,only : MCT_AtrVt_sort => sort -use m_AttrVect,only : MCT_AtrVt_sortPermute => SortPermute -use m_AttrVect,only : MCT_AtrVt_nIAttr => nIAttr -use m_AttrVect - -implicit none - -integer mypid -integer AVui - -type(AttrVect) :: av -logical,dimension(:), pointer :: des - -character(len=35) Ivariables - -integer length, result - -result = 0 - -length = 32 -Ivariables="date:lat:lon" - -call MCT_AtrVt_init(av,iList=Ivariables,lsize=length) -call MCT_AtrVt_sortPermute(av,key_list=av%iList) -call MCT_AtrVt_clean(av) -if(mypid .eq. 0) call outputTestStatus(AVui,"AttrVect_SortPermute",1,"PASS") - -call MCT_AtrVt_init(av,iList=Ivariables,lsize=length) -allocate(des(MCT_AtrVt_nIAttr(av)),stat=result) -if(result /= 0)then -if(mypid .eq. 0) write(AVui,*)"ERROR: Could not allocate des in the AttrVect_sortPermute test." -endif -des = .true. -call MCT_AtrVt_sortPermute(av,key_list=av%iList,descend=des) -call MCT_AtrVt_clean(av) -if(mypid .eq. 0) call outputTestStatus(AVui,"AttrVect_SortPermute",2,"PASS") - -call MCT_AtrVt_init(av,iList=Ivariables,lsize=length) -des = .false. -call MCT_AtrVt_sortPermute(av,key_list=av%iList,descend=des) -call MCT_AtrVt_clean(av) -if(mypid .eq. 0) call outputTestStatus(AVui,"AttrVect_SortPermute",3,"PASS") - -call MCT_AtrVt_init(av,iList=Ivariables,lsize=length) -des = .true. -call MCT_AtrVt_sortPermute(av,key_list=av%iList,descend=des,perrWith="ERROR") -call MCT_AtrVt_clean(av) -if(mypid .eq. 0) call outputTestStatus(AVui,"AttrVect_SortPermute",4,"PASS") - -call MCT_AtrVt_init(av,iList=Ivariables,lsize=length) -call MCT_AtrVt_sortPermute(av,key_list=av%iList,descend=des,perrWith="ERROR", & - dieWith="KILLED JOB") -call MCT_AtrVt_clean(av) -if(mypid .eq. 0) call outputTestStatus(AVui,"AttrVect_SortPermute",5,"PASS") - -call MCT_AtrVt_init(av,iList=Ivariables,lsize=length) -call MCT_AtrVt_sortPermute(av,key_list=av%iList,descend=des,dieWith="KILLED JOB") -call MCT_AtrVt_clean(av) -if(mypid .eq. 0) call outputTestStatus(AVui,"AttrVect_SortPermute",6,"PASS") - -call MCT_AtrVt_init(av,iList=Ivariables,lsize=length) -des = .true. -call MCT_AtrVt_sortPermute(av,key_list=av%iList,perrWith="ERROR") -call MCT_AtrVt_clean(av) -if(mypid .eq. 0) call outputTestStatus(AVui,"AttrVect_SortPermute",7,"PASS") - -call MCT_AtrVt_init(av,iList=Ivariables,lsize=length) -call MCT_AtrVt_sortPermute(av,key_list=av%iList,perrWith="ERROR", & - dieWith="KILLED JOB") -call MCT_AtrVt_clean(av) -if(mypid .eq. 0) call outputTestStatus(AVui,"AttrVect_SortPermute",8,"PASS") - -call MCT_AtrVt_init(av,iList=Ivariables,lsize=length) -call MCT_AtrVt_sortPermute(av,key_list=av%iList,dieWith="KILLED JOB") -call MCT_AtrVt_clean(av) -if(mypid .eq. 0) call outputTestStatus(AVui,"AttrVect_SortPermute",9,"PASS") - -deallocate(des,stat=result) -if(result /= 0)then -if(mypid .eq. 0) write(AVui,*)"ERROR: Could not deallocate des in the AttrVect_sortPermute test." -endif - -if(mypid .eq. 0) call outputRoutineStatus(AVui,"AttrVect_SortPermute","PASS") - -end subroutine - -!#################################### -!# -!# Test AttrVect_sharedAttrIndexList -!# -!#################################### -subroutine testAttrVect_sharedAttrIndexList(mypid,AVui) - -use m_AttrVect,only : MCT_AtrVt_init => init -use m_AttrVect,only : MCT_AtrVt_clean => clean -use m_AttrVect,only : MCT_AtrVt_sharedAttrIndexList => SharedAttrIndexList -use m_AttrVect,only : MCT_AtrVt_nIAttr => nIAttr -use m_AttrVect - -implicit none - -integer mypid -integer AVui - -type(AttrVect) :: av,av2 -character(len=35) type -integer numShare -integer, dimension(:),pointer :: indx1,indx2 - -character(len=35) Ivariables,Ivariables2 - -integer result,length - -result = 0 - -length = 32 -Ivariables="date:lat:lon" -Ivariables2="lat:lon:month:day:year" - -call MCT_AtrVt_init(av,iList=Ivariables,lsize=length) -call MCT_AtrVt_init(av2,iList=Ivariables2,lsize=length) -type="integer" -call MCT_AtrVt_sharedAttrIndexList(av,av2,type,numShare,indx1,indx2) -if(mypid .eq. 0) call outputTestStatus(AVui,"AttrVect_sharedAttrIndexList",1,"PASS") -deallocate(indx1,stat=result) -if(result /= 0)then -if(mypid .eq. 0) write(AVui,*)"ERROR: Could not deallocate indx1 in the AttrVect_sharedAttrIndexList test." -endif -deallocate(indx2,stat=result) -if(result /= 0)then -if(mypid .eq. 0) write(AVui,*)"ERROR: Could not deallocate indx2 in the AttrVect_sharedAttrIndexList test." -endif -call MCT_AtrVt_clean(av) - -if(mypid .eq. 0) call outputRoutineStatus(AVui,"AttrVect_sharedAttrIndexList","PASS") - -end subroutine diff --git a/cesm/models/utils/mct/testunit/Makefile b/cesm/models/utils/mct/testunit/Makefile deleted file mode 100644 index 3bd799b..0000000 --- a/cesm/models/utils/mct/testunit/Makefile +++ /dev/null @@ -1,41 +0,0 @@ - -SHELL = /bin/sh - -# SOURCE FILES - -SRCS_F90 = master.F90 \ - AttrVect_Test.F90 \ - -OBJS_ALL = $(SRCS_F90:.F90=.o) - -# MACHINE AND COMPILER FLAGS - -include ../Makefile.conf - -# ADDITIONAL DEFINITIONS SPECIFIC FOR UTMCT COMPILATION - -MCTLIBS = -L$(MPEUPATH) -L$(MCTPATH) -lmct -lmpeu -UTLDFLAGS = $(REAL8) -UTCMPFLAGS = $(REAL8) $(INCFLAG)$(MPEUPATH) $(INCFLAG)$(MCTPATH) - -# TARGETS - -all: mctTester - -mctTester: $(OBJS_ALL) - $(FC) -o $@ $(OBJS_ALL) $(FCFLAGS) $(UTLDFLAGS) $(MCTLIBS) $(MPILIBS) - -# RULES - -.SUFFIXES: -.SUFFIXES: .F90 .o - -.F90.o: - $(FC) -c $(INCPATH) $(FPPDEFS) $(FCFLAGS) $(MCTFLAGS) $(UTCMPFLAGS) $< - -clean: - ${RM} *.o *.mod mctTester - -# DEPENDENCIES: - -$(OBJS_ALL): $(MCTPATH)/libmct.a diff --git a/cesm/models/utils/mct/testunit/master.F90 b/cesm/models/utils/mct/testunit/master.F90 deleted file mode 100644 index 7a222cc..0000000 --- a/cesm/models/utils/mct/testunit/master.F90 +++ /dev/null @@ -1,101 +0,0 @@ -program main - -implicit none - -#include "mpif.h" - -integer ierr,myProc -character(len=12) date1 - -integer ui - -call MPI_INIT(ierr) -call MPI_COMM_RANK(MPI_COMM_WORLD,myProc,ierr) - -call DATE_AND_TIME(date=date1) -ui = 7 - -if(myProc .eq. 0) call openIO(date1,ui,'AttrVect') -call testAttrVect(myProc,ui) -ui = ui+1 - -call MPI_FINALIZE(ierr) - - -end program - -subroutine outputTestStatus(ui, routine, testid, status) - -integer ui, testid - -character(*) routine, status - -character(len=96) output - -integer ok - -if (status == "PASS") then -ok=1 -else if (status == "FAIL") then -ok = 1 -else -write(0,*) "WHAT HAPPENED? ", routine, testid -endif - -write(ui,'(a,a,i1,a,a)')routine," ... ",status - -end subroutine - - -subroutine outputRoutineStatus(ui, routine, status) - -integer ui - -character(*) routine, status - -character(len=96) output - -integer ok - -if (status == "PASS") then -ok=1 -else if (status == "FAIL") then -ok = 1 -else -write(0,*) "WHAT HAPPENED? ", routine -endif - -write(ui,'(a,a,a)')routine," SUMMARY ... ",status - -end subroutine - - -!#################################### -! -! open io unit for log file -! -!#################################### - -subroutine openIO(stamp,ui,routine) - - character(*) stamp, routine - integer ui - - character(len=54) filename - integer ierr - - ierr = 0 - - filename = trim(routine)//'.log.' // stamp(1:8) - OPEN (UNIT=ui, FILE=filename,STATUS='NEW',IOSTAT=ierr) - - if (ierr /= 0) then - write(6,*) "Open failed on unit: ", ui - write(6,*) "File name was: [", filename, "]" - write(6,*) "Error code was: ", ierr - - stop 1 - end if - -end subroutine - diff --git a/cesm/models/utils/timing/gptl/COPYING b/cesm/models/utils/timing/gptl/COPYING deleted file mode 100644 index 94a9ed0..0000000 --- a/cesm/models/utils/timing/gptl/COPYING +++ /dev/null @@ -1,674 +0,0 @@ - GNU GENERAL PUBLIC LICENSE - Version 3, 29 June 2007 - - Copyright (C) 2007 Free Software Foundation, Inc. - Everyone is permitted to copy and distribute verbatim copies - of this license document, but changing it is not allowed. - - Preamble - - The GNU General Public License is a free, copyleft license for -software and other kinds of works. - - The licenses for most software and other practical works are designed -to take away your freedom to share and change the works. By contrast, -the GNU General Public License is intended to guarantee your freedom to -share and change all versions of a program--to make sure it remains free -software for all its users. We, the Free Software Foundation, use the -GNU General Public License for most of our software; it applies also to -any other work released this way by its authors. You can apply it to -your programs, too. - - When we speak of free software, we are referring to freedom, not -price. Our General Public Licenses are designed to make sure that you -have the freedom to distribute copies of free software (and charge for -them if you wish), that you receive source code or can get it if you -want it, that you can change the software or use pieces of it in new -free programs, and that you know you can do these things. - - To protect your rights, we need to prevent others from denying you -these rights or asking you to surrender the rights. Therefore, you have -certain responsibilities if you distribute copies of the software, or if -you modify it: responsibilities to respect the freedom of others. - - For example, if you distribute copies of such a program, whether -gratis or for a fee, you must pass on to the recipients the same -freedoms that you received. You must make sure that they, too, receive -or can get the source code. And you must show them these terms so they -know their rights. - - Developers that use the GNU GPL protect your rights with two steps: -(1) assert copyright on the software, and (2) offer you this License -giving you legal permission to copy, distribute and/or modify it. - - For the developers' and authors' protection, the GPL clearly explains -that there is no warranty for this free software. For both users' and -authors' sake, the GPL requires that modified versions be marked as -changed, so that their problems will not be attributed erroneously to -authors of previous versions. - - Some devices are designed to deny users access to install or run -modified versions of the software inside them, although the manufacturer -can do so. This is fundamentally incompatible with the aim of -protecting users' freedom to change the software. The systematic -pattern of such abuse occurs in the area of products for individuals to -use, which is precisely where it is most unacceptable. Therefore, we -have designed this version of the GPL to prohibit the practice for those -products. If such problems arise substantially in other domains, we -stand ready to extend this provision to those domains in future versions -of the GPL, as needed to protect the freedom of users. - - Finally, every program is threatened constantly by software patents. -States should not allow patents to restrict development and use of -software on general-purpose computers, but in those that do, we wish to -avoid the special danger that patents applied to a free program could -make it effectively proprietary. To prevent this, the GPL assures that -patents cannot be used to render the program non-free. - - The precise terms and conditions for copying, distribution and -modification follow. - - TERMS AND CONDITIONS - - 0. Definitions. - - "This License" refers to version 3 of the GNU General Public License. - - "Copyright" also means copyright-like laws that apply to other kinds of -works, such as semiconductor masks. - - "The Program" refers to any copyrightable work licensed under this -License. Each licensee is addressed as "you". "Licensees" and -"recipients" may be individuals or organizations. - - To "modify" a work means to copy from or adapt all or part of the work -in a fashion requiring copyright permission, other than the making of an -exact copy. The resulting work is called a "modified version" of the -earlier work or a work "based on" the earlier work. - - A "covered work" means either the unmodified Program or a work based -on the Program. - - To "propagate" a work means to do anything with it that, without -permission, would make you directly or secondarily liable for -infringement under applicable copyright law, except executing it on a -computer or modifying a private copy. Propagation includes copying, -distribution (with or without modification), making available to the -public, and in some countries other activities as well. - - To "convey" a work means any kind of propagation that enables other -parties to make or receive copies. Mere interaction with a user through -a computer network, with no transfer of a copy, is not conveying. - - An interactive user interface displays "Appropriate Legal Notices" -to the extent that it includes a convenient and prominently visible -feature that (1) displays an appropriate copyright notice, and (2) -tells the user that there is no warranty for the work (except to the -extent that warranties are provided), that licensees may convey the -work under this License, and how to view a copy of this License. If -the interface presents a list of user commands or options, such as a -menu, a prominent item in the list meets this criterion. - - 1. Source Code. - - The "source code" for a work means the preferred form of the work -for making modifications to it. "Object code" means any non-source -form of a work. - - A "Standard Interface" means an interface that either is an official -standard defined by a recognized standards body, or, in the case of -interfaces specified for a particular programming language, one that -is widely used among developers working in that language. - - The "System Libraries" of an executable work include anything, other -than the work as a whole, that (a) is included in the normal form of -packaging a Major Component, but which is not part of that Major -Component, and (b) serves only to enable use of the work with that -Major Component, or to implement a Standard Interface for which an -implementation is available to the public in source code form. A -"Major Component", in this context, means a major essential component -(kernel, window system, and so on) of the specific operating system -(if any) on which the executable work runs, or a compiler used to -produce the work, or an object code interpreter used to run it. - - The "Corresponding Source" for a work in object code form means all -the source code needed to generate, install, and (for an executable -work) run the object code and to modify the work, including scripts to -control those activities. However, it does not include the work's -System Libraries, or general-purpose tools or generally available free -programs which are used unmodified in performing those activities but -which are not part of the work. For example, Corresponding Source -includes interface definition files associated with source files for -the work, and the source code for shared libraries and dynamically -linked subprograms that the work is specifically designed to require, -such as by intimate data communication or control flow between those -subprograms and other parts of the work. - - The Corresponding Source need not include anything that users -can regenerate automatically from other parts of the Corresponding -Source. - - The Corresponding Source for a work in source code form is that -same work. - - 2. Basic Permissions. - - All rights granted under this License are granted for the term of -copyright on the Program, and are irrevocable provided the stated -conditions are met. This License explicitly affirms your unlimited -permission to run the unmodified Program. The output from running a -covered work is covered by this License only if the output, given its -content, constitutes a covered work. This License acknowledges your -rights of fair use or other equivalent, as provided by copyright law. - - You may make, run and propagate covered works that you do not -convey, without conditions so long as your license otherwise remains -in force. You may convey covered works to others for the sole purpose -of having them make modifications exclusively for you, or provide you -with facilities for running those works, provided that you comply with -the terms of this License in conveying all material for which you do -not control copyright. Those thus making or running the covered works -for you must do so exclusively on your behalf, under your direction -and control, on terms that prohibit them from making any copies of -your copyrighted material outside their relationship with you. - - Conveying under any other circumstances is permitted solely under -the conditions stated below. Sublicensing is not allowed; section 10 -makes it unnecessary. - - 3. Protecting Users' Legal Rights From Anti-Circumvention Law. - - No covered work shall be deemed part of an effective technological -measure under any applicable law fulfilling obligations under article -11 of the WIPO copyright treaty adopted on 20 December 1996, or -similar laws prohibiting or restricting circumvention of such -measures. - - When you convey a covered work, you waive any legal power to forbid -circumvention of technological measures to the extent such circumvention -is effected by exercising rights under this License with respect to -the covered work, and you disclaim any intention to limit operation or -modification of the work as a means of enforcing, against the work's -users, your or third parties' legal rights to forbid circumvention of -technological measures. - - 4. Conveying Verbatim Copies. - - You may convey verbatim copies of the Program's source code as you -receive it, in any medium, provided that you conspicuously and -appropriately publish on each copy an appropriate copyright notice; -keep intact all notices stating that this License and any -non-permissive terms added in accord with section 7 apply to the code; -keep intact all notices of the absence of any warranty; and give all -recipients a copy of this License along with the Program. - - You may charge any price or no price for each copy that you convey, -and you may offer support or warranty protection for a fee. - - 5. Conveying Modified Source Versions. - - You may convey a work based on the Program, or the modifications to -produce it from the Program, in the form of source code under the -terms of section 4, provided that you also meet all of these conditions: - - a) The work must carry prominent notices stating that you modified - it, and giving a relevant date. - - b) The work must carry prominent notices stating that it is - released under this License and any conditions added under section - 7. This requirement modifies the requirement in section 4 to - "keep intact all notices". - - c) You must license the entire work, as a whole, under this - License to anyone who comes into possession of a copy. This - License will therefore apply, along with any applicable section 7 - additional terms, to the whole of the work, and all its parts, - regardless of how they are packaged. This License gives no - permission to license the work in any other way, but it does not - invalidate such permission if you have separately received it. - - d) If the work has interactive user interfaces, each must display - Appropriate Legal Notices; however, if the Program has interactive - interfaces that do not display Appropriate Legal Notices, your - work need not make them do so. - - A compilation of a covered work with other separate and independent -works, which are not by their nature extensions of the covered work, -and which are not combined with it such as to form a larger program, -in or on a volume of a storage or distribution medium, is called an -"aggregate" if the compilation and its resulting copyright are not -used to limit the access or legal rights of the compilation's users -beyond what the individual works permit. Inclusion of a covered work -in an aggregate does not cause this License to apply to the other -parts of the aggregate. - - 6. Conveying Non-Source Forms. - - You may convey a covered work in object code form under the terms -of sections 4 and 5, provided that you also convey the -machine-readable Corresponding Source under the terms of this License, -in one of these ways: - - a) Convey the object code in, or embodied in, a physical product - (including a physical distribution medium), accompanied by the - Corresponding Source fixed on a durable physical medium - customarily used for software interchange. - - b) Convey the object code in, or embodied in, a physical product - (including a physical distribution medium), accompanied by a - written offer, valid for at least three years and valid for as - long as you offer spare parts or customer support for that product - model, to give anyone who possesses the object code either (1) a - copy of the Corresponding Source for all the software in the - product that is covered by this License, on a durable physical - medium customarily used for software interchange, for a price no - more than your reasonable cost of physically performing this - conveying of source, or (2) access to copy the - Corresponding Source from a network server at no charge. - - c) Convey individual copies of the object code with a copy of the - written offer to provide the Corresponding Source. This - alternative is allowed only occasionally and noncommercially, and - only if you received the object code with such an offer, in accord - with subsection 6b. - - d) Convey the object code by offering access from a designated - place (gratis or for a charge), and offer equivalent access to the - Corresponding Source in the same way through the same place at no - further charge. You need not require recipients to copy the - Corresponding Source along with the object code. If the place to - copy the object code is a network server, the Corresponding Source - may be on a different server (operated by you or a third party) - that supports equivalent copying facilities, provided you maintain - clear directions next to the object code saying where to find the - Corresponding Source. Regardless of what server hosts the - Corresponding Source, you remain obligated to ensure that it is - available for as long as needed to satisfy these requirements. - - e) Convey the object code using peer-to-peer transmission, provided - you inform other peers where the object code and Corresponding - Source of the work are being offered to the general public at no - charge under subsection 6d. - - A separable portion of the object code, whose source code is excluded -from the Corresponding Source as a System Library, need not be -included in conveying the object code work. - - A "User Product" is either (1) a "consumer product", which means any -tangible personal property which is normally used for personal, family, -or household purposes, or (2) anything designed or sold for incorporation -into a dwelling. In determining whether a product is a consumer product, -doubtful cases shall be resolved in favor of coverage. For a particular -product received by a particular user, "normally used" refers to a -typical or common use of that class of product, regardless of the status -of the particular user or of the way in which the particular user -actually uses, or expects or is expected to use, the product. A product -is a consumer product regardless of whether the product has substantial -commercial, industrial or non-consumer uses, unless such uses represent -the only significant mode of use of the product. - - "Installation Information" for a User Product means any methods, -procedures, authorization keys, or other information required to install -and execute modified versions of a covered work in that User Product from -a modified version of its Corresponding Source. The information must -suffice to ensure that the continued functioning of the modified object -code is in no case prevented or interfered with solely because -modification has been made. - - If you convey an object code work under this section in, or with, or -specifically for use in, a User Product, and the conveying occurs as -part of a transaction in which the right of possession and use of the -User Product is transferred to the recipient in perpetuity or for a -fixed term (regardless of how the transaction is characterized), the -Corresponding Source conveyed under this section must be accompanied -by the Installation Information. But this requirement does not apply -if neither you nor any third party retains the ability to install -modified object code on the User Product (for example, the work has -been installed in ROM). - - The requirement to provide Installation Information does not include a -requirement to continue to provide support service, warranty, or updates -for a work that has been modified or installed by the recipient, or for -the User Product in which it has been modified or installed. Access to a -network may be denied when the modification itself materially and -adversely affects the operation of the network or violates the rules and -protocols for communication across the network. - - Corresponding Source conveyed, and Installation Information provided, -in accord with this section must be in a format that is publicly -documented (and with an implementation available to the public in -source code form), and must require no special password or key for -unpacking, reading or copying. - - 7. Additional Terms. - - "Additional permissions" are terms that supplement the terms of this -License by making exceptions from one or more of its conditions. -Additional permissions that are applicable to the entire Program shall -be treated as though they were included in this License, to the extent -that they are valid under applicable law. If additional permissions -apply only to part of the Program, that part may be used separately -under those permissions, but the entire Program remains governed by -this License without regard to the additional permissions. - - When you convey a copy of a covered work, you may at your option -remove any additional permissions from that copy, or from any part of -it. (Additional permissions may be written to require their own -removal in certain cases when you modify the work.) You may place -additional permissions on material, added by you to a covered work, -for which you have or can give appropriate copyright permission. - - Notwithstanding any other provision of this License, for material you -add to a covered work, you may (if authorized by the copyright holders of -that material) supplement the terms of this License with terms: - - a) Disclaiming warranty or limiting liability differently from the - terms of sections 15 and 16 of this License; or - - b) Requiring preservation of specified reasonable legal notices or - author attributions in that material or in the Appropriate Legal - Notices displayed by works containing it; or - - c) Prohibiting misrepresentation of the origin of that material, or - requiring that modified versions of such material be marked in - reasonable ways as different from the original version; or - - d) Limiting the use for publicity purposes of names of licensors or - authors of the material; or - - e) Declining to grant rights under trademark law for use of some - trade names, trademarks, or service marks; or - - f) Requiring indemnification of licensors and authors of that - material by anyone who conveys the material (or modified versions of - it) with contractual assumptions of liability to the recipient, for - any liability that these contractual assumptions directly impose on - those licensors and authors. - - All other non-permissive additional terms are considered "further -restrictions" within the meaning of section 10. If the Program as you -received it, or any part of it, contains a notice stating that it is -governed by this License along with a term that is a further -restriction, you may remove that term. If a license document contains -a further restriction but permits relicensing or conveying under this -License, you may add to a covered work material governed by the terms -of that license document, provided that the further restriction does -not survive such relicensing or conveying. - - If you add terms to a covered work in accord with this section, you -must place, in the relevant source files, a statement of the -additional terms that apply to those files, or a notice indicating -where to find the applicable terms. - - Additional terms, permissive or non-permissive, may be stated in the -form of a separately written license, or stated as exceptions; -the above requirements apply either way. - - 8. Termination. - - You may not propagate or modify a covered work except as expressly -provided under this License. Any attempt otherwise to propagate or -modify it is void, and will automatically terminate your rights under -this License (including any patent licenses granted under the third -paragraph of section 11). - - However, if you cease all violation of this License, then your -license from a particular copyright holder is reinstated (a) -provisionally, unless and until the copyright holder explicitly and -finally terminates your license, and (b) permanently, if the copyright -holder fails to notify you of the violation by some reasonable means -prior to 60 days after the cessation. - - Moreover, your license from a particular copyright holder is -reinstated permanently if the copyright holder notifies you of the -violation by some reasonable means, this is the first time you have -received notice of violation of this License (for any work) from that -copyright holder, and you cure the violation prior to 30 days after -your receipt of the notice. - - Termination of your rights under this section does not terminate the -licenses of parties who have received copies or rights from you under -this License. If your rights have been terminated and not permanently -reinstated, you do not qualify to receive new licenses for the same -material under section 10. - - 9. Acceptance Not Required for Having Copies. - - You are not required to accept this License in order to receive or -run a copy of the Program. Ancillary propagation of a covered work -occurring solely as a consequence of using peer-to-peer transmission -to receive a copy likewise does not require acceptance. However, -nothing other than this License grants you permission to propagate or -modify any covered work. These actions infringe copyright if you do -not accept this License. Therefore, by modifying or propagating a -covered work, you indicate your acceptance of this License to do so. - - 10. Automatic Licensing of Downstream Recipients. - - Each time you convey a covered work, the recipient automatically -receives a license from the original licensors, to run, modify and -propagate that work, subject to this License. You are not responsible -for enforcing compliance by third parties with this License. - - An "entity transaction" is a transaction transferring control of an -organization, or substantially all assets of one, or subdividing an -organization, or merging organizations. If propagation of a covered -work results from an entity transaction, each party to that -transaction who receives a copy of the work also receives whatever -licenses to the work the party's predecessor in interest had or could -give under the previous paragraph, plus a right to possession of the -Corresponding Source of the work from the predecessor in interest, if -the predecessor has it or can get it with reasonable efforts. - - You may not impose any further restrictions on the exercise of the -rights granted or affirmed under this License. For example, you may -not impose a license fee, royalty, or other charge for exercise of -rights granted under this License, and you may not initiate litigation -(including a cross-claim or counterclaim in a lawsuit) alleging that -any patent claim is infringed by making, using, selling, offering for -sale, or importing the Program or any portion of it. - - 11. Patents. - - A "contributor" is a copyright holder who authorizes use under this -License of the Program or a work on which the Program is based. The -work thus licensed is called the contributor's "contributor version". - - A contributor's "essential patent claims" are all patent claims -owned or controlled by the contributor, whether already acquired or -hereafter acquired, that would be infringed by some manner, permitted -by this License, of making, using, or selling its contributor version, -but do not include claims that would be infringed only as a -consequence of further modification of the contributor version. For -purposes of this definition, "control" includes the right to grant -patent sublicenses in a manner consistent with the requirements of -this License. - - Each contributor grants you a non-exclusive, worldwide, royalty-free -patent license under the contributor's essential patent claims, to -make, use, sell, offer for sale, import and otherwise run, modify and -propagate the contents of its contributor version. - - In the following three paragraphs, a "patent license" is any express -agreement or commitment, however denominated, not to enforce a patent -(such as an express permission to practice a patent or covenant not to -sue for patent infringement). To "grant" such a patent license to a -party means to make such an agreement or commitment not to enforce a -patent against the party. - - If you convey a covered work, knowingly relying on a patent license, -and the Corresponding Source of the work is not available for anyone -to copy, free of charge and under the terms of this License, through a -publicly available network server or other readily accessible means, -then you must either (1) cause the Corresponding Source to be so -available, or (2) arrange to deprive yourself of the benefit of the -patent license for this particular work, or (3) arrange, in a manner -consistent with the requirements of this License, to extend the patent -license to downstream recipients. "Knowingly relying" means you have -actual knowledge that, but for the patent license, your conveying the -covered work in a country, or your recipient's use of the covered work -in a country, would infringe one or more identifiable patents in that -country that you have reason to believe are valid. - - If, pursuant to or in connection with a single transaction or -arrangement, you convey, or propagate by procuring conveyance of, a -covered work, and grant a patent license to some of the parties -receiving the covered work authorizing them to use, propagate, modify -or convey a specific copy of the covered work, then the patent license -you grant is automatically extended to all recipients of the covered -work and works based on it. - - A patent license is "discriminatory" if it does not include within -the scope of its coverage, prohibits the exercise of, or is -conditioned on the non-exercise of one or more of the rights that are -specifically granted under this License. You may not convey a covered -work if you are a party to an arrangement with a third party that is -in the business of distributing software, under which you make payment -to the third party based on the extent of your activity of conveying -the work, and under which the third party grants, to any of the -parties who would receive the covered work from you, a discriminatory -patent license (a) in connection with copies of the covered work -conveyed by you (or copies made from those copies), or (b) primarily -for and in connection with specific products or compilations that -contain the covered work, unless you entered into that arrangement, -or that patent license was granted, prior to 28 March 2007. - - Nothing in this License shall be construed as excluding or limiting -any implied license or other defenses to infringement that may -otherwise be available to you under applicable patent law. - - 12. No Surrender of Others' Freedom. - - If conditions are imposed on you (whether by court order, agreement or -otherwise) that contradict the conditions of this License, they do not -excuse you from the conditions of this License. If you cannot convey a -covered work so as to satisfy simultaneously your obligations under this -License and any other pertinent obligations, then as a consequence you may -not convey it at all. For example, if you agree to terms that obligate you -to collect a royalty for further conveying from those to whom you convey -the Program, the only way you could satisfy both those terms and this -License would be to refrain entirely from conveying the Program. - - 13. Use with the GNU Affero General Public License. - - Notwithstanding any other provision of this License, you have -permission to link or combine any covered work with a work licensed -under version 3 of the GNU Affero General Public License into a single -combined work, and to convey the resulting work. The terms of this -License will continue to apply to the part which is the covered work, -but the special requirements of the GNU Affero General Public License, -section 13, concerning interaction through a network will apply to the -combination as such. - - 14. Revised Versions of this License. - - The Free Software Foundation may publish revised and/or new versions of -the GNU General Public License from time to time. Such new versions will -be similar in spirit to the present version, but may differ in detail to -address new problems or concerns. - - Each version is given a distinguishing version number. If the -Program specifies that a certain numbered version of the GNU General -Public License "or any later version" applies to it, you have the -option of following the terms and conditions either of that numbered -version or of any later version published by the Free Software -Foundation. If the Program does not specify a version number of the -GNU General Public License, you may choose any version ever published -by the Free Software Foundation. - - If the Program specifies that a proxy can decide which future -versions of the GNU General Public License can be used, that proxy's -public statement of acceptance of a version permanently authorizes you -to choose that version for the Program. - - Later license versions may give you additional or different -permissions. However, no additional obligations are imposed on any -author or copyright holder as a result of your choosing to follow a -later version. - - 15. Disclaimer of Warranty. - - THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY -APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT -HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY -OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, -THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM -IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF -ALL NECESSARY SERVICING, REPAIR OR CORRECTION. - - 16. Limitation of Liability. - - IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING -WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS -THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY -GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE -USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF -DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD -PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), -EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF -SUCH DAMAGES. - - 17. Interpretation of Sections 15 and 16. - - If the disclaimer of warranty and limitation of liability provided -above cannot be given local legal effect according to their terms, -reviewing courts shall apply local law that most closely approximates -an absolute waiver of all civil liability in connection with the -Program, unless a warranty or assumption of liability accompanies a -copy of the Program in return for a fee. - - END OF TERMS AND CONDITIONS - - How to Apply These Terms to Your New Programs - - If you develop a new program, and you want it to be of the greatest -possible use to the public, the best way to achieve this is to make it -free software which everyone can redistribute and change under these terms. - - To do so, attach the following notices to the program. It is safest -to attach them to the start of each source file to most effectively -state the exclusion of warranty; and each file should have at least -the "copyright" line and a pointer to where the full notice is found. - - - Copyright (C) - - 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 3 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. - - You should have received a copy of the GNU General Public License - along with this program. If not, see . - -Also add information on how to contact you by electronic and paper mail. - - If the program does terminal interaction, make it output a short -notice like this when it starts in an interactive mode: - - Copyright (C) - This program comes with ABSOLUTELY NO WARRANTY; for details type `show w'. - This is free software, and you are welcome to redistribute it - under certain conditions; type `show c' for details. - -The hypothetical commands `show w' and `show c' should show the appropriate -parts of the General Public License. Of course, your program's commands -might be different; for a GUI interface, you would use an "about box". - - You should also get your employer (if you work as a programmer) or school, -if any, to sign a "copyright disclaimer" for the program, if necessary. -For more information on this, and how to apply and follow the GNU GPL, see -. - - The GNU General Public License does not permit incorporating your program -into proprietary programs. If your program is a subroutine library, you -may consider it more useful to permit linking proprietary applications with -the library. If this is what you want to do, use the GNU Lesser General -Public License instead of this License. But first, please read -. diff --git a/cesm/models/utils/timing/gptl/ChangeLog b/cesm/models/utils/timing/gptl/ChangeLog deleted file mode 100644 index 9e163c6..0000000 --- a/cesm/models/utils/timing/gptl/ChangeLog +++ /dev/null @@ -1,144 +0,0 @@ -gptl4_0: When THREADED_PTHREADS is enabled, mutex locking only happens - when a new thread is found instead of on each start/stop - call. Can improve efficiency dramatically (on AIX anyway). - New entries start_handle and stop_handle added to improve - efficiency in fine-grained regions. - Moved threadutil.c contents back inside gptl.c for efficiency. - Can now call GPTLinitialize after GPTLfinalize. - Bugfix for GPTLstart* routines: Ensure don't read more than - strlen(name) characters from input name. - Added support for Cray compilers crayftn and craycc. - Bugfix for add: bump tout->count even when wallstats disabled. - Removed obsolete utr_rtc() code and ifdefs. - Added AIX-based read_real_time() function. - Added "volatile" attribute in appropriate places. - Cut tablesize to 1024, and added option to set it via GPTLsetoption - Added diagnostic print about how GPTL was built. - Bugfix for diagnostic prints when nanotime is true. - Print of memusage stats no longer based on dopr_collision. - Added to ./suggestions (Run autoconf, move configure to - suggestions, then set "silent=yes" in the script. - Added checks to MPI returns in MPIpr_summary. -gptl3_6_2: print_memusage converts to MB by default (if possible). - Added print_memusage test to testbasics.F90 - Added macros.make.bluegene (tested at ORNL) - Bugfix for GPTLpr_summary: slave tried to receive too much data. - Bugfix for process_namelist.F90: Needs to close opened file - on error. - Bugfix for gptl_papilibraryinit (Fortran): returns an int. - Changed LINUX ifdef to HAVE_SLASHPROC. Not all Linux systems - have /proc/pid/statm. - -gptl3_6_1: Bugfix for auto-profiling MPI_Recv: it could hang in gptl3_6. - Auto-profiling support for additional MPI routines. - Better estimates of bytes transfer for some auto-profiled - MPI routines. -gptl3_6: Support for auto-profiling some MPI routines. -gptl3_5_3: Makefile simplification. Can now run "make" from ctests/ and - ftests/. Initial set of PMPI wrappers, and synchronize option. -gptl3_5_2: Bugfix for when omp_get_max_threads() returns zero. -gptl3_5_1: No more OMP pragmas: PAPI events started from get_thread_num(). - Thus GPTL built with PTHREADS=yes now works when called from - OpenMP applications. -gptl3_4_7: Option to not run summary at all. -gptl3_4_6: totent counts collisions not entries. - Add target "testnompi" to only run tests that don't require MPI. -gptl3_4_5: Add realloc memory checks. Fix typo in uninstall target. - Bugfix for instrumented codes when orphan encounters - parent. Print additional hash table stats. Decrease MAX_AUX - from 16 to 8 to save memory. -gptl3_4_4: Added GPTLevent_name_to_code and GPTLevent_code_to_name. Add - some derived events. More description to print. -gptl3_4_2: Enable "make test". Error call to stop_instr won't invoke null - pointer to function. -gptl3_4_1: Fix tests for robustness. Move initialized check in GPTLstop - higher to avoid one of the error tests in ftests/errtest -gptl3_4: Put back GPTLpr_summary. Some people were using it. - Get ctests/ and ftests/ into a usable state. - Proper handling of input defines by Fortran. -gptl3_2: Handle multiple parents - Add parsegptlout.pl for handling MPI output - Add capability for derived counters (currently just IPC and CI) - Add GPTL_PAPIlibraryinit to allow enabling PAPI native events - Junk autoconf in favor of macros.make ("suggestions" retained as - an autoconf-generated script to suggest settings) - Vastly faster start/stop for auto-instrumented codes - hex2name.pl properly indents output - Efficiency enhancements (e.g. no character copying on start/stop) - Use stack to determine parent, for simplicity, efficiency, correctness - Arrange timers in tree for proper handling of parent/child -gptl2_16: Rename GPTLpr_mpistats to GPTLpr_summary. Make it behave - reasonably even when MPI not enabled. - Close print files after writing to them. -gptl2_14: Add GPTLpr_mpistats entry point. - Check string starts with "PAPI_" before lopping off. - Remove "inline" attribute to timing functions--they're probably - not inlined anyway. -gptl2_13: verbose = false by default. Wrap informational printout in - test on "verbose". Add verbose option to gptl_papi.c - Modified behavior of scale.c -gptl2_11: Man pages. Default narrowprint to true. Fix minor formatting - bug in GPTLpr. -gptl2_10: Add GPTLpercent (of 1st timers[0]), and GPTLpersec (for PAPI). - Add timingModule.F90 -gptl2_9: Update camgptl.inc to match gptl.inc (forgot in gptl2_8) -gptl2_8: Add option to retain parent/child relationships for printing. - Change behavior of ambiguous timers to put a "*" in column 1. -gptl2_7: Add GPTLget_nregions and GPTLget_regionname -gptl2_6: Add GPTLquerycounters (C and Fortran) -gptl2_5: Enable native events -gptl2_3: Minor changes to papiomptest.F -gptl2_2: Multiplexing: can enable, disable, or always enable. - GPTLnarrowprint (fewer digits) - Add cmd-line PAPI option arg to utrtest. - papiomptest no longer does malloc: caused trouble on SGI -gptl1_7: Split tests/ into ctests/ and ftests. - Fix logic on Fortran underscoring. - Return error when selected PAPI option not available. - Further fix (1.6 was not complete) on PAPI overhead. -gptl1_6: - Fix (bogus) print occurring from PAPI when overheadstats disabled. - - Add get_memusage and memusage test. - - Add "basic" test. - - Hack aclocal.m4 for openMP flags. -gptl1_5: - Fixed "install" target. - - Add NANOTIME (Linux only) option. - - Replace gettimeofday with generic utr (underlying timing routine) - option. - - Remove DIAG ifdef option. - - Interpret nested "start" calls as recursion. - - In NUMERIC mode, shift tag by 2 bits. -gptl1_4: - Added NUMERIC_TIMERS (configure --enable-numeric) for speedup. - If enabled, user args to start/stop MUST be numeric tags rather - than character strings. Intended primarily to be used with - automatic code instrumentation (g++ -finstrument-functions), - and tests/jr-resolve.pl to back out a name. - - Added "numeric" to tests/ in order to test --enable-numeric. - - Remove HASH as an option (it is now assumed) for readability. - - Moved some OMP code from threadutil.c to gptl.c strictly for - efficiency (inlining). Hated to do it because the code really - doesn't belong there. - - Added jr-resolve.pl to tests/ to back out symbol name from - address. -gpt1_2: Changed GPT to GPTL to avoid overlap with other utilities named GPT... -gpt1_1: Added README and man pages. Better commenting. Fixed bug in min - calcs in GPTstop. -gpt1_0: Added PAPI support. For whatever reason, on IBM get negative - increments occasionally. -gpt0_3: Added overflow diagnostic novfl - Migrate threading ops to threadutil.c - Remove useless calcs from GPTstop - Added iteration option to depth test - overhead test is now a C code and tests potentially expensive - calcs embedded in the library - Removed exp, expensive, timetimeing tests - Reenabled pthreads - Fix SGI complaints about arg lists - Changed depth array to mitigate false sharing - Added DISABLE_TIMERS ifdef - autoconf bugfix - Change microsecond accumulator test from 1000000 to 10000000 -gpt0_2: Remove unused components in Timer. Make "name" component a fixed - size for efficiency. -gpt0_1: Add hashtable for efficiency. Add some more tests. Add ChangeLog. - Bugfix for printing. - diff --git a/cesm/models/utils/timing/gptl/INSTALL b/cesm/models/utils/timing/gptl/INSTALL deleted file mode 100644 index 95f2f68..0000000 --- a/cesm/models/utils/timing/gptl/INSTALL +++ /dev/null @@ -1,24 +0,0 @@ -This file describes how to build and install GPTL. For information on using -the library, see the web pages in the doc/ directory, and the file README in -the main directory. - -After untarring the distribution, construct a macros.make file by editing one -of the templates that is close to the machine you're building the library on -(e.g. macros.make.linux). Step-by-step instructions for setting each -configuration option are embedded in that file. If unsure of some settings, -you can run "./suggestions". This is an autoconf "configure" script which has -been modified to just print suggestions, rather than creating any output -files. - -It is a good idea to build with FORTRAN=yes even if you're not going to use -the Fortran wrappers. Doing this means "make test" will do more thorough -testing of the library via the Fortran tests. - -After creating macros.make: - -% make -% make test -% make install - -The "make test" step runs some of the example codes in ctests/ and ftests/ -and checks the results. diff --git a/cesm/models/utils/timing/gptl/Makefile b/cesm/models/utils/timing/gptl/Makefile deleted file mode 100644 index 2e73c82..0000000 --- a/cesm/models/utils/timing/gptl/Makefile +++ /dev/null @@ -1,173 +0,0 @@ -include macros.make - -ifeq ($(findstring xlf, $(FC)),xlf) - DEFINE = -WF,-D -else - DEFINE = -D -endif - -null = -OBJS = gptl.o util.o get_memusage.o print_memusage.o gptl_papi.o pmpi.o getoverhead.o \ - hashstats.o memstats.o pr_summary.o print_rusage.o - -ifeq ($(ENABLE_PMPI),yes) - CFLAGS += -DENABLE_PMPI -DMPI_STATUS_SIZE_IN_INTS=$(MPI_STATUS_SIZE_IN_INTS) - ifeq ($(MPI_CONST),yes) - CFLAGS += -DCONST=const - else - CFLAGS += -DCONST= - endif - ifeq ($(HAVE_IARGCGETARG),yes) - CFLAGS += -DHAVE_IARGCGETARG - endif - LIBNAME = gptl_pmpi -else - LIBNAME = gptl -endif - -# Always run the C tests. Add Fortran tests if Fortran enabled -MAKETESTS = ctests/all -RUNTESTS = ctests/test - -ifeq ($(MANDIR),$(null)) - MANDIR = $(INSTALLDIR) -endif - -ifeq ($(HAVE_SLASHPROC),yes) - CFLAGS += -DHAVE_SLASHPROC -endif - -ifeq ($(OPENMP),yes) - CFLAGS += -DTHREADED_OMP $(COMPFLAG) -else - ifeq ($(PTHREADS),yes) - CFLAGS += -DTHREADED_PTHREADS - endif -endif - -FOBJS = -ifeq ($(FORTRAN),yes) - FOBJS = process_namelist.o gptlf.o - OBJS += f_wrappers.o f_wrappers_pmpi.o - MAKETESTS += ftests/all - RUNTESTS += ftests/test -endif - -CFLAGS += $(INLINEFLAG) $(UNDERSCORING) - -ifeq ($(HAVE_PAPI),yes) - CFLAGS += -DHAVE_PAPI - CFLAGS += $(PAPI_INCFLAGS) - FFLAGS += $(DEFINE)HAVE_PAPI -endif - -ifeq ($(HAVE_MPI),yes) - CFLAGS += -DHAVE_MPI - FFLAGS += $(DEFINE)HAVE_MPI - ifeq ($(HAVE_COMM_F2C),yes) - CFLAGS += -DHAVE_COMM_F2C - endif - CFLAGS += $(MPI_INCFLAGS) - LDFLAGS += $(MPI_LIBFLAGS) -endif - -ifeq ($(HAVE_LIBRT),yes) - CFLAGS += -DHAVE_LIBRT - LDFLAGS += -lrt -endif - -ifeq ($(HAVE_NANOTIME),yes) - CFLAGS += -DHAVE_NANOTIME - ifeq ($(BIT64),yes) - CFLAGS += -DBIT64 - endif -endif - -ifeq ($(HAVE_VPRINTF),yes) - CFLAGS += -DHAVE_VPRINTF -endif - -ifeq ($(HAVE_TIMES),yes) - CFLAGS += -DHAVE_TIMES -endif - -ifeq ($(HAVE_GETTIMEOFDAY),yes) - CFLAGS += -DHAVE_GETTIMEOFDAY -endif - -############################################################################## -%.o: %.F90 - $(FC) -c $(FFLAGS) $< - -ifeq ($(FORTRAN),yes) -all: lib$(LIBNAME).a $(MAKETESTS) printmpistatussize -printmpistatussize: printmpistatussize.o - $(FC) -o $@ $? $(FFLAGS) -else -all: lib$(LIBNAME).a $(MAKETESTS) -endif - -libonly: lib$(LIBNAME).a -test: $(RUNTESTS) - -# MAKETESTS is ctests/all and maybe ftests/all -ctests/all: - $(MAKE) -C ctests all - -ftests/all: - $(MAKE) -C ftests all - -# RUNTESTS is ctests and maybe ftests -ctests/test: - $(MAKE) -C ctests test - -ftests/test: - $(MAKE) -C ftests test - -lib$(LIBNAME).a: $(OBJS) $(FOBJS) - $(AR) ruv $@ $(OBJS) $(FOBJS) - $(RM) -f ctests/*.o ftests/*.o - -install: lib$(LIBNAME).a - install -d $(INSTALLDIR)/lib - install -d $(INSTALLDIR)/include - install -d $(INSTALLDIR)/bin - install -d $(INSTALLDIR)/man/man3 - install -m 0644 lib$(LIBNAME).a $(INSTALLDIR)/lib - install -m 0644 gptl.h $(INSTALLDIR)/include -ifeq ($(FORTRAN),yes) -# *.mod will install either gptl.mod or GPTL.mod - install -m 0644 gptl.inc *.mod $(INSTALLDIR)/include -endif - install -m 0644 man/man3/*.3 $(MANDIR)/man/man3 - install -m 0755 *pl $(INSTALLDIR)/bin - $(MAKE) -C ctests/ install INSTALLDIR=$(INSTALLDIR) - -# Some Fortran compilers name modules in upper case, so account for both possibilities -uninstall: - $(RM) -f $(INSTALLDIR)/lib/lib$(LIBNAME).a - $(RM) -f $(INSTALLDIR)/include/gptl.h $(INSTALLDIR)/include/gptl.inc $(INSTALLDIR)/include/gptl.mod $(INSTALLDIR)/include/GPTL.mod - $(RM) -f $(MANDIR)/man/man3/GPTL*.3 - -clean: - $(RM) -f $(OBJS) $(FOBJS) lib$(LIBNAME).a *.mod printmpistatussize.o printmpistatussize - $(MAKE) -C ctests clean - $(MAKE) -C ftests clean - -f_wrappers.o: gptl.h private.h -f_wrappers_pmpi.o: gptl.h private.h -gptl.o: gptl.h private.h -util.o: gptl.h private.h -gptl_papi.o: gptl.h private.h -process_namelist.o: process_namelist.F90 gptl.inc -gptlf.o: gptlf.F90 -pmpi.o: gptl.h private.h -getoverhead.o: private.h -hashstats.o: private.h -memstats.o: private.h -pr_summary.o: private.h -get_memusage.o: -print_memusage.o: gptl.h -print_rusage.o: private.h - -printmpistatussize.o: printmpistatussize.F90 diff --git a/cesm/models/utils/timing/gptl/Makefile.in b/cesm/models/utils/timing/gptl/Makefile.in deleted file mode 100644 index b249154..0000000 --- a/cesm/models/utils/timing/gptl/Makefile.in +++ /dev/null @@ -1,43 +0,0 @@ -CC = @CC@ -CFLAGS = @CFLAGS@ @THREADFLAGS@ @FDEFS@ @THREADDEFS@ @DEFS@ @PAPIPREP@ @BITFLAGS@ - -LIBNAME = libgptl.a -LIBDIR = @prefix@/lib -INCDIR = @prefix@/include -MANDIR = @prefix@/man/man3 -OBJS = f_wrappers.o gptl.o util.o threadutil.o get_memusage.o \ - print_memusage.o gptl_papi.o -AR = @AR@ - -@SET_MAKE@ - -all: $(LIBNAME) ctests/all ftests/all - -$(LIBNAME): $(OBJS) - ar @ARFLAGS@ $@ $(OBJS) - rm -f ctests/*.o ftests/*.o - -install: $(LIBNAME) - cp $(LIBNAME) $(LIBDIR) - cp gptl.h gptl.inc $(INCDIR) - cp man/man3/*.3 $(MANDIR) - -uninstall: - rm -f $(LIBDIR)/$(LIBNAME) $(INCDIR)/gptl.h $(INCDIR)/gptl.inc - -ctests/all: - (cd ctests && $(MAKE) all) - -ftests/all: - (cd ftests && $(MAKE) all) - -clean: - rm -f $(OBJS) $(LIBNAME) - (cd ctests && $(MAKE) clean) - (cd ftests && $(MAKE) clean) - -f_wrappers.o: f_wrappers.c gptl.h private.h -gptl.o: gptl.c gptl.h private.h -util.o: util.c gptl.h private.h -threadutil.o: threadutil.c gptl.h private.h -gptl_papi.o: gptl_papi.c gptl.h private.h diff --git a/cesm/models/utils/timing/gptl/README b/cesm/models/utils/timing/gptl/README deleted file mode 100644 index eccdb57..0000000 --- a/cesm/models/utils/timing/gptl/README +++ /dev/null @@ -1,151 +0,0 @@ -This file contains information about using GPTL. For information on building -and installing GPTL, see the file INSTALL. - -GPTL is the "General Purpose Timing Library". It can be used to manually -instrument application codes with an arbitrary set of "regions" (or "timers") -over which statistics such as wallclock time and CPU time are gathered and -subsequently printed. If the target application is built with the GNU -compilers (gcc or gfortran), Pathscale (pathcc or pathf95), or PGI compilers, -GPTL can also be used to automatically instrument regions which are defined -by function entry and exit points. This is an easy way to generate a dynamic -call tree. See Auto-Instrumentation below for a description of how to use -this feature. - -Similar to compiler-generated auto-instrumentation, GPTL can intercept and -auto-profile MPI calls made by the application if the target MPI library -supports the PMPI profiling layer. In this case an estimate of bytes -transferred by each MPI call is presented in the printed output. - -If the PAPI library is installed (http://icl.cs.utk.edu/papi), GPTL -also provides a convenient mechanism to access all available PAPI events. In -addtion to PAPI preset and native events, GPTL defines derived events which -are based on PAPI counters. See gptl.h for a list of available derived events. -Of course these events can only be enabled if the PAPI counters they require -are available on the target architecture. - - -Using GPTL ----------- - -C codes making GPTL library calls should #include . Fortran codes can -"use gptl" or #include or Fortran include 'gptl.inc'. The C and Fortran -interfaces are identical, except that the C interface uses mixed case. All -user-accessible functions return either 0 (success) or -1 (failure). Example -codes that use the library can be found in subdirectories ctests/ and -ftests/. - -Code instrumentation to utilize GPTL involves zero or more calls to -GPTLsetoption(), then a single call to GPTLinitialize(), then an arbitrary -sequence of calls to GPTLstart() and GPTLstop(), and finally a call to -GPTLpr() or GPTLpr_file(). See "Example" below for a sample calling -sequence. Calls to GPTLstart() and GPTLstop() are thread-safe, with per-thread -statistics printed by GPTLpr() or GPTLpr_file(). - -The purpose of GPTLsetoption() is to enable or disable various library -options. For example, to enable the PAPI counter for total cycles, do this: - -ret = GPTLsetoption (PAPI_TOT_CYC, 1); - -The "1" says "enable". Use "0" for "disable". See the man pages for complete -documentation on function usage and arguments. The list of available GPTL -options is contained in gptl.h, and a complete list of available PAPI-based -events can be found by running "ctests/avail". - -GPTLinitialize() initializes the GPTL library. - -There can be an arbitrary number of start/stop pairs before GPTLpr() or -GPTLpr_file() is called to print the results. And an arbitrary amount of -nesting of regions is also allowed. The printed results will be indented to -indicate the level of nesting for each region. - -GPTLpr() prints the results to a file named timing., where the single -argument is an integer. For MPI jobs, it is most convenient to use -the MPI rank of the invoking task for . Equivalently, function -GPTLpr_file() can be called. Its input argument is a character string -indicating the output file name to be written. It is up to the user to ensure -that these print functions write to uniquely-named files, in order to avoid -name-space collisions. - -GPTLfinalize() can be called to clean up the GPTL environment. All space -malloc'ed by the GPTL library will be freed by this call. - - -Example -------- - -From "man GPTLstart", a simple example calling sequence to time a couple of -code regions and print the results is: - -(void) GPTLsetoption (GPTLcpu, 1); /* enable cpu timings */ -(void) GPTLsetoption (GPTLwall, 0); /* disable wallclock timings */ -(void) GPTLsetoption (PAPI_TOT_CYC, 1); /* enable counting of total cycles */ -... -(void) GPTLinitialize(); /* initialize the GPTL library */ -(void) GPTLstart ("total"); /* start a timer */ -... -(void) GPTLstart ("do_work"); /* start another timer */ - -do_work(); /* do some work */ - -(void) GPTLstop ("do_work"); /* stop a timer */ -(void) GPTLstop ("total"); /* stop a timer */ -... -(void) GPTLpr (mympitaskid); /* print the results to timing. */ - - -Auto-instrumentation --------------------- - -If the regions to be timed are defined by function entry and exit points, and -the application to be profiled is built with either the GNU or Pathscale -compilers, you might find it convenient to use the auto-instrumentation -feature of GPTL. Here's how: - -1) Add the flag -finstrument-functions (-Minstrument:functions under PGI) -when compiling the routines you'd like to profile. - -2) Add calls to GPTLsetoption() (if desired), and GPTLinitialize() to the main -program before any other routines are invoked. - -3) Add a call to GPTLpr() or GPTLpr_file() wherever appropriate prior to where -the code terminates. - -4) Link with -lgptl (and -lpapi if PAPI is enabled). - -5) Run the code. - -6) Run "hex2name.pl | less", where - is the name of the executable, and is the name of the -timing file to be converted. - -The result should be a dynamic call tree with timings and (if enabled) PAPI -counts and derived event statistics for each region, where regions are defined -by function entry and exit points. - -Here's what's happening under the covers: - -The -finstrument-functions flag tells the compiler to insert calls to -__cyg_profile_func_enter (void *this_fn, void *call_site) at function start, -and __cyg_profile_func_exit (void *this_fn, void *call_site) at function -exit. GPTL defines these functions as calls to (effectively) GPTLstart() and -GPTLstop(), where the address of the function is used as the input sentinel to -these routines. - -Running hex2name.pl converts the function addresses back to human-readable -function names. It uses the UNIX "nm" utility to do this. - -When using MPI auto-profiling, steps 2) and 3) above can be omitted. In this -case GPTL auto-generates calls to GPTLinitialize and GPTLpr from MPI_Init and -MPI_finalize, respectively. - -Multi-processor instrumented codes ----------------------------------- - -With rev. 4.3 of GPTL, function GPTLpr_summary(mpi_communicator) was -rewritten from scratch for scalability and the presentation of additional -statistical information. Max, min, mean, and standard deviation of region -timings, along with the process and thread index responsible for max and min, -are presented in a single output file named timing.summary. With this -rewrite, this is now the preferred method (over parsegptlout.pl) for -gathering summary statistics across threads and tasks. See example3 in the -web documentation for further information. diff --git a/cesm/models/utils/timing/gptl/TODO b/cesm/models/utils/timing/gptl/TODO deleted file mode 100644 index c2e0bce..0000000 --- a/cesm/models/utils/timing/gptl/TODO +++ /dev/null @@ -1,9 +0,0 @@ -o For THREADED_PTHREADS, improve speed of finding threadid -o Why does C++ test break when use prototypes for pr_summary*? -o "make clean" should always get rid of everything that might have been built -o Revamp test suite. Suggestions: - - More, shorter tests - - "make test" should only build what is going to be run - - Overload specific tests only when necessary - - Rewrite runalltests* in Perl -o GPU port diff --git a/cesm/models/utils/timing/gptl/configure.ac b/cesm/models/utils/timing/gptl/configure.ac deleted file mode 100644 index 4795deb..0000000 --- a/cesm/models/utils/timing/gptl/configure.ac +++ /dev/null @@ -1,53 +0,0 @@ -dnl Process this file with autoconf to produce a configure script. -AC_INIT(private.h) -AC_LANG(C) -echo "This script provides suggestions for settings to apply in macros.make" -echo "You can pass things like FC=gfortran or CC=pathcc to it to override defaults." -AC_PROG_MAKE_SET -AC_PROG_CC() -echo "Assuming C compiler is $CC" -AC_PROG_FC() -echo "Assuming Fortran compiler is $FC" -dnl This barfs when CC is pgcc and F77 pgf90 -AC_FC_FUNC(z_zz,z_zz) -case $z_zz in - z_zz__) echo "Fortran name mangling: UNDERSCORING=-DFORTRANDOUBLEUNDERSCORE" ;; - z_zz_) echo "Fortran name mangling: UNDERSCORING=-DFORTRANUNDERSCORE" ;; - Z_ZZ) echo "Fortran name mangling: UNDERSCORING=-DFORTRANCAPS" ;; - *) echo "Fortran name mangling: UNDERSCORING=" ;; -esac - -dnl For proper handling of const and inline -AC_C_INLINE -echo "Inlining: -Dinline=$ac_cv_c_inline" -dnl AC_FUNC_VPRINTF -AC_CHECK_LIB(papi,PAPI_library_init,[echo "PAPI library found: OK to set HAVE_PAPI=yes"], - [echo "PAPI library not found: HAVE_PAPI=no"]) - -AC_CHECK_FUNC(backtrace_symbols,[echo "backtrace_symbols found: OK to set HAVE_BACKTRACE=yes"], - [echo "backtrace_symbols NOT found: HAVE_BACKTRACE=no"]) - -unset usempich; -unset usempi; -AC_CHECK_LIB(mpich,MPI_Init,[echo "libmpich.a found: OK to set HAVE_MPI=yes";usempich=yes], - AC_CHECK_LIB(mpi,MPI_Init,[echo "libmpi.a found: OK to set HAVE_MPI=yes OK";usempi=yes],[echo "MPI library not found: HAVE_MPI=no"])) -AC_CHECK_FILE(/proc,[echo "/proc found: HAVE_SLASHPROC=yes"], - [echo "/proc not found: HAVE_SLASHPROC=no"]) -AC_CHECK_LIB(pthread,pthread_mutex_init,[echo "pthreads library found: OK to set PTHREADS=yes"], - [echo "pthreads library not found: PTHREADS=no"]) - -if test -n "${usempich}" ; then -AC_CHECK_LIB(mpich,iargc,[echo "iargc found in libmpich.a: OK to set HAVE_IARGCGETARG=yes"], [echo "iargc not found in libmpich.a: HAVE_IARGCGETARG=no"]) -fi - -if test -n "${usempi}" ; then -AC_CHECK_LIB(mpi,iargc,[echo "iargc found in libmpi.a: OK to set HAVE_IARGCGETARG=yes"], - [echo "iargc not found in libmpi.a: HAVE_IARGCGETARG=no"]) -fi - -AC_CHECK_SIZEOF([void *]) -if test "$ac_cv_sizeof_void_p" = 8; then - echo "Pointer size = 8 so BIT64=yes"; -elif test "$ac_cv_sizeof_void_p" = 4; then - echo "Pointer size = 4 so BIT64=no"; -fi diff --git a/cesm/models/utils/timing/gptl/ctests/Makefile b/cesm/models/utils/timing/gptl/ctests/Makefile deleted file mode 100644 index 10c4d6f..0000000 --- a/cesm/models/utils/timing/gptl/ctests/Makefile +++ /dev/null @@ -1,158 +0,0 @@ -# TESTS defines which EXES to run when "make test" is done. -# Always run "summary". Add others depending on settings. - -include ../macros.make - -# Ensure that CFLAGS are set for no optimization -CFLAGS += -g -O0 - -TESTS = global -ifeq ($(HAVE_MPI),yes) - TESTS += summary pmpi -endif - -ifeq ($(HAVE_PAPI),yes) - TESTS += testpapi -endif - -ifeq ($(ENABLE_PMPI),yes) - CFLAGS += -DENABLE_PMPI - LIBNAME = gptl_pmpi - ifeq ($(HAVE_IARGCGETARG),yes) - CFLAGS += -DHAVE_IARGCGETARG - endif -else - LIBNAME = gptl -endif - -LDFLAGS = $(CFLAGS) -L.. -l$(LIBNAME) $(ABIFLAGS) -lm - -ifeq ($(OPENMP),yes) - CFLAGS += -DTHREADED_OMP $(COMPFLAG) - LDFLAGS += $(COMPFLAG) -else - ifeq ($(PTHREADS),yes) -# Threaded tests use OpenMP - CFLAGS += -DTHREADED_OMP $(COMPFLAG) - LDFLAGS += -lpthread $(COMPFLAG) - endif -endif - -ifeq ($(HAVE_PAPI),yes) - CFLAGS += -DHAVE_PAPI $(PAPI_INCFLAGS) - LDFLAGS += $(PAPI_LIBFLAGS) -endif - -ifeq ($(HAVE_MPI),yes) - CFLAGS += -DHAVE_MPI $(MPI_INCFLAGS) - LDFLAGS += $(MPI_LIBFLAGS) -endif - -# Auto-profiling -ifeq ($(TEST_AUTOPROFILE),yes) - TESTS += cygprofile profcxx -# Initialize OBJS: cygprofilesubs.o is the one .o file needed that patsubst can't -# set automatically - OBJS = cygprofilesubs.o -endif - -# EXES is TESTS plus some other sample codes. -# Items in EXES but not TESTS are built by "make all" but -# not run by "make test" - -EXES = $(TESTS) papiomptest gptl_gran_overhead printwhileon - -UTILEXES = gptl_gran_overhead -ifeq ($(HAVE_PAPI),yes) - UTILEXES += gptl_avail gptl_knownflopcount -endif -EXES += $(UTILEXES) - -OBJS += $(patsubst %,%.o,$(EXES)) - -all: $(EXES) - -clean: - $(RM) *.o $(EXES) timing.* - -gptl_avail: avail.o - $(CC) -o $@ $< $(LDFLAGS) - -gptl_knownflopcount: knownflopcount.o - $(CC) -o $@ $< $(LDFLAGS) - -gptl_gran_overhead: gran_overhead.o - $(CC) $(CFLAGS) -o $@ $< $(LDFLAGS) - -papiomptest: papiomptest.o - $(CC) $(THREADFLAGS) -o $@ $< $(LDFLAGS) - -cygprofile: cygprofile.o cygprofilesubs.o - $(CC) -o $@ cygprofile.o cygprofilesubs.o $(LDFLAGS) $(INSTRFLAG) -cygprofilesubs.o: cygprofilesubs.c - $(CC) -c $(CFLAGS) $(INSTRFLAG) -o $@ $< - -profcxx: profcxx.o - $(CXX) -o $@ $< $(LDFLAGS) $(INSTRFLAG) -profcxx.o: profcxx.C myclasses.h - $(CXX) -c $(CFLAGS) $(INSTRFLAG) -o $@ $< - -summary: summary.o - $(CC) -o $@ $< $(LDFLAGS) - -testpapi: testpapi.o - $(CC) -o $@ $< $(LDFLAGS) - -pmpi: pmpi.o - $(CC) -o $@ $< $(LDFLAGS) - -global: global.o - $(CC) -o $@ $< $(LDFLAGS) - -printwhileon: printwhileon.o - $(CC) -o $@ $< $(LDFLAGS) - -# Built-in tests to ensure that GPTL is behaving as expected -# Invoke as "make test" from one dir above - -test: $(TESTS) - @echo - -ifeq ($(HAVE_PAPI),yes) - @./testpapi - @echo -endif - -ifeq ($(HAVE_MPI),yes) - @echo Running env OMP_NUM_THREADS=2 $(MPICMD) ./summary... - @env OMP_NUM_THREADS=2 $(MPICMD) ./summary || (echo "Failure to run" && exit 1) - @echo Success - @echo "Shell is checking contents of timing.summary produced by ./summary for a specific region name..." - @grep -q sleep timing.summary || (echo "Failure" && exit 1) - @echo Success -ifeq ($(ENABLE_PMPI),yes) - @echo - @echo Running $(MPICMD) ./pmpi... - @env $(MPICMD) ./pmpi || (echo "Failure" && exit 1) - @echo Success -endif -endif - -ifeq ($(TEST_AUTOPROFILE),yes) - @echo - @echo "Testing auto-profiling..." - ./cygprofile || (echo "Failure to run" && exit 1) - @echo Success at running - @echo "Running hex2name.pl | grep callutil100times..." - (../hex2name.pl ./cygprofile timing.0 | grep -q callutil100times) && echo "Success" || (echo "Failure" && exit 1) -endif - @echo - @echo "All C and C++ tests passed" - @echo - -install: $(UTILEXES) -ifneq ($(UTILEXES),) - install -m 0755 $(UTILEXES) $(INSTALLDIR)/bin && exit 0 -else - @exit 0 -endif diff --git a/cesm/models/utils/timing/gptl/ctests/avail.c b/cesm/models/utils/timing/gptl/ctests/avail.c deleted file mode 100644 index 49dcca9..0000000 --- a/cesm/models/utils/timing/gptl/ctests/avail.c +++ /dev/null @@ -1,90 +0,0 @@ -#include "../gptl.h" - -#include -#include -#include - -int main () -{ - int ret; - -#ifndef HAVE_PAPI - printf ("gptl_avail: GPTL was compiled without HAVE_PAPI so doing nothing\n"); - return 0; -#endif - - if ((ret = PAPI_library_init (PAPI_VER_CURRENT)) != PAPI_VER_CURRENT) { - printf ("%s\n", PAPI_strerror (ret)); - return -1; - } - - printf ("Purpose: print derived events available on this architecture\n"); - printf ("Note: 'available' may require enabling multiplexing in some cases\n"); - printf ("For PAPI-specific events, run papi_avail and papi_native_avail" - " from the PAPI distribution\n\n"); - printf ("Available derived events:\n"); - printf ("Name Code Description\n"); - printf ("-------------------------------------------\n"); - - if (GPTLsetoption (GPTL_IPC, 1) == 0) { - printf("%-20s %-10d %s\n", "GPTL_IPC", GPTL_IPC, "Instructions per cycle"); - ret = GPTLinitialize (); - ret = GPTLfinalize (); - } - - if (GPTLsetoption (GPTL_CI, 1) == 0) { - printf("%-20s %-10d %s\n", "GPTL_CI", GPTL_CI, "Computational intensity"); - ret = GPTLinitialize (); - ret = GPTLfinalize (); - } - - if (GPTLsetoption (GPTL_FPC, 1) == 0) { - printf("%-20s %-10d %s\n", "GPTL_FPC", GPTL_FPC, "FP Ops per cycle"); - ret = GPTLinitialize (); - ret = GPTLfinalize (); - } - - if (GPTLsetoption (GPTL_FPI, 1) == 0) { - printf("%-20s %-10d %s\n", "GPTL_FPI", GPTL_FPI, "FP Ops per instruction"); - ret = GPTLinitialize (); - ret = GPTLfinalize (); - } - - if (GPTLsetoption (GPTL_LSTPI, 1) == 0) { - printf("%-20s %-10d %s\n", "GPTL_LSTPI", GPTL_LSTPI, "Load-store instruction fraction"); - ret = GPTLinitialize (); - ret = GPTLfinalize (); - } - - if (GPTLsetoption (GPTL_DCMRT, 1) == 0) { - printf("%-20s %-10d %s\n", "GPTL_DCMRT", GPTL_DCMRT, "L1 Miss rate (fraction)"); - ret = GPTLinitialize (); - ret = GPTLfinalize (); - } - - if (GPTLsetoption (GPTL_LSTPDCM, 1) == 0) { - printf("%-20s %-10d %s\n", "GPTL_LSTPDCM", GPTL_LSTPDCM, "Load-store instructions per L1 miss"); - ret = GPTLinitialize (); - ret = GPTLfinalize (); - } - - if (GPTLsetoption (GPTL_L2MRT, 1) == 0) { - printf("%-20s %-10d %s\n", "GPTL_L2MRT", GPTL_L2MRT, "L2 Miss rate (fraction)"); - ret = GPTLinitialize (); - ret = GPTLfinalize (); - } - - if (GPTLsetoption (GPTL_L3MRT, 1) == 0) { - printf("%-20s %-10d %s\n", "GPTL_L3MRT", GPTL_L3MRT, "L3 Miss rate (fraction)"); - ret = GPTLinitialize (); - ret = GPTLfinalize (); - } - - if (GPTLsetoption (GPTL_LSTPL2M, 1) == 0) { - printf("%-20s %-10d %s\n", "GPTL_LSTPL2M", GPTL_LSTPL2M, "Load-store instructions per L2 miss"); - ret = GPTLinitialize (); - ret = GPTLfinalize (); - } - - return 0; -} diff --git a/cesm/models/utils/timing/gptl/ctests/cygprofile.c b/cesm/models/utils/timing/gptl/ctests/cygprofile.c deleted file mode 100644 index b6ad442..0000000 --- a/cesm/models/utils/timing/gptl/ctests/cygprofile.c +++ /dev/null @@ -1,54 +0,0 @@ -#include -#include -#include "../gptl.h" - -extern void callsubs (int); - -int main (int argc, char **argv) -{ - int niter = 1000; - int ret; - int n, nregions; - char name[64]; - double wallclock; - - if (argc == 2) { - niter = atoi (argv[1]); - } else if (argc > 2) { - printf ("Usage: %s loop_length\n", argv[0]); - } - - GPTLsetoption (GPTLabort_on_error, 0); - - if ((ret = GPTLinitialize ()) != 0) { - printf ("%s: GPTLinitialize failure\n", argv[0]); - return -1; - } - callsubs (niter); - GPTLpr (0); - - printf ("%s: Testing GPTLget_nregions...\n", argv[0]); - if (GPTLget_nregions (0, &nregions) < 0) { - printf ("%s: GPTLget_nregions failure\n", argv[0]); - return -1; - } - printf ("Success\n"); - - printf ("%s: Testing GPTLget_regionname, GPTLget_wallclock " - "for %d regions...\n", argv[0], nregions); - for (n = 0; n < nregions; ++n) { - if ((ret = GPTLget_regionname (0, n, name, sizeof (name))) < 0) { - printf ("%s: GPTLget_regionname failure\n", argv[0]); - return -1; - } - - if ((ret = GPTLget_wallclock (name, 0, &wallclock)) < 0) { - printf ("%s: GPTLget_wallclock failure for name=%s\n", argv[0], name); - return -1; - } - } - printf ("Success\n"); - - (void) GPTLfinalize (); - return 0; -} diff --git a/cesm/models/utils/timing/gptl/ctests/cygprofilesubs.c b/cesm/models/utils/timing/gptl/ctests/cygprofilesubs.c deleted file mode 100644 index 234ae7b..0000000 --- a/cesm/models/utils/timing/gptl/ctests/cygprofilesubs.c +++ /dev/null @@ -1,52 +0,0 @@ -#include - -static int junk; -extern void callutil10times (); -extern void callutil100times (); -extern void util (); -extern void A (); -extern void B (); -extern void C (); - -void callsubs (int niter) -{ - callutil10times (); - callutil100times (); - A(); - util (); -} - -void callutil10times () -{ - int n; - for (n = 0; n < 10; ++n) - util (); -} - -void callutil100times () -{ - int n; - for (n = 0; n < 100; ++n) - util (); -} - -void util () -{ - junk = 11; -} - -void A () -{ - B (); -} - -void B () -{ - C (); -} - -void C () -{ - util (); - callutil10times (); -} diff --git a/cesm/models/utils/timing/gptl/ctests/global.c b/cesm/models/utils/timing/gptl/ctests/global.c deleted file mode 100644 index 9a89584..0000000 --- a/cesm/models/utils/timing/gptl/ctests/global.c +++ /dev/null @@ -1,116 +0,0 @@ -#include -#include /* sleep, usleep */ -#include "../gptl.h" - -#ifdef HAVE_MPI -#include -#endif - -#ifdef THREADED_OMP -#include -#endif - -int main (int argc, char **argv) -{ - int iam = 0; - int nranks = 1; /* number of MPI tasks (default 1) */ - int nthreads = 1; /* number of threads (default 1) */ - int iter; - int tnum = 0; -#ifdef HAVE_PAPI - int code; -#endif - int ret; - unsigned int nsec; /* number of seconds to sleep */ - -#ifdef HAVE_PAPI - int sub (int, int); -#endif - - ret = GPTLsetoption (GPTLabort_on_error, 1); -#ifdef HAVE_PAPI - ret = GPTLevent_name_to_code ("PAPI_FP_OPS", &code); - if (ret == 0) { - printf ("Enabling option PAPI_FP_OPS\n"); - ret = GPTLsetoption (code, 1); - } else { - printf ("Unable to get option for PAPI_FP_OPS\n"); - } -#endif - -#ifdef HAVE_MPI - if (MPI_Init (&argc, &argv) != MPI_SUCCESS) { - printf ("Failure from MPI_Init\n"); - return 1; - } - ret = MPI_Comm_rank (MPI_COMM_WORLD, &iam); - ret = MPI_Comm_size (MPI_COMM_WORLD, &nranks); -#endif - - ret = GPTLinitialize (); - ret = GPTLstart ("total"); - -#ifdef THREADED_OMP - nthreads = omp_get_max_threads (); -#pragma omp parallel for private (ret, tnum, nsec) -#endif - for (iter = 0; iter < nthreads; ++iter) { -#ifdef THREADED_OMP - tnum = omp_get_thread_num (); -#endif - /* Test 1: threaded sleep */ - ret = GPTLstart ("nranks-iam+mythread"); - nsec = (unsigned int) nranks-iam+tnum; - ret = sleep (nsec); - ret = GPTLstop ("nranks-iam+mythread"); - } - - /* Test 2: 5-task sleep(iam) ms */ - if (iam > 0 && iam < 6) { - ret = GPTLstart ("1-5_iam"); - nsec = iam; - ret = sleep (nsec); - ret = GPTLstop ("1-5_iam"); - } - -#ifdef HAVE_PAPI - /* Test 3: PAPI */ - ret = GPTLstart ("1e3*iam*mythread_FP_OPS"); - ret = sub (iam, tnum); - ret = GPTLstop ("1e3*iam*mythread_FP_OPS"); -#endif - - ret = GPTLstop ("total"); - ret = GPTLpr (iam); - - if (iam == 0) - printf ("global: testing GPTLpr_summary...\n"); - -#ifdef HAVE_MPI - if (GPTLpr_summary (MPI_COMM_WORLD) != 0) - return 1; - ret = MPI_Finalize (); -#else - if (GPTLpr_summary () != 0) - return 1; -#endif - - if (GPTLfinalize () != 0) - return 1; - - return 0; -} - -#ifdef HAVE_PAPI -int sub (int iam, int tnum) -{ - float sum; - int i; - - sum = 1.7; - for (i = 0; i < iam*tnum; ++i) - sum *= 0.999; - printf ("sum=%f\n", sum); - return 0; -} -#endif diff --git a/cesm/models/utils/timing/gptl/ctests/gran_overhead.c b/cesm/models/utils/timing/gptl/ctests/gran_overhead.c deleted file mode 100644 index d56f3f8..0000000 --- a/cesm/models/utils/timing/gptl/ctests/gran_overhead.c +++ /dev/null @@ -1,140 +0,0 @@ -#include "../gptl.h" -#ifdef HAVE_MPI -#include -#endif -#include - -int handle; /* for _handle routines--used by both granularity and overhead */ - -int main (int argc, char **argv) -{ - typedef struct { - char *name; - int utr; - } Vals; - /* - ** Don't test MPI_Wtime: too complex to get to work everywhere. - */ - Vals vals[] = {{"gettimeofday", GPTLgettimeofday}, - {"nanotime", GPTLnanotime}, - /* {"mpiwtime", GPTLmpiwtime}, */ - {"clockgettime", GPTLclockgettime}, - {"papitime", GPTLpapitime}, - {"read_real_time", GPTLread_real_time}}; - static const int nvals = sizeof (vals) / sizeof (Vals); - - int ret; - int n; - char *mingranname = 0; - char *minohname = 0; - double mingran = 99999.; - double minoh = 99999.; - double val; - - extern double granularity (void); - extern double overhead (void); - - for (n = 0; n < nvals; n++) { - printf ("Checking %s...\n", vals[n].name); - if ((ret = GPTLsetutr (vals[n].utr)) == 0) { - ret = GPTLsetoption (GPTLoverhead, 0); - - if ((ret = GPTLinitialize ()) != 0) { - printf ("GPTLinitialize failure\n"); - return -1; - } - - /* Need to call MPI_Init when the UTR is MPI_Wtime */ - - /* - ** Don't test MPI_Wtime: too complex to get to work everywhere. - */ - - /* - if (vals[n].utr == GPTLmpiwtime) { - if ((ret = MPI_Init (&argc, &argv)) != 0) { - printf ("Failure from MPI_Init: skipping MPI_Wtime...\n"); - continue; - } - } - */ - - /* - ** Warm up the handle routines, especially the first "start" call - ** which adds the entry point. - */ - - handle = 0; - ret = GPTLstart_handle ("zzz", &handle); - ret = GPTLstop_handle ("zzz", &handle); - ret = GPTLreset (); - - val = granularity (); - if (val < mingran) { - mingran = val; - mingranname = vals[n].name; - } - - ret = GPTLreset (); - val = overhead (); - if (val < minoh) { - minoh = val; - minohname = vals[n].name; - } - } else { - printf ("Not available\n"); - } - ret = GPTLfinalize (); - printf ("\n"); - } - printf ("func with finest granularity = %s (%g)\n", mingranname, mingran); - printf ("func with min overhead = %s (%g)\n", minohname, minoh); - return 0; -} - -double granularity () -{ - int ret; - int count; - int onflg; - double wallclock; - double usr; - double sys; - long long papi; - - /* handle was initialized in main*/ - - do { - ret = GPTLstart_handle ("zzz", &handle); - ret = GPTLstop_handle ("zzz", &handle); - ret = GPTLquery ("zzz", 0, &count, &onflg, &wallclock, &usr, &sys, &papi, 0); - } while (wallclock == 0.); - - printf ("granularity = %g seconds found after %d iterations\n", wallclock, count); - return wallclock; -} - -double overhead () -{ - int n; - double oh; - - int ret; - int count; - int onflg; - double wallclock; - double usr; - double sys; - long long papi; - - /* handle was initialized in main*/ - - for (n = 0; n < 10000; n++) { - ret = GPTLstart_handle ("zzz", &handle); - ret = GPTLstop_handle ("zzz", &handle); - } - ret = GPTLquery ("zzz", 0, &count, &onflg, &wallclock, &usr, &sys, &papi, 0); - oh = 0.0001 * wallclock; - printf ("overhead = %g per call based on 10,000 iterations\n", oh); - return oh; -} diff --git a/cesm/models/utils/timing/gptl/ctests/knownflopcount.c b/cesm/models/utils/timing/gptl/ctests/knownflopcount.c deleted file mode 100644 index 3032611..0000000 --- a/cesm/models/utils/timing/gptl/ctests/knownflopcount.c +++ /dev/null @@ -1,130 +0,0 @@ -#include /* getopt */ -#include -#include -#include -#include - -int main (int argc, char **argv) -{ - const int niter = 1000; /* iteration count */ - const int arrlen = 1000000; /* array size */ - const int maxevents = 10; /* Max PAPI events */ - long_long *papicounters; /* output from PAPI_read */ - long_long *prvcounters; /* output from PAPI_read */ - long_long diff; /* PAPI count for region */ - char eventname[maxevents][PAPI_MAX_STR_LEN]; - - int EventSet = PAPI_NULL; /* Event set needed by PAPI lib */ - - int ret; /* return code */ - int code; /* PAPI event code */ - int i, n; /* loop indices */ - int c; /* for parsing argv */ - int nevents = 0; /* number of PAPI events (init to 0) */ - - double arr[arrlen]; /* array to do math on */ - - void init (double *); /* initialize arr */ - - papicounters = (long_long *) malloc (maxevents * sizeof (long_long)); - prvcounters = (long_long *) malloc (maxevents * sizeof (long_long)); - - /* Initialize the PAPI library */ - - if ((ret = PAPI_library_init (PAPI_VER_CURRENT)) != PAPI_VER_CURRENT) { - printf ("%s\n", PAPI_strerror (ret)); - return -1; - } - - /* Create the eventset */ - - if ((ret = PAPI_create_eventset (&EventSet)) != PAPI_OK) { - printf ("Failure creating eventset: %s\n", PAPI_strerror (ret)); - return -1; - } - - if (argc < 2) { - printf ("Usage: %s -e papi_counter_name ...\n", argv[0]); - return -1; - } - - /* Parse arg list */ - - while ((c = getopt (argc, argv, "e:")) != -1) { - switch (c) { - case 'e': - - /* Convert name to code */ - - if ((ret = PAPI_event_name_to_code (optarg, &code)) != PAPI_OK) { - printf ("No code found for event %s\n", optarg); - printf ("PAPI_strerror says: %s\n", PAPI_strerror (ret)); - return -1; - } - - /* Add the event */ - - if ((ret = PAPI_add_event (EventSet, code)) != PAPI_OK) { - printf ("%s\n", PAPI_strerror (ret)); - printf ("Failure adding event %s\n", optarg); - return -1; - } - - if (nevents >= maxevents) { - printf ("%d events is too many\n", nevents); - return -1; - } - strcpy (eventname[nevents++], optarg); - break; - default: - printf ("unknown option %c\n", c); - return -1; - } - } - - /* Start the eventset */ - - if ((ret = PAPI_start (EventSet)) != PAPI_OK) - printf ("%s\n", PAPI_strerror (ret)); - - init (arr); - - /* Read counters before computation */ - - if ((ret = PAPI_read (EventSet, prvcounters)) != PAPI_OK) { - printf ("PAPI_read error\n"); - return -1; - } - - /* Do computation */ - - for (n = 0; n < niter; ++n) - for (i = 0; i < arrlen; ++i) - arr[i] += 0.1e0*arr[i]; - - /* Read counters after computation */ - - if ((ret = PAPI_read (EventSet, papicounters)) != PAPI_OK) { - printf ("PAPI_read error\n"); - return -1; - } - - /* Print counter information */ - - printf ("FP_OPS and FP_INS should be 2.e9\n\n"); - - for (n = 0; n < nevents; ++n) { - diff = papicounters[n] - prvcounters[n]; - printf ("%s count = %20.14e\n", eventname[n], (double) diff); - } - return 0; -} - -void init (double *arr) -{ - int i; - - for (i = 0; i < 1000000; ++i) - arr[i] = 1./i; -} - diff --git a/cesm/models/utils/timing/gptl/ctests/myclasses.h b/cesm/models/utils/timing/gptl/ctests/myclasses.h deleted file mode 100644 index 7922d24..0000000 --- a/cesm/models/utils/timing/gptl/ctests/myclasses.h +++ /dev/null @@ -1,56 +0,0 @@ -class Base -{ - public: - Base (); - ~Base (); -}; - -Base::Base () -{ -} - -Base::~Base () -{ -} - -class X: Base -{ - public: - X () - { - } - ~X() - { - } - void func (int x) - { - } - void func (double x) - { - } -}; - -class Y: Base -{ - public: - Y (); - ~Y(); - void func (int); - void func (double); -}; - -Y::Y () -{ -} - -Y::~Y() -{ -} - -void Y::func (int x) -{ -} - -void Y::func (double x) -{ -} diff --git a/cesm/models/utils/timing/gptl/ctests/papiomptest.c b/cesm/models/utils/timing/gptl/ctests/papiomptest.c deleted file mode 100644 index 92a4cbe..0000000 --- a/cesm/models/utils/timing/gptl/ctests/papiomptest.c +++ /dev/null @@ -1,206 +0,0 @@ -#include -#include /* atoi,exit */ -#include /* getopt */ -#include /* memset */ -#ifdef THREADED_OMP -#include -#endif - -#include "../gptl.h" - -double add (int, double); -double multiply (int, int, double); -double multadd (int, double); -double divide (int, double); -double compare (int, int); - -int main (int argc, char **argv) -{ - int nompiter = 128; - int looplen = 1000000; - int iter; - int papiopt; - int c; - int ret; - double value; - extern char *optarg; - - printf ("Purpose: test known-length loops with various floating point ops\n"); - printf ("Include PAPI and OpenMP, respectively, if enabled\n"); - printf ("Usage: %s [-l looplen] [-n nompiter] [-p papi_option_name]\n", argv[0]); - - while ((c = getopt (argc, argv, "l:n:p:")) != -1) { - switch (c) { - case 'l': - looplen = atoi (optarg); - printf ("Set looplen=%d\n", looplen); - break; - case 'n': - nompiter = atoi (optarg); - printf ("Set nompiter=%d\n", nompiter); - break; - case 'p': - if ((ret = GPTLevent_name_to_code (optarg, &papiopt)) != 0) { - printf ("Failure from GPTLevent_name_to_code(%s)\n", optarg); - exit (1); - } - - if (GPTLsetoption (papiopt, 1) < 0) { - printf ("Failure from GPTLsetoption (%s,1)\n", optarg); - exit (1); - } - break; - default: - printf ("unknown option %c\n", c); - exit (2); - } - } - - printf ("Outer loop length (OMP)=%d\n", nompiter); - printf ("Inner loop length=%d\n", looplen); - - ret = GPTLsetoption (GPTLverbose, 1); - ret = GPTLsetoption (GPTLabort_on_error, 1); - ret = GPTLsetoption (GPTLoverhead, 1); - ret = GPTLsetoption (GPTLnarrowprint, 1); - - if ((GPTLinitialize ()) != 0) { - printf ("papiomptest: GPTLinitialize failure\n"); - return -1; - } - - ret = GPTLstart ("total"); -#ifdef THREADED_OMP -#pragma omp parallel for private (iter, value) -#endif - for (iter = 1; iter <= nompiter; iter++) { - value = add (looplen, 0.); - value = multiply (looplen, iter, 0.); - value = multadd (looplen, 0.); - value = divide (looplen, 1.); - value = compare (looplen, iter); - } - ret = GPTLstop ("total"); - ret = GPTLpr (0); - if (GPTLfinalize () < 0) - exit (6); - - return 0; -} - -double add (int looplen, double zero) -{ - int i; - char string[128]; - double val = zero; - - if (looplen < 1000) - sprintf (string, "%dadditions", looplen); - else - sprintf (string, "%-.3gadditions", (double) looplen); - - if (GPTLstart (string) < 0) - exit (1); - - for (i = 1; i <= looplen; ++i) - val += zero; - - if (GPTLstop (string) < 0) - exit (1); - - return val; -} - -double multiply (int looplen, int iter, double zero) -{ - int i; - char string[128]; - double val = iter; - - if (looplen < 1000) - sprintf (string, "%dmultiplies", looplen); - else - sprintf (string, "%-.3gmultiplies", (double) looplen); - - if (GPTLstart (string) < 0) - exit (1); - - for (i = 1; i <= looplen; ++i) { - val *= zero; - } - - if (GPTLstop (string) < 0) - exit (1); - - return val; -} - -double multadd (int looplen, double zero) -{ - int i; - char string[128]; - double val = zero; - - if (looplen < 1000) - sprintf (string, "%dmultadds", looplen); - else - sprintf (string, "%-.3gmultadds", (double) looplen); - - if (GPTLstart (string) < 0) - exit (1); - - for (i = 1; i <= looplen; ++i) - val += zero * i; - - if (GPTLstop (string) < 0) - exit (1); - - return val; -} - -double divide (int looplen, double one) -{ - int i; - char string[128]; - double val = one; - - if (looplen < 1000) - sprintf (string, "%ddivides", looplen); - else - sprintf (string, "%-.3gdivides", (double) looplen); - - if (GPTLstart (string) < 0) - exit (1); - - for (i = 1; i <= looplen; ++i) - val /= one; - - if (GPTLstop (string) < 0) - exit (1); - - return val; -} - -double compare (int looplen, int iter) -{ - int i; - char string[128]; - double val = iter; - - if (looplen < 1000) - sprintf (string, "%dcompares", looplen); - else - sprintf (string, "%-.3gcompares", (double) looplen); - - if (GPTLstart (string) < 0) - exit (1); - - for (i = 0; i < looplen; ++i) - if (val < i) - val = i; - - if (GPTLstop (string) < 0) - exit (1); - - return val; -} diff --git a/cesm/models/utils/timing/gptl/ctests/pmpi.c b/cesm/models/utils/timing/gptl/ctests/pmpi.c deleted file mode 100644 index b1302ae..0000000 --- a/cesm/models/utils/timing/gptl/ctests/pmpi.c +++ /dev/null @@ -1,231 +0,0 @@ -#include -#include -#include -#include "../gptl.h" - -static const MPI_Comm comm = MPI_COMM_WORLD; -static int iam; - -int main (int argc, char **argv) -{ - int i, ret; - int commsize; - int val; - const int count = 1024; - const int tag = 98; - int sendbuf[count]; - int recvbuf[count]; - int *gsbuf; - int *atoabufsend, *atoabufrecv; - int sum; - MPI_Status status; - MPI_Request sendreq, recvreq; - int dest; - int source; - int resultlen; /* returned length of string from MPI routine */ - int provided; /* level of threading support in this MPI lib */ - char string[MPI_MAX_ERROR_STRING]; /* character string returned from MPI routine */ - const char *mpiroutine[] = {"MPI_Ssend", "MPI_Send", "MPI_Recv", "MPI_Sendrecv", "MPI_Irecv", - "MPI_Isend", "MPI_Waitall", "MPI_Barrier", "MPI_Bcast", "MPI_Allreduce", - "MPI_Gather", "MPI_Scatter", "MPI_Alltoall", "MPI_Reduce", "MPI_Issend"}; - const int nroutines = sizeof (mpiroutine) / sizeof (char *); - double wallclock; - - void chkbuf (const char *, int *, const int, const int); - - /* - int DebugWait = 1; - while (DebugWait) { - } - */ - - ret = GPTLsetoption (GPTLoverhead, 0); /* Don't print overhead stats */ - ret = GPTLsetoption (GPTLpercent, 0); /* Don't print percentage stats */ - ret = GPTLsetoption (GPTLabort_on_error, 1); /* Abort on any GPTL error */ - - /* - ** Only initialize GPTL if ENABLE_PMPI is false. - ** If it is true, the library will be initialized in MPI_Init() - */ -#ifndef ENABLE_PMPI - ret = GPTLinitialize (); /* Initialize GPTL */ - ret = GPTLstart ("total"); /* Time the whole program */ -#endif - - /* Initialize MPI by using MPI_Init_thread: report back level of MPI support */ - if ((ret = MPI_Init_thread (&argc, &argv, MPI_THREAD_SINGLE, &provided)) != 0) { - MPI_Error_string (ret, string, &resultlen); - printf ("%s: error from MPI_Init_thread: %s\n", argv[0], string); - MPI_Abort (comm, -1); - } - - ret = MPI_Comm_rank (comm, &iam); /* Get my rank */ - ret = MPI_Comm_size (comm, &commsize); /* Get communicator size */ - - if (iam == 0) { - printf ("%s: testing suite of MPI routines for auto-instrumentation via GPTL PMPI layer\n", argv[0]); - switch (provided) { - case MPI_THREAD_SINGLE: - printf ("MPI support level is MPI_THREAD_SINGLE\n"); - break; - case MPI_THREAD_SERIALIZED: - printf ("MPI support level is MPI_THREAD_SERIALIZED\n"); - break; - case MPI_THREAD_MULTIPLE: - printf ("MPI support level is MPI_THREAD_MULTIPLE\n"); - break; - default: - printf ("MPI support level is not known\n"); - MPI_Abort (comm, -1); - } - } - - for (i = 0; i < count; ++i) - sendbuf[i] = iam; - - dest = (iam + 1)%commsize; - source = iam - 1; - if (source < 0) - source = commsize - 1; - - /* Send, Ssend */ - if (commsize % 2 == 0) { - if (iam % 2 == 0) { - ret = MPI_Send (sendbuf, count, MPI_INT, dest, tag, comm); - ret = MPI_Recv (recvbuf, count, MPI_INT, source, tag, comm, &status); - } else { - ret = MPI_Recv (recvbuf, count, MPI_INT, source, tag, comm, &status); - ret = MPI_Send (sendbuf, count, MPI_INT, dest, tag, comm); - } - chkbuf ("MPI_Send + MPI_Recv", recvbuf, count, source); - - if (iam % 2 == 0) { - ret = MPI_Ssend (sendbuf, count, MPI_INT, dest, tag, comm); - ret = MPI_Recv (recvbuf, count, MPI_INT, source, tag, comm, &status); - } else { - ret = MPI_Recv (recvbuf, count, MPI_INT, source, tag, comm, &status); - ret = MPI_Ssend (sendbuf, count, MPI_INT, dest, tag, comm); - } - chkbuf ("MPI_Ssend + MPI_Recv", recvbuf, count, source); - - if (iam % 2 == 0) { - ret = MPI_Issend (sendbuf, count, MPI_INT, dest, tag, comm, &sendreq); - ret = MPI_Recv (recvbuf, count, MPI_INT, source, tag, comm, &status); - } else { - ret = MPI_Recv (recvbuf, count, MPI_INT, source, tag, comm, &status); - ret = MPI_Issend (sendbuf, count, MPI_INT, dest, tag, comm, &sendreq); - } - chkbuf ("MPI_Issend + MPI_Recv", recvbuf, count, source); - } - - ret = MPI_Sendrecv (sendbuf, count, MPI_INT, dest, tag, - recvbuf, count, MPI_INT, source, tag, - comm, &status); - chkbuf ("MPI_Sendrecv", recvbuf, count, source); - - ret = MPI_Irecv (recvbuf, count, MPI_INT, source, tag, - comm, &recvreq); - ret = MPI_Isend (sendbuf, count, MPI_INT, dest, tag, - comm, &sendreq); - ret = MPI_Wait (&recvreq, &status); - ret = MPI_Wait (&sendreq, &status); - chkbuf ("MPI_Isend + MPI_Irecv + MPI_Wait", recvbuf, count, source); - - ret = MPI_Irecv (recvbuf, count, MPI_INT, source, tag, - comm, &recvreq); - ret = MPI_Isend (sendbuf, count, MPI_INT, dest, tag, - comm, &sendreq); - ret = MPI_Waitall (1, &recvreq, &status); - ret = MPI_Waitall (1, &sendreq, &status); - chkbuf ("MPI_Waitall", recvbuf, count, source); - - ret = MPI_Barrier (comm); - - ret = MPI_Bcast (sendbuf, count, MPI_INT, 0, comm); - chkbuf ("MPI_Bcast", sendbuf, count, 0); - - for (i = 0; i < count; ++i) - sendbuf[i] = iam; - - ret = MPI_Allreduce (sendbuf, recvbuf, count, MPI_INT, MPI_SUM, comm); - sum = 0.; - for (i = 0; i < commsize; ++i) - sum += i; - chkbuf ("MPI_Allreduce", recvbuf, count, sum); - - gsbuf = (int *) malloc (commsize * count * sizeof (int)); - ret = MPI_Gather (sendbuf, count, MPI_INT, - gsbuf, count, MPI_INT, - 0, comm); - if (iam == 0) { - val = 0; - for (i = 0; i < commsize*count; ++i) { - if (gsbuf[i] != val) { - printf ("iam=%d MPI_Gather: bad gsbuf[%d]=%d != %d\n", iam, i, gsbuf[i], val); - MPI_Abort (comm, -1); - } - if ((i+1) % count == 0) - ++val; - } - } - - ret = MPI_Scatter (gsbuf, count, MPI_INT, - recvbuf, count, MPI_INT, - 0, comm); - chkbuf ("MPI_Scatter", recvbuf, count, iam); - - atoabufsend = (int *) malloc (commsize * sizeof (int)); - atoabufrecv = (int *) malloc (commsize * sizeof (int)); - for (i = 0; i < commsize; ++i) - atoabufsend[i] = i; - - ret = MPI_Alltoall (atoabufsend, 1, MPI_INT, - atoabufrecv, 1, MPI_INT, - comm); - - for (i = 0; i < commsize; ++i) - if (atoabufrecv[i] != iam) { - printf ("iam=%d MPI_Alltoall: bad atoabufrecv[%d]=%d != %d\n", - iam, i, atoabufrecv[i], i); - MPI_Abort (comm, -1); - } - - ret = MPI_Reduce (sendbuf, recvbuf, count, MPI_INT, MPI_SUM, 0, comm); - if (iam == 0) { - sum = 0.; - for (i = 0; i < commsize; ++i) - sum += i; - chkbuf ("MPI_Reduce", recvbuf, count, sum); - } - - ret = MPI_Finalize (); /* Clean up MPI */ - -#ifndef ENABLE_PMPI - ret = GPTLstop ("total"); - ret = GPTLpr (iam); /* Print the results */ -#endif - - /* Check that PMPI entries were generated for all expected routines */ - if (iam == 0) { - for (i = 0; i < nroutines; ++i) { - printf ("%s: checking that there is a GPTL entry for MPI routine %s...\n", argv[0], mpiroutine[i]); - ret = GPTLget_wallclock (mpiroutine[i], 0, &wallclock); - if (ret < 0) { - printf ("Failure\n"); - return -1; - } - printf("Success\n"); - } - } - return 0; -} - -void chkbuf (const char *msg, int *recvbuf, const int count, const int source) -{ - int i; - for (i = 0; i < count; ++i) - if (recvbuf[i] != source) { - printf ("iam=%d %s:bad recvbuf[%d]=%d != %d\n", iam, msg, i, recvbuf[i], source); - MPI_Abort (comm, -1); - } -} diff --git a/cesm/models/utils/timing/gptl/ctests/printwhileon.c b/cesm/models/utils/timing/gptl/ctests/printwhileon.c deleted file mode 100644 index 6569d62..0000000 --- a/cesm/models/utils/timing/gptl/ctests/printwhileon.c +++ /dev/null @@ -1,99 +0,0 @@ -#include -#include -#ifdef HAVE_MPI -#include -#endif -#ifdef THREADED_OMP -#include -#endif -#include "../gptl.h" - -int main (int argc, char **argv) -{ - int nthreads = 1; /* Value is 1 if no threading */ - int iam = 0; /* Value is 0 if no MPI */ - int commsize = 1; /* Value is 1 if no MPI */ - int provided = -1; /* level of threading support in this MPI lib */ - int n; - int ret; - -#ifdef HAVE_MPI - int resultlen; /* returned length of string from MPI routine */ - char string[MPI_MAX_ERROR_STRING]; /* character string returned from MPI routine */ - - /* Initialize MPI by using MPI_Init_thread: report back level of MPI support */ - if ((ret = MPI_Init_thread (&argc, &argv, MPI_THREAD_SINGLE, &provided)) != 0) { - MPI_Error_string (ret, string, &resultlen); - printf ("%s: error from MPI_Init_thread: %s\n", argv[0], string); - MPI_Abort (MPI_COMM_WORLD, -1); - } - - ret = MPI_Comm_rank (MPI_COMM_WORLD, &iam); /* Get my rank */ - ret = MPI_Comm_size (MPI_COMM_WORLD, &commsize); /* Get communicator size */ -#endif - - if (iam == 0) { - printf ("%s: testing GPTLpr() and GPTLpr_summary() with some timers ON\n", argv[0]); - printf ("Check timing.* files: 1st and last ranks, 1st and last threads should print error\n"); -#ifdef HAVE_MPI - switch (provided) { - case MPI_THREAD_SINGLE: - printf ("MPI support level is MPI_THREAD_SINGLE\n"); - break; - case MPI_THREAD_SERIALIZED: - printf ("MPI support level is MPI_THREAD_SERIALIZED\n"); - break; - case MPI_THREAD_MULTIPLE: - printf ("MPI support level is MPI_THREAD_MULTIPLE\n"); - break; - default: - printf ("MPI support level is not known\n"); - MPI_Abort (MPI_COMM_WORLD, -1); - } -#endif - } - - ret = GPTLsetoption (GPTLoverhead, 0); /* Don't print overhead stats */ - ret = GPTLsetoption (GPTLpercent, 0); /* Don't print percentage stats */ - ret = GPTLinitialize (); /* Initialize GPTL */ - - ret = GPTLstart ("total"); - /* Everyone starts "sub", but 1st and last ranks erroneously start it twice */ - ret = GPTLstart ("sub"); - if (iam == 0 || iam == commsize-1) - ret = GPTLstart ("sub"); - -#ifdef THREADED_OMP - nthreads = omp_get_max_threads (); -#endif - - if (iam == 0) - printf ("nthreads=%d ntasks=%d\n", nthreads, commsize); - -#pragma omp parallel for private (ret) - for (n = 0; n < nthreads; ++n) { - ret = GPTLstart ("threaded_region"); - ret = GPTLstart ("threaded_region_sub"); - - /* sleep a short time so timings are meaningful */ - ret = sleep (iam+n); - - /* Everyone starts "threaded_region_sub", but 1st and last threads erroneously start it twice */ - if (n == 0 || n == nthreads-1) - ret = GPTLstart ("threaded_region_sub"); - - ret = GPTLstop ("threaded_region_sub"); - ret = GPTLstop ("threaded_region"); - } - - ret = GPTLstop ("sub"); - ret = GPTLstop ("total"); - ret = GPTLpr (iam); -#ifdef HAVE_MPI - ret = GPTLpr_summary (MPI_COMM_WORLD); - ret = MPI_Finalize (); -#else - ret = GPTLpr_summary (); -#endif - return 0; -} diff --git a/cesm/models/utils/timing/gptl/ctests/profcxx.C b/cesm/models/utils/timing/gptl/ctests/profcxx.C deleted file mode 100644 index 5be4013..0000000 --- a/cesm/models/utils/timing/gptl/ctests/profcxx.C +++ /dev/null @@ -1,35 +0,0 @@ -#include "../gptl.h" -#ifdef HAVE_PAPI -#include -#endif -#include "myclasses.h" - -int main () -{ - X *x; - Y *y; - int ret; - -#ifdef HAVE_PAPI - GPTLsetoption(GPTLmultiplex,1); - GPTLsetoption(PAPI_L2_DCH, 1); - GPTLsetoption(PAPI_L1_TCM, 1); - GPTLsetoption(PAPI_L3_TCM, 1); -#endif - - ret = GPTLinitialize (); - ret = GPTLstart ("total"); - x = new (X); - x->func (1.2); - x->func (1); - delete (x); - - y = new (Y); - y->func (1.2); - y->func (1); - delete (y); - - ret = GPTLstop ("total"); - ret = GPTLpr (0); -} - diff --git a/cesm/models/utils/timing/gptl/ctests/summary.c b/cesm/models/utils/timing/gptl/ctests/summary.c deleted file mode 100644 index e92d5ea..0000000 --- a/cesm/models/utils/timing/gptl/ctests/summary.c +++ /dev/null @@ -1,152 +0,0 @@ -#include - -#include -#include -#include /* getopt */ -#include /* memset */ - -#include "../gptl.h" - -#ifdef THREADED_OMP -#include -#endif - -static int iam = 0; -static int nproc = 1; /* number of MPI tasks (default 1) */ -static int nthreads = 1; /* number of threads (default 1) */ - -double sub (int); - -int main (int argc, char **argv) -{ - char pname[MPI_MAX_PROCESSOR_NAME]; - - int iter; - int counter; - int c; - int tnum = 0; - int resultlen; - int ret; - double value; - extern char *optarg; - - while ((c = getopt (argc, argv, "p:")) != -1) { - switch (c) { - case 'p': - if ((ret = GPTLevent_name_to_code (optarg, &counter)) != 0) { - printf ("Failure from GPTLevent_name_to_code\n"); - return 1; - } - if (GPTLsetoption (counter, 1) < 0) { - printf ("Failure from GPTLsetoption (%s,1)\n", optarg); - return 1; - } - break; - default: - printf ("unknown option %c\n", c); - printf ("Usage: %s [-p option_name]\n", argv[0]); - return 2; - } - } - - ret = GPTLsetoption (GPTLabort_on_error, 1); - ret = GPTLsetoption (GPTLoverhead, 1); - ret = GPTLsetoption (GPTLnarrowprint, 1); - - if (MPI_Init (&argc, &argv) != MPI_SUCCESS) { - printf ("Failure from MPI_Init\n"); - return 1; - } - - /* - ** If ENABLE_PMPI is set, GPTL was initialized in MPI_Init - */ - -#ifndef ENABLE_PMPI - ret = GPTLinitialize (); - ret = GPTLstart ("total"); -#endif - - ret = MPI_Comm_rank (MPI_COMM_WORLD, &iam); - ret = MPI_Comm_size (MPI_COMM_WORLD, &nproc); - - ret = MPI_Get_processor_name (pname, &resultlen); - printf ("Rank %d is running on processor %s\n", iam, pname); - -#ifdef THREADED_OMP - nthreads = omp_get_max_threads (); -#pragma omp parallel for private (iter, ret, tnum) -#endif - - for (iter = 1; iter <= nthreads; iter++) { -#ifdef THREADED_OMP - tnum = omp_get_thread_num (); -#endif - printf ("Thread %d of rank %d on processor %s\n", tnum, iam, pname); - value = sub (iter); - } - -#ifndef ENABLE_PMPI - ret = GPTLstop ("total"); - ret = GPTLpr (iam); -#endif - - if (iam == 0) { - printf ("summary: testing GPTLpr_summary...\n"); - printf ("Number of threads was %d\n", nthreads); - printf ("Number of tasks was %d\n", nproc); - } - - if (GPTLpr_summary (MPI_COMM_WORLD) != 0) - return 1; - - if (GPTLpr_summary_file (MPI_COMM_WORLD, "timing.summary.duplicate") != 0) - return 1; - - ret = MPI_Finalize (); - - if (GPTLfinalize () != 0) - return 1; - - return 0; -} - -double sub (int iter) -{ - unsigned long usec; - unsigned long looplen = iam*iter*100000; - unsigned long i; - double sum; - int ret; - - ret = GPTLstart ("sub"); - /* Sleep msec is mpi rank + thread number */ - usec = 1000 * (iam * iter); - - ret = GPTLstart ("sleep"); - usleep (usec); - ret = GPTLstop ("sleep"); - - ret = GPTLstart ("work"); - sum = 0.; - ret = GPTLstart ("add"); - for (i = 0; i < looplen; ++i) { - sum += i; - } - ret = GPTLstop ("add"); - - ret = GPTLstart ("madd"); - for (i = 0; i < looplen; ++i) { - sum += i*1.1; - } - ret = GPTLstop ("madd"); - - ret = GPTLstart ("div"); - for (i = 0; i < looplen; ++i) { - sum /= 1.1; - } - ret = GPTLstop ("div"); - ret = GPTLstop ("work"); - ret = GPTLstop ("sub"); - return sum; -} diff --git a/cesm/models/utils/timing/gptl/ctests/testpapi.c b/cesm/models/utils/timing/gptl/ctests/testpapi.c deleted file mode 100644 index 3165ceb..0000000 --- a/cesm/models/utils/timing/gptl/ctests/testpapi.c +++ /dev/null @@ -1,66 +0,0 @@ -#include "../gptl.h" -#include - -int main (int argc, char **argv) -{ - int ret; - int i, code; - long long pc[1]; /* papi counters */ - double sum; - - printf ("testpapi: Testing PAPI interface...\n"); - - printf ("%s: testing getting event code for PAPI_TOT_CYC...\n", argv[0]); - if ((ret = GPTLevent_name_to_code ("PAPI_TOT_CYC", &code)) != 0) { - printf ("Failure\n"); - return 2; - } - printf ("Success\n"); - - printf ("%s: testing GPTLsetoption(PAPI_TOT_CYC,1)...\n", argv[0]); - if (GPTLsetoption (code, 1) != 0) { - printf ("Failure\n"); - return 3; - } - printf ("Success\n"); - - printf ("%s: testing GPTLinitialize\n", argv[0]); - if ((ret = GPTLinitialize ()) != 0) { - printf ("Failure\n"); - return 3; - } - printf ("Success\n"); - - printf ("%s: testing GPTLstart\n", argv[0]); - if ((ret = GPTLstart ("sum")) != 0) { - printf ("Unexpected failure from GPTLstart(\"sum\")\n"); - return 3; - } - printf ("Success\n"); - - sum = 0.; - for (i = 0; i < 1000000; ++i) - sum += (double) i; - printf ("%s: testing GPTLstop\n", argv[0]); - if ((ret = GPTLstop ("sum")) != 0) { - printf ("Unexpected failure from GPTLstop(\"sum\")\n"); - return 3; - } - printf ("Success\n"); - - printf ("%s: testing GPTLquerycounters...\n", argv[0]); - if (GPTLquerycounters ("sum", 0, pc) != 0) { - printf ("Failure\n"); - return 4; - } - printf ("sum=%g\n",sum); - printf ("%s: testing reasonableness of PAPI counters...\n", argv[0]); - if (pc[0] < 1 || pc[0] > 1.e8) { - printf ("Suspicious PAPI_TOT_CYC value=%lld for 1e6 additions\n", pc[0]); - return 5; - } else { - printf ("Success\n"); - } - printf ("%s: all tests successful\n", argv[0]); - return 0; -} diff --git a/cesm/models/utils/timing/gptl/doc/INSTALL b/cesm/models/utils/timing/gptl/doc/INSTALL deleted file mode 100755 index 95f2f68..0000000 --- a/cesm/models/utils/timing/gptl/doc/INSTALL +++ /dev/null @@ -1,24 +0,0 @@ -This file describes how to build and install GPTL. For information on using -the library, see the web pages in the doc/ directory, and the file README in -the main directory. - -After untarring the distribution, construct a macros.make file by editing one -of the templates that is close to the machine you're building the library on -(e.g. macros.make.linux). Step-by-step instructions for setting each -configuration option are embedded in that file. If unsure of some settings, -you can run "./suggestions". This is an autoconf "configure" script which has -been modified to just print suggestions, rather than creating any output -files. - -It is a good idea to build with FORTRAN=yes even if you're not going to use -the Fortran wrappers. Doing this means "make test" will do more thorough -testing of the library via the Fortran tests. - -After creating macros.make: - -% make -% make test -% make install - -The "make test" step runs some of the example codes in ctests/ and ftests/ -and checks the results. diff --git a/cesm/models/utils/timing/gptl/doc/btn_next.gif b/cesm/models/utils/timing/gptl/doc/btn_next.gif deleted file mode 100644 index 564d00c..0000000 Binary files a/cesm/models/utils/timing/gptl/doc/btn_next.gif and /dev/null differ diff --git a/cesm/models/utils/timing/gptl/doc/btn_previous.gif b/cesm/models/utils/timing/gptl/doc/btn_previous.gif deleted file mode 100644 index b1eea99..0000000 Binary files a/cesm/models/utils/timing/gptl/doc/btn_previous.gif and /dev/null differ diff --git a/cesm/models/utils/timing/gptl/doc/earlier.html b/cesm/models/utils/timing/gptl/doc/earlier.html deleted file mode 100644 index ede5de5..0000000 --- a/cesm/models/utils/timing/gptl/doc/earlier.html +++ /dev/null @@ -1,242 +0,0 @@ - - -Earlier changes to GPTL - -

Earlier changes to GPTL

- -
-

gptl-v5.3.2

-
    -
  • Bugfix to enable multiplexed use of latest PAPI library which includes - the Component interface (PAPI-C), which became available around - PAPI-3.9.0. The problem occurred in GPTL because the PAPI-C API changed - slightly vs. previous versions. Thanks to Crystal Jernigan of ORNL for - discovering and reporting the bug. -
  • New entry point GPTLprint_rusage() enables printing useful - information from standard C library routine getrusage(). This is - the preferred mechanism for getting memory hiwater mark from GPTL now that Linux - supports it (as of Linux 2.6.32). Other information printed includes - number of hard and soft page faults, and number of voluntary context switches. -
  • Do not print values of timers which are ON. This is - because a GPTLstop call is required to achieve a current accumulation. -
  • Obsoleted FORTRANCAPS -
  • Relevant to ENABLE_PMPI=yes only: Migrate specification of - MPI_STATUS_SIZE up to macros.make. A value of 10 is now more common, - while in older MPI libraries it was often 5. -
  • Relevant to ENABLE_PMPI=yes only: Bugfix to PMPI hooks enables use - of recent MPI libraries which include mods to the function prototypes - adding "const" to appropriate MPI arguments. This was a change to the MPI - standard adopted around definition of the MPI 2.2 standard. -

    - Note to MPI forum: Please only change existing API specs when absolutely - necessary! Changing the API can cause major disruption to other library - developers and to users of your library! The recent addition of "const" to - the API spec of some arguments of existing MPI functions seems totally - unnecessary. -

    • -
- -

gptl-v5.0

-
    -
  • Lower overhead incurred by the GPTL library itself: New hash algorithm results in fewer - collisions by employing better randomization. -
  • Improved user interface to GPTLstart_handle() and GPTLstop_handle() by changing - the second argument (the handle) to be the hash index instead of a - pointer to the timer itself. This has the huge advantage that inside of - threaded loops, thread-local storage for the handle variable is no longer - required in user code. The previous severe restriction of thread-local storage for these - variables effectively rendered GPTLstart_handle() and GPTLstop_handle() - unusable inside of threaded regions. And threaded regions are exactly where these more - efficient equivalents of GPTLstart() and GPTLstop() are most likely to be - useful! - -

    IMPORTANT NOTE: Slight API changes to GPTLstart_handle() - and GPTLstop_handle() were required. In C/C++ the type of the handle - argument was changed from void ** to int *. In Fortran the type - changed from integer(8) to integer. Tests of the new library with the - GNU compilers using the old types produced compiler warnings but still worked - properly. -

  • Produce a much more accurate estimate of the overhead incurred by the GPTL - library itself. Previously, the overhead estimate printed was only for the underlying - timing utility employed by GPTL (e.g. gettimeofday()). Now the printed overhead estimate - is for the entire GPTL library, not just the underlying timing utility. - -

    Also, a breakdown of overhead components by GPTL function is presented - when gptlpr() or gptlpr_file() are called. Examples include the Fortran - wrapper layer, generating the hash index, and calling the underlying timing - routine. More importantly, also printed is a per-region estimate of total overhead - incurred, and total overhead incurred in the parent of the region as a - result of timing the region. - -

    IMPORTANT NOTE: Currently GPTL doesn't know if the user API was Fortran or - C/C++. Also, calls to the start/stop routines can be intermixed with their - start_handle and stop_handle counterparts at will. Therefore GPTL produces a - "worst-case" estimate of induced overhead. Specifically, Fortran user-level code and - exclusive use of GPTLstart()/GPTLstop() instead of the more efficient - GPTLstart_handle() and GPTLstop_handle() is assumed. Users can refine the - overhead estimate by hand by subtracting the components which do not apply. For example, - if the Fortran API is not used and GPTL reports that the relative cost of the Fortran - API is 10% of the total overhead, the total overhead estimate can be reduced by 10%. -

- -

gptl-v4.3

-
    -
  • Complete rewrite of GPTLpr_summary() for accuracy and scalability to many thousands - of cores. Mean and standard deviation timing statistics across MPI tasks are calculated using - the algorithm of Chan et. al. described - here. - It is a one-pass algorithm well-suited to parallel computation. Additional statistics - from GPTLpr_summary() include max and min times across MPI tasks, MPI rank responsible - for max and min times, threading information, and PAPI statistics (if applicable). Thanks to - Pat Worley for suggesting the addition of this scalable function to GPTL. -
  • Added option GPTLmaxthreads to the list of settable options in - GPTLsetoption(). This setting indicates the maximum number of threads (OMP - or pthreads) that can have timers enabled. Especially useful when building - with THREADED_PTHREADS because the internal thread array used in this mode - defaults to a fixed size. If this size is much larger than needed it - will result in large memory wastage. If too small it limits the number of threads which - can enable timers. Also useful when GPTL is built with OPENMP=yes, in cases where the - invoking application sets the number of threads after GPTLinitialize() - is called. -
  • Changed default value of MAX_THREADS from 256 to 64. This value is only relevant - when GPTL is built with PTHREADS=yes). -
  • Bugfix for Fortran namelist parsing which indicated the incorrect print method to - be applied in GPTLpr(). -
  • Bugfix for incorrect estimate of memory overhead caused by the timing library itself. -
    • -
- -

gptl-v4.2

-
  • Enable GPTLget_wallclock() and GPTLget_eventvalue() to work when passed either - auto-instrumented or manually instrumented regions. -
  • Modify print_memusage to ensure size2 always exceeds size -
  • Add tests of GPTLget_nregions(), GPTLget_regionname(), and GPTLget_wallclock() to - cygprofile -
  • Add MPI_Ssend test to pmpi.c, and checks that MPI wrappers are working for - all expected regions. - -

    gptl-v4.0

    -
      -
    • Speedups for PTHREADS implementation eliminate - critical sections except on 1st invocation of each timer. Library overhead - is significantly reduced on many machines, especially when applications - are profiled with high thread counts. -
    • New entries GPTLstart_handle() and GPTLstop_handle(). These - routines work just like GPTLstart() and GPTLstop(), except - they take a 2nd argument, a "handle" to the region being - timed. The space for this argument is provided by the user, but is managed - by GPTL. It contains the address of the region being timed, and allows GPTL - to bypass determing the hash value and performing an address lookup on each - call. See "man GPTLstart_handle", and Example 7. -
    • New underlying timer option for AIX "read_real_time", provides - significantly better granularity than gettimeofday, with somewhat lower - overhead. -
    • Now safe to call GPTLinitialize() after GPTLfinalize(). -
    • Works with craycc/crayftn (see macros.make.xt5). -
    - -

    gptl-v3.7

    -
      -
    • Added Fortran module enabling "use gptl" instead of "include gptl.inc". -Adds interface block for argument checking. -
    • Enable auto-profiling under AIX. -
    • Enable GPTLprint_memusage() under MacOS (thanks to Chuck Bardeen). -
    • Bugfix for Fortran entry gptlget_regionname() to remove null terminator put -there by underlying GPTLget_regionname(). -
    • Bugfix for "make install" creates directories if they don't already exist. -
    • Added auto-profiling entry for MPI_Init_thread. -
    • Changed default print method from most_frequent to full_tree. -
    - -

    gptl-v3.6.3

    -
      -
    • GPTLprint_memusage() converts memory usage units to MB by default (if possible). -
    • Added support for bluegene (see macros.make.bluegene). -
    • Bugfix for gptl_papilibraryinit (Fortran): needed to return an int. -
    • Bugfix for GPTLpr_summary: slave tried to receive too much data. -
    • Changed LINUX ifdef to HAVE_SLASHPROC. Not all Linux systems have /proc/pid/statm. -
    • Makefile uses "findstring xlf" to decide how Fortran defines are set. -
    - -

    gptl-v3.6.1

    -
      -
    • Bugfix for auto-profiling MPI_Recv wrapper (when ENABLE_PMPI is set in macros.make): - previous version could cause hangs in some cases. -
    • Added auto-profiling entries for more MPI routines: MPI_Iprobe, MPI_Probe, MPI_Ssend, - MPI_Alltoallv, MPI_Scatterv, MPI_Test. -
    • Better estimates of bytes transferred for auto-profiled MPI routines. -
    - -

    gptl-v3.6

    -
      -
    • Makefile simplification. Can now run "make" from ctests/ and ftests/. -
    • Initial set of PMPI wrappers. Automatically generates MPI times and - statistics for the most common MPI calls. -
    • Option to synchronize and time certain collectives (see ENABLE_PMPI in - macros.make.linux). Note that the set of MPI routines profiled is not yet - complete. This option has not yet been fully tested. -
    - -

    gptl-v3.5.2

    -
      -
    • Bugfix for when omp_get_max_threads() returns zero. -
    • GPTLallocate() returns error when asked for zero bytes. -
    - -

    gptl-v3.5.1

    -
      -
    • OpenMP applications now work when GPTL is built with PTHREADS -
    • Fortran bugfix enables longer event names. This allows one to enable the - PAPI native event names which can be long. -
    • Remove some of the relatively unuseful entries from ctests/ and ftests/. -
    • Tested on AIX. -
    - -

    gptl-v3.5

    -
      -
    • Easier linking with C++ applications. -
    • Options for call-tree generation based on number of invocations per -parent: most_frequent (default), first_parent, last_parent, full_tree. -Previous versions always used first_parent. New option full_tree can -produce tons of output depending the nature of the call tree. But it -can also be very useful because it shows all parent-child relationships. -
    • Derived events based on PAPI: -
        -
      • L2 miss rate (GPTL_L2MRT) -
      • Load-stores per L2 miss (GPTL_LSTPL2M) -
      • L3 miss rate (GPTL_L3MRT) -
      -
    • Function GPTLpr_summary() now takes an MPI communicator as its -argument. Passing an "int" doesn't work with some MPI implementations (e.g. OpenMPI). -
    • New subroutine gptlprocess_namelist() enables Fortran codes to -use a namelist to set GPTL options. This allows changing settings -without having to recompile or relink application -codes. See Example 5 for example usage. -
    • New function GPTLget_eventvalue() allows an application to query -the current value of any PAPI-based event, including derived events. -
    • New function GPTLget_wallclock() allows an application to query -the current wallclock accumulation for any region. -
    • New function GPTLbarrier() calls MPI_Barrier() and times it. -
    • parsegptlout.pl now takes header name as an argument rather -than an integer index. -
    • hex2name.pl converts auto-instrumented entries for thread summary regions. -
    - -

    gptl-v3.4.7

    -
      -
    • Derived events based on PAPI: -
        -
      • Computational intensity (GPTL_CI) -
      • Instructions per cycle (GPTL_IPC) -
      • FP ops per cycle (GPTL_FPC) -
      • FP ops per instruction (GPTL_FPI) -
      • Load-store instruction fraction (GPTL_LSTPI) -
      • L1 miss rate (GPTL_DCMRT) -
      • Load-stores per L1 miss (GPTL_LSTPDCM) -
      -
    • New entry points GPTLevent_code_to name() and GPTLevent_name_to_code() -
    • Ability to disable portions of printed output (e.g. GPTLdopr_preamble) -
    • Better description of enabled events -
    - - diff --git a/cesm/models/utils/timing/gptl/doc/example1.html b/cesm/models/utils/timing/gptl/doc/example1.html deleted file mode 100644 index 393572e..0000000 --- a/cesm/models/utils/timing/gptl/doc/example1.html +++ /dev/null @@ -1,191 +0,0 @@ - - -GPTL usage example 1 - - - - - - -
    -GPTL home page -Example 2 - -
    - -

    Example 1: Simple manual instrumentation

    -This is an OpenMP Fortran code manually instrumented with GPTL calls. The -output produced by the embedded call to gptlpr() is shown and -explained. PAPI is used to compute floating point operation count. -

    -papiomptest.f90: -

    -
    
-program papiomptest
-  implicit none
-  include 'gptl.inc'                 ! Fortran GPTL include file
-  include 'f90papi.h'                ! Needed for PAPI_FP_OPS
-  integer :: ret, iter
-  integer, parameter :: nompiter = 2 ! Number of OMP threads
-
-  ret = gptlsetoption (gptlabort_on_error, 1) ! Abort on GPTL error
-  ret = gptlsetoption (PAPI_FP_OPS, 1)        ! Count floating point ops
-  ret = gptlsetoption (gptlnarrowprint, 1)    ! Print fewer sig figs
-  ret = gptlsetoption (gptlpercent, 1)        ! Turn on "% of" print
-  ret = gptlsetoption (gptloverhead, 0)       ! Turn off overhead estimate
-  ret = gptlinitialize ()                     ! Initialize GPTL
-  ret = gptlstart ('total')                   ! Start a timer
-
-!$OMP PARALLEL DO PRIVATE (iter)   ! Threaded loop
-  do iter=1,nompiter
-    ret = gptlstart ('A')          ! Start a timer
-    ret = gptlstart ('B')          ! Start another timer
-    ret = gptlstart ('C')
-    call sleep (iter)              ! Sleep for "iter" seconds
-    ret = gptlstop ('C')           ! Stop a timer
-    ret = gptlstart ('CC')
-    ret = gptlstop ('CC')
-    ret = gptlstop ('A')
-    ret = gptlstop ('B')         
-  end do
-  ret = gptlstop ('total')
-  ret = gptlpr (0)                 ! Print timer stats
-  ret = gptlfinalize ()            ! Clean up
-end program papiomptest
-
    
-
    - -Compile and link, then run: -
    -% gfortran -fopenmp papiomptest.f90 -I/usr/local/include -lgptl -lpapi 
-% env OMP_NUM_THREADS=2 ./a.out
-
    - -The call to gptlpr(0) wrote a file named timing.0, which looks like this: - -
    -
    
-PAPI event multiplexing was OFF
-PAPI events enabled (including derived):
-  Floating point operations executed
-
-Underlying timing routine was gettimeofday.
-Per-call utr overhead est: 2.9e-07 sec.
-Per-call PAPI overhead est: 1.4e-07 sec.
-If overhead stats are printed, roughly half the estimated number is
-embedded in the wallclock (and/or PAPI counter) stats for each timer
-
-If a '% of' field is present, it is w.r.t. the first timer for thread 0.
-If a 'e6 per sec' field is present, it is in millions of PAPI counts per sec.
-
-A '*' in column 1 below means the timer had multiple parents, though the
-values printed are for all calls. Further down the listing is more detailed
-information about multiple parents. Look for 'Multiple parent info'
-
-Stats for thread 0:
-             Called Recurse Wallclock max       min       % of total   FP_OPS e6 / sec 
-  total             1   -       2.000     2.000     2.000     100.00       59     0.00 
-    A               1   -       1.000     1.000     1.000      50.00       32     0.00 
-      B             1   -       1.000     1.000     1.000      50.00       36     0.00 
-        C           1   -       1.000     1.000     1.000      50.00        4     0.00 
-        CC          1   -       0.000     0.000     0.000       0.00        4     4.00 
-Total calls           = 5
-Total recursive calls = 0
-
-Stats for thread 1:
-        Called Recurse Wallclock max       min       % of total   FP_OPS e6 / sec 
-  A            1   -       2.000     2.000     2.000     100.00       50     0.00 
-    B          1   -       2.000     2.000     2.000     100.00       54     0.00 
-      C        1   -       2.000     2.000     2.000     100.00       22     0.00 
-      CC       1   -       0.000     0.000     0.000       0.00        4     4.00 
-Total calls           = 4
-Total recursive calls = 0
-
-Same stats sorted by timer for threaded regions:
-Thd      Called Recurse Wallclock max       min       % of total   FP_OPS e6 / sec 
-000 A           1   -       1.000     1.000     1.000      50.00       32     0.00 
-001 A           1   -       2.000     2.000     2.000     100.00       50     0.00 
-SUM A           2   -       3.000     2.000     1.000     150.00       82     0.00 
-
-000 B           1   -       1.000     1.000     1.000      50.00       36     0.00 
-001 B           1   -       2.000     2.000     2.000     100.00       54     0.00 
-SUM B           2   -       3.000     2.000     1.000     150.00       90     0.00 
-
-000 C           1   -       1.000     1.000     1.000      50.00        4     0.00 
-001 C           1   -       2.000     2.000     2.000     100.00       22     0.00 
-SUM C           2   -       3.000     2.000     1.000     150.00       26     0.00 
-
-000 CC          1   -       0.000     0.000     0.000       0.00        4     4.00 
-001 CC          1   -       0.000     0.000     0.000       0.00        4     4.00 
-SUM CC          2   -       0.000     0.000     0.000       0.00        8     4.00 
-
    
-
    - -

    Explanation of the above output

    -The output file contains a preamble which lists PAPI -settings such as whether multiplexing was on or off, and -which PAPI events were enabled. In this case -"Floating point operations executed" were counted. Other preamble contents -include estimates of underlying timing routine (UTR) -overhead, PAPI overhead, and an explanation of the printed -statistics. -

    -The statistics themselves begin with the line which reads "Stats for -thread 0:". The region names are listed on the far left. A -"region" is defined in the application by calling -GPTLstart(), then GPTLstop() for the same input (character -string) argument. -Indenting of -the names preserves parent-child relationships between the regions. In -the example, we see that region "A" was contained in "total", "B" -contained in "A", and regions "C" and "CC" both contained in "B". -

    -Reading across the output from left to right, the next column is labelled -"Called". This is the number of times the region was invoked. If any regions -were called recursively, that information is printed next. In this case there -were no recursive calls, so just a "-" is printed. Total wallclock time for -each region is printed next, followed by the max and min values for any -single invocation. In this simple example each region was called only once, so -"Wallclock", "max", and "min" are all the same. The next column lists the -percentage of wallclock time each region took compared to the first -region timed, and was produced due to the call to GPTLsetoption (GPTLpercent,1). -Turning this option on is generally useful only if there is a single region -wrapping the entire execution ("total" in the above example). -PAPI-based statistics are presented next. In -the example, the counter PAPI_FP_OPS was enabled. The name was shortened to FP_OPS to -confine the printed output to as few columns as possible. Finally, each PAPI -count is divided by wallclock time and printed as millions per second (in -this case millions of floating point operations per second). This column can -be turned off, with a call to GPTLsetoption (GPTLpersec, 0). - -

    -Since this was a threaded code run with OMP_NUM_THREADS=2, statistics -for the second thread are also printed. It starts at "Stats for thread 1:" The -output shows that thread 1 -participated in the computations for regions "A", "B", "C", and "CC", but not -"total". This is reflected in the code itself, since only the master -thread was active when start and stop calls were made for region "total". - -

    -After the per-thread statistics section, the same information is repeated, sorted by -region name if more than one thread was active. This section is delimited by -the string "Same stats sorted by -timer for threaded regions:". This region presentation order makes it easier - to inspect for load -balance across threads. The leftmost column is thread number, and the region -names are not indented. A sum across threads for each region is also printed, -and labeled "SUM". - -

    -GPTL home page -Example 2 - -
    - - diff --git a/cesm/models/utils/timing/gptl/doc/example2.html b/cesm/models/utils/timing/gptl/doc/example2.html deleted file mode 100644 index 597d857..0000000 --- a/cesm/models/utils/timing/gptl/doc/example2.html +++ /dev/null @@ -1,168 +0,0 @@ - - -GPTL usage example 2 - - - - - - -
    -Example 1 -Example 3 - -
    - -

    Example 2: Auto-instrumentation

    -This example is a C code compiled with auto-instrumentation enabled. It -uses PAPI to count total instructions, and instructions per cycle. Note -that function B has multiple parents, and GPTL reports the - multiple parent information in the output produced by the call - to GPTLpr_file(). -

    -main.c: -

    -
    
-#include <gptl.h>
-#include <papi.h>
-
-int main ()
-{
-  void do_work (void);
-  int i, ret;
-  ret = GPTLsetoption (GPTL_IPC, 1);     // Count instructions per cycle
-  ret = GPTLsetoption (PAPI_TOT_INS, 1); // Print total instructions
-  ret = GPTLsetoption (GPTLoverhead, 0); // Don't print overhead estimate
-  ret = GPTLinitialize ();               // Initialize GPTL
-  ret = GPTLstart ("main");              // Start a manual timer
-  do_work ();                            // Do some work 
-  ret = GPTLstop ("main");               // Stop the manual timer
-  ret = GPTLpr_file ("outfile");         // Write output to "outfile"
-}
-
    
-
    - -subs.c: -
    -
    -#include <unistd.h>
-
-extern void A(void);
-extern void AA(void);
-extern void B(void);
-
-void do_work ()
-{
-  A ();
-  AA ();
-  B ();
-}
-
-void A ()
-{
-  B ();
-}
-
-void AA ()
-{
-}
-
-void B ()
-{
-  sleep (1);
-}
-
    - -Compile all but main.c with auto-instrumentation, then link and -run. Useful auto-instrumentation of the main program is not possible, -because the call to GPTLinitialize() must be done manually and -needs to preceed all calls to GPTLstart and GPTLstop. -
    -% gcc -c main.c
-% gcc -finstrument-functions subs.c main.o -lgptl -lpapi
-% ./a.out
-
    - -Now convert the auto-instrumented output to human-readable form: -
    -% hex2name.pl a.out outfile > outfile.converted
-
    - -Output file outfile.converted looks like this: -
    -
    
-PAPI event multiplexing was OFF
-Description of printed events (PAPI and derived):
-  GPTL_IPC: Instructions per cycle
-  Instr completed  
-
-PAPI events enabled (including those required for derived events):
-  PAPI_TOT_INS
-  PAPI_TOT_CYC
-
-Underlying timing routine was gettimeofday.
-Per-call utr overhead est: 1.65e-06 sec.
-Per-call PAPI overhead est: 3.4e-07 sec.
-If overhead stats are printed, roughly half the estimated number is
-embedded in the wallclock stats for each timer.
-Print method was most_frequent.
-If a '%_of' field is present, it is w.r.t. the first timer for thread 0.
-If a 'e6_per_sec' field is present, it is in millions of PAPI counts per sec.
-
-A '*' in column 1 below means the timer had multiple parents, though the
-values printed are for all calls. Further down the listing is more detailed
-information about multiple parents. Look for 'Multiple parent info'
-
-Stats for thread 0:
-                       Called  Recurse Wallclock max       min       IPC      TOT_INS  e6_/_sec 
-  main                       1     -       2.000     2.000     2.000 2.81e-01    18060     0.01 
-    do_work                  1     -       2.000     2.000     2.000 2.61e-01    12547     0.01 
-      A                      1     -       1.000     1.000     1.000 3.01e-01     4958     0.00 
-*       B                    2     -       2.000     1.000     1.000 1.09e-01     2812     0.00 
-      AA                     1     -       0.000     0.000     0.000 7.77e-01      488   244.00 
-Total calls           = 6
-Total recursive calls = 0
-
-Multiple parent info (if any) for thread 0:
-Columns are count and name for the listed child
-Rows are each parent, with their common child being the last entry, which is indented
-Count next to each parent is the number of times it called the child
-Count next to child is total number of times it was called by the listed parents
-
-       1 A                         
-       1 do_work                         
-       2   B                         
-
    
-
    -

    Explanation of the above output

    -PAPI event "Total instructions executed" -(PAPI_TOT_INS) and derived event "Instructions per -cycle" (GPTL_IPC) were enabled. To compute instructions per -cycle, GPTL made the -PAPI library call to count total cycles (PAPI_TOT_CYC) in addition to -the already-enabled event PAPI_TOT_INS. When -GPTLpr_file() was called, it computed: -
    -      GPTL_IPC = PAPI_TOT_INS / PAPI_TOT_CYC;
-
    -

    -Note the asterisk in front of region "B". This -indicates that region "B" had multiple parents. It is presented as a child of -region "A" because that is the first region that invoked it. Information -about other parents is presented after the main call tree. It shows that -region "B" had two parents, "A", and "do_work". Each parent invoked "B" once, -for a total of 2 calls. - -

    -Example 1 -Example 3 - -
    - - diff --git a/cesm/models/utils/timing/gptl/doc/example3.html b/cesm/models/utils/timing/gptl/doc/example3.html deleted file mode 100644 index c9ec570..0000000 --- a/cesm/models/utils/timing/gptl/doc/example3.html +++ /dev/null @@ -1,67 +0,0 @@ - - -GPTL usage example 3 - - - - - - -
    -Example 2 -Example 4 - -
    - -

    Example 3: GPTLsummary

    -This hybrid OpenMP/MPI code demonstrates the use of summary routine GPTLpr_summary(). -It simulates variable work load by sleeping some number of seconds depending on rank -and thread number. Here we show only the output--the code is available in ctests/global.c. -

    -Compile and link (this example used the Intel compiler), then run with 2 threads and 8 MPI tasks: -

    -% mpif90 -o global -openmp global.c -L.. -lgptl
-% env OMP_NUM_THREADS=2 mpiexec -n 8 ./global
-
    - -Output file timing.summary was created by a call to GPTLpr_summary(MPI_COMM_WORLD). - -

    -timing.summary: -

    -
    
-Total ranks in communicator=8
-nthreads on rank 0=2
-'N' used for mean, std. dev. calcs.: 'ncalls'/'nthreads'
-'ncalls': number of times the region was invoked across tasks and threads.
-'nranks': number of ranks which invoked the region.
-mean, std. dev: computed using per-rank max time across all threads on each rank
-wallmax and wallmin: max, min time across tasks and threads.
-
-name                  ncalls nranks mean_time   std_dev   wallmax (rank  thread)   wallmin (rank  thread)
-total                      8      8     7.376     3.021     9.001 (     1     0)     2.001 (     7     0)
-nranks-iam+mythread       16      8     5.500     2.449     9.000 (     0     1)     1.000 (     7     0)
-1-5_iam                    5      5     3.000     1.581     5.000 (     5     0)     1.000 (     1     0)
-
-
    
-
    -In this example iam is the MPI rank and mythread is the thread number. -The output shows that sleeping nranks-iam+mythread has a max time of 9 seconds on rank 0, -thread 1, an a min time of 1 second on rank 7 thread 0. Mean and standard deviation stats are also -printed. The other region, 1-5_iam, is not threaded and only MPI ranks 1 through 5 -participate. Max time is on the highest rank participating (5 seconds on rank 5), and min time is -on the lowest rank participating (1 second on rank 1). - -
    -Example 2 -Example 4 - -
    - - diff --git a/cesm/models/utils/timing/gptl/doc/example4.html b/cesm/models/utils/timing/gptl/doc/example4.html deleted file mode 100644 index b623923..0000000 --- a/cesm/models/utils/timing/gptl/doc/example4.html +++ /dev/null @@ -1,188 +0,0 @@ - - -GPTL usage example 4 - - - - - - -
    -Example 3 -Example 5 - -
    - -

    Example 4: Auto-instrumentation of a C++ code

    -This example is a C++ code compiled with auto-instrumentation enabled. Note -that the constructor and destructor for X are inside the class definition, -and outside the class definition for Y. After running the code, -function addresses in the timing output file are translated to human-readable -form with perl script hex2name.pl. -

    -profcxx.C: -

    -
    
-#include <gptl.h>
-#include <myclasses.h>
-
-int main ()
-{
-  X *x;
-  Y *y;
-  int ret;
-
-  ret = GPTLinitialize ();
-  ret = GPTLstart ("total");
-
-  x = new (X);
-  x->func (1.2);
-  x->func (1);
-  delete (x);
-
-  y = new (Y);
-  y->func (1.2);
-  y->func (1);
-  delete (y);
-
-  ret = GPTLstop ("total");
-  ret = GPTLpr (0);
-}
-
-
    
-
    - -myclasses.h: -
    -
    -class Base
-{
- public:
-  Base ();
-  ~Base ();
-};
-
-Base::Base ()
-{
-}
-
-Base::~Base ()
-{
-}
-
-class X: Base
-{
- public:
-  X () 
-  {
-  }
-  ~X() 
-  {
-  }
-  void func (int x)
-  {
-  }
-  void func (double x)
-  {
-  }
-};
-
-class Y: Base
-{
- public:
-  Y ();
-  ~Y();
-  void func (int);
-  void func (double);
-};
-
-Y::Y ()
-{
-}
-
-Y::~Y()
-{
-}
-
-void Y::func (int x)
-{
-}
-
-void Y::func (double x)
-{
-}
-
    - -Compile profcxx.C with auto-instrumentation, then link and -run. In this case, The -fopenmp argument is needed because GPTL was built -with threading support. -
    -% g++ -fopenmp -finstrument-functions profcxx.C -o profcxx -lgptl
-% ./profcxx
-
    - -Now convert the auto-instrumented output to human-readable form: -
    -% hex2name.pl -demangle profcxx timing.0 > timing.0.converted
-
    - -Output file timing.0.converted looks like this: -
    -
    
-Stats for thread 0:
-                      Called  Recurse Wallclock max       min       UTR_Overhead  
-  total                     1     -       0.000     0.000     0.000         0.000 
-    ???                     1     -       0.000     0.000     0.000         0.000 
-*     Base::Base()          2     -       0.000     0.000     0.000         0.000 
-    ???                     1     -       0.000     0.000     0.000         0.000 
-    ???                     1     -       0.000     0.000     0.000         0.000 
-    ???                     1     -       0.000     0.000     0.000         0.000 
-*     Base::~Base()         2     -       0.000     0.000     0.000         0.000 
-    Y::Y()                  1     -       0.000     0.000     0.000         0.000 
-    Y::func(double)         1     -       0.000     0.000     0.000         0.000 
-    Y::func(int)            1     -       0.000     0.000     0.000         0.000 
-    Y::~Y()                 1     -       0.000     0.000     0.000         0.000 
-Overhead sum          =  8.32e-06 wallclock seconds
-Total calls           = 13
-Total recursive calls = 0
-
-Multiple parent info (if any) for thread 0:
-Columns are count and name for the listed child
-Rows are each parent, with their common child being the last entry, which is indented
-Count next to each parent is the number of times it called the child
-Count next to child is total number of times it was called by the listed parents
-
-       1 ???                         
-       1 Y::Y()                         
-       2   Base::Base()                         
-
-       1 ???                         
-       1 Y::~Y()                         
-       2   Base::~Base()                         
-
    
-
    -

    Explanation of the above output

    -Most of the output should be self-explanatory. But what are the "???" -strings? Those represent function invocations for which nm (invoked -by hex2name.pl) was unable to translate an address to a function -name. Note that constructor and destructor definitions for "X" -(myclasses.h above) are in-line. They're automatically inlined, -so there is no name to associate with their address and hex2name.pl -punts by printing three "?" characters. -

    -Constructor and destructor definitions for "Y" however, are outside the class -definition. Therefore they are compiled as separate functions, -and hex2name.pl is able to associate a name with their address. -

    -Example 3 -Example 5 - -
    - - diff --git a/cesm/models/utils/timing/gptl/doc/example5.html b/cesm/models/utils/timing/gptl/doc/example5.html deleted file mode 100644 index edf268b..0000000 --- a/cesm/models/utils/timing/gptl/doc/example5.html +++ /dev/null @@ -1,132 +0,0 @@ - - -GPTL usage example 5: Fortran use of gptlprocess_namelist() to set GPTL options - - - - - - -
    -Example 4 -Example 6 - -
    - -

    Example 5: Fortran use of gptlprocess_namelist() to set GPTL options

    -This example is a Fortran code which uses convenience -function gptlprocess_namelist() to set GPTL options instead of inserting -calls to gptlsetoption() into the application code. The main advantage -to this approach is that it avoids having to recompile and relink the -application code when changing GPTL options. -

    -nlreader.F: -

    -
    
-      program nlreader
-      implicit none
-
-      include 'gptl.inc'
-
-      integer :: ret
-
-! Process GPTL namelist. Args are namelist file name, unit number, and
-! output return code
-
-      call gptlprocess_namelist ('gptlnl', 1, ret)
-      if (ret /= 0) then
-        write(6,*)'GPTL namelist read failure'
-        call exit (1)
-      end if
-      
-      ret = gptlsetoption (gptlverbose, 0)
-      ret = gptlinitialize ()
-      end program nlreader
-
    
-
    -Next are the contents of the namelist file. Note that verbose = 1, -which results in printout when each namelist variable is set. The namelist -group name must always be gptlnl. The equivalent library call is -commented next to each namelist setting. -

    -gptlnl: -

    -
    
-&gptlnl
-! These settings are all the opposite of the default
- wall            = .false.   ! gptlsetoption (gptlwall,0)
- cpu             = .true.    ! gptlsetoption (gptlcpu,1)
- abort_on_error  = .true.    ! gptlsetoption (gptlabort_on_error,1)
- overhead        = .true.    ! gptlsetoption (gptloverhead,1)
- depthlimit      = 5         ! gptlsetoption (gptldepthlimit,5)
- verbose         = .true.    ! gptlsetoption (gptlverbose,1)
- narrowprint     = .false.   ! gptlsetoption (gptlnarrowprint,0)
- percent         = .true.    ! gptlsetoption (gptlpercent,1)
-! Comment out persec and multiplex so "nlreader" test won't fail even if 
-!   PAPI unavailable
-! persec          = .false.  ! gptlsetoption (gptlpersec,0)
-! multiplex       = .true.   ! gptlsetoption (gptlmultiplex,1)
- dopr_preamble   = .false.   ! gptlsetoption (gptldopr_preamble,0)
- dopr_threadsort = .false.   ! gptlsetoption (gptldopr_threadsort,0)
- dopr_multparent = .false.   ! gptlsetoption (gptldopr_multparent,0)
- dopr_collision  = .false.   ! gptlsetoption (gptldopr_collision,0)
-
-! utr, print_method, and eventlist use character variables instead of integer 
-! to avoid "magic number" settings in the namelist
-
- utr             = 'nanotime'     ! gptlsetutr (gptlnanotime)
- print_method    = 'full_tree'    ! gptlsetoption (gptlprintmethod, gptlfull_tree)
-!print_method    = 'first_parent' ! gptlsetoption (gptlprintmethod, gptlfirst_parent)
-!print_method    = 'last_parent'  ! gptlsetoption (gptlprintmethod, gptllast_parent)
-!print_method    = 'most_frequent'! gptlsetoption (gptlprintmethod, gptlmost_frequent)
-
-! List of events to count. PAPI_FP_OPS is a PAPI event, and GPTL_CI is a
-! PAPI-based derived event.
-! Comment out eventlist so "nlreader" test won't fail even if PAPI unavailable
-! eventlist       = 'PAPI_FP_OPS','GPTL_CI'
-/
-
    
-
    -Now compile and run: -
    -
    
-% mpif90 -fopenmp -o nlreader nlreader.F -lgptl
-% ./nlreader
-
    
-
    - -Here's the output: -
    -
    
-GPTLsetoption: boolean verbose = 1
-GPTLsetoption: boolean abort_on_error = 1
-GPTLsetoption: boolean wallstats = 0
-GPTLsetoption: cpustats = 1
-GPTLsetoption: depthlimit = 1
-GPTLsetoption: boolean percent = 1
-GPTLsetoption: boolean dopr_preamble = 0
-GPTLsetoption: boolean dopr_threadsort = 0
-GPTLsetoption: boolean dopr_multparent = 0
-GPTLsetoption: boolean dopr_collision = 0
-GPTLsetutr: underlying wallclock timer = nanotime
-GPTLsetoption: print_method = full_tree
- gptlprocess_namelist: skipping check for PAPI-based events because GPTL was built without PAPI support
-
    
-
    -

    Explanation of the above output

    -Each namelist setting results in a call to GPTLsetoption() -or GPTLsetutr() with the listed value. The output appears -because verbose was set to true. -
    -Example 4 -Example 6 - -
    - - diff --git a/cesm/models/utils/timing/gptl/doc/example6.html b/cesm/models/utils/timing/gptl/doc/example6.html deleted file mode 100644 index 24714f6..0000000 --- a/cesm/models/utils/timing/gptl/doc/example6.html +++ /dev/null @@ -1,506 +0,0 @@ - - -GPTL usage example 6: Automatic generation of MPI statistics - - - - - - -
    -Example 5 -Example 7 - -
    - -

    Example 6: Automatic generation of MPI statistics

    -This is a Fortran code which uses option -ENABLE_PMPI (in macros.make) to automatically profile various MPI routines in -the call tree along with number of invocations and average number of bytes -transferred per call. The set of MPI routines which can be automatically -profiled in this way is currently limited to a subset of commonly called -routines (MPI_Send, MPI_Recv, MPI_Isend, MPI_Irecv, etc.). An easy -way to see the list of supported routines is to run ftests/pmpi and examine -output file timing.0 which it creates. -

    -If you would like to add some routines, see files pmpi.c and -f_wrappers_pmpi.c. I'd be glad to add any of interest to the library if you can -provide them. It's just a methodical and repetitive process of typing in the -appropriate wrapping code. -

    -In this example HAVE_IARGCGETARG=yes in macros.make. This declares -that libraries provided by the Fortran compiler or runtime contains entries -for functions iargc() and getarg(). If these functions are -available, MPI_Init() and MPI_Finalize() are automatically -instrumented with calls to GPTLinitialize(), and a wrapping timer for -the entire program. Likewise, MPI_Finalize() is automatically -instrumented to print timers when it is called. GPTL can therefore be -used to gather and print timing statistics with zero modifications to user -code. Potentially used in conjunction with the auto-instrumentation feature -of many compilers (e.g. -finstrument-functions in gcc), a large amount of -hopefully useful data can be gathered. -

    -pmpi.F90: -

    -
    
-module myvars
-  integer :: iam
-  integer :: commsize
-end module myvars
-
-program pmpi
-  use myvars
-  implicit none
-
-#include <mpif.h>
-#include "../gptl.inc"
-
-  integer, parameter :: tag = 98
-  integer, parameter :: count = 1024
-
-  integer :: i, j, ret
-  integer :: val
-  integer :: comm = MPI_COMM_WORLD
-  integer :: sendbuf(0:count-1)
-  integer :: recvbuf(0:count-1)
-  integer :: sum
-  integer :: status(MPI_STATUS_SIZE)
-  integer :: sendreq, recvreq
-  integer :: dest
-  integer :: source
-  integer :: rdispls(0:count-1)
-  integer :: sdispls(0:count-1)
-
-  integer, allocatable :: atoabufsend(:)
-  integer, allocatable :: atoabufrecv(:)
-  integer, allocatable :: gsbufsend(:,:)      ! gather/scatter buffer send
-  integer, allocatable :: gsbufrecv(:,:)      ! gather/scatter buffer recv
-  integer, allocatable :: recvcounts(:)
-  integer, allocatable :: sendcounts(:)
-  integer, allocatable :: atoacounts(:)
-  integer, allocatable :: atoadispls(:)
-
-  logical :: flag
-
-  ret = gptlsetoption (gptloverhead, 0)
-  ret = gptlsetoption (gptlpercent, 0)
-  ret = gptlsetoption (gptlabort_on_error, 1)
-  ret = gptlsetoption (gptlsync_mpi, 1)
-
-#if ( ! defined HAVE_IARGCGETARG )
-  ret = gptlinitialize ()
-  ret = gptlstart ("total")
-#endif
-
-  call mpi_init (ret)
-
-  call mpi_comm_rank (comm, iam, ret)
-  call mpi_comm_size (comm, commsize, ret)
-  if (iam == 0) write(6,*)'commsize is ', commsize
-
-  do i=0,count-1
-    sendbuf(i) = iam
-  end do
-
-  dest = mod ((iam + 1), commsize)
-  source = iam - 1
-  if (source < 0) then
-    source = commsize - 1
-  end if
-!
-! mpi_send
-! mpi_recv
-! mpi_probe
-!
-  recvbuf(:) = -1
-  if (mod (commsize, 2) == 0) then
-    if (iam == 0) then
-      write(6,*)'Testing send, recv, probe...'
-    end if
-
-    if (mod (iam, 2) == 0) then
-      call mpi_send (sendbuf, count, MPI_INTEGER, dest, tag, comm, ret)
-      call mpi_recv (recvbuf, count, MPI_INTEGER, source, tag, comm, status, ret)
-    else
-      call mpi_probe (source, tag, comm, status, ret)
-      if (ret /= MPI_SUCCESS) then
-        write(6,*) "iam=", iam, " mpi_probe: bad return"
-        call mpi_abort (MPI_COMM_WORLD, -1, ret)
-      end if
-      call mpi_recv (recvbuf, count, MPI_INTEGER, source, tag, comm, status, ret)
-      call mpi_send (sendbuf, count, MPI_INTEGER, dest, tag, comm, ret)
-    end if
-    call chkbuf ('mpi_send + mpi_recv', recvbuf(:), count, source)
-
-    if (iam == 0) then
-      write(6,*)'Success'
-      write(6,*)'Testing ssend...'
-    end if
-!
-! mpi_ssend
-!
-    recvbuf(:) = -1
-    if (mod (iam, 2) == 0) then
-      call mpi_ssend (sendbuf, count, MPI_INTEGER, dest, tag, comm, ret)
-      call mpi_recv (recvbuf, count, MPI_INTEGER, source, tag, comm, status, ret)
-    else
-      call mpi_recv (recvbuf, count, MPI_INTEGER, source, tag, comm, status, ret)
-      call mpi_ssend (sendbuf, count, MPI_INTEGER, dest, tag, comm, ret)
-    end if
-    call chkbuf ('mpi_send + mpi_recv', recvbuf(:), count, source)
-    if (iam == 0) then
-      write(6,*)'Success'
-      write(6,*)'Testing sendrecv...'
-    end if
-  else
-    if (iam == 0) write(6,*)'NOTE: commsize=',commsize,' is odd so wont test ', &
-                            'send, recv, probe, ssend'
-  end if
-!
-! mpi_sendrecv
-! 
-  recvbuf(:) = -1
-  call mpi_sendrecv (sendbuf, count, MPI_INTEGER, dest, tag, &
-                     recvbuf, count, MPI_INTEGER, source, tag, &
-                     comm, status, ret)
-  call chkbuf ('mpi_sendrecv', recvbuf(:), count, source)
-  if (iam == 0) then
-    write(6,*)'Success'
-    write(6,*)'Testing irecv, isend, iprobe, itest, wait, waitall...'
-  end if
-!
-! mpi_irecv
-! mpi_isend
-! mpi_iprobe
-! mpi_test
-! mpi_wait
-! mpi_waitall
-!
-  recvbuf(:) = -1
-  call mpi_irecv (recvbuf, count, MPI_INTEGER, source, tag, &
-                  comm, recvreq, ret)
-  call mpi_iprobe (source, tag, comm, flag, status, ret)
-  call mpi_test (recvreq, flag, status, ret)
-  call mpi_isend (sendbuf, count, MPI_INTEGER, dest, tag, &
-                  comm, sendreq, ret)
-  call mpi_wait (recvreq, status, ret)
-  call mpi_wait (sendreq, status, ret)
-  call chkbuf ("mpi_wait", recvbuf(:), count, source)
-
-  recvbuf(:) = -1
-  call mpi_irecv (recvbuf, count, MPI_INTEGER, source, tag, &
-                  comm, recvreq, ret)
-  call mpi_isend (sendbuf, count, MPI_INTEGER, dest, tag, &
-                  comm, sendreq, ret)
-  call mpi_waitall (1, recvreq, status, ret)
-  call mpi_waitall (1, sendreq, status, ret)
-  call chkbuf ("mpi_waitall", recvbuf(:), count, source)
-
-  call mpi_barrier (comm, ret)
-  if (iam == 0) then
-    write(6,*)'Success'
-    write(6,*)'Testing bcast...'
-  end if
-!
-! mpi_bcast
-!
-  call mpi_bcast (sendbuf, count, MPI_INTEGER, 0, comm, ret)
-  call chkbuf ("mpi_bcast", sendbuf(:), count, 0)
-  if (iam == 0) then
-    write(6,*)'Success'
-    write(6,*)'Testing allreduce...'
-  end if
-!
-! mpi_allreduce: need to reset sendbuf due to bcast just done
-!
-  do i=0,count-1
-    sendbuf(i) = iam
-  end do
-
-  recvbuf(:) = -1
-  call mpi_allreduce (sendbuf, recvbuf, count, MPI_INTEGER, MPI_SUM, comm, ret)
-  sum = 0.
-  do i=0,commsize-1
-    sum = sum + i
-  end do
-  call chkbuf ("mpi_allreduce", recvbuf(:), count, sum)
-  if (iam == 0) then
-    write(6,*)'Success'
-    write(6,*)'Testing gather...'
-  end if
-
-  allocate (gsbufsend(0:count-1,0:commsize-1))
-  allocate (gsbufrecv(0:count-1,0:commsize-1))
-  allocate (recvcounts(0:commsize-1))
-  allocate (sendcounts(0:commsize-1))
-!
-! mpi_gather
-!
-  gsbufrecv(:,:) = -1
-  call mpi_gather (sendbuf, count, MPI_INTEGER, &
-                   gsbufrecv, count, MPI_INTEGER, 0, comm, ret)
-  if (iam == 0) then
-    do j=1,commsize-1
-      call chkbuf ("mpi_gather", gsbufrecv(:,j), count, j)
-    end do
-    write(6,*)'Success'
-    write(6,*)'Testing gatherv...'
-  end if
-!
-! mpi_gatherv: make just like mpi_gather for simplicity
-!
-  gsbufrecv(:,:) = -1
-  recvcounts(:) = count
-  rdispls(0) = 0
-  do j=1,commsize-1
-    rdispls(j) = rdispls(j-1) + recvcounts(j-1)
-  end do
-  call mpi_gatherv (sendbuf, count, MPI_INTEGER, &
-                    gsbufrecv, recvcounts, rdispls, &
-                    MPI_INTEGER, 0, comm, ret)
-  if (iam == 0) then
-    do j=1,commsize-1
-      call chkbuf ("mpi_gatherv", gsbufrecv(:,j), count, j)
-    end do
-    write(6,*)'Success'
-    write(6,*)'Testing scatter...'
-  end if
-!
-! mpi_scatter
-!
-  if (iam == 0) then
-    do j=0,commsize-1
-      gsbufsend(:,j) = j
-    end do
-  else
-    do j=0,commsize-1
-      gsbufsend(:,j) = -1
-    end do
-  end if
-  recvbuf(:) = -1
-  call mpi_scatter (gsbufsend, count, MPI_INTEGER, recvbuf, count, MPI_INTEGER, &
-                    0, comm, ret)
-  call chkbuf ("mpi_scatter", recvbuf(:), count, iam)
-  if (iam == 0) then
-    write(6,*)'Success'
-    write(6,*)'Testing scatterv...'
-  end if
-!
-! mpi_scatterv: make just like mpi_scatter for simplicity.
-!
-  if (iam == 0) then
-    do j=0,commsize-1
-      gsbufsend(:,j) = j
-    end do
-  else
-    gsbufsend(:,:) = -1
-  end if
-  sendcounts(:) = count
-  sdispls(0) = 0
-  do j=1,commsize-1
-    sdispls(j) = sdispls(j-1) + sendcounts(j-1)
-  end do
-  recvbuf(:) = -1
-  call mpi_scatterv (gsbufsend, sendcounts, sdispls, &
-                     MPI_INTEGER, recvbuf, count, &
-                     MPI_INTEGER, 0, comm, ret)
-  call chkbuf ("mpi_scatterv", recvbuf(:), count, iam)
-  if (iam == 0) then
-    write(6,*)'Success'
-    write(6,*)'Testing alltoall...'
-  end if
-!
-! mpi_alltoall
-!
-  allocate (atoabufsend(0:commsize-1))
-  allocate (atoabufrecv(0:commsize-1))
-  allocate (atoacounts(0:commsize-1))
-  allocate (atoadispls(0:commsize-1))
-  do j=0,commsize-1
-    atoabufsend(j) = j
-  end do
-  atoabufrecv(:) = -1
-  call mpi_alltoall (atoabufsend, 1, MPI_INTEGER, atoabufrecv, 1, MPI_INTEGER, comm, ret)
-  call chkbuf ("mpi_alltoall", atoabufrecv(:), 1, iam)
-  if (iam == 0) then
-    write(6,*)'Success'
-    write(6,*)'Testing alltoallv...'
-  end if
-!
-! mpi_alltoallv
-!
-  atoabufrecv(:) = -1
-  atoacounts(:) = 1
-  atoadispls(0) = 0
-  do j=1,commsize-1
-    atoadispls(j) = atoadispls(j-1) + atoacounts(j-1)
-  end do
-  
-  call mpi_alltoallv (atoabufsend, atoacounts, atoadispls, MPI_INTEGER, &
-                      atoabufrecv, atoacounts, atoadispls, MPI_INTEGER, comm, ret)
-  call chkbuf ("mpi_alltoall", atoabufrecv(:), 1, iam)
-
-  if (iam == 0) then
-    write(6,*)'Success'
-    write(6,*)'Testing reduce...'
-  end if
-!
-! mpi_reduce
-!
-  call mpi_reduce (sendbuf, recvbuf, count, MPI_INTEGER, MPI_SUM, 0, comm, ret)
-  if (iam == 0) then
-    sum = 0.
-    do i=0,commsize-1
-      sum = sum + i
-    end do
-    call chkbuf ("mpi_reduce", recvbuf(:), count, sum)
-  end if
-
-  if (iam == 0) then
-    write(6,*)'Success'
-    write(6,*)'Testing allgather...'
-  end if
-!
-! mpi_allgather
-!
-  gsbufrecv(:,:) = -1
-  call mpi_allgather (sendbuf, count, MPI_INTEGER, &
-                      gsbufrecv, count, MPI_INTEGER, comm, ret)
-  do j=0,commsize-1
-    call chkbuf ("mpi_allgather", gsbufrecv(:,j), count, j)
-  end do
-
-  if (iam == 0) then
-    write(6,*)'Success'
-    write(6,*)'Testing allgatherv...'
-  end if
-!
-! mpi_allgatherv: Make just like mpi_allgather for simplicity
-!
-  gsbufrecv(:,:) = -1
-  recvcounts(:) = count
-  call mpi_allgatherv (sendbuf, count, MPI_INTEGER, &
-                       gsbufrecv, recvcounts, rdispls, &
-                       MPI_INTEGER, comm, ret)
-  do j=0,commsize-1
-    call chkbuf ("mpi_allgatherv", gsbufrecv(:,j), count, j)
-  end do
-
-  if (iam == 0) then
-    write(6,*)'Success. Calling finalize'
-  end if
-!
-! mpi_finalize
-!
-  call mpi_finalize (ret)
-
-#if ( ! defined HAVE_IARGCGETARG )
-  ret = gptlstop ("total")
-  ret = gptlpr (iam)
-#endif
-
-  stop 0
-end program pmpi
-
-subroutine chkbuf (msg, recvbuf, count, val)
-  use myvars
-  implicit none
-
-#include <mpif.h>
-
-  character(len=*), intent(in) :: msg
-
-  integer, intent(in) :: count
-  integer, intent(in) :: recvbuf(0:count-1)
-  integer, intent(in) :: val
-
-  integer :: i
-  integer :: ret
-  do i=0,count-1
-    if (recvbuf(i) /= val) then
-      write(6,*) "iam=", iam, msg, " bad recvbuf(", i,")=",recvbuf(i), "/= ", val
-      call mpi_abort (MPI_COMM_WORLD, -1, ret)
-    end if
-  end do
-end subroutine chkbuf
-
-
    
-
    -Now compile and run: -
    -
    
-% mpif90 -fopenmp -o pmpi pmpi.F90 -L.. -lgptl
-% mpiexec -n 2 ./pmpi
-
    
-
    - -Here's the output contained in file timing.1: -
    -
    
-Stats for thread 0:
-                            Called  Recurse Wallclock max       min       AVG_MPI_BYTES 
-  MPI_Init_thru_Finalize           1    -       0.001     0.001     0.001       -       
-    MPI_Probe                      1    -       0.000     0.000     0.000       -       
-    sync_Recv                      2    -       0.000     0.000     0.000       -       
-    MPI_Recv                       2    -       0.000     0.000     0.000     4.096e+03 
-    MPI_Send                       1    -       0.000     0.000     0.000     4.096e+03 
-    MPI_Ssend                      1    -       0.000     0.000     0.000     4.096e+03 
-    MPI_Sendrecv                   1    -       0.000     0.000     0.000     8.192e+03 
-    MPI_Irecv                      2    -       0.000     0.000     0.000     4.096e+03 
-    MPI_Iprobe                     1    -       0.000     0.000     0.000       -       
-    MPI_Test                       1    -       0.000     0.000     0.000       -       
-    MPI_Isend                      2    -       0.000     0.000     0.000     4.096e+03 
-    MPI_Wait                       2    -       0.000     0.000     0.000       -       
-    MPI_Waitall                    2    -       0.000     0.000     0.000       -       
-    MPI_Barrier                    1    -       0.000     0.000     0.000       -       
-    sync_Bcast                     1    -       0.000     0.000     0.000       -       
-    MPI_Bcast                      1    -       0.000     0.000     0.000     4.096e+03 
-    sync_Allreduce                 1    -       0.000     0.000     0.000       -       
-    MPI_Allreduce                  1    -       0.000     0.000     0.000     8.192e+03 
-    sync_Gather                    1    -       0.000     0.000     0.000       -       
-    MPI_Gather                     1    -       0.000     0.000     0.000     4.096e+03 
-    sync_Gatherv                   1    -       0.000     0.000     0.000       -       
-    MPI_Gatherv                    1    -       0.000     0.000     0.000     4.096e+03 
-    sync_Scatter                   1    -       0.000     0.000     0.000       -       
-    MPI_Scatter                    1    -       0.000     0.000     0.000     4.096e+03 
-    sync_Scatterv                  1    -       0.000     0.000     0.000       -       
-    MPI_Scatterv                   1    -       0.000     0.000     0.000     8.192e+03 
-    sync_Alltoall                  1    -       0.000     0.000     0.000       -       
-    MPI_Alltoall                   1    -       0.000     0.000     0.000     8.000e+00 
-    sync_Alltoallv                 1    -       0.000     0.000     0.000       -       
-    MPI_Alltoallv                  1    -       0.000     0.000     0.000     8.000e+00 
-    sync_Reduce                    1    -       0.000     0.000     0.000       -       
-    MPI_Reduce                     1    -       0.000     0.000     0.000     4.096e+03 
-    sync_Allgather                 1    -       0.000     0.000     0.000       -       
-    MPI_Allgather                  1    -       0.000     0.000     0.000     8.192e+03 
-    sync_Allgatherv                1    -       0.000     0.000     0.000       -       
-    MPI_Allgatherv                 1    -       0.000     0.000     0.000     8.192e+03 
-Total calls           = 42
-Total recursive calls = 0
-
    
-
    -

    Explanation of the above output

    -All of this output was generated automatically. Other than some optional -calls to gptlsetoption(), no GPTL-specific modifications to the -application code were made. -Timings for various MPI calls were automatically generated because GPTL was -built with ENABLE_PMPI (see macros.make.linux). A wrapping region -named MPI_Init_thru_Finalize was automatically generated for the region -between MPI_Init() and MPI_Finalize(). Average number of bytes -transferred was also reported automatically (see AVG_MPI_BYTES in the above -output). Also, since gptlsync_mpi was set (see code above), synchronization -routine MPI_Barrier() was called prior to certain collectives, and -synchronization time reported. -
    -Example 5 -Example 7 - -
    - - diff --git a/cesm/models/utils/timing/gptl/doc/example7.html b/cesm/models/utils/timing/gptl/doc/example7.html deleted file mode 100644 index fe590ba..0000000 --- a/cesm/models/utils/timing/gptl/doc/example7.html +++ /dev/null @@ -1,136 +0,0 @@ - - -GPTL usage example 7: Using GPTLstart_handle() and GPTLstop_handle() - - - - - - -
    -Example 6 -GPTL home page - -
    - -

    Example 7: Using GPTLstart_handle() and GPTLstop_handle()

    -This is a threaded Fortran code which uses functions GPTLstart_handle() -and GPTLstop_handle(). The purpose of these functions is to lower GPTL -overhead by maintaining in user-space the value of the hash function for the region of -interest, avoiding the overhead of hash table lookup every time the start or stop functions -are called. On initial invocation, a zero input value of the "handle" -argument is a flag which tells GPTL to compute the hash value and store its -contents for later use by the library. -

    -The hash value for any given GPTL region is invariant across threads. So -per-thread copies of the handle are not needed. Also, these -functions can be freely mixed with their GPTLstart() -and GPTLstop() counterparts, as shown in the example below. - -

    -handle.F90: -

    -
    
-program handle
-  use gptl
-  implicit none
-
-  integer :: handle1       ! Hash index
-  integer :: n
-  integer :: ret
-
-  ret = gptlinitialize ()
-
-  ret = gptlstart ('total') ! Time the entire code
-! IMPORTANT: Start with a zero handle value so GPTLstart_handle knows to initialize
-! Instead of setting handle1=0 here we could also do:
-! ret=gptlinit_handle('loop', handle1)
-! This latter approach is actually preferable to avoid one-time multiple threads
-! computing the handle value inside the threaded loop.
-  handle1 = 0
-
-!$OMP PARALLEL DO SHARED (handle1)
-  do n=1,1000000
-! First call the "_handle" versions of start and stop for the region
-    ret = gptlstart_handle ('loop', handle1)
-    ret = gptlstop_handle ('loop', handle1)
-! Now call the standard start and stop functions for the same region
-    ret = gptlstart ('loop')
-    ret = gptlstop ('loop')
-  end do
-  ret = gptlstop ('total') ! Time the entire code
-
-  ret = gptlpr (0)
-  stop
-end program handle
-
    
-
    -Now compile and run: -
    -
    
-% mpif90 -fopenmp -o handle handle.F90 -L.. -lgptl
-% ./handle
-
    
-
    - -Here's the important output from the timing.0 file that got created by the -call to gptlpr(0): -
    -
    
-
-Total overhead of 1 GPTL start or GPTLstop call=1.08e-07 seconds
-Components are as follows:
-Fortran layer:             2.0e-09 =   1.9% of total
-Get thread number:         2.0e-08 =  18.5% of total
-Generate hash index:       3.1e-08 =  28.7% of total
-Find hashtable entry:      2.2e-08 =  20.4% of total
-Underlying timing routine: 3.3e-08 =  30.6% of total
-...
-Stats for thread 0:
-           Called  Recurse Wallclock max       min       self_OH  parent_OH 
-  total           1    -       0.159     0.159     0.159     0.000     0.000 
-    loop     500000    -       0.045  1.40e-05  0.00e+00     0.018     0.091 
-Overhead sum =     0.108 wallclock seconds
-Total calls  = 500001
-...
-Same stats sorted by timer for threaded regions:
-Thd      Called  Recurse Wallclock max       min       self_OH  parent_OH 
-000 loop   500000    -       0.045  1.40e-05  0.00e+00     0.018     0.091 
-001 loop   500000    -       0.046  2.50e-05  0.00e+00     0.018     0.091 
-002 loop   500000    -       0.048  8.60e-05  0.00e+00     0.018     0.091 
-003 loop   500000    -       0.049  3.30e-03  0.00e+00     0.018     0.091 
-SUM loop  2.0e+06    -       0.189  3.30e-03  0.00e+00     0.070     0.362 
-
    
-
    -

    Explanation of the above output

    -Only a single region named "loop" was timed. It was called a total of 2 -million times across 4 threads. One million for the loop induction variable, -and another factor of two for the two different flavors of GPTLstart() -and GPTLstop(). These different flavors each accumulated time into -the same reported timer ("loop"). -

    -It is worth noting that the reported -overhead assumes that only GPTLstart() and GPTLstop() were -called. This estimate can be further refined in this example by taking the reported 28.7% -of overhead that is due to generating the hash index, multiplying it by 0.5 (since -half of the start/stop calls used the "_handle" GPTL routines which don't -need to generate hash indices), and subtracting that fraction from the 0.108 -seconds reported overhead to a new overhead estimate of 0.092 seconds. -

    -Note that the reported overhead was very high relative to the cost of the -work being timed. This is understandable considering that no real work is -being done between GPTL "start" and "stop" calls. - -

    -Example 6 -GPTL home page - -
    - - diff --git a/cesm/models/utils/timing/gptl/doc/gptl_homepage.html b/cesm/models/utils/timing/gptl/doc/gptl_homepage.html deleted file mode 100644 index 273714e..0000000 --- a/cesm/models/utils/timing/gptl/doc/gptl_homepage.html +++ /dev/null @@ -1,224 +0,0 @@ - - -GPTL timing library Home Page - - - -

    GPTL - General Purpose Timing Library

    -

    (with optional PAPI interface)

    -

    Download the latest source code here

    - -
    -

    Description

    -GPTL is a library to instrument C, C++, and Fortran codes for -performance analysis and profiling. The instrumentation can be inserted -manually by the user wherever they wish, or it can be done automatically by -the compiler at function entry and exit points if the application being -profiled is built with GNU, Pathscale, Intel, PGI (8.0.2 or later), or AIX -compilers. To auto-instrument an application, add --finstrument-functions (Pathscale, GNU, Intel) or --Minstrument:functions (PGI) or --qdebug=function_trace (AIX) -to the compile and link flags of the source files to be profiled. -

    -Automatic instrumentation of a number of MPI routines is also possible. In this -case no special compiler flags are necessary, and profiles are obtained -with zero changes to application source files. See -Example 6 for further details. -

    -Here is a portion of GPTL printout after running the HPCC benchmark -with compiler-based automatic instrumentation enabled: -

    
-Stats for thread 0:
-                                             Called  Recurse Wallclock max       min       FP_OPS   e6_/_sec CI       
-  total                                            1     -      64.021    64.021    64.021 3.50e+08     5.47 7.20e-02 
-    HPCC_Init                                     11      10     0.157     0.157     0.000    95799     0.61 8.90e-02 
-*     HPL_pdinfo                                 120     118     0.019     0.018     0.000    96996     4.99 8.56e-02 
-*       HPL_all_reduce                             7     -       0.043     0.036     0.000      448     0.01 1.03e-02 
-*         HPL_broadcast                           21     -       0.041     0.036     0.000      126     0.00 6.72e-03 
-        HPL_pdlamch                                2     -       0.004     0.004     0.000    94248    21.21 1.13e-01 
-*       HPL_fprintf                              240     120     0.001     0.000     0.000     1200     0.93 6.67e-03 
-      HPCC_InputFileInit                          41      40     0.001     0.001     0.000      194     0.27 8.45e-03 
-        ReadInts                                   2     -       0.000     0.000     0.000       12     3.00 1.61e-02 
-    PTRANS                                        21      20    22.667    22.667     0.000 4.19e+07     1.85 3.19e-02 
-      MaxMem                                       5       4     0.000     0.000     0.000      796     2.70 1.79e-02 
-*     iceil_                                     132     -       0.000     0.000     0.000      792     2.88 1.75e-02 
-*     ilcm_                                       14     -       0.000     0.000     0.000       84     2.71 1.71e-02 
-      param_dump                                  18      12     0.000     0.000     0.000       84     0.82 7.05e-03 
-      Cblacs_get                                   5     -       0.000     0.000     0.000       30     1.43 1.67e-02 
-      Cblacs_gridmap                              35      30     0.005     0.001     0.000      225     0.05 1.79e-03 
-*       Cblacs_pinfo                               7       1     0.000     0.000     0.000       40     3.08 1.54e-02 
-*     Cblacs_gridinfo                             60      50     0.000     0.000     0.000      260     2.28 2.10e-02 
-      Cigsum2d                                     5     -       0.088     0.047     0.000      165     0.00 6.37e-03 
-      pdmatgen                                    20     -      21.497     1.213     0.942 4.00e+07     1.86 3.08e-02 
-*       numroc_                                   96     -       0.000     0.000     0.000      576     2.87 1.69e-02 
-*       setran_                                   25     -       0.000     0.000     0.000      150     2.94 1.72e-02 
-*       pdrand                               3.7e+06   2e+06    15.509     0.041     0.000 1.72e+07     1.11 2.24e-02 
-        xjumpm_                                57506   57326     0.219     0.030     0.000   230384     1.05 2.66e-02 
-        jumpit_                                60180   40120     0.214     0.021     0.000   280840     1.32 2.18e-02 
-      slboot_                                      5     -       0.000     0.000     0.000       30     1.30 1.01e-02 
-      Cblacs_barrier                              10       5     0.481     0.167     0.000       50     0.00 3.26e-03 
-      sltimer_                                    10     -       0.000     0.000     0.000      614     3.05 1.90e-02 
-*       dwalltime00                               15     -       0.000     0.000     0.000      150     2.54 2.57e-02 
-*       dcputime00                                15     -       0.000     0.000     0.000      373     3.06 1.91e-02 
-*         HPL_ptimer_cputime                      17     -       0.000     0.000     0.000      170     2.66 2.29e-02 
-      pdtrans                                     14       9     0.124     0.045     0.000   573505     4.61 1.36e-01 
-        Cblacs_dSendrecv                          12       8     0.115     0.042     0.000       56     0.00 2.24e-03 
-      pdmatcmp                                     5     -       0.448     0.295     0.003 1.29e+06     2.87 2.94e-01 
-*       HPL_daxpy                               2596     -       0.008     0.000     0.000 1.34e+06   177.06 4.40e-01 
-*       HPL_idamax                              2966     -       0.007     0.000     0.000   767291   104.75 4.15e-01 
-...
-
    
-
    - Function names on the left of the output are indented to indicate their - parent, and depth in the call tree. An asterisk next to an entry means it - has more than one parent (see Example 2 for - further details). Other entries in this output show the number of - invocations, number of recursive invocations, wallclock timing - statistics, and PAPI-based information. In this example, HPL_daxpy - produced 1.34e6 floating point operations, 177.06 MFlops/sec, and had a - computational intensity (floating point ops per memory reference) of - 0.415. -

    - If the PAPI library is - installed on the target platform, GPTL can be used to - access all available PAPI events. - To count floating point operations for example, one need only add - a call that looks like: - - 

        ret = GPTLsetoption (PAPI_FP_OPS, 1);
-
    - - The second argument "1" in the above call means "enable". Any non-zero - integer means "enable", and a zero means "disable". - Multiple GPTL or PAPI options can be specified with additional - calls to GPTLsetoption(). The man pages provided with the - distribution describe the full API specification. The interface is - identical for both Fortran and C/C++ - codes, modulo the case-insensitivity of Fortran. -

    - Calls to GPTLstart() and GPTLstop() can be nested to an - arbitrary depth. As shown above, GPTL handles nested regions by - presenting output in an indented fashion. The example also shows how - auto-instrumentation - can be used to easily produce a dynamic call tree of - the application being profiled, where region names correspond to function - entry and exit points. - -

    -

    What's new in the latest release (gptl-v5.4.3)

    -
      -
    • Support for Cray compilers -
    • New function GPTLpr_summary_file() allows user-specification of - output file to hold summary information. Thanks to Jim Edwards of NCAR - for his contribution. -
      • -
    - -
    -

    Description of what was new in earlier releases is here.

    - -
    -

    Features

    -
      -
    • Low overhead. -
    • No external dependencies (PAPI interface is optional). -
    • Automatically multiplexes requested PAPI counters when required. -
    • Thread-safe, and reports per-thread statistics for multi-threaded - codes. -
    • Includes utility functions to print memory usage - (GPTLprint_memusage()) and get timestamps (GPTLstamp()). -
    • Support for derived (PAPI-based) events such as computational - intensity and instructions per cycle. Run ctests/gptl_avail to list - available events. -
    - -
    -

    Download and Installation

    -
      -
    • Download the most recent release here. -
    • To build and install GPTL, see the file named INSTALL after downloading. - You'll need to create a macros.make file appropriate for your target - platform. Example files for various architectures are - included in the tar file (e.g. macros.make.linux). An autoconf-based - script named suggestions is included to help in editing this - file. Example usage might be: -
      ./suggestions FC=gfortran CC=gcc
-
      -Comments in the sample macros.make files describe - each required setting. -
    • For information on using GPTL, refer to - EXAMPLES below, and the man pages provided with the - distribution. -
    - -
    - -

    Examples

    - These pages contain simple codes which illustrate the use of some features of - GPTL. All examples were run on a Linux x86 using GNU compilers. -

    - Example 1 is a manually-instrumented - Fortran code which uses PAPI to count floating point - operations. -

    - Example 2 is a C code compiled - with gcc's auto-instrumentation hooks to print a dynamic call tree. Perl - script hex2name.pl is used to convert addresses to - human-readable names. -

    - Example 3 demonstrates the use of - GPTLpr_summary() to obtain a statistical summary of timing statistics across OpenMP - threads and MPI tasks. -

    - Example 4 is an auto-instrumented C++ code. - Issues related to in-line constructors are illustrated. -

    - Example 5 is a Fortran code which uses - gptlprocess_namelist() and an associated namelist file to - set GPTL options. -

    - Example 6 is a Fortran code which utilizes the - ENABLE_PMPI option to automatically time various MPI calls and print the - average number of bytes transferred. -

    - Example 7 is a Fortran code which utilizes the - functions GPTLstart_handle() and GPTLstop_handle(), which - avoid much of the table lookup overhead of their siblings - GPTLstart() and GPTLstop(). - -

    - -

    Bugs

    -
      -
    • PMPI interface doesn't work on AIX. The problem has to do with the MPI definition - of MPI_STATUS_SIZE. -
    • PAPI developers have warned about using omp_get_thread_num() as the - underlying routine to get the thread number. Therefore for threaded codes it's probably - better to build GPTL with PTHREADS than OPENMP (see macros.make.linux). -
    - -
    - -

    Bug Reports

    -Please email me bug reports and/or feature requests (jmrosinski AT gmail DOT com). - -

    Author

    -GPTL was written -by Jim Rosinski, currently at NOAA/ESRL, formerly - at ORNL, SiCortex, -and NCAR. -

    Copyright

    -This software is Open Source. My only requests are proper attribution when you use -the software, and that you don't embed GPTL library source in software that you -intend to sell. - -
    -Example 1 - -
    - diff --git a/cesm/models/utils/timing/gptl/f_wrappers.c b/cesm/models/utils/timing/gptl/f_wrappers.c deleted file mode 100644 index 76c0035..0000000 --- a/cesm/models/utils/timing/gptl/f_wrappers.c +++ /dev/null @@ -1,492 +0,0 @@ -/* -** f_wrappers.c -** -** Author: Jim Rosinski -** -** Fortran wrappers for timing library routines -*/ - -#ifdef HAVE_MPI -#include -#endif - -#include -#include -#include "private.h" /* MAX_CHARS, bool */ -#include "gptl.h" /* function prototypes */ - -#if ( defined FORTRANUNDERSCORE ) - -#define gptlinitialize gptlinitialize_ -#define gptlfinalize gptlfinalize_ -#define gptlpr gptlpr_ -#define gptlpr_file gptlpr_file_ -#define gptlpr_summary gptlpr_summary_ -#define gptlpr_summary_file gptlpr_summary_file_ -#define gptlbarrier gptlbarrier_ -#define gptlreset gptlreset_ -#define gptlstamp gptlstamp_ -#define gptlstart gptlstart_ -#define gptlinit_handle gptlinit_handle_ -#define gptlstart_handle gptlstart_handle_ -#define gptlstop gptlstop_ -#define gptlstop_handle gptlstop_handle_ -#define gptlsetoption gptlsetoption_ -#define gptlenable gptlenable_ -#define gptldisable gptldisable_ -#define gptlsetutr gptlsetutr_ -#define gptlquery gptlquery_ -#define gptlquerycounters gptlquerycounters_ -#define gptlget_wallclock gptlget_wallclock_ -#define gptlget_eventvalue gptlget_eventvalue_ -#define gptlget_nregions gptlget_nregions_ -#define gptlget_regionname gptlget_regionname_ -#define gptlget_memusage gptlget_memusage_ -#define gptlprint_memusage gptlprint_memusage_ -#define gptlprint_rusage gptlprint_rusage_ -#define gptlnum_errors gptlnum_errors_ -#define gptlnum_warn gptlnum_warn_ -#define gptlget_count gptlget_count_ -#define gptl_papilibraryinit gptl_papilibraryinit_ -#define gptlevent_name_to_code gptlevent_name_to_code_ -#define gptlevent_code_to_name gptlevent_code_to_name_ - -#elif ( defined FORTRANDOUBLEUNDERSCORE ) - -#define gptlinitialize gptlinitialize_ -#define gptlfinalize gptlfinalize_ -#define gptlpr gptlpr_ -#define gptlpr_file gptlpr_file__ -#define gptlpr_summary gptlpr_summary__ -#define gptlpr_summary_file gptlpr_summary_file__ -#define gptlbarrier gptlbarrier_ -#define gptlreset gptlreset_ -#define gptlstamp gptlstamp_ -#define gptlstart gptlstart_ -#define gptlinit_handle gptlinit_handle__ -#define gptlstart_handle gptlstart_handle__ -#define gptlstop gptlstop_ -#define gptlstop_handle gptlstop_handle__ -#define gptlsetoption gptlsetoption_ -#define gptlenable gptlenable_ -#define gptldisable gptldisable_ -#define gptlsetutr gptlsetutr_ -#define gptlquery gptlquery_ -#define gptlquerycounters gptlquerycounters_ -#define gptlget_wallclock gptlget_wallclock__ -#define gptlget_eventvalue gptlget_eventvalue__ -#define gptlget_nregions gptlget_nregions__ -#define gptlget_regionname gptlget_regionname__ -#define gptlget_memusage gptlget_memusage__ -#define gptlprint_memusage gptlprint_memusage__ -#define gptlprint_rusage gptlprint_rusage__ -#define gptlnum_errors gptlnum_errors__ -#define gptlnum_warn gptlnum_warn__ -#define gptlget_count gptlget_count__ -#define gptl_papilibraryinit gptl_papilibraryinit__ -#define gptlevent_name_to_code gptlevent_name_to_code__ -#define gptlevent_code_to_name gptlevent_code_to_name__ - -#endif - -/* Local function prototypes */ -int gptlinitialize (void); -int gptlfinalize (void); -int gptlpr (int *procid); -int gptlpr_file (char *file, int nc1); -#ifdef HAVE_MPI -int gptlpr_summary (int *fcomm); -int gptlpr_summary_file (int *fcomm, char *name, int nc1); -int gptlbarrier (int *fcomm, char *name, int nc1); -#else -int gptlpr_summary (void); -int gptlpr_summary_file (char *name, int nc1); -int gptlbarrier (void); -#endif -int gptlreset (void); -int gptlstamp (double *wall, double *usr, double *sys); -int gptlstart (char *name, int nc1); -int gptlinit_handle (char *name, int *, int nc1); -int gptlstart_handle (char *name, int *, int nc1); -int gptlstop (char *name, int nc1); -int gptlstop_handle (char *name, int *, int nc1); -int gptlsetoption (int *option, int *val); -int gptlenable (void); -int gptldisable (void); -int gptlsetutr (int *option); -int gptlquery (const char *name, int *t, int *count, int *onflg, double *wallclock, - double *usr, double *sys, long long *papicounters_out, int *maxcounters, - int nc); -int gptlquerycounters (const char *name, int *t, long long *papicounters_out, int nc); -int gptlget_wallclock (const char *name, int *t, double *value, int nc); -int gptlget_eventvalue (const char *timername, const char *eventname, int *t, double *value, - int nc1, int nc2); -int gptlget_nregions (int *t, int *nregions); -int gptlget_regionname (int *t, int *region, char *name, int nc); -int gptlget_memusage (int *size, int *rss, int *share, int *text, int *datastack); -int gptlprint_memusage (const char *str, int nc); -int gptlprint_rusage (const char *str, int nc); -int gptlnum_errors (void); -int gptlnum_warn (void); -int gptlget_count (char *, int *, int *, int); -#ifdef HAVE_PAPI -int gptl_papilibraryinit (void); -int gptlevent_name_to_code (const char *str, int *code, int nc); -int gptlevent_code_to_name (int *code, char *str, int nc); -#endif - -/* Fortran wrapper functions start here */ -int gptlinitialize (void) -{ - return GPTLinitialize (); -} - -int gptlfinalize (void) -{ - return GPTLfinalize (); -} - -int gptlpr (int *procid) -{ - return GPTLpr (*procid); -} - -int gptlpr_file (char *file, int nc1) -{ - char *locfile; - int ret; - - if ( ! (locfile = (char *) malloc (nc1+1))) - return GPTLerror ("gptlpr_file: malloc error\n"); - - snprintf (locfile, nc1+1, "%s", file); - - ret = GPTLpr_file (locfile); - free (locfile); - return ret; -} - -#ifdef HAVE_MPI - -int gptlpr_summary (int *fcomm) -{ - MPI_Comm ccomm; -#ifdef HAVE_COMM_F2C - ccomm = MPI_Comm_f2c (*fcomm); -#else - /* Punt and try just casting the Fortran communicator */ - ccomm = (MPI_Comm) *fcomm; -#endif - return GPTLpr_summary (ccomm); -} - -int gptlpr_summary_file (int *fcomm, char *outfile, int nc1) -{ - MPI_Comm ccomm; - char *locfile; - int ret; - - if ( ! (locfile = (char *) malloc (nc1+1))) - return GPTLerror ("gptlpr_summary_file: malloc error\n"); - - snprintf (locfile, nc1+1, "%s", outfile); - -#ifdef HAVE_COMM_F2C - ccomm = MPI_Comm_f2c (*fcomm); -#else - /* Punt and try just casting the Fortran communicator */ - ccomm = (MPI_Comm) *fcomm; -#endif - ret = GPTLpr_summary_file (ccomm, locfile); - free (locfile); - return ret; -} - -int gptlbarrier (int *fcomm, char *name, int nc1) -{ - MPI_Comm ccomm; - char cname[MAX_CHARS+1]; - int numchars; - - numchars = MIN (nc1, MAX_CHARS); - strncpy (cname, name, numchars); - cname[numchars] = '\0'; -#ifdef HAVE_COMM_F2C - ccomm = MPI_Comm_f2c (*fcomm); -#else - /* Punt and try just casting the Fortran communicator */ - ccomm = (MPI_Comm) *fcomm; -#endif - return GPTLbarrier (ccomm, cname); -} - -#else - -int gptlpr_summary (void) -{ - return GPTLpr_summary (); -} - -int gptlpr_summary_file (char *outfile, int nc1) -{ - char *locfile; - int ret; - - if ( ! (locfile = (char *) malloc (nc1+1))) - return GPTLerror ("gptlpr_summary_file: malloc error\n"); - - snprintf (locfile, nc1+1, "%s", outfile); - ret = GPTLpr_summary_file (locfile); - free (locfile); - return ret; -} - -int gptlbarrier (void) -{ - return GPTLerror ("gptlbarrier: Need to build GPTL with #define HAVE_MPI to enable this routine\n"); -} - -#endif - - -int gptlreset (void) -{ - return GPTLreset (); -} - -int gptlstamp (double *wall, double *usr, double *sys) -{ - return GPTLstamp (wall, usr, sys); -} - -int gptlstart (char *name, int nc1) -{ - char cname[MAX_CHARS+1]; - int numchars; - - numchars = MIN (nc1, MAX_CHARS); - strncpy (cname, name, numchars); - cname[numchars] = '\0'; - return GPTLstart (cname); -} - -int gptlinit_handle (char *name, int *handle, int nc1) -{ - char cname[MAX_CHARS+1]; - int numchars; - - numchars = MIN (nc1, MAX_CHARS); - strncpy (cname, name, numchars); - cname[numchars] = '\0'; - return GPTLinit_handle (cname, handle); -} - -int gptlstart_handle (char *name, int *handle, int nc1) -{ - char cname[MAX_CHARS+1]; - int numchars; - - numchars = MIN (nc1, MAX_CHARS); - strncpy (cname, name, numchars); - cname[numchars] = '\0'; - return GPTLstart_handle (cname, handle); -} - -int gptlstop (char *name, int nc1) -{ - char cname[MAX_CHARS+1]; - int numchars; - - numchars = MIN (nc1, MAX_CHARS); - strncpy (cname, name, numchars); - cname[numchars] = '\0'; - return GPTLstop (cname); -} - -int gptlstop_handle (char *name, int *handle, int nc1) -{ - char cname[MAX_CHARS+1]; - int numchars; - - numchars = MIN (nc1, MAX_CHARS); - strncpy (cname, name, numchars); - cname[numchars] = '\0'; - return GPTLstop_handle (cname, handle); -} - -int gptlsetoption (int *option, int *val) -{ - return GPTLsetoption (*option, *val); -} - -int gptlenable (void) -{ - return GPTLenable (); -} - -int gptldisable (void) -{ - return GPTLdisable (); -} - -int gptlsetutr (int *option) -{ - return GPTLsetutr (*option); -} - -int gptlquery (const char *name, int *t, int *count, int *onflg, double *wallclock, - double *usr, double *sys, long long *papicounters_out, int *maxcounters, - int nc) -{ - char cname[MAX_CHARS+1]; - int numchars; - - numchars = MIN (nc, MAX_CHARS); - strncpy (cname, name, numchars); - cname[numchars] = '\0'; - return GPTLquery (cname, *t, count, onflg, wallclock, usr, sys, papicounters_out, *maxcounters); -} - -int gptlquerycounters (const char *name, int *t, long long *papicounters_out, int nc) -{ - char cname[MAX_CHARS+1]; - int numchars; - - numchars = MIN (nc, MAX_CHARS); - strncpy (cname, name, numchars); - cname[numchars] = '\0'; - return GPTLquerycounters (cname, *t, papicounters_out); -} - -int gptlget_wallclock (const char *name, int *t, double *value, int nc) -{ - char cname[MAX_CHARS+1]; - int numchars; - - numchars = MIN (nc, MAX_CHARS); - strncpy (cname, name, numchars); - cname[numchars] = '\0'; - - return GPTLget_wallclock (cname, *t, value); -} - -int gptlget_eventvalue (const char *timername, const char *eventname, int *t, double *value, - int nc1, int nc2) -{ - char ctimername[MAX_CHARS+1]; - char ceventname[MAX_CHARS+1]; - int numchars; - - numchars = MIN (nc1, MAX_CHARS); - strncpy (ctimername, timername, numchars); - ctimername[numchars] = '\0'; - - numchars = MIN (nc2, MAX_CHARS); - strncpy (ceventname, eventname, numchars); - ceventname[numchars] = '\0'; - - return GPTLget_eventvalue (ctimername, ceventname, *t, value); -} - -int gptlget_nregions (int *t, int *nregions) -{ - return GPTLget_nregions (*t, nregions); -} - -int gptlget_regionname (int *t, int *region, char *name, int nc) -{ - int n; - int ret; - - ret = GPTLget_regionname (*t, *region, name, nc); - /* Turn nulls into spaces for fortran */ - for (n = 0; n < nc; ++n) - if (name[n] == '\0') - name[n] = ' '; - return ret; -} - -int gptlget_memusage (int *size, int *rss, int *share, int *text, int *datastack) -{ - return GPTLget_memusage (size, rss, share, text, datastack); -} - -int gptlprint_memusage (const char *str, int nc) -{ - char cname[128+1]; - int numchars = MIN (nc, 128); - - strncpy (cname, str, numchars); - cname[numchars] = '\0'; - return GPTLprint_memusage (cname); -} - -int gptlprint_rusage (const char *str, int nc) -{ - char cname[128+1]; - int numchars = MIN (nc, 128); - - strncpy (cname, str, numchars); - cname[numchars] = '\0'; - return GPTLprint_rusage (cname); -} - -int gptlnum_errors (void) -{ - return GPTLnum_errors (); -} - -int gptlnum_warn (void) -{ - return GPTLnum_warn (); -} - -int gptlget_count (char *name, int *t, int *count, int nc) -{ - char cname[MAX_CHARS+1]; - int numchars; - - numchars = MIN (nc, MAX_CHARS); - strncpy (cname, name, numchars); - cname[numchars] = '\0'; - - return GPTLget_count (cname, *t, count); -} - -#ifdef HAVE_PAPI -#include - -int gptl_papilibraryinit (void) -{ - return GPTL_PAPIlibraryinit ();; -} - -int gptlevent_name_to_code (const char *str, int *code, int nc) -{ - char cname[PAPI_MAX_STR_LEN+1]; - int numchars = MIN (nc, PAPI_MAX_STR_LEN); - - strncpy (cname, str, numchars); - cname[numchars] = '\0'; - - /* "code" is an int* and is an output variable */ - return GPTLevent_name_to_code (cname, code); -} - -int gptlevent_code_to_name (int *code, char *str, int nc) -{ - int i; - - if (nc < PAPI_MAX_STR_LEN) - return GPTLerror ("gptl_event_code_to_name: output name must hold at least %d characters\n", - PAPI_MAX_STR_LEN); - - if (GPTLevent_code_to_name (*code, str) == 0) { - for (i = strlen(str); i < nc; ++i) - str[i] = ' '; - } else { - return GPTLerror (""); - } - return 0; -} -#endif diff --git a/cesm/models/utils/timing/gptl/f_wrappers_pmpi.c b/cesm/models/utils/timing/gptl/f_wrappers_pmpi.c deleted file mode 100644 index 0718e37..0000000 --- a/cesm/models/utils/timing/gptl/f_wrappers_pmpi.c +++ /dev/null @@ -1,562 +0,0 @@ -#include -#include - -#ifdef HAVE_MPI -#include -#endif - -#if ( defined FORTRANUNDERSCORE ) - -#define iargc iargc_ -#define getarg getarg_ -#define mpi_init mpi_init_ -#define mpi_init_thread mpi_init_thread_ -#define mpi_finalize mpi_finalize_ -#define mpi_send mpi_send_ -#define mpi_recv mpi_recv_ -#define mpi_sendrecv mpi_sendrecv_ -#define mpi_isend mpi_isend_ -#define mpi_issend mpi_issend_ -#define mpi_irecv mpi_irecv_ -#define mpi_wait mpi_wait_ -#define mpi_waitall mpi_waitall_ -#define mpi_barrier mpi_barrier_ -#define mpi_bcast mpi_bcast_ -#define mpi_allreduce mpi_allreduce_ -#define mpi_gather mpi_gather_ -#define mpi_gatherv mpi_gatherv_ -#define mpi_scatter mpi_scatter_ -#define mpi_alltoall mpi_alltoall_ -#define mpi_reduce mpi_reduce_ -#define mpi_allgather mpi_allgather_ -#define mpi_allgatherv mpi_allgatherv_ -#define mpi_iprobe mpi_iprobe_ -#define mpi_probe mpi_probe_ -#define mpi_ssend mpi_ssend_ -#define mpi_alltoallv mpi_alltoallv_ -#define mpi_scatterv mpi_scatterv_ -#define mpi_test mpi_test_ - -#elif ( defined FORTRANDOUBLEUNDERSCORE ) - -#define iargc iargc_ -#define getarg getarg_ -#define mpi_init mpi_init__ -#define mpi_init_thread mpi_init_thread__ -#define mpi_finalize mpi_finalize__ -#define mpi_send mpi_send__ -#define mpi_recv mpi_recv__ -#define mpi_sendrecv mpi_sendrecv__ -#define mpi_isend mpi_isend__ -#define mpi_issend mpi_issend__ -#define mpi_irecv mpi_irecv__ -#define mpi_wait mpi_wait__ -#define mpi_waitall mpi_waitall__ -#define mpi_barrier mpi_barrier__ -#define mpi_bcast mpi_bcast__ -#define mpi_allreduce mpi_allreduce__ -#define mpi_gather mpi_gather__ -#define mpi_gatherv mpi_gatherv__ -#define mpi_scatter mpi_scatter__ -#define mpi_alltoall mpi_alltoall__ -#define mpi_reduce mpi_reduce__ -#define mpi_allgather mpi_allgather__ -#define mpi_allgatherv mpi_allgatherv__ -#define mpi_iprobe mpi_iprobe__ -#define mpi_probe mpi_probe__ -#define mpi_ssend mpi_ssend__ -#define mpi_alltoallv mpi_alltoallv__ -#define mpi_scatterv mpi_scatterv__ -#define mpi_test mpi_test__ - -#endif - -#ifdef HAVE_IARGCGETARG -void mpi_init (MPI_Fint *ierr); -void mpi_finalize (MPI_Fint *ierr); -#endif - -#ifdef HAVE_MPI -#ifdef ENABLE_PMPI - -/* -** Wart needed for MPI_Waitall. fpmpi configure figures this out--I just hardwired -** the most common value. It currently fails on NCAR bluefire machine. -*/ -#ifndef MPI_STATUS_SIZE -#define MPI_STATUS_SIZE MPI_STATUS_SIZE_IN_INTS -#endif - -/* Local prototypes */ -void mpi_send (void *buf, MPI_Fint *count, MPI_Fint *datatype, MPI_Fint *dest, - MPI_Fint *tag, MPI_Fint *comm, MPI_Fint *__ierr); -void mpi_recv (void *buf, MPI_Fint *count, MPI_Fint *datatype, - MPI_Fint *source, MPI_Fint *tag, MPI_Fint *comm, - MPI_Fint *status, MPI_Fint *__ierr); -void mpi_sendrecv (void *sendbuf, MPI_Fint *sendcount, MPI_Fint *sendtype, - MPI_Fint *dest, MPI_Fint *sendtag, - void *recvbuf, MPI_Fint *recvcount, MPI_Fint *recvtype, - MPI_Fint *source, MPI_Fint *recvtag, - MPI_Fint *comm, MPI_Fint *status, MPI_Fint *__ierr); -void mpi_isend (void *buf, MPI_Fint *count, MPI_Fint *datatype, - MPI_Fint *dest, MPI_Fint *tag, MPI_Fint *comm, - MPI_Fint *request, MPI_Fint *__ierr); -void mpi_issend (void *buf, MPI_Fint *count, MPI_Fint *datatype, - MPI_Fint *dest, MPI_Fint *tag, MPI_Fint *comm, - MPI_Fint *request, MPI_Fint *__ierr); -void mpi_irecv (void *buf, MPI_Fint *count, MPI_Fint *datatype, - MPI_Fint *source, MPI_Fint *tag, MPI_Fint *comm, - MPI_Fint *request, MPI_Fint *__ierr); -void mpi_wait (MPI_Fint *request, MPI_Fint *status, MPI_Fint *__ierr); -void mpi_waitall (MPI_Fint *count, MPI_Fint array_of_requests[], - MPI_Fint array_of_statuses[][MPI_STATUS_SIZE], - MPI_Fint *__ierr); -void mpi_barrier (MPI_Fint *comm, MPI_Fint *__ierr); -void mpi_bcast (void *buffer, MPI_Fint *count, MPI_Fint *datatype, - MPI_Fint *root, MPI_Fint *comm, MPI_Fint *__ierr); -void mpi_allreduce (void *sendbuf, void *recvbuf, MPI_Fint *count, - MPI_Fint *datatype, MPI_Fint *op, MPI_Fint *comm, - MPI_Fint *__ierr); -void mpi_gather (void *sendbuf, MPI_Fint *sendcount, MPI_Fint *sendtype, - void *recvbuf, MPI_Fint *recvcount, MPI_Fint *recvtype, - MPI_Fint *root, MPI_Fint *comm, MPI_Fint *__ierr); -void mpi_gatherv (void *sendbuf, MPI_Fint *sendcount, MPI_Fint *sendtype, - void *recvbuf, MPI_Fint *recvcounts, MPI_Fint *displs, - MPI_Fint *recvtype, MPI_Fint *root, MPI_Fint *comm, MPI_Fint *__ierr); -void mpi_scatter (void *sendbuf, MPI_Fint *sendcount, MPI_Fint *sendtype, - void *recvbuf, MPI_Fint *recvcount, MPI_Fint *recvtype, - MPI_Fint *root, MPI_Fint *comm, MPI_Fint *__ierr); -void mpi_alltoall (void *sendbuf, MPI_Fint *sendcount, MPI_Fint *sendtype, - void *recvbuf, MPI_Fint *recvcount, MPI_Fint *recvtype, - MPI_Fint *comm, MPI_Fint *__ierr); -void mpi_reduce (void *sendbuf, void *recvbuf, MPI_Fint *count, - MPI_Fint *datatype, MPI_Fint *op, MPI_Fint *root, - MPI_Fint *comm, MPI_Fint *__ierr); -void mpi_allgather (void *sendbuf, MPI_Fint *sendcount, MPI_Fint *sendtype, - void *recvbuf, MPI_Fint *recvcount, MPI_Fint *recvtype, - MPI_Fint *comm, MPI_Fint *__ierr); -void mpi_allgatherv (void *sendbuf, MPI_Fint *sendcount, MPI_Fint *sendtype, - void *recvbuf, MPI_Fint *recvcounts, MPI_Fint *displs, - MPI_Fint *recvtype, MPI_Fint *comm, MPI_Fint *__ierr); -void mpi_iprobe (MPI_Fint *source, MPI_Fint *tag, MPI_Fint *comm, - MPI_Fint *flag, MPI_Fint *status, MPI_Fint *__ierr); -void mpi_probe (MPI_Fint *source, MPI_Fint *tag, MPI_Fint *comm, - MPI_Fint *status, MPI_Fint *__ierr); -void mpi_ssend (void *buf, MPI_Fint *count, MPI_Fint *datatype, MPI_Fint *dest, - MPI_Fint *tag, MPI_Fint *comm, MPI_Fint *__ierr); -void mpi_alltoallv (void *sendbuf, MPI_Fint *sendcnts, MPI_Fint *sdispls, - MPI_Fint *sendtype, void *recvbuf, MPI_Fint *recvcnts, - MPI_Fint *rdispls, MPI_Fint *recvtype, MPI_Fint *comm, - MPI_Fint *__ierr); -void mpi_scatterv (void *sendbuf, MPI_Fint *sendcnts, MPI_Fint *displs, - MPI_Fint *sendtype, void *recvbuf, MPI_Fint *recvcnt, - MPI_Fint *recvtype, MPI_Fint *root, MPI_Fint *comm, - MPI_Fint *__ierr ); -void mpi_test (MPI_Fint *request, MPI_Fint *flag, MPI_Fint *status, - MPI_Fint *__ierr ); - -/* -** These routines were adapted from the FPMPI distribution. They ensure profiling of -** Fortran codes, using the routines defined in pmpi.c -*/ - -/* -** mpi_init requires iargc and getarg. If these exist, define mpi_init and mpi_finalize -** wrappers so that GPTLinitialize and GPTLpr will be called. -*/ -#ifdef HAVE_IARGCGETARG -extern int iargc (void); -extern void getarg (int *, char *, int); - -void mpi_init (MPI_Fint *ierr) -{ - int Argc; - int i, argsize = 1024; - char **Argv, *p; - int ArgcSave; /* Save the argument count */ - char **ArgvSave; /* Save the pointer to the argument vector */ - char **ArgvValSave; /* Save entries in the argument vector */ - - /* Recover the args with the Fortran routines iargc and getarg */ - ArgcSave = Argc = iargc() + 1; - ArgvSave = Argv = (char **) malloc (Argc * sizeof(char *)); - ArgvValSave = (char**) malloc (Argc * sizeof(char *)); - if ( ! Argv) { - fprintf (stderr, "Out of space in MPI_INIT"); - *ierr = -1; - return; - } - - for (i = 0; i < Argc; i++) { - ArgvValSave[i] = Argv[i] = (char *) malloc (argsize + 1); - if ( ! Argv[i]) { - fprintf (stderr, "Out of space in MPI_INIT"); - *ierr = -1; - return; - } - getarg (&i, Argv[i], argsize); - - /* Trim trailing blanks */ - p = Argv[i] + argsize - 1; - while (p > Argv[i]) { - if (*p != ' ') { - p[1] = '\0'; - break; - } - p--; - } - } - - *ierr = MPI_Init (&Argc, &Argv); - - /* Recover space */ - for (i = 0; i < ArgcSave; i++) { - free (ArgvValSave[i]); - } - free (ArgvValSave); - free (ArgvSave); -} - -void mpi_init_thread (MPI_Fint *required, MPI_Fint *provided, MPI_Fint *ierr) -{ - int Argc; - int i, argsize = 1024; - char **Argv, *p; - int ArgcSave; /* Save the argument count */ - char **ArgvSave; /* Save the pointer to the argument vector */ - char **ArgvValSave; /* Save entries in the argument vector */ - - /* Recover the args with the Fortran routines iargc and getarg */ - ArgcSave = Argc = iargc() + 1; - ArgvSave = Argv = (char **) malloc (Argc * sizeof(char *)); - ArgvValSave = (char**) malloc (Argc * sizeof(char *)); - if ( ! Argv) { - fprintf (stderr, "Out of space in MPI_INIT"); - *ierr = -1; - return; - } - - for (i = 0; i < Argc; i++) { - ArgvValSave[i] = Argv[i] = (char *) malloc (argsize + 1); - if ( ! Argv[i]) { - fprintf (stderr, "Out of space in MPI_INIT"); - *ierr = -1; - return; - } - getarg (&i, Argv[i], argsize); - - /* Trim trailing blanks */ - p = Argv[i] + argsize - 1; - while (p > Argv[i]) { - if (*p != ' ') { - p[1] = '\0'; - break; - } - p--; - } - } - - *ierr = MPI_Init_thread (&Argc, &Argv, *required, provided); - - /* Recover space */ - for (i = 0; i < ArgcSave; i++) { - free (ArgvValSave[i]); - } - free (ArgvValSave); - free (ArgvSave); -} - -void mpi_finalize (MPI_Fint *ierr) -{ - *ierr = MPI_Finalize(); -} -#endif - -void mpi_send (void *buf, MPI_Fint *count, MPI_Fint *datatype, MPI_Fint *dest, - MPI_Fint *tag, MPI_Fint *comm, MPI_Fint *__ierr) -{ - *__ierr = MPI_Send (buf, *count, MPI_Type_f2c (*datatype), *dest, *tag, - MPI_Comm_f2c (*comm)); -} - -void mpi_recv (void *buf, MPI_Fint *count, MPI_Fint *datatype, - MPI_Fint *source, MPI_Fint *tag, MPI_Fint *comm, - MPI_Fint *status, MPI_Fint *__ierr) -{ - MPI_Status s; - /* A local status should be used if MPI_Fint and int are different sizes */ - *__ierr = MPI_Recv (buf, *count, MPI_Type_f2c (*datatype), *source, *tag, - MPI_Comm_f2c (*comm), &s); - MPI_Status_c2f (&s, status); -} - -void mpi_sendrecv (void *sendbuf, MPI_Fint *sendcount, MPI_Fint *sendtype, - MPI_Fint *dest, MPI_Fint *sendtag, - void *recvbuf, MPI_Fint *recvcount, MPI_Fint *recvtype, - MPI_Fint *source, MPI_Fint *recvtag, - MPI_Fint *comm, MPI_Fint *status, MPI_Fint *__ierr) -{ - MPI_Status s; - *__ierr = MPI_Sendrecv (sendbuf, *sendcount, MPI_Type_f2c (*sendtype), - *dest, *sendtag, recvbuf, *recvcount, - MPI_Type_f2c (*recvtype), *source, *recvtag, - MPI_Comm_f2c (*comm), &s); - MPI_Status_c2f (&s, status); -} - -void mpi_isend (void *buf, MPI_Fint *count, MPI_Fint *datatype, - MPI_Fint *dest, MPI_Fint *tag, MPI_Fint *comm, - MPI_Fint *request, MPI_Fint *__ierr) -{ - MPI_Request lrequest; - *__ierr = MPI_Isend (buf, (int) *count, MPI_Type_f2c (*datatype), - (int) *dest, (int) *tag, MPI_Comm_f2c (*comm), - &lrequest); - *request = MPI_Request_c2f (lrequest); -} - -void mpi_issend (void *buf, MPI_Fint *count, MPI_Fint *datatype, - MPI_Fint *dest, MPI_Fint *tag, MPI_Fint *comm, - MPI_Fint *request, MPI_Fint *__ierr) -{ - MPI_Request lrequest; - *__ierr = MPI_Issend (buf, (int) *count, MPI_Type_f2c (*datatype), - (int) *dest, (int) *tag, MPI_Comm_f2c (*comm), - &lrequest); - *request = MPI_Request_c2f (lrequest); -} - -void mpi_irecv (void *buf, MPI_Fint *count, MPI_Fint *datatype, - MPI_Fint *source, MPI_Fint *tag, MPI_Fint *comm, - MPI_Fint *request, MPI_Fint *__ierr) -{ - MPI_Request lrequest; - *__ierr = MPI_Irecv (buf, (int)*count, MPI_Type_f2c (*datatype), - (int)*source,(int)*tag, - MPI_Comm_f2c(*comm),&lrequest); - *request = MPI_Request_c2f (lrequest); -} - -void mpi_wait (MPI_Fint *request, MPI_Fint *status, MPI_Fint *__ierr) -{ - MPI_Request lrequest; - MPI_Status c_status; - - lrequest = MPI_Request_f2c (*request); - *__ierr = MPI_Wait (&lrequest, &c_status); - *request = MPI_Request_c2f (lrequest); - - MPI_Status_c2f (&c_status, status); -} - -/* -** mpi_waitall was simplified from the FPMPI version. -** This one has a hard limit of LOCAL_ARRAY_SIZE requests. -** If this limit is exceeded, MPI_Abort is called. There is probably -** a better solution. -*/ -void mpi_waitall (MPI_Fint *count, MPI_Fint array_of_requests[], - MPI_Fint array_of_statuses[][MPI_STATUS_SIZE], - MPI_Fint *__ierr) -{ - const int LOCAL_ARRAY_SIZE = 128; - int i; - MPI_Request lrequest[LOCAL_ARRAY_SIZE]; - MPI_Status c_status[LOCAL_ARRAY_SIZE]; - static const char *thisfunc = "GPTL's mpi_waitall"; - - if (MPI_STATUS_SIZE != sizeof(MPI_Status)/sizeof(int)) { - /* Warning - */ - fprintf (stderr, "%s ERROR: mpi_waitall expected sizeof MPI_Status\n" - "to be %d integers but it is %d. Rebuild GPTL after ensuring that the\n" - "correct value is found and set in macros.make\n", thisfunc, MPI_STATUS_SIZE, - (int) (sizeof(MPI_Status)/sizeof(int)) ); - fprintf (stderr, "Aborting...\n"); - (void) MPI_Abort (MPI_COMM_WORLD, -1); - } - - /* fpmpi does mallocs. Instead used fixed array sizes and Abort if too many */ - if ((int) *count > LOCAL_ARRAY_SIZE) { - fprintf (stderr, "mpi_waitall: %d is too many requests: recompile f_wrappers_pmpi.c " - "with LOCAL_ARRAY_SIZE > %d\n", (int)*count, LOCAL_ARRAY_SIZE); - fprintf (stderr, "Aborting...\n"); - (void) MPI_Abort (MPI_COMM_WORLD, -1); - } - - if ((int) *count > 0) { - for (i = 0; i < (int) *count; i++) { - lrequest[i] = MPI_Request_f2c (array_of_requests[i]); - } - - *__ierr = MPI_Waitall ((int)*count, lrequest, c_status); - /* By checking for lrequest[i] = 0, we handle persistent requests */ - for (i = 0; i < (int)*count; i++) { - array_of_requests[i] = MPI_Request_c2f (lrequest[i]); - } - } else { - *__ierr = MPI_Waitall ((int)*count, (MPI_Request *)0, c_status); - } - - for (i = 0; i < (int)*count; i++) - MPI_Status_c2f (&(c_status[i]), &(array_of_statuses[i][0])); -} - -void mpi_barrier (MPI_Fint *comm, MPI_Fint *__ierr) -{ - *__ierr = MPI_Barrier (MPI_Comm_f2c (*comm)); -} - -void mpi_bcast (void *buffer, MPI_Fint *count, MPI_Fint *datatype, - MPI_Fint *root, MPI_Fint *comm, MPI_Fint *__ierr) -{ - *__ierr = MPI_Bcast (buffer, *count, MPI_Type_f2c (*datatype), *root, - MPI_Comm_f2c (*comm)); -} - -void mpi_allreduce (void *sendbuf, void *recvbuf, MPI_Fint *count, - MPI_Fint *datatype, MPI_Fint *op, MPI_Fint *comm, - MPI_Fint *__ierr) -{ - *__ierr = MPI_Allreduce (sendbuf, recvbuf, *count, MPI_Type_f2c (*datatype), - MPI_Op_f2c (*op), MPI_Comm_f2c (*comm)); -} - -void mpi_gather (void *sendbuf, MPI_Fint *sendcount, MPI_Fint *sendtype, - void *recvbuf, MPI_Fint *recvcount, MPI_Fint *recvtype, - MPI_Fint *root, MPI_Fint *comm, MPI_Fint *__ierr) -{ - *__ierr = MPI_Gather (sendbuf, *sendcount, MPI_Type_f2c (*sendtype), - recvbuf, *recvcount, MPI_Type_f2c (*recvtype), *root, - MPI_Comm_f2c (*comm)); -} - -void mpi_gatherv (void *sendbuf, MPI_Fint *sendcount, MPI_Fint *sendtype, - void *recvbuf, MPI_Fint *recvcounts, MPI_Fint *displs, - MPI_Fint *recvtype, MPI_Fint *root, MPI_Fint *comm, MPI_Fint *__ierr) -{ - *__ierr = MPI_Gatherv (sendbuf, *sendcount, MPI_Type_f2c (*sendtype), - recvbuf, recvcounts, displs, - MPI_Type_f2c (*recvtype), *root,MPI_Comm_f2c (*comm)); -} - -void mpi_scatter (void *sendbuf, MPI_Fint *sendcount, MPI_Fint *sendtype, - void *recvbuf, MPI_Fint *recvcount, MPI_Fint *recvtype, - MPI_Fint *root, MPI_Fint *comm, MPI_Fint *__ierr) -{ - *__ierr = MPI_Scatter (sendbuf, *sendcount, MPI_Type_f2c (*sendtype), - recvbuf, *recvcount, MPI_Type_f2c (*recvtype), - *root, MPI_Comm_f2c (*comm)); -} - -void mpi_alltoall (void *sendbuf, MPI_Fint *sendcount, MPI_Fint *sendtype, - void *recvbuf, MPI_Fint *recvcount, MPI_Fint *recvtype, - MPI_Fint *comm, MPI_Fint *__ierr) -{ - *__ierr = MPI_Alltoall (sendbuf, *sendcount, MPI_Type_f2c(*sendtype), - recvbuf, *recvcount, MPI_Type_f2c(*recvtype), - MPI_Comm_f2c (*comm)); -} - -void mpi_reduce (void *sendbuf, void *recvbuf, MPI_Fint *count, - MPI_Fint *datatype, MPI_Fint *op, MPI_Fint *root, - MPI_Fint *comm, MPI_Fint *__ierr) -{ - *__ierr = MPI_Reduce (sendbuf, recvbuf, *count, MPI_Type_f2c(*datatype), - MPI_Op_f2c(*op), *root, MPI_Comm_f2c(*comm)); -} - -void mpi_allgather (void *sendbuf, MPI_Fint *sendcount, MPI_Fint *sendtype, - void *recvbuf, MPI_Fint *recvcount, MPI_Fint *recvtype, - MPI_Fint *comm, MPI_Fint *__ierr) -{ - *__ierr = MPI_Allgather (sendbuf, *sendcount, MPI_Type_f2c (*sendtype), - recvbuf, *recvcount, MPI_Type_f2c (*recvtype), - MPI_Comm_f2c (*comm)); -} - -void mpi_allgatherv (void *sendbuf, MPI_Fint *sendcount, MPI_Fint *sendtype, - void *recvbuf, MPI_Fint *recvcounts, MPI_Fint *displs, - MPI_Fint *recvtype, MPI_Fint *comm, MPI_Fint *__ierr) -{ - *__ierr = MPI_Allgatherv (sendbuf, *sendcount, MPI_Type_f2c (*sendtype), - recvbuf, recvcounts, displs, - MPI_Type_f2c (*recvtype), MPI_Comm_f2c (*comm)); -} - -void mpi_iprobe (MPI_Fint *source, MPI_Fint *tag, MPI_Fint *comm, - MPI_Fint *flag, MPI_Fint *status, MPI_Fint *__ierr) -{ - int l_flag; - MPI_Status c_status; - *__ierr = MPI_Iprobe ((int) *source, (int) *tag, MPI_Comm_f2c (*comm), - &l_flag, &c_status ); - /* - ** The following setting ASSUMES that the C value for l_flag (0=false, non-zero=true) - ** maps properly to a Fortran logical. Have tested gfortran, Cray, Intel, PGI, - ** Pathscale and found this to be valid in all cases. - */ - *flag = (MPI_Fint) l_flag; - if (l_flag) { - MPI_Status_c2f (&c_status, status); - } -} - -void mpi_probe (MPI_Fint *source, MPI_Fint *tag, MPI_Fint *comm, - MPI_Fint *status, MPI_Fint *__ierr) -{ - MPI_Status c_status; - *__ierr = MPI_Probe ((int) *source, (int) *tag, MPI_Comm_f2c (*comm), - &c_status ); - MPI_Status_c2f (&c_status, status); -} - -void mpi_ssend (void *buf, MPI_Fint *count, MPI_Fint *datatype, MPI_Fint *dest, - MPI_Fint *tag, MPI_Fint *comm, MPI_Fint *__ierr) -{ - *__ierr = MPI_Ssend (buf, *count, MPI_Type_f2c (*datatype), *dest, *tag, - MPI_Comm_f2c (*comm)); -} - -void mpi_alltoallv (void *sendbuf, MPI_Fint *sendcnts, MPI_Fint *sdispls, - MPI_Fint *sendtype, void *recvbuf, MPI_Fint *recvcnts, - MPI_Fint *rdispls, MPI_Fint *recvtype, MPI_Fint *comm, - MPI_Fint *__ierr) -{ - *__ierr = MPI_Alltoallv (sendbuf, sendcnts, sdispls, - MPI_Type_f2c (*sendtype), recvbuf, - recvcnts, rdispls, MPI_Type_f2c (*recvtype), - MPI_Comm_f2c (*comm)); -} - -void mpi_scatterv (void *sendbuf, MPI_Fint *sendcnts, MPI_Fint *displs, - MPI_Fint *sendtype, void *recvbuf, MPI_Fint *recvcnt, - MPI_Fint *recvtype, MPI_Fint *root, MPI_Fint *comm, - MPI_Fint *__ierr ) -{ - *__ierr = MPI_Scatterv (sendbuf, sendcnts, displs, MPI_Type_f2c (*sendtype), - recvbuf, *recvcnt, MPI_Type_f2c (*recvtype), *root, - MPI_Comm_f2c (*comm)); -} - -void mpi_test (MPI_Fint *request, MPI_Fint *flag, MPI_Fint *status, - MPI_Fint *__ierr ) -{ - int l_flag; - MPI_Status c_status; - MPI_Request lrequest = MPI_Request_f2c (*request); - - *__ierr = MPI_Test (&lrequest, &l_flag, &c_status); - *request = MPI_Request_c2f (lrequest); /* In case request is changed */ - - /* - ** The following setting ASSUMES that the C value for l_flag (0=false, non-zero=true) - ** maps properly to a Fortran logical. Have tested gfortran, Cray, Intel, PGI, - ** Pathscale and found this to be valid in all cases. - */ - *flag = (MPI_Fint) l_flag; - if (l_flag) { - MPI_Status_c2f (&c_status, status); - } -} -#endif /* ENABLE_PMPI */ -#endif /* HAVE_MPI */ diff --git a/cesm/models/utils/timing/gptl/ftests/Makefile b/cesm/models/utils/timing/gptl/ftests/Makefile deleted file mode 100644 index 53d978d..0000000 --- a/cesm/models/utils/timing/gptl/ftests/Makefile +++ /dev/null @@ -1,152 +0,0 @@ -include ../macros.make -# *xlf* (IBM) compilers use a different mechanism for #defines than other compilers -ifeq ($(findstring xlf, $(FC)),xlf) - DEFINE = -WF,-D -else - DEFINE = -D -endif - -# May be reset below -THREADED = no - -# Ensure that FFLAGS are set for low optimization -FFLAGS += -g -O1 - -# TESTS defines which of EXES have a built-in testing procedure. -TESTS = testbasics nlreader outoforder - -ifeq ($(HAVE_PAPI),yes) - TESTS += testinit testpapi -endif -EXES = $(TESTS) errtest utrtest overhead - -LDFLAGS = -g -L.. -l$(LIBNAME) $(ABIFLAGS) - -#For gptlf.mod -FFLAGS += -I.. - -ifeq ($(HAVE_MPI),yes) - EXES += summary pmpi - FFLAGS += $(DEFINE)HAVE_MPI $(MPI_INCFLAGS) - LDFLAGS += $(MPI_LIBFLAGS) -endif - -ifeq ($(ENABLE_PMPI),yes) - FFLAGS += $(DEFINE)ENABLE_PMPI - LIBNAME = gptl_pmpi - ifeq ($(HAVE_IARGCGETARG),yes) - FFLAGS += $(DEFINE)HAVE_IARGCGETARG - endif -else - LIBNAME = gptl -endif - -ifeq ($(OPENMP),yes) - THREADED = yes - EXES += toomanythreads - FFLAGS += $(DEFINE)THREADED_OMP $(FOMPFLAG) - LDFLAGS += $(FOMPFLAG) -else - ifeq ($(PTHREADS),yes) -# Threaded tests use OpenMP - THREADED = yes - EXES += toomanythreads - FFLAGS += $(DEFINE)THREADED_OMP $(FOMPFLAG) - LDFLAGS += $(FOMPFLAG) -lpthread - endif -endif - -ifeq ($(HAVE_PAPI),yes) - FFLAGS += $(DEFINE)HAVE_PAPI - LDFLAGS += $(PAPI_LIBFLAGS) -endif - -OBJS = $(patsubst %,%.o,$(EXES)) - -%.o: %.F90 - $(FC) $(FFLAGS) -c $< - -all: $(EXES) - -clean: - $(RM) $(OBJS) *.mod $(EXES) timing.* - -errtest: errtest.o - $(FC) $(FFLAGS) -o $@ $< $(LDFLAGS) - -utrtest: utrtest.o - $(FC) $(FFLAGS) -o $@ $< $(LDFLAGS) - -summary: summary.o - $(FC) $(FFLAGS) -o $@ $< $(LDFLAGS) - -testinit: testinit.o - $(FC) $(FFLAGS) -o $@ $< $(LDFLAGS) - -testpapi: testpapi.o - $(FC) $(FFLAGS) -o $@ $< $(LDFLAGS) - -testbasics: testbasics.o - $(FC) $(FFLAGS) -o $@ $< $(LDFLAGS) - -nlreader: nlreader.o - $(FC) $(FFLAGS) -o $@ $< $(LDFLAGS) - -outoforder: outoforder.o - $(FC) $(FFLAGS) -o $@ $< $(LDFLAGS) - -pmpi: pmpi.o - $(FC) $(FFLAGS) -o $@ $< $(LDFLAGS) -pmpi.o: pmpi.F90 - $(FC) -c $(FFLAGS) $< - -overhead: overhead.F90 ../lib$(LIBNAME).a - $(FC) $(FFLAGS) -o $@ $< $(LDFLAGS) - -toomanythreads: toomanythreads.F90 - $(FC) $(FFLAGS) -o $@ $< $(LDFLAGS) - -# Hidden executable testbacktrace requires some strange flags so don't build it unless asked -testbacktrace: testbacktrace.F90 - $(FC) $(FFLAGS) $(INSTRFLAG) -rdynamic -o $@ $< $(LDFLAGS) - -# Built-in tests to ensure that GPTL is behaving as expected -# Invoke as "make test" from one dir above - -test: $(TESTS) - @$(RM) timing.0 - @echo Running ./testbasics... - ./testbasics - @echo Success - @echo - @echo Checking contents of timing.0 for a specific region name... - @grep -q testbasics timing.0 || (echo "Failed" && exit 1) - @echo Success - @echo - @echo Running ./nlreader... - ./nlreader - @echo Success - @echo Running ./outoforder... - ./outoforder - @echo Success -ifeq ($(THREADED),yes) - @echo Running ./toomanythreads... - ./toomanythreads -endif -ifeq ($(HAVE_PAPI),yes) - @echo - @echo Running ./testinit... - ./testinit - @echo - @echo Running ./testpapi... - ./testpapi -endif -ifeq ($(ENABLE_PMPI),yes) - @echo - @echo Running $(MPICMD) ./pmpi - env $(MPICMD) ./pmpi - @echo Checking contents of timing.0 for region name MPI_Send... - @grep -q MPI_Send timing.0 || (echo "Failed" && exit 1) - @echo Success -endif - @echo "All Fortran tests passed" diff --git a/cesm/models/utils/timing/gptl/ftests/errtest.F90 b/cesm/models/utils/timing/gptl/ftests/errtest.F90 deleted file mode 100644 index 09e24b4..0000000 --- a/cesm/models/utils/timing/gptl/ftests/errtest.F90 +++ /dev/null @@ -1,42 +0,0 @@ -program errtest - use gptl - - implicit none - - integer ret, iter - integer val - - write(6,*)'Purpose: test error conditions' - -1 write(6,*)'Enter number for error test:' - write(6,*)'0: bad option' - write(6,*)'3: stop never started' - write(6,*)'4: stop while already stopped' - write(6,*)'5: instance not called' - - read (5,*) val - if (val < 0 .or. val > 5) then - write(6,*)'Val must be between 0 and 5' - goto 1 - end if - - if (val == 0) then - if (gptlsetoption (100, 1) < 0) write(6,*)'setoption failure' - if (gptlinitialize () < 0) write(6,*)'initialize failure' - else if (val == 3) then - if (gptlinitialize () < 0) write(6,*)'initialize failure' - if (gptlstop ('errtest') < 0) write(6,*)'stop failure' - else if (val == 4) then - if (gptlinitialize () < 0) write(6,*)'initialize failure' - if (gptlstart ('errtest') < 0) write(6,*)'start failure' - if (gptlstop ('errtest') < 0) write(6,*)'stop failure' - if (gptlstop ('errtest') < 0) write(6,*)'stop failure' - else if (val == 5) then - if (gptlstart ('errtest') < 0) write(6,*)'start failure' - if (gptlstop ('errtest') < 0) write(6,*)'stop failure' - if (gptlpr (0) < 0) write(6,*)'stop failure' - end if - - if (gptlfinalize () < 0) write(6,*)'gptlfinalize error' - stop 0 -end program errtest diff --git a/cesm/models/utils/timing/gptl/ftests/gptlnl b/cesm/models/utils/timing/gptl/ftests/gptlnl deleted file mode 100644 index 5d5c10b..0000000 --- a/cesm/models/utils/timing/gptl/ftests/gptlnl +++ /dev/null @@ -1,33 +0,0 @@ -&gptlnl -! These settings are all the opposite of the default--for testing - sync_mpi = .true. - wall = .false. - cpu = .true. - abort_on_error = .true. - overhead = .true. - depthlimit = 1 -! verbose = .true. - narrowprint = .false. - percent = .true. -! Comment out persec and multiplex so "nlreader" test won't fail even if -! PAPI unavailable -! persec = .false. -! multiplex = .true. - dopr_preamble = .false. - dopr_threadsort = .false. - dopr_multparent = .false. - dopr_collision = .false. - -! utr, print_method, and eventlist use character variables instead of integer -! to avoid "magic number" settings in the namelist. Leave utr commented -! so that abort_on_error doesn't make tests fail if chosen timer unavailable - -! utr = 'nanotime' - print_method = 'full_tree' -!print_method = 'first_parent' -!print_method = 'last_parent' -!print_method = 'most_frequent' ! default - -! Comment out eventlist so "nlreader" test won't fail even if PAPI unavailable -! eventlist = 'PAPI_FP_OPS','GPTL_CI' -/ diff --git a/cesm/models/utils/timing/gptl/ftests/handle.F90 b/cesm/models/utils/timing/gptl/ftests/handle.F90 deleted file mode 100644 index 11f4343..0000000 --- a/cesm/models/utils/timing/gptl/ftests/handle.F90 +++ /dev/null @@ -1,28 +0,0 @@ -program handle - use gptl - implicit none - - integer :: handle1 ! Hash index - integer :: n - integer :: ret - - ret = gptlinitialize () - - ret = gptlstart ('total') ! Time the entire code -! IMPORTANT: Start with a zero handle value so GPTLstart_handle knows to initialize - handle1 = 0 - -!$OMP PARALLEL DO SHARED (handle1) - do n=1,1000000 -! First call the "_handle" versions of start and stop for the region - ret = gptlstart_handle ('loop', handle1) - ret = gptlstop_handle ('loop', handle1) -! Now call the standard start and stop functions for the same region - ret = gptlstart ('loop') - ret = gptlstop ('loop') - end do - ret = gptlstop ('total') ! Time the entire code - - ret = gptlpr (0) - stop -end program handle diff --git a/cesm/models/utils/timing/gptl/ftests/nlreader.F90 b/cesm/models/utils/timing/gptl/ftests/nlreader.F90 deleted file mode 100644 index 3990c9c..0000000 --- a/cesm/models/utils/timing/gptl/ftests/nlreader.F90 +++ /dev/null @@ -1,24 +0,0 @@ -program nlreader - use gptl - - implicit none - - integer :: ret - - ret = gptlsetoption (gptlverbose, 1) - write(6,*)'nlreader: Testing gptlprocess_namelist...' - call gptlprocess_namelist ('gptlnl', 1, ret) - if (ret /= 0) then - write(6,*)'Failure' - call exit (1) - end if - - ! Now turn off verbosity - - ret = gptlsetoption (gptlverbose, 0) - ret = gptlinitialize () - ret = gptlstart ('main') - ret = gptlstop ('main') - ret = gptlpr (0) - write(6,*)'Success' -end program nlreader diff --git a/cesm/models/utils/timing/gptl/ftests/outoforder.F90 b/cesm/models/utils/timing/gptl/ftests/outoforder.F90 deleted file mode 100644 index 7da5f38..0000000 --- a/cesm/models/utils/timing/gptl/ftests/outoforder.F90 +++ /dev/null @@ -1,56 +0,0 @@ -program outoforder -! Purpose: test behavior of imperfectly-nested regions - use gptl - implicit none - - integer :: n - integer :: ret - integer :: num_warn - integer :: kount - - write(6,*) 'Testing out of order calls...' - ret = gptlinitialize () - - do n=1,10 - ret = gptlstart ("xxx") - ret = gptlstart ("yyy") - ret = gptlstart ("zzz") - ret = gptlstop ("xxx") - ret = gptlstop ("yyy") - ret = gptlstop ("zzz") - end do - - ret = gptlstart ("A") - ret = gptlstart ("B") - ret = gptlstart ("C") - ret = gptlstop ("C") - ret = gptlstop ("B") - ret = gptlstop ("A") - - ret = gptlget_count ('xxx', 0, kount) - if (kount /= 10) then - write(6,*)'Failure: Got count=', kount, ' for xxx when expected 10' - call exit (1) - end if - - ret = gptlget_count ('yyy', 0, kount) - if (kount /= 10) then - write(6,*)'Failure: Got count=', kount, ' for yyy when expected 10' - call exit (1) - end if - - ret = gptlget_count ('zzz', 0, kount) - if (kount /= 10) then - write(6,*)'Failure: Got count=', kount, ' for zzz when expected 10' - call exit (1) - end if - - num_warn = gptlnum_warn () - if (num_warn > 0) then - write(6,*)'Success: ', num_warn,' warnings were found' - else - write(6,*) 'Failure: no warnings were found when they should have been' - call exit (1) - end if - ret = gptlpr (0) -end program outoforder diff --git a/cesm/models/utils/timing/gptl/ftests/overhead.F90 b/cesm/models/utils/timing/gptl/ftests/overhead.F90 deleted file mode 100644 index 6c41609..0000000 --- a/cesm/models/utils/timing/gptl/ftests/overhead.F90 +++ /dev/null @@ -1,174 +0,0 @@ -program overhead - use gptl - - implicit none - - integer :: ret, iter, i - real*8 :: wall1, usr1, sys1 - real*8 :: wall2, usr2, sys2 - integer :: cycles1, cycles2, cps - character(len=16) :: msg - integer :: handle -#ifdef THREADED_OMP - integer, parameter :: maxthreads = 8 -#else - integer, parameter :: maxthreads = 1 -#endif - integer :: nthreads - -#ifdef THREADED_OMP - integer, external :: omp_set_num_threads -#endif - - open (unit=1, file='gettimeofday', form='formatted', status='replace') - nthreads = 1 - do while (nthreads <= maxthreads) - write(6,*)'overhead: running gettimeofday nthreads=', nthreads - ret = gptlsetutr (gptlgettimeofday) -#ifdef THREADED_OMP - ret = omp_set_num_threads (nthreads) -#endif - ret = gptlsetoption (gptlabort_on_error, 1) - ret = gptlinitialize () - ret = gptlstamp (wall1, usr1, sys1) -!$OMP PARALLEL DO PRIVATE (RET) - do i=1,10000000 - ret = gptlstart ('loop') - ret = gptlstop ('loop') - end do - ret = gptlstamp (wall2, usr2, sys2) - write(1,'(i3,3f9.3)') nthreads, wall2-wall1, usr2-usr2, sys2-sys1 - nthreads = nthreads * 2 - ret = gptlpr (0) - ret = gptlfinalize () - end do - close (unit=1) - -#ifdef _AIX - open (unit=1, file='read_real_time', form='formatted', status='replace') -#else - open (unit=1, file='nanotime', form='formatted', status='replace') -#endif - nthreads = 1 - do while (nthreads <= maxthreads) -#ifdef _AIX - write(6,*)'overhead: running read_real_time nthreads=', nthreads - ret = gptlsetutr (gptlread_real_time) -#else - write(6,*)'overhead: running nanotime nthreads=', nthreads - ret = gptlsetutr (gptlnanotime) -#endif - -#ifdef THREADED_OMP - ret = omp_set_num_threads (nthreads) -#endif - ret = gptlsetoption (gptlabort_on_error, 1) - ret = gptlinitialize () - ret = gptlstamp (wall1, usr1, sys1) -!$OMP PARALLEL DO PRIVATE (RET) - do i=1,10000000 - ret = gptlstart ('loop') - ret = gptlstop ('loop') - end do - ret = gptlstamp (wall2, usr2, sys2) - write(1,'(i3,3f9.3)') nthreads, wall2-wall1, usr2-usr2, sys2-sys1 - nthreads = nthreads * 2 - ret = gptlpr (0) - ret = gptlfinalize () - end do - close (unit=1) - - open (unit=1, file='no_wallclock', form='formatted', status='replace') - nthreads = 1 - do while (nthreads <= maxthreads) - write(6,*)'overhead: running no_wallclock nthreads=', nthreads - ret = gptlsetutr (gptlgettimeofday) -#ifdef THREADED_OMP - ret = omp_set_num_threads (nthreads) -#endif - ret = gptlsetoption (gptlwall, 0) - ret = gptlsetoption (gptlabort_on_error, 1) - ret = gptlinitialize () - call system_clock (cycles1, cps) -!$OMP PARALLEL DO PRIVATE (RET) - do i=1,10000000 - ret = gptlstart ('loop') - ret = gptlstop ('loop') - end do - call system_clock (cycles2, cps) - write(1,'(i3,f9.3)') nthreads, float((cycles2-cycles1))/cps - nthreads = nthreads * 2 - ret = gptlpr (0) - ret = gptlfinalize () - end do - close (unit=1) - - open (unit=1, file='handle', form='formatted', status='replace') - nthreads = 1 - do while (nthreads <= maxthreads) - write(6,*)'overhead: running handle (no_wallclock) nthreads=', nthreads - ret = gptlsetutr (gptlgettimeofday) -#ifdef THREADED_OMP - ret = omp_set_num_threads (nthreads) -#endif - ret = gptlsetoption (gptlwall, 0) - ret = gptlsetoption (gptlabort_on_error, 1) - ret = gptlinitialize () - handle = 0 - call system_clock (cycles1, cps) -!$OMP PARALLEL DO PRIVATE (RET) FIRSTPRIVATE (HANDLE) - do i=1,10000000 - ret = gptlstart_handle ('loop', handle) - ret = gptlstop_handle ('loop', handle) - end do - call system_clock (cycles2, cps) - write(1,'(i3,f9.3)') nthreads, float((cycles2-cycles1))/cps - nthreads = nthreads * 2 - ret = gptlpr (0) - ret = gptlfinalize () - end do - close (unit=1) - - open (unit=1, file='do_nothing', form='formatted', status='replace') - nthreads = 1 - do while (nthreads <= maxthreads) - write(6,*)'overhead: running do_nothing nthreads=', nthreads - handle = 0 - call system_clock (cycles1, cps) -!$OMP PARALLEL DO PRIVATE (RET) FIRSTPRIVATE (HANDLE) - do i=1,10000000 - call do_nothing1 ('string1', handle) - call do_nothing2 ('string2', handle) - call do_nothing1 ('string3', handle) - call do_nothing2 ('string4', handle) - end do - call system_clock (cycles2, cps) - write(1,'(i3,f9.3)') nthreads, float((cycles2-cycles1))/cps - nthreads = nthreads * 2 - end do - close (unit=1) - - stop 0 -end program overhead - -subroutine do_nothing1 (string, handle) - implicit none - - character(len=*), intent(in) :: string - integer, intent(in) :: handle - - if (string(1:1) == 'x') then - write(6,*)'Bad string value' - end if -end subroutine do_nothing1 - -subroutine do_nothing2 (string, handle) - implicit none - - character(len=*), intent(in) :: string - integer, intent(in) :: handle - - if (string(1:1) == 'x') then - write(6,*)'Bad string value' - end if -end subroutine do_nothing2 diff --git a/cesm/models/utils/timing/gptl/ftests/pmpi.F90 b/cesm/models/utils/timing/gptl/ftests/pmpi.F90 deleted file mode 100644 index cf3f59d..0000000 --- a/cesm/models/utils/timing/gptl/ftests/pmpi.F90 +++ /dev/null @@ -1,415 +0,0 @@ -#undef DEBUG -module myvars - integer :: iam - integer :: commsize -end module myvars - -program pmpi - use myvars - use gptl - - implicit none - -#include - - integer, parameter :: tag = 98 - integer, parameter :: count = 100000 - - integer :: i, j, ret - integer :: val - integer :: comm = MPI_COMM_WORLD - integer :: sendbuf(0:count-1) - integer :: recvbuf(0:count-1) - integer :: sum - integer :: status(MPI_STATUS_SIZE) - integer :: sendreq, recvreq - integer :: dest - integer :: source - integer :: rdispls(0:count-1) - integer :: sdispls(0:count-1) - - integer :: kount, of ! for gptlquery - real(8) :: wc, usr, sys ! for gptlquery - integer(8) :: pc ! for gptlquery - - integer, allocatable :: atoabufsend(:) - integer, allocatable :: atoabufrecv(:) - integer, allocatable :: gsbufsend(:,:) ! gather/scatter buffer send - integer, allocatable :: gsbufrecv(:,:) ! gather/scatter buffer recv - integer, allocatable :: recvcounts(:) - integer, allocatable :: sendcounts(:) - integer, allocatable :: atoacounts(:) - integer, allocatable :: atoadispls(:) - - logical :: flag - integer :: debugflag = 1 - - ret = gptlsetoption (gptloverhead, 0) - ret = gptlsetoption (gptlpercent, 0) - ret = gptlsetoption (gptlabort_on_error, 1) - ret = gptlsetoption (gptlsync_mpi, 1) - -#if ( ! defined HAVE_IARGCGETARG ) - ret = gptlinitialize () - ret = gptlstart ("total") -#endif - - call mpi_init (ret) - -! For debugging, go into infinite loop so debugger can attach and reset -#ifdef DEBUG - do while (debugflag == 1) - end do -#endif - - call mpi_comm_rank (comm, iam, ret) - call mpi_comm_size (comm, commsize, ret) - if (iam == 0) write(6,*)'commsize is ', commsize - - do i=0,count-1 - sendbuf(i) = iam - end do - - dest = mod ((iam + 1), commsize) - source = iam - 1 - if (source < 0) then - source = commsize - 1 - end if -! -! mpi_send -! mpi_recv -! mpi_probe -! - recvbuf(:) = -1 - if (mod (commsize, 2) == 0) then - if (iam == 0) then - write(6,*)'Testing send, recv, probe...' - end if - - if (mod (iam, 2) == 0) then - call mpi_send (sendbuf, count, MPI_INTEGER, dest, tag, comm, ret) - call mpi_recv (recvbuf, count, MPI_INTEGER, source, tag, comm, status, ret) - else - call mpi_probe (source, tag, comm, status, ret) - if (ret /= MPI_SUCCESS) then - write(6,*) "iam=", iam, " mpi_probe: bad return" - call mpi_abort (MPI_COMM_WORLD, -1, ret) - end if - call mpi_recv (recvbuf, count, MPI_INTEGER, source, tag, comm, status, ret) - call mpi_send (sendbuf, count, MPI_INTEGER, dest, tag, comm, ret) - end if - call chkbuf ('mpi_send + mpi_recv', recvbuf(:), count, source) - - if (iam == 0) then - write(6,*)'Success' - write(6,*)'Testing ssend...' - end if -! -! mpi_ssend -! - recvbuf(:) = -1 - if (mod (iam, 2) == 0) then - call mpi_ssend (sendbuf, count, MPI_INTEGER, dest, tag, comm, ret) - call mpi_recv (recvbuf, count, MPI_INTEGER, source, tag, comm, status, ret) - else - call mpi_recv (recvbuf, count, MPI_INTEGER, source, tag, comm, status, ret) - call mpi_ssend (sendbuf, count, MPI_INTEGER, dest, tag, comm, ret) - end if - call chkbuf ('mpi_send + mpi_recv', recvbuf(:), count, source) - if (iam == 0) then - write(6,*)'Success' - write(6,*)'Testing sendrecv...' - end if - else - if (iam == 0) write(6,*)'NOTE: commsize=',commsize,' is odd so wont test ', & - 'send, recv, probe, ssend' - end if -! -! mpi_sendrecv -! - recvbuf(:) = -1 - call mpi_sendrecv (sendbuf, count, MPI_INTEGER, dest, tag, & - recvbuf, count, MPI_INTEGER, source, tag, & - comm, status, ret) - call chkbuf ('mpi_sendrecv', recvbuf(:), count, source) - if (iam == 0) then - write(6,*)'Success' - write(6,*)'Testing irecv, isend, issend, iprobe, itest, wait, waitall...' - end if -! -! mpi_irecv -! mpi_isend -! mpi_issend -! mpi_iprobe -! mpi_test -! mpi_wait -! mpi_waitall -! - recvbuf(:) = -1 - call mpi_irecv (recvbuf, count, MPI_INTEGER, source, tag, & - comm, recvreq, ret) - call mpi_iprobe (source, tag, comm, flag, status, ret) - call mpi_test (recvreq, flag, status, ret) - call mpi_isend (sendbuf, count, MPI_INTEGER, dest, tag, & - comm, sendreq, ret) - call mpi_wait (recvreq, status, ret) - call mpi_wait (sendreq, status, ret) - call chkbuf ("mpi_wait", recvbuf(:), count, source) - - recvbuf(:) = -1 - call mpi_irecv (recvbuf, count, MPI_INTEGER, source, tag, & - comm, recvreq, ret) - call mpi_iprobe (source, tag, comm, flag, status, ret) - call mpi_test (recvreq, flag, status, ret) - call mpi_issend (sendbuf, count, MPI_INTEGER, dest, tag, & - comm, sendreq, ret) - call mpi_wait (recvreq, status, ret) - call mpi_wait (sendreq, status, ret) - call chkbuf ("mpi_wait", recvbuf(:), count, source) - - recvbuf(:) = -1 - call mpi_irecv (recvbuf, count, MPI_INTEGER, source, tag, & - comm, recvreq, ret) - call mpi_isend (sendbuf, count, MPI_INTEGER, dest, tag, & - comm, sendreq, ret) - call mpi_waitall (1, recvreq, status, ret) - call mpi_waitall (1, sendreq, status, ret) - call chkbuf ("mpi_waitall", recvbuf(:), count, source) - - call mpi_barrier (comm, ret) - if (iam == 0) then - write(6,*)'Success' - write(6,*)'Testing bcast...' - end if -! -! mpi_bcast -! - call mpi_bcast (sendbuf, count, MPI_INTEGER, 0, comm, ret) - call chkbuf ("mpi_bcast", sendbuf(:), count, 0) - if (iam == 0) then - write(6,*)'Success' - write(6,*)'Testing allreduce...' - end if -! -! mpi_allreduce: need to reset sendbuf due to bcast just done -! - do i=0,count-1 - sendbuf(i) = iam - end do - - recvbuf(:) = -1 - call mpi_allreduce (sendbuf, recvbuf, count, MPI_INTEGER, MPI_SUM, comm, ret) - sum = 0. - do i=0,commsize-1 - sum = sum + i - end do - call chkbuf ("mpi_allreduce", recvbuf(:), count, sum) - if (iam == 0) then - write(6,*)'Success' - write(6,*)'Testing gather...' - end if - - allocate (gsbufsend(0:count-1,0:commsize-1)) - allocate (gsbufrecv(0:count-1,0:commsize-1)) - allocate (recvcounts(0:commsize-1)) - allocate (sendcounts(0:commsize-1)) -! -! mpi_gather -! - gsbufrecv(:,:) = -1 - call mpi_gather (sendbuf, count, MPI_INTEGER, & - gsbufrecv, count, MPI_INTEGER, 0, comm, ret) - if (iam == 0) then - do j=1,commsize-1 - call chkbuf ("mpi_gather", gsbufrecv(:,j), count, j) - end do - write(6,*)'Success' - write(6,*)'Testing gatherv...' - end if -! -! mpi_gatherv: make just like mpi_gather for simplicity -! - gsbufrecv(:,:) = -1 - recvcounts(:) = count - rdispls(0) = 0 - do j=1,commsize-1 - rdispls(j) = rdispls(j-1) + recvcounts(j-1) - end do - call mpi_gatherv (sendbuf, count, MPI_INTEGER, & - gsbufrecv, recvcounts, rdispls, & - MPI_INTEGER, 0, comm, ret) - if (iam == 0) then - do j=1,commsize-1 - call chkbuf ("mpi_gatherv", gsbufrecv(:,j), count, j) - end do - write(6,*)'Success' - write(6,*)'Testing scatter...' - end if -! -! mpi_scatter -! - if (iam == 0) then - do j=0,commsize-1 - gsbufsend(:,j) = j - end do - else - do j=0,commsize-1 - gsbufsend(:,j) = -1 - end do - end if - recvbuf(:) = -1 - call mpi_scatter (gsbufsend, count, MPI_INTEGER, recvbuf, count, MPI_INTEGER, & - 0, comm, ret) - call chkbuf ("mpi_scatter", recvbuf(:), count, iam) - if (iam == 0) then - write(6,*)'Success' - write(6,*)'Testing scatterv...' - end if -! -! mpi_scatterv: make just like mpi_scatter for simplicity. -! - if (iam == 0) then - do j=0,commsize-1 - gsbufsend(:,j) = j - end do - else - gsbufsend(:,:) = -1 - end if - sendcounts(:) = count - sdispls(0) = 0 - do j=1,commsize-1 - sdispls(j) = sdispls(j-1) + sendcounts(j-1) - end do - recvbuf(:) = -1 - call mpi_scatterv (gsbufsend, sendcounts, sdispls, & - MPI_INTEGER, recvbuf, count, & - MPI_INTEGER, 0, comm, ret) - call chkbuf ("mpi_scatterv", recvbuf(:), count, iam) - if (iam == 0) then - write(6,*)'Success' - write(6,*)'Testing alltoall...' - end if -! -! mpi_alltoall -! - allocate (atoabufsend(0:commsize-1)) - allocate (atoabufrecv(0:commsize-1)) - allocate (atoacounts(0:commsize-1)) - allocate (atoadispls(0:commsize-1)) - do j=0,commsize-1 - atoabufsend(j) = j - end do - atoabufrecv(:) = -1 - call mpi_alltoall (atoabufsend, 1, MPI_INTEGER, atoabufrecv, 1, MPI_INTEGER, comm, ret) - call chkbuf ("mpi_alltoall", atoabufrecv(:), 1, iam) - if (iam == 0) then - write(6,*)'Success' - write(6,*)'Testing alltoallv...' - end if -! -! mpi_alltoallv -! - atoabufrecv(:) = -1 - atoacounts(:) = 1 - atoadispls(0) = 0 - do j=1,commsize-1 - atoadispls(j) = atoadispls(j-1) + atoacounts(j-1) - end do - - call mpi_alltoallv (atoabufsend, atoacounts, atoadispls, MPI_INTEGER, & - atoabufrecv, atoacounts, atoadispls, MPI_INTEGER, comm, ret) - call chkbuf ("mpi_alltoall", atoabufrecv(:), 1, iam) - - if (iam == 0) then - write(6,*)'Success' - write(6,*)'Testing reduce...' - end if -! -! mpi_reduce -! - call mpi_reduce (sendbuf, recvbuf, count, MPI_INTEGER, MPI_SUM, 0, comm, ret) - if (iam == 0) then - sum = 0. - do i=0,commsize-1 - sum = sum + i - end do - call chkbuf ("mpi_reduce", recvbuf(:), count, sum) - end if - - if (iam == 0) then - write(6,*)'Success' - write(6,*)'Testing allgather...' - end if -! -! mpi_allgather -! - gsbufrecv(:,:) = -1 - call mpi_allgather (sendbuf, count, MPI_INTEGER, & - gsbufrecv, count, MPI_INTEGER, comm, ret) - do j=0,commsize-1 - call chkbuf ("mpi_allgather", gsbufrecv(:,j), count, j) - end do - - if (iam == 0) then - write(6,*)'Success' - write(6,*)'Testing allgatherv...' - end if -! -! mpi_allgatherv: Make just like mpi_allgather for simplicity -! - gsbufrecv(:,:) = -1 - recvcounts(:) = count - call mpi_allgatherv (sendbuf, count, MPI_INTEGER, & - gsbufrecv, recvcounts, rdispls, & - MPI_INTEGER, comm, ret) - do j=0,commsize-1 - call chkbuf ("mpi_allgatherv", gsbufrecv(:,j), count, j) - end do - - if (iam == 0) then - write(6,*)'Success. Calling finalize' - end if -! -! mpi_finalize -! - call mpi_finalize (ret) - -#if ( defined HAVE_IARGCGETARG ) - if (iam == 0) then - write(6,*)'Testing for auto-generated MPI_Init_thru_Finalize region...' - ret = gptlquery ('MPI_Init_thru_Finalize', 0, kount, of, wc, usr, sys, pc, 0) - if (ret == 0) then - write(6,*)'Success' - else - write(6,*)'Failure' - end if - end if -#else - ret = gptlstop ("total") - ret = gptlpr (iam) -#endif - - stop 0 -end program pmpi - -subroutine chkbuf (msg, recvbuf, count, val) - use myvars - implicit none - -#include - - character(len=*), intent(in) :: msg - - integer, intent(in) :: count - integer, intent(in) :: recvbuf(0:count-1) - integer, intent(in) :: val - - integer :: i - integer :: ret - do i=0,count-1 - if (recvbuf(i) /= val) then - write(6,*) "iam=", iam, msg, " bad recvbuf(", i,")=",recvbuf(i), "/= ", val - call mpi_abort (MPI_COMM_WORLD, -1, ret) - end if - end do -end subroutine chkbuf diff --git a/cesm/models/utils/timing/gptl/ftests/summary.F90 b/cesm/models/utils/timing/gptl/ftests/summary.F90 deleted file mode 100644 index b86fef2..0000000 --- a/cesm/models/utils/timing/gptl/ftests/summary.F90 +++ /dev/null @@ -1,128 +0,0 @@ -program main - use gptl - - implicit none - -#include - -#ifdef THREADED_OMP - integer, external :: omp_get_max_threads -#endif - - double precision, external :: sub - double precision result - - integer :: iam - integer :: nthreads = 1 ! number of threads (default 1) - integer :: nproc = 1 - integer iter - integer code - integer c - integer :: comm = 0 - integer ierr - integer ret - -#ifdef HAVE_PAPI -! Turn abort_on_error off just long enough to check PAPI-based options - ret = gptlsetoption (gptlabort_on_error, 0) - if (gptlevent_name_to_code ('PAPI_FP_OPS', code) == 0) then - ret = gptlsetoption (code, 1) - end if - ret = gptlsetoption (gptl_ci, 1) - ret = gptlsetoption (gptlabort_on_error, 1) -#endif - - ret = gptlsetoption (gptlabort_on_error, 1) - ret = gptlsetoption (gptloverhead, 1) - ret = gptlsetoption (gptlnarrowprint, 1) - - call mpi_init (ierr) - comm = MPI_COMM_WORLD - -#ifndef ENABLE_PMPI - ret = gptlinitialize () - ret = gptlstart ("total") -#endif - - call mpi_comm_rank (MPI_COMM_WORLD, iam, ierr) - call mpi_comm_size (MPI_COMM_WORLD, nproc, ierr) - - if (iam == 0) then - write (6,*) "Purpose: test behavior of summary stats" - write (6,*) "Include OpenMP if enabled" - end if - -#ifdef THREADED_OMP - nthreads = omp_get_max_threads () -#endif - -!$OMP PARALLEL DO PRIVATE (RESULT) - do iter=1,nthreads - result = sub (iter, iam) - end do - -#ifndef ENABLE_PMPI - ret = gptlstop ("total") - ret = gptlpr (iam) -#endif - ret = gptlpr_summary (comm) - if (ret /= 0) then - write(6,*)'summary.F90: error from gptlpr_summary' - stop 1 - end if - ret = gptlpr_summary_file (comm, "timing.summary.duplicate") - if (ret /= 0) then - write(6,*)'summary.F90: error from gptlpr_summary_file' - stop 1 - end if - - call mpi_finalize (ret) - - if (gptlfinalize () < 0) stop 1 - stop 0 -end program main - - -double precision function sub (iter, iam) - use gptl - implicit none - - integer, intent (in) :: iter - integer, intent (in) :: iam - - integer (8) :: looplen - integer (8) :: i - integer :: ret - double precision sum - - looplen = iam*iter*10000 - ret = gptlstart ("sub") - - ret = gptlstart ("sleep") - ret = gptlstop ("sleep") - - ret = gptlstart ("work") - sum = 0. - ret = gptlstart ("add") - do i=0,looplen-1 - sum = sum + i - end do - ret = gptlstop ("add") - - ret = gptlstart ("madd") - do i=0,looplen-1 - sum = sum + i*1.1 - end do - ret = gptlstop ("madd") - - ret = gptlstart ("div") - do i=0,looplen-1 - sum = sum / 1.1 - end do - ret = gptlstop ("div") - ret = gptlstop ("work") - ret = gptlstop ("sub") - - sub = sum - return -end function sub diff --git a/cesm/models/utils/timing/gptl/ftests/testbacktrace.F90 b/cesm/models/utils/timing/gptl/ftests/testbacktrace.F90 deleted file mode 100644 index 9cf4f85..0000000 --- a/cesm/models/utils/timing/gptl/ftests/testbacktrace.F90 +++ /dev/null @@ -1,46 +0,0 @@ -program testbacktrace - use gptl - - implicit none - - integer :: n, ret - - ret = gptlsetoption (gptldopr_memusage, 1) - ret = gptlinitialize () - -!$OMP PARALLEL DO - do n=1,240 - call threaded_sub (n) - end do -end program testbacktrace - -subroutine threaded_sub (n) - implicit none - - integer, intent(in) :: n - - call onemstack (n) - return -end subroutine threaded_sub - -subroutine onemstack (n) - implicit none - - integer, intent(in) :: n - character(len=1) :: chararr(1000000) - - chararr(:) = 'x' - call testchars (chararr) - return -end subroutine onemstack - -subroutine testchars (chararr) - implicit none - - character(len=1), intent(in) :: chararr(1000000) - - if (chararr(1000000) == 'y') then - write(6,*)'charr(1000000) = y' - end if - return -end subroutine testchars diff --git a/cesm/models/utils/timing/gptl/ftests/testbasics.F90 b/cesm/models/utils/timing/gptl/ftests/testbasics.F90 deleted file mode 100644 index 61d89f8..0000000 --- a/cesm/models/utils/timing/gptl/ftests/testbasics.F90 +++ /dev/null @@ -1,145 +0,0 @@ -program testbasics - use gptl - - implicit none - - integer :: ret - integer :: nregions - integer count, of ! for gptlquery - integer(8) :: pc ! for gptlquery - integer(8), allocatable :: iarr8(:) - real(8) :: wc, usr, sys ! for gptlquery - character(len=80) :: str - integer :: size, rss, share, text, datastack - - write(6,*)'testbasics: Testing basic GPTL usage...' - write(6,*)'Testing gptlinitialize...' - if (gptlinitialize () /= 0) then - write(6,*)'Failure in gptlinitialize' - call exit (1) - end if - write(6,*)'Success' - - write(6,*)'Testing gptlstart...' - if (gptlstart ('testbasics') /= 0) then - write(6,*)'Failure in gptlstart' - call exit(1) - end if - write(6,*)'Success' - - write(6,*)'Testing gptlstop...' - if (gptlstop ('testbasics') /= 0) then - write(6,*)'Failure in gptlstop' - call exit(1) - end if - write(6,*)'Success' - - write(6,*)'Testing gptlpr...' - if (gptlpr (0) /= 0) then - write(6,*)'Failure in gptlpr(0)' - call exit(1) - end if - write(6,*)'Success' - - write(6,*)'Testing gptlget_wallclock...' - if (gptlget_wallclock ('testbasics', 0, wc) /= 0) then - write(6,*)'Failure in gptlget_wallclock' - call exit(1) - end if - write(6,*)'Success: wc=', wc - - write(6,*)'Testing gptlget_memusage...' - if (gptlget_memusage (size, rss, share, text, datastack) /= 0) then - write(6,*)'Failure in gptlget_memusage' - call exit(1) - end if - write(6,*)'Success: size=', size, ' rss=', rss - - write(6,*)'Testing gptlprint_memusage...' - str = 'testbasics before allocating 100 MB' - if (gptlprint_memusage (trim(str)) /= 0) then - write(6,*)'Failure in gptlprint_memusage' - call exit(1) - end if - - allocate (iarr8(13107200)) - iarr8(:) = 0 - - str = 'testbasics after allocating 100 MB' - if (gptlprint_memusage (trim(str)) /= 0) then - write(6,*)'Failure in gptlprint_memusage' - call exit(1) - end if - - if (gptlprint_rusage (trim(str)) /= 0) then - write(6,*)'Failure in gptlprint_rusage' - call exit(1) - end if - - write(6,*)'Success' - - write(6,*)'Testing gptldisable/gptlenable...' - if (gptldisable () /= 0) then - write(6,*)'Failure in gptldisable' - call exit(1) - end if - if (gptlstart ('zzz') /= 0) then - write(6,*)'Failure in disabled gptlstart' - call exit(1) - end if - if (gptlstop ('zzz') /= 0) then - write(6,*)'Failure in disabled gptlstop' - call exit(1) - end if - if (gptlenable () /= 0) then - write(6,*)'Failure in gptlenable' - call exit(1) - end if - - write(6,*)'Sub-testing gptlget_nregions...' - if (gptlget_nregions (0, nregions) /= 0) then - write(6,*)'Failure in gptlget_nregions' - call exit(1) - end if - if (nregions /= 1) then - write(6,*)'Failure: expected nregions=1 got', nregions - call exit(1) - end if - write(6,*)'Success in gptlget_nregions' - write(6,*)'Success' - - write(6,*)'Testing gptlquery...' - ret = gptlquery ('testbasics', 0, count, of, wc, usr, sys, pc, 0) - if (ret /= 0) then - write(6,*)'Failure' - call exit(1) - end if - if (count /= 1) then - write(6,*)'Bad count value from gptlquery' - call exit(1) - end if - if (of /= 0) then - write(6,*)'Bad onflg value from gptlquery' - call exit(1) - end if - write (6,*)'Success' - - write(6,*)'Testing gptlreset...' - ret = gptlreset () - if (ret /= 0) then - write(6,*)'Failure' - call exit(1) - end if - ret = gptlquery ('testbasics', 0, count, of, wc, usr, sys, pc, 0) - if (ret /= 0) then - write(6,*)'Failure from gptlquery' - call exit(1) - end if - if (count/=0 .or. of/=0 .or. wc/=0. .or. usr/=0.) then - write(6,*)'Failure: one or more counts were not zeroed' - call exit(1) - end if - write (6,*)'Success' - - write (6,*)'testbasics: All tests succeeded' -end program testbasics diff --git a/cesm/models/utils/timing/gptl/ftests/testinit.F90 b/cesm/models/utils/timing/gptl/ftests/testinit.F90 deleted file mode 100644 index aac5ef8..0000000 --- a/cesm/models/utils/timing/gptl/ftests/testinit.F90 +++ /dev/null @@ -1,17 +0,0 @@ -program testinit - use gptl - - implicit none - - integer :: ret - - write(6,*)'testinit: Testing gptl_papilibraryinit...' - ret = gptl_papilibraryinit () - - if (ret == 0) then - write(6,*)'Success' - else - write(6,*)'Failure' - stop 999 - end if -end program testinit diff --git a/cesm/models/utils/timing/gptl/ftests/testpapi.F90 b/cesm/models/utils/timing/gptl/ftests/testpapi.F90 deleted file mode 100644 index a1cd366..0000000 --- a/cesm/models/utils/timing/gptl/ftests/testpapi.F90 +++ /dev/null @@ -1,149 +0,0 @@ -program testpapi - use gptl - - implicit none - - integer :: ret - integer :: i, code - integer(8) :: pc ! papi counters - real(8) :: sum, val - character(len=256) :: name - character(len=2) :: tooshort - - write(6,*)'testpapi: Testing PAPI interface...' - - write(6,*)'Testing enabling gptlverbose...' - if (gptlsetoption (gptlverbose, 1) /= 0) then - write(6,*)'Failure' - call exit(1) - end if - write(6,*)'Success' - - write(6,*)'Calling gptl_papilibraryinit...' - if (gptl_papilibraryinit () /= 0) then - write(6,*)'Failure from gptl_papilibraryinit...' - call exit(1) - end if - write(6,*)'Success' - - write(6,*)'Testing gptlevent_name_to_code for PAPI_TOT_CYC...' - if (gptlevent_name_to_code ('PAPI_TOT_CYC', code) /= 0) then - write(6,*)'Failure from gptlevent_name_to_code' - call exit(1) - end if - write(6,*)'Success: PAPI_TOT_CYC=',code - - write(6,*)'Testing passing PAPI_TOT_CYC to gptlsetoption...' - if (gptlsetoption (code, 1) /= 0) then - write(6,*)'Failure' - call exit(1) - end if - write(6,*)'Success' - - write(6,*)'Testing duplicate enable PAPI_TOT_CYC...' - if (gptlsetoption (code, 1) == 0) then - write(6,*)'Failure to fail!' - call exit(1) - end if - write(6,*)'Succeeded at failing!' - - write(6,*)'Testing turning off an already-on counter...' - if (gptlsetoption (code, 0) == 0) then - write(6,*)'Failure' - call exit(1) - end if - write(6,*)'Succeeded at failing!' - - write(6,*)'Testing gptlevent_code_to_name for PAPI_TOT_CYC...' - if (gptlevent_code_to_name (code, name) /= 0) then - write(6,*)'Failure from gptlevent_code_to_name' - call exit(1) - end if - - if (trim(name) == 'PAPI_TOT_CYC') then - write(6,*)'Success' - else - write(6,*)'Failure: got ',trim(name) - write(6,*)'Expected PAPI_TOT_CYC' - call exit(1) - end if - - write(6,*)'Testing gptlevent_name_to_code for GPTL_CI...' - if (gptlevent_name_to_code ('GPTL_CI', code) /= 0) then - write(6,*)'Failure from gptlevent_name_to_code' - call exit(1) - end if - write(6,*)'Success: GPTL_CI=',code - - write(6,*)'Testing too short var for gptlevent_code_to_name...' - if (gptlevent_code_to_name (code, tooshort) == 0) then - write(6,*)'Failure of gptlevent_code_to_name to fail' - call exit(1) - end if - write(6,*)'Success at catching too short output var name' - - write(6,*)'Testing gptlevent_code_to_name for GPTL_CI...' - if (gptlevent_code_to_name (code, name) /= 0) then - write(6,*)'Failure from gptlevent_code_to_name' - call exit(1) - end if - - if (name == 'GPTL_CI') then - write(6,*)'Success' - else - write(6,*)'Failure: got ',trim(name) - write(6,*)'Expected GPTL_CI' - call exit(1) - end if - - write(6,*)'Testing bogus input to gptlevent_name_to_code...' - if (gptlevent_name_to_code ('zzz', code) == 0) then - write(6,*)'Failure of gptlevent_name_to_code to fail' - call exit(1) - end if - write(6,*)'Success at catching bogus input name' - - write(6,*)'Testing bogus input to gptlevent_code_to_name...' - code = -1 - if (gptlevent_code_to_name (code, name) == 0) then - write(6,*)'Failure of gptlevent_code_to_name to fail' - call exit(1) - end if - write(6,*)'Success at catching bogus input code' - - write(6,*)'Testing gptlinitialize' - if (gptlinitialize () /= 0) then - write(6,*)'Failure' - call exit(1) - end if - write(6,*)'Success' - - ret = gptlstart ('sum') - sum = 0. - do i=1,1000000 - sum = sum + i - end do - ret = gptlstop ('sum') - - write(6,*)'Testing gptlquerycounters...' - if (gptlquerycounters ('sum', 0, pc) /= 0) then - write(6,*)'Failure' - call exit(1) - end if - write(6,*)'Success: pc=', pc - - write(6,*)'Testing gptlget_eventvalue...' - if (gptlget_eventvalue ('sum', 'PAPI_TOT_CYC', 0, val) /= 0) then - write(6,*)'Failure' - call exit(1) - end if - write(6,*)'Success: val=', val - - write(6,*)'sum,pc=',sum, pc - if (pc < 1 .or. pc > 1.e9) then - write(6,*)'Suspicious pc value=',pc - call exit(1) - else - write(6,*)'Success' - end if -end program testpapi diff --git a/cesm/models/utils/timing/gptl/ftests/toomanythreads.F90 b/cesm/models/utils/timing/gptl/ftests/toomanythreads.F90 deleted file mode 100644 index 4c44a76..0000000 --- a/cesm/models/utils/timing/gptl/ftests/toomanythreads.F90 +++ /dev/null @@ -1,39 +0,0 @@ -program toomanythreads - use gptl - - implicit none - - integer :: mythread - integer :: ret(2) ! for each of 2 threads - integer :: n - - integer, external :: omp_get_thread_num - - write(6,*)'Testing setting of maxthreads...' - if (gptlsetoption (gptlmaxthreads, 1) /= 0) then ! only allow 1 thread - write(6,*) 'Failure' - call exit (1) - end if - write(6,*) 'Success' - - if (gptlinitialize () /= 0) then - write(6,*) 'Failure from gptlinitialize' - call exit (1) - end if - - write(6,*) 'Testing using more threads than space was allocated for...' - call omp_set_num_threads (2) -!$OMP PARALLEL DO PRIVATE (mythread) - do n=1,2 - mythread = omp_get_thread_num () - ret(mythread+1) = gptlstart ('loop1') - end do -!$OMP END PARALLEL DO - - if (ret(1) == 0 .and. ret(2) == 0) then - write(6,*) 'Failure: Too many threads did NOT cause a GPTL failure' - call exit (1) - end if - - write(6,*) 'Success' -end program toomanythreads diff --git a/cesm/models/utils/timing/gptl/ftests/utrtest.F90 b/cesm/models/utils/timing/gptl/ftests/utrtest.F90 deleted file mode 100644 index 2a5d4b6..0000000 --- a/cesm/models/utils/timing/gptl/ftests/utrtest.F90 +++ /dev/null @@ -1,83 +0,0 @@ -program utrtest - use gptl - - implicit none - - external :: sub - - double precision :: sum - integer :: ret - integer :: handle1 - integer :: handle2 - integer :: handle3 - integer :: handle4 - integer :: handle5 - integer :: handle6 - integer :: handle7 - integer :: handle8 - - sum = 0. - - write(6,*) 'Purpose: estimate overhead of GPTL timing (UTR)' - ret = gptlsetoption (gptlabort_on_error, 0) - ret = gptlsetoption (gptlverbose, 1) -! ret = gptlsetoption (gptltablesize, 111) - -! ret = gptlsetutr (gptlmpiwtime) - ret = gptlsetutr (gptlread_real_time) - ret = gptlsetutr (gptlclockgettime) - ret = gptlsetutr (gptlgettimeofday) - ret = gptlsetutr (gptlpapitime) - ret = gptlsetutr (gptlnanotime) - - ret = gptlinitialize () - - ret = gptlinit_handle ('1x1e7', handle1) - ret = gptlinit_handle ('10x1e6', handle2) - ret = gptlinit_handle ('100x1e5', handle3) - ret = gptlinit_handle ('1000x1e4', handle4) - ret = gptlinit_handle ('1e4x1000', handle5) - ret = gptlinit_handle ('1e5x100', handle6) - ret = gptlinit_handle ('1e6x10', handle7) - ret = gptlinit_handle ('1e7x1', handle8) - - ret = gptlstart ('total') - ! ret = GPTLdisable () - call sub (1, 10000000, "1x1e7", sum, handle1) - call sub (10, 1000000, "10x1e6", sum, handle2) - call sub (100, 100000, "100x1e5", sum, handle3) - call sub (1000, 10000, "1000x1e4", sum, handle4) - call sub (10000, 1000, "1e4x1000", sum, handle5) - call sub (100000, 100, "1e5x100", sum, handle6) - call sub (1000000, 10, "1e6x10", sum, handle7) - call sub (10000000, 1, "1e7x1", sum, handle8) - ! ret = gptlenable () - ret = gptlstop ("total") - - ret = gptlpr (0) - stop 0 -end program utrtest - -subroutine sub (outer, inner, name, sum, handle) - use gptl - - implicit none - - integer, intent(in) :: outer - integer, intent(in) :: inner - character(len=*), intent(in) :: name - double precision, intent(inout) :: sum - integer, intent(inout) :: handle - - integer :: i, j, ret - - do i=0,outer-1 - ret = gptlstart_handle (name, handle) - do j=0,inner-1 - sum = sum + j - end do - ret = gptlstop_handle (name, handle) - end do - - return -end subroutine sub diff --git a/cesm/models/utils/timing/gptl/get_memusage.c b/cesm/models/utils/timing/gptl/get_memusage.c deleted file mode 100644 index f97aee7..0000000 --- a/cesm/models/utils/timing/gptl/get_memusage.c +++ /dev/null @@ -1,104 +0,0 @@ -/* -** get_memusage.c -** -** Author: Jim Rosinski -** Credit to Chuck Bardeen for MACOS section (__APPLE__ ifdef) -** -** get_memusage: -** -** Designed to be called from Fortran, returns information about memory -** usage in each of 5 input int* args. On Linux read from the /proc -** filesystem because getrusage() returns placebos (zeros). Return -1 for -** values which are unavailable or ambiguous on a particular architecture. -** -** Return value: 0 = success -** -1 = failure -*/ - -#include - -/* _AIX is automatically defined when using the AIX C compilers */ -#ifdef _AIX -#include -#endif - -#ifdef IRIX64 -#include -#endif - -#ifdef HAVE_SLASHPROC - -#include -#include -#include -#include - -#elif (defined __APPLE__) - -#include -#include -#include - -#endif - -#include "gptl.h" /* function prototypes */ - -int GPTLget_memusage (int *size, int *rss, int *share, int *text, int *datastack) -{ -#ifdef HAVE_SLASHPROC - FILE *fd; /* file descriptor for fopen */ - static char *file = "/proc/self/statm"; - int dum; /* placeholder for unused return arguments */ - int ret; /* function return value */ - - if ((fd = fopen (file, "r")) < 0) { - fprintf (stderr, "get_memusage: bad attempt to open %s\n", file); - return -1; - } - - /* - ** Read the desired data from the /proc filesystem directly into the output - ** arguments, close the file and return. - */ - ret = fscanf (fd, "%d %d %d %d %d %d %d", - size, rss, share, text, &dum, datastack, &dum); - ret = fclose (fd); - return 0; - -#elif (defined __APPLE__) - - FILE *fd; - char cmd[60]; - int pid = (int) getpid (); - - sprintf (cmd, "ps -o vsz -o rss -o tsiz -p %d | grep -v RSS", pid); - fd = popen (cmd, "r"); - - if (fd) { - fscanf (fd, "%d %d %d", size, rss, text); - *share = -1; - *datastack = -1; - (void) pclose (fd); - } - - return 0; - -#else - - struct rusage usage; /* structure filled in by getrusage */ - - if (getrusage (RUSAGE_SELF, &usage) < 0) - return -1; - - *size = -1; - *rss = usage.ru_maxrss; - *share = -1; - *text = -1; - *datastack = -1; -#ifdef IRIX64 - *datastack = usage.ru_idrss + usage.ru_isrss; -#endif - return 0; - -#endif -} diff --git a/cesm/models/utils/timing/gptl/getoverhead.c b/cesm/models/utils/timing/gptl/getoverhead.c deleted file mode 100644 index eb9cd02..0000000 --- a/cesm/models/utils/timing/gptl/getoverhead.c +++ /dev/null @@ -1,277 +0,0 @@ -#include -#include -#include "private.h" - -static int gptlstart_sim (char *, int); -static Timer *getentry_instr_sim (const Hashentry *,void *, unsigned int *, const int); -static void misc_sim (Nofalse *, Timer ***, int); -static bool initialized = true; -static bool disabled = false; - -/* -** All routines in this file are non-public -*/ - -/* -** GPTLget_overhead: return current status info about a timer. If certain stats are not enabled, -** they should just have zeros in them. If PAPI is not enabled, input counter info is ignored. -** -** Input args: -** fp: File descriptor to write to -** ptr2wtimefunc: Underlying timing routine -** getentry: From gptl.c, finds the entry in the hash table -** genhashidx: From gptl.c, generates the hash index -** get_thread_num:From gptl.c, gets the thread number -** hashtable: hashtable for thread 0 -** tablesize: size of hashtable -** dousepapi: whether or not PAPI is enabled -** -** Output args: -** self_ohd: Estimate of GPTL-induced overhead in the timer itself (included in "Wallclock") -** parent_ohd: Estimate of GPTL-induced overhead for the timer which appears in its parents -*/ -int GPTLget_overhead (FILE *fp, - double (*ptr2wtimefunc)(void), - Timer *getentry (const Hashentry *, const char *, unsigned int), - unsigned int genhashidx (const char *), - int get_thread_num (void), - Nofalse *stackidx, - Timer ***callstack, - const Hashentry *hashtable, - const int tablesize, - bool dousepapi, - int imperfect_nest, - double *self_ohd, - double *parent_ohd) -{ - double t1, t2; /* Initial, final timer values */ - double ftn_ohd; /* Fortran-callable layer */ - double get_thread_num_ohd; /* Getting my thread index */ - double genhashidx_ohd; /* Generating hash index */ - double getentry_ohd; /* Finding entry in hash table */ - double utr_ohd; /* Underlying timing routine */ - double papi_ohd; /* Reading PAPI counters */ - double total_ohd; /* Sum of overheads */ - double getentry_instr_ohd; /* Finding entry in hash tabe for auto-instrumented calls */ - double misc_ohd; /* misc. calcs within start/stop */ - int i, n; - int ret; - int mythread; /* which thread are we */ - unsigned int hashidx; /* Hash index */ - int randomvar; /* placeholder for taking the address of a variable */ - Timer *entry; /* placeholder for return from "getentry()" */ - static const char *thisfunc = "GPTLget_overhead"; - - /* - ** Gather timings by running kernels 1000 times each. - ** First: Fortran wrapper overhead - */ - t1 = (*ptr2wtimefunc)(); -#pragma unroll(10) - for (i = 0; i < 1000; ++i) { - ret = gptlstart_sim ("timername", strlen ("timername")); - } - t2 = (*ptr2wtimefunc)(); - ftn_ohd = 0.001 * (t2 - t1); - - /* get_thread_num() overhead */ - t1 = (*ptr2wtimefunc)(); -#pragma unroll(10) - for (i = 0; i < 1000; ++i) { - mythread = get_thread_num (); - } - t2 = (*ptr2wtimefunc)(); - get_thread_num_ohd = 0.001 * (t2 - t1); - - /* genhashidx overhead */ - t1 = (*ptr2wtimefunc)(); -#pragma unroll(10) - for (i = 0; i < 1000; ++i) { - hashidx = genhashidx ("timername"); - } - t2 = (*ptr2wtimefunc)(); - genhashidx_ohd = 0.001 * (t2 - t1); - - /* - ** getentry overhead - ** Find the first hashtable entry with a valid name. Start at 1 because 0 is not a valid hash - */ - for (n = 1; n < tablesize; ++n) { - if (hashtable[n].nument > 0 && strlen (hashtable[n].entries[0]->name) > 0) { - hashidx = genhashidx (hashtable[n].entries[0]->name); - t1 = (*ptr2wtimefunc)(); - for (i = 0; i < 1000; ++i) - entry = getentry (hashtable, hashtable[n].entries[0]->name, hashidx); - t2 = (*ptr2wtimefunc)(); - fprintf (fp, "%s: using hash entry %d=%s for getentry estimate\n", - thisfunc, n, hashtable[n].entries[0]->name); - break; - } - } - if (n == tablesize) { - fprintf (fp, "%s: hash table empty: Using alternate means to find getentry time\n", thisfunc); - t1 = (*ptr2wtimefunc)(); - for (i = 0; i < 1000; ++i) - entry = getentry (hashtable, "timername", hashidx); - t2 = (*ptr2wtimefunc)(); - } - getentry_ohd = 0.001 * (t2 - t1); - - /* utr overhead */ - t1 = (*ptr2wtimefunc)(); -#pragma unroll(10) - for (i = 0; i < 1000; ++i) { - t2 = (*ptr2wtimefunc)(); - } - utr_ohd = 0.001 * (t2 - t1); - - /* PAPI overhead */ -#ifdef HAVE_PAPI - if (dousepapi) { - t1 = (*ptr2wtimefunc)(); - read_counters1000 (); - t2 = (*ptr2wtimefunc)(); - } else { - t1 = 0.; - t2 = 0.; - } - papi_ohd = 0.001 * (t2 - t1); -#else - papi_ohd = 0.; -#endif - - /* getentry_instr overhead */ - t1 = (*ptr2wtimefunc)(); -#pragma unroll(10) - for (i = 0; i < 1000; ++i) { - entry = getentry_instr_sim (hashtable, &randomvar, &hashidx, tablesize); - } - t2 = (*ptr2wtimefunc)(); - getentry_instr_ohd = 0.001 * (t2 - t1); - - /* misc start/stop overhead */ - if (imperfect_nest) { - fprintf (fp, "Imperfect nesting detected: setting misc_ohd=0\n"); - misc_ohd = 0.; - } else { - t1 = (*ptr2wtimefunc)(); -#pragma unroll(10) - for (i = 0; i < 1000; ++i) { - misc_sim (stackidx, callstack, 0); - } - t2 = (*ptr2wtimefunc)(); - misc_ohd = 0.001 * (t2 - t1); - } - - total_ohd = ftn_ohd + get_thread_num_ohd + genhashidx_ohd + getentry_ohd + - utr_ohd + misc_ohd + papi_ohd; - fprintf (fp, "Total overhead of 1 GPTL start or GPTLstop call=%g seconds\n", total_ohd); - fprintf (fp, "Components are as follows:\n"); - fprintf (fp, "Fortran layer: %7.1e = %5.1f%% of total\n", - ftn_ohd, ftn_ohd / total_ohd * 100.); - fprintf (fp, "Get thread number: %7.1e = %5.1f%% of total\n", - get_thread_num_ohd, get_thread_num_ohd / total_ohd * 100.); - fprintf (fp, "Generate hash index: %7.1e = %5.1f%% of total\n", - genhashidx_ohd, genhashidx_ohd / total_ohd * 100.); - fprintf (fp, "Find hashtable entry: %7.1e = %5.1f%% of total\n", - getentry_ohd, getentry_ohd / total_ohd * 100.); - fprintf (fp, "Underlying timing routine: %7.1e = %5.1f%% of total\n", - utr_ohd, utr_ohd / total_ohd * 100.); - fprintf (fp, "Misc start/stop functions: %7.1e = %5.1f%% of total\n", - misc_ohd, misc_ohd / total_ohd * 100.); -#ifdef HAVE_PAPI - if (dousepapi) { - fprintf (fp, "Read PAPI counters: %7.1e = %5.1f%% of total\n", - papi_ohd, papi_ohd / total_ohd * 100.); - } -#endif - fprintf (fp, "\n"); - fprintf (fp, "NOTE: If GPTL is called from C not Fortran, the 'Fortran layer' overhead is zero\n"); - fprintf (fp, "NOTE: For calls to GPTLstart_handle()/GPTLstop_handle(), the 'Generate hash index' overhead is zero\n"); - fprintf (fp, "NOTE: For auto-instrumented calls, the cost of generating the hash index plus finding\n" - " the hashtable entry is %7.1e not the %7.1e portion taken by GPTLstart\n", - getentry_instr_ohd, genhashidx_ohd + getentry_ohd); - fprintf (fp, "NOTE: Each hash collision roughly doubles the 'Find hashtable entry' cost of that timer\n"); - *self_ohd = ftn_ohd + utr_ohd; /* In GPTLstop() ftn wrapper is called before utr */ - *parent_ohd = ftn_ohd + utr_ohd + misc_ohd + - 2.*(get_thread_num_ohd + genhashidx_ohd + getentry_ohd + papi_ohd); - return 0; -} - -/* -** GPTLstart_sim: Simulate the cost of Fortran wrapper layer "gptlstart()" -** -** Input args: -** name: timer name -** nc1: number of characters in "name" -*/ -static int gptlstart_sim (char *name, int nc1) -{ - char cname[MAX_CHARS+1]; - int numchars; - - numchars = MIN (nc1, MAX_CHARS); - strncpy (cname, name, numchars); - cname[numchars] = '\0'; - return 0; -} - -/* -** getentry_instr_sim: Simulate the cost of getentry_instr(), which is invoked only when -** auto-instrumentation is enabled on non-AIX platforms -** -** Input args: -** hashtable: hashtable for thread 0 -** self: address of function -** indx: hashtable index -** tablesize: size of hashtable -*/ -static Timer *getentry_instr_sim (const Hashentry *hashtable, - void *self, - unsigned int *indx, - const int tablesize) -{ - Timer *ptr = 0; - - *indx = (((unsigned long) self) >> 4) % tablesize; - if (hashtable[*indx].nument > 0 && hashtable[*indx].entries[0]->address == self) { - ptr = hashtable[*indx].entries[0]; - } - return ptr; -} - -/* -** misc_sim: Simulate the cost of miscellaneous computations in start/stop -** -** Input args: -** stackidx: stack index -** callstack: call stack -** t: thread index -*/ -static void misc_sim (Nofalse *stackidx, Timer ***callstack, int t) -{ - int bidx; - Timer *bptr; - static Timer *ptr = 0; - static const char *thisfunc = "misc_sim"; - - if (disabled) - printf ("GPTL: %s: should never print disabled\n", thisfunc); - - if (! initialized) - printf ("GPTL: %s: should never print ! initialized\n", thisfunc); - - bidx = stackidx[t].val; - bptr = callstack[t][bidx]; - if (ptr == bptr) - printf ("GPTL: %s: should never print ptr=bptr\n", thisfunc); - - --stackidx[t].val; - if (stackidx[t].val < -2) - printf ("GPTL: %s: should never print stackidxt < -2\n", thisfunc); - - if (++stackidx[t].val > MAX_STACK-1) - printf ("GPTL: %s: should never print stackidxt > MAX_STACK-1\n", thisfunc); - - return; -} diff --git a/cesm/models/utils/timing/gptl/gptl.c b/cesm/models/utils/timing/gptl/gptl.c deleted file mode 100644 index e2fc0a5..0000000 --- a/cesm/models/utils/timing/gptl/gptl.c +++ /dev/null @@ -1,3512 +0,0 @@ -/* -** gptl.c -** Author: Jim Rosinski -** -** Main file contains most user-accessible GPTL functions -*/ - -#ifdef HAVE_MPI -#include -#endif - -#include /* malloc */ -#include /* gettimeofday */ -#include /* times */ -#include /* gettimeofday, syscall */ -#include -#include /* memset, strcmp (via STRMATCH) */ -#include /* isdigit */ -#include /* u_int8_t, u_int16_t */ -#include - -#ifdef HAVE_PAPI -#include /* PAPI_get_real_usec */ -#endif - -#ifdef HAVE_LIBRT -#include -#endif - -#ifdef _AIX -#include -#endif - -#ifdef HAVE_BACKTRACE -#include -#endif - -#include "private.h" -#include "gptl.h" - -static Timer **timers = 0; /* linked list of timers */ -static Timer **last = 0; /* last element in list */ -static int *max_depth; /* maximum indentation level encountered */ -static int *max_name_len; /* max length of timer name */ -static volatile int nthreads = -1; /* num threads. Init to bad value */ -/* -** For THREADED_PTHREADS case, default maxthreads to a big number. -** For THREADED_OMP, the value will be set to $OMP_NUM_THREADS, OR: -** For either case, the user can specify maxthreads with a GPTLsetoption call. -*/ -#ifdef THREADED_PTHREADS -#define MAX_THREADS 64 -static volatile int maxthreads = MAX_THREADS; -#else -static volatile int maxthreads = -1; /* max threads */ -#endif -static int depthlimit = 99999; /* max depth for timers (99999 is effectively infinite) */ -static volatile bool disabled = false; /* Timers disabled? */ -static volatile bool initialized = false; /* GPTLinitialize has been called */ -static volatile bool pr_has_been_called = false; /* GPTLpr_file has been called */ -#ifdef HAVE_PAPI -Entry GPTLeventlist[MAX_AUX]; /* list of PAPI-based events to be counted */ -int GPTLnevents = 0; /* number of PAPI events (init to 0) */ -#endif -static bool dousepapi = false; /* saves a function call if stays false */ -static bool verbose = false; /* output verbosity */ -static bool percent = false; /* print wallclock also as percent of 1st timers[0] */ -static bool dopr_preamble = true; /* whether to print preamble info */ -static bool dopr_threadsort = true; /* whether to print sorted thread stats */ -static bool dopr_multparent = true; /* whether to print multiple parent info */ -static bool dopr_collision = true; /* whether to print hash collision info */ -static bool dopr_memusage = false; /* whether to include memusage print when auto-profiling */ - -static time_t ref_gettimeofday = -1; /* ref start point for gettimeofday */ -static time_t ref_clock_gettime = -1; /* ref start point for clock_gettime */ -#ifdef _AIX -static time_t ref_read_real_time = -1; /* ref start point for read_real_time */ -#endif -static long long ref_papitime = -1; /* ref start point for PAPI_get_real_usec */ - -#if ( defined THREADED_OMP ) - -#include -volatile int *GPTLthreadid_omp = 0; /* array of thread ids */ - -#elif ( defined THREADED_PTHREADS ) - -#include - -#define MUTEX_API -#ifdef MUTEX_API -static volatile pthread_mutex_t t_mutex; -#else -static volatile pthread_mutex_t t_mutex = PTHREAD_MUTEX_INITIALIZER; -#endif -volatile pthread_t *GPTLthreadid = 0; /* array of thread ids */ -static int lock_mutex (void); /* lock a mutex for entry into a critical region */ -static int unlock_mutex (void); /* unlock a mutex for exit from a critical region */ - -#else - -/* Unthreaded case */ -int GPTLthreadid = -1; - -#endif - -typedef struct { - const Option option; /* wall, cpu, etc. */ - const char *str; /* descriptive string for printing */ - bool enabled; /* flag */ -} Settings; - -/* Options, print strings, and default enable flags */ -static Settings cpustats = {GPTLcpu, "Usr sys usr+sys ", false}; -static Settings wallstats = {GPTLwall, "Wallclock max min ", true }; -static Settings overheadstats = {GPTLoverhead, "self_OH parent_OH " , true }; - -static Hashentry **hashtable; /* table of entries */ -static long ticks_per_sec; /* clock ticks per second */ -static Timer ***callstack; /* call stack */ -static Nofalse *stackidx; /* index into callstack: */ - -static Method method = GPTLfull_tree; /* default parent/child printing mechanism */ - -/* Local function prototypes */ -static void print_titles (int, FILE *fp); -static void printstats (const Timer *, FILE *, int, int, bool, double, double); -static void add (Timer *, const Timer *); -static void print_multparentinfo (FILE *, Timer *); -static inline int get_cpustamp (long *, long *); -static int newchild (Timer *, Timer *); -static int get_max_depth (const Timer *, const int); -static int is_descendant (const Timer *, const Timer *); -static int is_onlist (const Timer *, const Timer *); -static char *methodstr (Method); - -/* Prototypes from previously separate file threadutil.c */ -static int threadinit (void); /* initialize threading environment */ -static void threadfinalize (void); /* finalize threading environment */ -static inline int get_thread_num (void); /* get 0-based thread number */ - -/* These are the (possibly) supported underlying wallclock timers */ -static inline double utr_nanotime (void); -static inline double utr_mpiwtime (void); -static inline double utr_clock_gettime (void); -static inline double utr_papitime (void); -static inline double utr_read_real_time (void); -static inline double utr_gettimeofday (void); -static inline double utr_placebo (void); - -static int init_nanotime (void); -static int init_mpiwtime (void); -static int init_clock_gettime (void); -static int init_papitime (void); -static int init_read_real_time (void); -static int init_gettimeofday (void); -static int init_placebo (void); - -static inline unsigned int genhashidx (const char *); -static inline Timer *getentry_instr (const Hashentry *, void *, unsigned int *); -static inline Timer *getentry (const Hashentry *, const char *, unsigned int); -static void printself_andchildren (const Timer *, FILE *, int, int, double, double); -static inline int update_parent_info (Timer *, Timer **, int); -static inline int update_stats (Timer *, const double, const long, const long, const int); -static int update_ll_hash (Timer *, int, unsigned int); -static inline int update_ptr (Timer *, const int); -static int construct_tree (Timer *, Method); -static int get_max_depth (const Timer *, const int); - -typedef struct { - const Funcoption option; - double (*func)(void); - int (*funcinit)(void); - const char *name; -} Funcentry; - -static Funcentry funclist[] = { - {GPTLgettimeofday, utr_gettimeofday, init_gettimeofday, "gettimeofday"}, - {GPTLnanotime, utr_nanotime, init_nanotime, "nanotime"}, - {GPTLmpiwtime, utr_mpiwtime, init_mpiwtime, "MPI_Wtime"}, - {GPTLclockgettime, utr_clock_gettime, init_clock_gettime, "clock_gettime"}, - {GPTLpapitime, utr_papitime, init_papitime, "PAPI_get_real_usec"}, - {GPTLread_real_time, utr_read_real_time, init_read_real_time,"read_real_time"}, /* AIX only */ - {GPTLplacebo, utr_placebo, init_placebo, "placebo"} /* does nothing */ -}; -static const int nfuncentries = sizeof (funclist) / sizeof (Funcentry); - -static double (*ptr2wtimefunc)() = 0; /* init to invalid */ -static int funcidx = 0; /* default timer is gettimeofday */ - -#ifdef HAVE_NANOTIME -static float cpumhz = -1.; /* init to bad value */ -static double cyc2sec = -1; /* init to bad value */ -static inline long long nanotime (void); /* read counter (assembler) */ -static float get_clockfreq (void); /* cycles/sec */ -static char *clock_source = "UNKNOWN"; /* where clock found */ -#endif - -#define DEFAULT_TABLE_SIZE 1023 -static int tablesize = DEFAULT_TABLE_SIZE; /* per-thread size of hash table (settable parameter) */ -static int tablesizem1 = DEFAULT_TABLE_SIZE - 1; - -#define MSGSIZ 256 /* max size of msg printed when dopr_memusage=true */ -static int rssmax = 0; /* max rss of the process */ -static bool imperfect_nest; /* e.g. start(A),start(B),stop(A) */ - -/* VERBOSE is a debugging ifdef local to the rest of this file */ -#undef VERBOSE - -/* -** GPTLsetoption: set option value to true or false. -** -** Input arguments: -** option: option to be set -** val: value to which option should be set (nonzero=true, zero=false) -** -** Return value: 0 (success) or GPTLerror (failure) -*/ -int GPTLsetoption (const int option, /* option */ - const int val) /* value */ -{ - static const char *thisfunc = "GPTLsetoption"; - - if (initialized) - return GPTLerror ("%s: must be called BEFORE GPTLinitialize\n", thisfunc); - - if (option == GPTLabort_on_error) { - GPTLset_abort_on_error ((bool) val); - if (verbose) - printf ("%s: boolean abort_on_error = %d\n", thisfunc, val); - return 0; - } - - switch (option) { - case GPTLcpu: -#ifdef HAVE_TIMES - cpustats.enabled = (bool) val; - if (verbose) - printf ("%s: cpustats = %d\n", thisfunc, val); -#else - if (val) - return GPTLerror ("%s: times() not available\n", thisfunc); -#endif - return 0; - case GPTLwall: - wallstats.enabled = (bool) val; - if (verbose) - printf ("%s: boolean wallstats = %d\n", thisfunc, val); - return 0; - case GPTLoverhead: - overheadstats.enabled = (bool) val; - if (verbose) - printf ("%s: boolean overheadstats = %d\n", thisfunc, val); - return 0; - case GPTLdepthlimit: - depthlimit = val; - if (verbose) - printf ("%s: depthlimit = %d\n", thisfunc, val); - return 0; - case GPTLverbose: - verbose = (bool) val; -#ifdef HAVE_PAPI - (void) GPTL_PAPIsetoption (GPTLverbose, val); -#endif - if (verbose) - printf ("%s: boolean verbose = %d\n", thisfunc, val); - return 0; - case GPTLpercent: - percent = (bool) val; - if (verbose) - printf ("%s: boolean percent = %d\n", thisfunc, val); - return 0; - case GPTLdopr_preamble: - dopr_preamble = (bool) val; - if (verbose) - printf ("%s: boolean dopr_preamble = %d\n", thisfunc, val); - return 0; - case GPTLdopr_threadsort: - dopr_threadsort = (bool) val; - if (verbose) - printf ("%s: boolean dopr_threadsort = %d\n", thisfunc, val); - return 0; - case GPTLdopr_multparent: - dopr_multparent = (bool) val; - if (verbose) - printf ("%s: boolean dopr_multparent = %d\n", thisfunc, val); - return 0; - case GPTLdopr_collision: - dopr_collision = (bool) val; - if (verbose) - printf ("%s: boolean dopr_collision = %d\n", thisfunc, val); - return 0; - case GPTLdopr_memusage: - dopr_memusage = (bool) val; - if (verbose) - printf ("%s: boolean dopr_memusage = %d\n", thisfunc, val); - return 0; - case GPTLprint_method: - method = (Method) val; - if (verbose) - printf ("%s: print_method = %s\n", thisfunc, methodstr (method)); - return 0; - case GPTLtablesize: - if (val < 1) - return GPTLerror ("%s: tablesize must be positive. %d is invalid\n", thisfunc, val); - - tablesize = val; - tablesizem1 = val - 1; - if (verbose) - printf ("%s: tablesize = %d\n", thisfunc, tablesize); - return 0; - case GPTLsync_mpi: -#ifdef ENABLE_PMPI - if (GPTLpmpi_setoption (option, val) != 0) - fprintf (stderr, "%s: GPTLpmpi_setoption failure\n", thisfunc); -#endif - if (verbose) - printf ("%s: boolean sync_mpi = %d\n", thisfunc, val); - return 0; - - case GPTLmaxthreads: - if (val < 1) - return GPTLerror ("%s: maxthreads must be positive. %d is invalid\n", thisfunc, val); - - maxthreads = val; - return 0; - - case GPTLmultiplex: - /* Allow GPTLmultiplex to fall through because it will be handled by GPTL_PAPIsetoption() */ - default: - break; - } - -#ifdef HAVE_PAPI - if (GPTL_PAPIsetoption (option, val) == 0) { - if (val) - dousepapi = true; - return 0; - } -#else - /* Make GPTLnarrowprint a placebo if PAPI not enabled */ - if (option == GPTLnarrowprint) - return 0; -#endif - - return GPTLerror ("%s: failure to enable option %d\n", thisfunc, option); -} - -/* -** GPTLsetutr: set underlying timing routine. -** -** Input arguments: -** option: index which sets function -** -** Return value: 0 (success) or GPTLerror (failure) -*/ -int GPTLsetutr (const int option) -{ - int i; /* index over number of underlying timer */ - static const char *thisfunc = "GPTLsetutr"; - - if (initialized) - return GPTLerror ("%s: must be called BEFORE GPTLinitialize\n", thisfunc); - - for (i = 0; i < nfuncentries; i++) { - if (option == (int) funclist[i].option) { - if (verbose) - printf ("%s: underlying wallclock timer = %s\n", thisfunc, funclist[i].name); - funcidx = i; - - /* - ** Return an error condition if the function is not available. - ** OK for the user code to ignore: GPTLinitialize() will reset to gettimeofday - */ - - if ((*funclist[i].funcinit)() < 0) - return GPTLerror ("%s: utr=%s not available or doesn't work\n", thisfunc, funclist[i].name); - else - return 0; - } - } - return GPTLerror ("%s: unknown option %d\n", thisfunc, option); -} - -/* -** GPTLinitialize (): Initialization routine must be called from single-threaded -** region before any other timing routines may be called. The need for this -** routine could be eliminated if not targetting timing library for threaded -** capability. -** -** return value: 0 (success) or GPTLerror (failure) -*/ -int GPTLinitialize (void) -{ - int i; /* loop index */ - int t; /* thread index */ - double t1, t2; /* returned from underlying timer */ - static const char *thisfunc = "GPTLinitialize"; - - if (initialized) - return GPTLerror ("%s: has already been called\n", thisfunc); - - if (threadinit () < 0) - return GPTLerror ("%s: bad return from threadinit\n", thisfunc); - - if ((ticks_per_sec = sysconf (_SC_CLK_TCK)) == -1) - return GPTLerror ("%s: failure from sysconf (_SC_CLK_TCK)\n", thisfunc); - - /* Allocate space for global arrays */ - callstack = (Timer ***) GPTLallocate (maxthreads * sizeof (Timer **), thisfunc); - stackidx = (Nofalse *) GPTLallocate (maxthreads * sizeof (Nofalse), thisfunc); - timers = (Timer **) GPTLallocate (maxthreads * sizeof (Timer *), thisfunc); - last = (Timer **) GPTLallocate (maxthreads * sizeof (Timer *), thisfunc); - max_depth = (int *) GPTLallocate (maxthreads * sizeof (int), thisfunc); - max_name_len = (int *) GPTLallocate (maxthreads * sizeof (int), thisfunc); - hashtable = (Hashentry **) GPTLallocate (maxthreads * sizeof (Hashentry *), thisfunc); - - /* Initialize array values */ - for (t = 0; t < maxthreads; t++) { - max_depth[t] = -1; - max_name_len[t] = 0; - callstack[t] = (Timer **) GPTLallocate (MAX_STACK * sizeof (Timer *), thisfunc); - hashtable[t] = (Hashentry *) GPTLallocate (tablesize * sizeof (Hashentry), thisfunc); - for (i = 0; i < tablesize; i++) { - hashtable[t][i].nument = 0; - hashtable[t][i].entries = 0; - } - - /* Make a timer "GPTL_ROOT" to ensure no orphans, and to simplify printing. */ - timers[t] = (Timer *) GPTLallocate (sizeof (Timer), thisfunc); - memset (timers[t], 0, sizeof (Timer)); - strcpy (timers[t]->name, "GPTL_ROOT"); - timers[t]->onflg = true; - last[t] = timers[t]; - - stackidx[t].val = 0; - callstack[t][0] = timers[t]; - for (i = 1; i < MAX_STACK; i++) - callstack[t][i] = 0; - } - -#ifdef HAVE_PAPI - if (GPTL_PAPIinitialize (maxthreads, verbose, &GPTLnevents, GPTLeventlist) < 0) - return GPTLerror ("%s: Failure from GPTL_PAPIinitialize\n", thisfunc); -#endif - - /* Call init routine for underlying timing routine. */ - if ((*funclist[funcidx].funcinit)() < 0) { - fprintf (stderr, "%s: Failure initializing %s. Reverting underlying timer to %s\n", - thisfunc, funclist[funcidx].name, funclist[0].name); - funcidx = 0; - } - - ptr2wtimefunc = funclist[funcidx].func; - - if (verbose) { - t1 = (*ptr2wtimefunc) (); - t2 = (*ptr2wtimefunc) (); - if (t1 > t2) - fprintf (stderr, "%s: negative delta-t=%g\n", thisfunc, t2-t1); - - printf ("Per call overhead est. t2-t1=%g should be near zero\n", t2-t1); - printf ("Underlying wallclock timing routine is %s\n", funclist[funcidx].name); - } - - imperfect_nest = false; - initialized = true; - return 0; -} - -/* -** GPTLfinalize (): Finalization routine must be called from single-threaded -** region. Free all malloc'd space -** -** return value: 0 (success) or GPTLerror (failure) -*/ -int GPTLfinalize (void) -{ - int t; /* thread index */ - int n; /* array index */ - Timer *ptr, *ptrnext; /* ll indices */ - static const char *thisfunc = "GPTLfinalize"; - - if ( ! initialized) - return GPTLerror ("%s: initialization was not completed\n", thisfunc); - - for (t = 0; t < maxthreads; ++t) { - for (n = 0; n < tablesize; ++n) { - if (hashtable[t][n].nument > 0) - free (hashtable[t][n].entries); - } - free (hashtable[t]); - hashtable[t] = NULL; - free (callstack[t]); - for (ptr = timers[t]; ptr; ptr = ptrnext) { - ptrnext = ptr->next; - if (ptr->nparent > 0) { - free (ptr->parent); - free (ptr->parent_count); - } - if (ptr->nchildren > 0) - free (ptr->children); - free (ptr); - } - } - - free (callstack); - free (stackidx); - free (timers); - free (last); - free (max_depth); - free (max_name_len); - free (hashtable); - - threadfinalize (); - GPTLreset_errors (); - -#ifdef HAVE_PAPI - GPTL_PAPIfinalize (maxthreads); -#endif - - /* Reset initial values */ - timers = 0; - last = 0; - max_depth = 0; - max_name_len = 0; - nthreads = -1; -#ifdef THREADED_PTHREADS - maxthreads = MAX_THREADS; -#else - maxthreads = -1; -#endif - depthlimit = 99999; - disabled = false; - initialized = false; - pr_has_been_called = false; - dousepapi = false; - verbose = false; - percent = false; - dopr_preamble = true; - dopr_threadsort = true; - dopr_multparent = true; - dopr_collision = true; - ref_gettimeofday = -1; - ref_clock_gettime = -1; -#ifdef _AIX - ref_read_real_time = -1; -#endif - ref_papitime = -1; - funcidx = 0; -#ifdef HAVE_NANOTIME - cpumhz= 0; - cyc2sec = -1; -#endif - tablesize = DEFAULT_TABLE_SIZE; - tablesizem1 = tablesize - 1; - - return 0; -} - -/* -** GPTLstart_instr: start a timer (auto-instrumented) -** -** Input arguments: -** self: function address -** -** Return value: 0 (success) or GPTLerror (failure) -*/ -int GPTLstart_instr (void *self) -{ - Timer *ptr; /* linked list pointer */ - int t; /* thread index (of this thread) */ - unsigned int indx; /* hash table index */ - static const char *thisfunc = "GPTLstart_instr"; - - if (disabled) - return 0; - - if ( ! initialized) - return GPTLerror ("%s self=%p: GPTLinitialize has not been called\n", thisfunc, self); - - if ((t = get_thread_num ()) < 0) - return GPTLerror ("%s: bad return from get_thread_num\n", thisfunc); - - /* If current depth exceeds a user-specified limit for print, just increment and return */ - if (stackidx[t].val >= depthlimit) { - ++stackidx[t].val; - return 0; - } - - ptr = getentry_instr (hashtable[t], self, &indx); - - /* - ** Recursion => increment depth in recursion and return. We need to return - ** because we don't want to restart the timer. We want the reported time for - ** the timer to reflect the outermost layer of recursion. - */ - if (ptr && ptr->onflg) { - ++ptr->recurselvl; - return 0; - } - - /* - ** Increment stackidx[t] unconditionally. This is necessary to ensure the correct - ** behavior when GPTLstop_instr decrements stackidx[t] unconditionally. - */ - if (++stackidx[t].val > MAX_STACK-1) - return GPTLerror ("%s: stack too big\n", thisfunc); - - if ( ! ptr) { /* Add a new entry and initialize */ - ptr = (Timer *) GPTLallocate (sizeof (Timer), thisfunc); - memset (ptr, 0, sizeof (Timer)); - - /* - ** Need to save the address string for later conversion back to a real - ** name by an offline tool. - */ - snprintf (ptr->name, MAX_CHARS+1, "%lx", (unsigned long) self); - ptr->address = self; - - if (update_ll_hash (ptr, t, indx) != 0) - return GPTLerror ("%s: update_ll_hash error\n", thisfunc); - } - - if (update_parent_info (ptr, callstack[t], stackidx[t].val) != 0) - return GPTLerror ("%s: update_parent_info error\n", thisfunc); - - if (update_ptr (ptr, t) != 0) - return GPTLerror ("%s: update_ptr error\n", thisfunc); - - return (0); -} - -/* -** GPTLstart: start a timer -** -** Input arguments: -** name: timer name -** -** Return value: 0 (success) or GPTLerror (failure) -*/ -int GPTLstart (const char *name) /* timer name */ -{ - Timer *ptr; /* linked list pointer */ - int t; /* thread index (of this thread) */ - int numchars; /* number of characters to copy */ - unsigned int indx; /* hash table index */ - static const char *thisfunc = "GPTLstart"; - - if (disabled) - return 0; - - if ( ! initialized) - return GPTLerror ("%s name=%s: GPTLinitialize has not been called\n", thisfunc, name); - - if ((t = get_thread_num ()) < 0) - return GPTLerror ("%s: bad return from get_thread_num\n", thisfunc); - - /* - ** If current depth exceeds a user-specified limit for print, just - ** increment and return - */ - if (stackidx[t].val >= depthlimit) { - ++stackidx[t].val; - return 0; - } - - /* ptr will point to the requested timer in the current list, or NULL if this is a new entry */ - indx = genhashidx (name); - ptr = getentry (hashtable[t], name, indx); - - /* - ** Recursion => increment depth in recursion and return. We need to return - ** because we don't want to restart the timer. We want the reported time for - ** the timer to reflect the outermost layer of recursion. - */ - if (ptr && ptr->onflg) { - ++ptr->recurselvl; - return 0; - } - - /* - ** Increment stackidx[t] unconditionally. This is necessary to ensure the correct - ** behavior when GPTLstop decrements stackidx[t] unconditionally. - */ - if (++stackidx[t].val > MAX_STACK-1) - return GPTLerror ("%s: stack too big\n", thisfunc); - - if ( ! ptr) { /* Add a new entry and initialize */ - ptr = (Timer *) GPTLallocate (sizeof (Timer), thisfunc); - memset (ptr, 0, sizeof (Timer)); - - numchars = MIN (strlen (name), MAX_CHARS); - strncpy (ptr->name, name, numchars); - ptr->name[numchars] = '\0'; - - if (update_ll_hash (ptr, t, indx) != 0) - return GPTLerror ("%s: update_ll_hash error\n", thisfunc); - } - - if (update_parent_info (ptr, callstack[t], stackidx[t].val) != 0) - return GPTLerror ("%s: update_parent_info error\n", thisfunc); - - if (update_ptr (ptr, t) != 0) - return GPTLerror ("%s: update_ptr error\n", thisfunc); - - return (0); -} - -/* -** GPTLinit_handle: Initialize a handle for further use by GPTLstart_handle() and GPTLstop_handle() -** -** Input arguments: -** name: timer name -** -** Output arguments: -** handle: hash value corresponding to "name" -** -** Return value: 0 (success) or GPTLerror (failure) -*/ -int GPTLinit_handle (const char *name, /* timer name */ - int *handle) /* handle (output if input value is zero) */ -{ - if (disabled) - return 0; - - *handle = (int) genhashidx (name); - return 0; -} - -/* -** GPTLstart_handle: start a timer based on a handle -** -** Input arguments: -** name: timer name (required when on input, handle=0) -** handle: pointer to timer matching "name" -** -** Return value: 0 (success) or GPTLerror (failure) -*/ -int GPTLstart_handle (const char *name, /* timer name */ - int *handle) /* handle (output if input value is zero) */ -{ - Timer *ptr; /* linked list pointer */ - int t; /* thread index (of this thread) */ - int numchars; /* number of characters to copy */ - static const char *thisfunc = "GPTLstart_handle"; - - if (disabled) - return 0; - - if ( ! initialized) - return GPTLerror ("%s name=%s: GPTLinitialize has not been called\n", thisfunc, name); - - if ((t = get_thread_num ()) < 0) - return GPTLerror ("%s: bad return from get_thread_num\n", thisfunc); - - /* If current depth exceeds a user-specified limit for print, just increment and return */ - if (stackidx[t].val >= depthlimit) { - ++stackidx[t].val; - return 0; - } - - /* - ** If handle is zero on input, generate the hash entry and return it to the user. - ** Otherwise assume it's a previously generated hash index passed in by the user. - ** Don't need a critical section here--worst case multiple threads will generate the - ** same handle and store to the same memory location, and this will only happen once. - */ - if (*handle == 0) { - *handle = (int) genhashidx (name); -#ifdef VERBOSE - printf ("%s: name=%s thread %d generated handle=%d\n", thisfunc, name, t, *handle); -#endif - } else if ((unsigned int) *handle > tablesizem1) { - return GPTLerror ("%s: Bad input handle=%u exceeds tablesizem1=%d\n", - thisfunc, (unsigned int) *handle, tablesizem1); - } - - ptr = getentry (hashtable[t], name, (unsigned int) *handle); - - /* - ** Recursion => increment depth in recursion and return. We need to return - ** because we don't want to restart the timer. We want the reported time for - ** the timer to reflect the outermost layer of recursion. - */ - if (ptr && ptr->onflg) { - ++ptr->recurselvl; - return 0; - } - - /* - ** Increment stackidx[t] unconditionally. This is necessary to ensure the correct - ** behavior when GPTLstop decrements stackidx[t] unconditionally. - */ - if (++stackidx[t].val > MAX_STACK-1) - return GPTLerror ("%s: stack too big\n", thisfunc); - - if ( ! ptr) { /* Add a new entry and initialize */ - ptr = (Timer *) GPTLallocate (sizeof (Timer), thisfunc); - memset (ptr, 0, sizeof (Timer)); - - numchars = MIN (strlen (name), MAX_CHARS); - strncpy (ptr->name, name, numchars); - ptr->name[numchars] = '\0'; - - if (update_ll_hash (ptr, t, (unsigned int) *handle) != 0) - return GPTLerror ("%s: update_ll_hash error\n", thisfunc); - } - - if (update_parent_info (ptr, callstack[t], stackidx[t].val) != 0) - return GPTLerror ("%s: update_parent_info error\n", thisfunc); - - if (update_ptr (ptr, t) != 0) - return GPTLerror ("%s: update_ptr error\n", thisfunc); - - return (0); -} - -/* -** update_ll_hash: Update linked list and hash table. -** Called by all GPTLstart* routines when there is a new entry -** -** Input arguments: -** ptr: pointer to timer -** t: thread index -** indx: hash index -** -** Return value: 0 (success) or GPTLerror (failure) -*/ -static int update_ll_hash (Timer *ptr, int t, unsigned int indx) -{ - int nchars; /* number of chars */ - int nument; /* number of entries */ - Timer **eptr; /* for realloc */ - - nchars = strlen (ptr->name); - if (nchars > max_name_len[t]) - max_name_len[t] = nchars; - - last[t]->next = ptr; - last[t] = ptr; - ++hashtable[t][indx].nument; - nument = hashtable[t][indx].nument; - - eptr = (Timer **) realloc (hashtable[t][indx].entries, nument * sizeof (Timer *)); - if ( ! eptr) - return GPTLerror ("update_ll_hash: realloc error\n"); - - hashtable[t][indx].entries = eptr; - hashtable[t][indx].entries[nument-1] = ptr; - - return 0; -} - -/* -** update_ptr: Update timer contents. Called by GPTLstart, GPTLstart_instr and GPTLstart_handle -** -** Input arguments: -** ptr: pointer to timer -** t: thread index -** -** Return value: 0 (success) or GPTLerror (failure) -*/ -static inline int update_ptr (Timer *ptr, const int t) -{ - double tp2; /* time stamp */ - - ptr->onflg = true; - - if (cpustats.enabled && get_cpustamp (&ptr->cpu.last_utime, &ptr->cpu.last_stime) < 0) - return GPTLerror ("update_ptr: get_cpustamp error"); - - if (wallstats.enabled) { - tp2 = (*ptr2wtimefunc) (); - ptr->wall.last = tp2; - } - -#ifdef HAVE_PAPI - if (dousepapi && GPTL_PAPIstart (t, &ptr->aux) < 0) - return GPTLerror ("update_ptr: error from GPTL_PAPIstart\n"); -#endif - return 0; -} - -/* -** update_parent_info: update info about parent, and in the parent about this child -** Called by all GPTLstart* routines -** -** Arguments: -** ptr: pointer to timer -** callstackt: callstack for this thread -** stackidxt: stack index for this thread -** -** Return value: 0 (success) or GPTLerror (failure) -*/ -static inline int update_parent_info (Timer *ptr, - Timer **callstackt, - int stackidxt) -{ - int n; /* loop index through known parents */ - Timer *pptr; /* pointer to parent in callstack */ - Timer **pptrtmp; /* for realloc parent pointer array */ - int nparent; /* number of parents */ - int *parent_count; /* number of times parent invoked this child */ - static const char *thisfunc = "update_parent_info"; - - if ( ! ptr ) - return -1; - - if (stackidxt < 0) - return GPTLerror ("%s: called with negative stackidx\n", thisfunc); - - callstackt[stackidxt] = ptr; - - /* Bump orphan count if the region has no parent (should never happen since "GPTL_ROOT" added) */ - if (stackidxt == 0) { - ++ptr->norphan; - return 0; - } - - pptr = callstackt[stackidxt-1]; - - /* If this parent occurred before, bump its count */ - for (n = 0; n < ptr->nparent; ++n) { - if (ptr->parent[n] == pptr) { - ++ptr->parent_count[n]; - break; - } - } - - /* If this is a new parent, update info */ - if (n == ptr->nparent) { - ++ptr->nparent; - nparent = ptr->nparent; - pptrtmp = (Timer **) realloc (ptr->parent, nparent * sizeof (Timer *)); - if ( ! pptrtmp) - return GPTLerror ("%s: realloc error pptrtmp nparent=%d\n", thisfunc, nparent); - - ptr->parent = pptrtmp; - ptr->parent[nparent-1] = pptr; - parent_count = (int *) realloc (ptr->parent_count, nparent * sizeof (int)); - if ( ! parent_count) - return GPTLerror ("%s: realloc error parent_count nparent=%d\n", thisfunc, nparent); - - ptr->parent_count = parent_count; - ptr->parent_count[nparent-1] = 1; - } - - return 0; -} - -/* -** GPTLstop_instr: stop a timer (auto-instrumented) -** -** Input arguments: -** self: function address -** -** Return value: 0 (success) or GPTLerror (failure) -*/ -int GPTLstop_instr (void *self) -{ - double tp1 = 0.0; /* time stamp */ - Timer *ptr; /* linked list pointer */ - int t; /* thread number for this process */ - unsigned int indx; /* index into hash table */ - long usr = 0; /* user time (returned from get_cpustamp) */ - long sys = 0; /* system time (returned from get_cpustamp) */ - static const char *thisfunc = "GPTLstop_instr"; - - if (disabled) - return 0; - - if ( ! initialized) - return GPTLerror ("%s: GPTLinitialize has not been called\n", thisfunc); - - /* Get the timestamp */ - if (wallstats.enabled) { - tp1 = (*ptr2wtimefunc) (); - } - - if (cpustats.enabled && get_cpustamp (&usr, &sys) < 0) - return GPTLerror ("%s: bad return from get_cpustamp\n", thisfunc); - - if ((t = get_thread_num ()) < 0) - return GPTLerror ("%s: bad return from get_thread_num\n", thisfunc); - - /* If current depth exceeds a user-specified limit for print, just decrement and return */ - if (stackidx[t].val > depthlimit) { - --stackidx[t].val; - return 0; - } - - ptr = getentry_instr (hashtable[t], self, &indx); - - if ( ! ptr) - return GPTLerror ("%s: timer for %p had not been started.\n", thisfunc, self); - - if ( ! ptr->onflg ) - return GPTLerror ("%s: timer %s was already off.\n", thisfunc, ptr->name); - - ++ptr->count; - - /* - ** Recursion => decrement depth in recursion and return. We need to return - ** because we don't want to stop the timer. We want the reported time for - ** the timer to reflect the outermost layer of recursion. - */ - if (ptr->recurselvl > 0) { - ++ptr->nrecurse; - --ptr->recurselvl; - return 0; - } - - if (update_stats (ptr, tp1, usr, sys, t) != 0) - return GPTLerror ("%s: error from update_stats\n", thisfunc); - - return 0; -} - -/* -** GPTLstop: stop a timer -** -** Input arguments: -** name: timer name -** -** Return value: 0 (success) or -1 (failure) -*/ -int GPTLstop (const char *name) /* timer name */ -{ - double tp1 = 0.0; /* time stamp */ - Timer *ptr; /* linked list pointer */ - int t; /* thread number for this process */ - unsigned int indx; /* index into hash table */ - long usr = 0; /* user time (returned from get_cpustamp) */ - long sys = 0; /* system time (returned from get_cpustamp) */ - static const char *thisfunc = "GPTLstop"; - - if (disabled) - return 0; - - if ( ! initialized) - return GPTLerror ("%s: GPTLinitialize has not been called\n", thisfunc); - - /* Get the timestamp */ - - if (wallstats.enabled) { - tp1 = (*ptr2wtimefunc) (); - } - - if (cpustats.enabled && get_cpustamp (&usr, &sys) < 0) - return GPTLerror ("%s: get_cpustamp error", thisfunc); - - if ((t = get_thread_num ()) < 0) - return GPTLerror ("%s: bad return from get_thread_num\n", thisfunc); - - /* If current depth exceeds a user-specified limit for print, just decrement and return */ - if (stackidx[t].val > depthlimit) { - --stackidx[t].val; - return 0; - } - - indx = genhashidx (name); - if (! (ptr = getentry (hashtable[t], name, indx))) - return GPTLerror ("%s thread %d: timer for %s had not been started.\n", thisfunc, t, name); - - if ( ! ptr->onflg ) - return GPTLerror ("%s: timer %s was already off.\n", thisfunc, ptr->name); - - ++ptr->count; - - /* - ** Recursion => decrement depth in recursion and return. We need to return - ** because we don't want to stop the timer. We want the reported time for - ** the timer to reflect the outermost layer of recursion. - */ - if (ptr->recurselvl > 0) { - ++ptr->nrecurse; - --ptr->recurselvl; - return 0; - } - - if (update_stats (ptr, tp1, usr, sys, t) != 0) - return GPTLerror ("%s: error from update_stats\n", thisfunc); - - return 0; -} - -/* -** GPTLstop_handle: stop a timer based on a handle -** -** Input arguments: -** name: timer name (used only for diagnostics) -** handle: pointer to timer -** -** Return value: 0 (success) or -1 (failure) -*/ -int GPTLstop_handle (const char *name, /* timer name */ - int *handle) /* handle */ -{ - double tp1 = 0.0; /* time stamp */ - Timer *ptr; /* linked list pointer */ - int t; /* thread number for this process */ - long usr = 0; /* user time (returned from get_cpustamp) */ - long sys = 0; /* system time (returned from get_cpustamp) */ - unsigned int indx; - static const char *thisfunc = "GPTLstop_handle"; - - if (disabled) - return 0; - - if ( ! initialized) - return GPTLerror ("%s: GPTLinitialize has not been called\n", thisfunc); - - /* Get the timestamp */ - if (wallstats.enabled) { - tp1 = (*ptr2wtimefunc) (); - } - - if (cpustats.enabled && get_cpustamp (&usr, &sys) < 0) - return GPTLerror (0); - - if ((t = get_thread_num ()) < 0) - return GPTLerror ("%s: bad return from get_thread_num\n", thisfunc); - - /* If current depth exceeds a user-specified limit for print, just decrement and return */ - if (stackidx[t].val > depthlimit) { - --stackidx[t].val; - return 0; - } - - indx = (unsigned int) *handle; - if (indx == 0 || indx > tablesizem1) - return GPTLerror ("%s: bad input handle=%u for timer %s.\n", thisfunc, indx, name); - - if ( ! (ptr = getentry (hashtable[t], name, indx))) - return GPTLerror ("%s: handle=%u has not been set for timer %s.\n", - thisfunc, indx, name); - - if ( ! ptr->onflg ) - return GPTLerror ("%s: timer %s was already off.\n", thisfunc, ptr->name); - - ++ptr->count; - - /* - ** Recursion => decrement depth in recursion and return. We need to return - ** because we don't want to stop the timer. We want the reported time for - ** the timer to reflect the outermost layer of recursion. - */ - if (ptr->recurselvl > 0) { - ++ptr->nrecurse; - --ptr->recurselvl; - return 0; - } - - if (update_stats (ptr, tp1, usr, sys, t) != 0) - return GPTLerror ("%s: error from update_stats\n", thisfunc); - - return 0; -} - -/* -** update_stats: update stats inside ptr. Called by GPTLstop, GPTLstop_instr, -** GPTLstop_handle -** -** Input arguments: -** ptr: pointer to timer -** tp1: input time stapm -** usr: user time -** sys: system time -** t: thread index -** -** Return value: 0 (success) or GPTLerror (failure) -*/ -static inline int update_stats (Timer *ptr, - const double tp1, - const long usr, - const long sys, - const int t) -{ - double delta; /* difference */ - int bidx; /* bottom of call stack */ - Timer *bptr; /* pointer to last entry in call stack */ - static const char *thisfunc = "update_stats"; - - ptr->onflg = false; - -#ifdef HAVE_PAPI - if (dousepapi && GPTL_PAPIstop (t, &ptr->aux) < 0) - return GPTLerror ("%s: error from GPTL_PAPIstop\n", thisfunc); -#endif - - if (wallstats.enabled) { - delta = tp1 - ptr->wall.last; - ptr->wall.accum += delta; - - if (delta < 0.) { - fprintf (stderr, "GPTL: %s: negative delta=%g\n", thisfunc, delta); - } - - if (ptr->count == 1) { - ptr->wall.max = delta; - ptr->wall.min = delta; - } else { - if (delta > ptr->wall.max) - ptr->wall.max = delta; - if (delta < ptr->wall.min) - ptr->wall.min = delta; - } - } - - if (cpustats.enabled) { - ptr->cpu.accum_utime += usr - ptr->cpu.last_utime; - ptr->cpu.accum_stime += sys - ptr->cpu.last_stime; - ptr->cpu.last_utime = usr; - ptr->cpu.last_stime = sys; - } - - /* Verify that the timer being stopped is at the bottom of the call stack */ - bidx = stackidx[t].val; - bptr = callstack[t][bidx]; - if (ptr != bptr) { - imperfect_nest = true; - GPTLwarn ("%s: Got timer=%s expected btm of call stack=%s\n", - thisfunc, ptr->name, bptr->name); - } - - --stackidx[t].val; /* Pop the callstack */ - if (stackidx[t].val < -1) { - stackidx[t].val = -1; - return GPTLerror ("%s: tree depth has become negative.\n", thisfunc); - } - - return 0; -} - -/* -** GPTLenable: enable timers -** -** Return value: 0 (success) -*/ -int GPTLenable (void) -{ - disabled = false; - return (0); -} - -/* -** GPTLdisable: disable timers -** -** Return value: 0 (success) -*/ -int GPTLdisable (void) -{ - disabled = true; - return (0); -} - -/* -** GPTLstamp: Compute timestamp of usr, sys, and wallclock time (seconds) -** -** Output arguments: -** wall: wallclock -** usr: user time -** sys: system time -** -** Return value: 0 (success) or GPTLerror (failure) -*/ -int GPTLstamp (double *wall, double *usr, double *sys) -{ - struct tms buf; /* argument to times */ - - if ( ! initialized) - return GPTLerror ("GPTLstamp: GPTLinitialize has not been called\n"); - -#ifdef HAVE_TIMES - *usr = 0; - *sys = 0; - - if (times (&buf) == -1) - return GPTLerror ("GPTLstamp: times() failed. Results bogus\n"); - - *usr = buf.tms_utime / (double) ticks_per_sec; - *sys = buf.tms_stime / (double) ticks_per_sec; -#endif - *wall = (*ptr2wtimefunc) (); - return 0; -} - -/* -** GPTLreset: reset all timers to 0 -** -** Return value: 0 (success) or GPTLerror (failure) -*/ -int GPTLreset (void) -{ - int t; /* index over threads */ - Timer *ptr; /* linked list index */ - static const char *thisfunc = "GPTLreset"; - - if ( ! initialized) - return GPTLerror ("%s: GPTLinitialize has not been called\n", thisfunc); - - for (t = 0; t < nthreads; t++) { - for (ptr = timers[t]; ptr; ptr = ptr->next) { - ptr->onflg = false; - ptr->count = 0; - memset (&ptr->wall, 0, sizeof (ptr->wall)); - memset (&ptr->cpu, 0, sizeof (ptr->cpu)); -#ifdef HAVE_PAPI - memset (&ptr->aux, 0, sizeof (ptr->aux)); -#endif - } - } - - if (verbose) - printf ("%s: accumulators for all timers set to zero\n", thisfunc); - - return 0; -} - -/* -** GPTLpr: Print values of all timers -** -** Input arguments: -** id: integer to append to string "timing." -** -** Return value: 0 (success) or GPTLerror (failure) -*/ -int GPTLpr (const int id) /* output file will be named "timing." */ -{ - char outfile[14]; /* name of output file: timing.xxxxxx */ - static const char *thisfunc = "GPTLpr"; - - if (id < 0 || id > 999999) - return GPTLerror ("%s: bad id=%d for output file. Must be >= 0 and < 1000000\n", thisfunc, id); - - sprintf (outfile, "timing.%d", id); - - if (GPTLpr_file (outfile) != 0) - return GPTLerror ("%s: Error in GPTLpr_file\n", thisfunc); - - return 0; -} - -/* -** GPTLpr_file: Print values of all timers -** -** Input arguments: -** outfile: Name of output file to write -** -** Return value: 0 (success) or GPTLerror (failure) -*/ -int GPTLpr_file (const char *outfile) /* output file to write */ -{ - FILE *fp; /* file handle to write to */ - Timer *ptr; /* walk through master thread linked list */ - Timer *tptr; /* walk through slave threads linked lists */ - Timer sumstats; /* sum of same timer stats over threads */ - int n, t; /* indices */ - unsigned long totcount; /* total timer invocations */ - float *sum; /* sum of overhead values (per thread) */ - float osum; /* sum of overhead over threads */ - bool found; /* jump out of loop when name found */ - bool foundany; /* whether summation print necessary */ - bool first; /* flag 1st time entry found */ - double self_ohd; /* estimated library overhead in self timer */ - double parent_ohd; /* estimated library overhead due to self in parent timer */ - - static const char *thisfunc = "GPTLpr_file"; - - if ( ! initialized) - return GPTLerror ("%s: GPTLinitialize() has not been called\n", thisfunc); - - if ( ! (fp = fopen (outfile, "w"))) - fp = stderr; - - /* Print a warning if GPTLerror() was ever called */ - if (GPTLnum_errors () > 0) { - fprintf (fp, "WARNING: GPTLerror was called at least once during the run.\n"); - fprintf (fp, "Please examine your output for error messages beginning with GPTL...\n"); - } - - /* Print a warning if imperfect nesting was encountered */ - if (imperfect_nest) { - fprintf (fp, "WARNING: SOME TIMER CALLS WERE DETECTED TO HAVE IMPERFECT NESTING.\n"); - fprintf (fp, "TIMING RESULTS WILL BE PRINTED WITHOUT INDENTING AND NO PARENT-CHILD\n"); - fprintf (fp, "INDENTING WILL BE DONE.\n"); - fprintf (fp, "ALSO: NO MULTIPLE PARENT INFORMATION WILL BE PRINTED SINCE IT MAY CONTAIN ERRORS\n"); - } - - /* A set of nasty ifdefs to tell important aspects of how GPTL was built */ -#ifdef HAVE_NANOTIME - if (funclist[funcidx].option == GPTLnanotime) { - fprintf (fp, "Clock rate = %f MHz\n", cpumhz); - fprintf (fp, "Source of clock rate was %s\n", clock_source); - if (strcmp (clock_source, "/proc/cpuinfo") == 0) { - fprintf (fp, "WARNING: The contents of /proc/cpuinfo can change in variable frequency CPUs"); - fprintf (fp, "Therefore the use of nanotime (register read) is not recommended on machines so equipped"); - } -#ifdef BIT64 - fprintf (fp, " BIT64 was true\n"); -#else - fprintf (fp, " BIT64 was false\n"); -#endif - } -#endif - -#if ( defined THREADED_OMP ) - fprintf (fp, "GPTL was built with THREADED_OMP\n"); -#elif ( defined THREADED_PTHREADS ) - fprintf (fp, "GPTL was built with THREADED_PTHREADS\n"); -#else - fprintf (fp, "GPTL was built without threading\n"); -#endif - -#ifdef HAVE_MPI - fprintf (fp, "HAVE_MPI was true\n"); - -#ifdef HAVE_COMM_F2C - fprintf (fp, " HAVE_COMM_F2C was true\n"); -#else - fprintf (fp, " HAVE_COMM_F2C was false\n"); -#endif - -#ifdef ENABLE_PMPI - fprintf (fp, " ENABLE_PMPI was true\n"); -#else - fprintf (fp, " ENABLE_PMPI was false\n"); -#endif - -#else - fprintf (fp, "HAVE_MPI was false\n"); -#endif - -#ifdef HAVE_PAPI - fprintf (fp, "HAVE_PAPI was true\n"); - if (dousepapi) { - if (GPTL_PAPIis_multiplexed ()) - fprintf (fp, " PAPI event multiplexing was ON\n"); - else - fprintf (fp, " PAPI event multiplexing was OFF\n"); - GPTL_PAPIprintenabled (fp); - } -#else - fprintf (fp, "HAVE_PAPI was false\n"); -#endif - - fprintf (fp, "Underlying timing routine was %s.\n", funclist[funcidx].name); - (void) GPTLget_overhead (fp, ptr2wtimefunc, getentry, genhashidx, get_thread_num, - stackidx, callstack, hashtable[0], tablesize, dousepapi, imperfect_nest, - &self_ohd, &parent_ohd); - if (dopr_preamble) { - fprintf (fp, "\nIf overhead stats are printed, they are the columns labeled self_OH and parent_OH\n" - "self_OH is estimated as 2X the Fortran layer cost (start+stop) plust the cost of \n" - "a single call to the underlying timing routine.\n" - "parent_OH is the overhead for the named timer which is subsumed into its parent.\n" - "It is estimated as the cost of a single GPTLstart()/GPTLstop() pair.\n" - "Print method was %s.\n", methodstr (method)); -#ifdef ENABLE_PMPI - fprintf (fp, "\nIf a AVG_MPI_BYTES field is present, it is an estimate of the per-call\n" - "average number of bytes handled by that process.\n" - "If timers beginning with sync_ are present, it means MPI synchronization " - "was turned on.\n"); -#endif - fprintf (fp, "\nIf a \'%%_of\' field is present, it is w.r.t. the first timer for thread 0.\n" - "If a \'e6_per_sec\' field is present, it is in millions of PAPI counts per sec.\n\n" - "A '*' in column 1 below means the timer had multiple parents, though the\n" - "values printed are for all calls.\n" - "Further down the listing may be more detailed information about multiple\n" - "parents. Look for 'Multiple parent info'\n\n"); - } - - sum = (float *) GPTLallocate (nthreads * sizeof (float), thisfunc); - - for (t = 0; t < nthreads; ++t) { - print_titles (t, fp); - /* - ** Print timing stats. If imperfect nesting was detected, print stats by going through - ** the linked list and do not indent anything due to the possibility of error. - ** Otherwise, print call tree and properly indented stats via recursive routine. "-1" - ** is flag to avoid printing dummy outermost timer, and initialize the depth. - */ - if (imperfect_nest) { - for (ptr = timers[t]->next; ptr; ptr = ptr->next) { - printstats (ptr, fp, t, 0, false, self_ohd, parent_ohd); - } - } else { - printself_andchildren (timers[t], fp, t, -1, self_ohd, parent_ohd); - } - - /* - ** Sum of self+parent overhead across timers is an estimate of total overhead. - */ - sum[t] = 0; - totcount = 0; - for (ptr = timers[t]->next; ptr; ptr = ptr->next) { - sum[t] += ptr->count * (parent_ohd + self_ohd); - totcount += ptr->count; - } - if (wallstats.enabled && overheadstats.enabled) - fprintf (fp, "\n"); - fprintf (fp, "Overhead sum = %9.3g wallclock seconds\n", sum[t]); - if (totcount < PRTHRESH) - fprintf (fp, "Total calls = %lu\n", totcount); - else - fprintf (fp, "Total calls = %9.3e\n", (float) totcount); - } - - /* Print per-name stats for all threads */ - if (dopr_threadsort && nthreads > 1) { - fprintf (fp, "\nSame stats sorted by timer for threaded regions:\n"); - fprintf (fp, "Thd "); - - for (n = 0; n < max_name_len[0]; ++n) /* longest timer name */ - fprintf (fp, " "); - - fprintf (fp, "Called Recurse "); - - if (cpustats.enabled) - fprintf (fp, "%s", cpustats.str); - if (wallstats.enabled) { - fprintf (fp, "%s", wallstats.str); - if (percent && timers[0]->next) - fprintf (fp, "%%_of_%5.5s ", timers[0]->next->name); - if (overheadstats.enabled) - fprintf (fp, "%s", overheadstats.str); - } - -#ifdef HAVE_PAPI - GPTL_PAPIprstr (fp); -#endif - - fprintf (fp, "\n"); - - /* Start at next to skip dummy */ - for (ptr = timers[0]->next; ptr; ptr = ptr->next) { - /* - ** To print sum stats, first create a new timer then copy thread 0 - ** stats into it. then sum using "add", and finally print. - */ - foundany = false; - first = true; - sumstats = *ptr; - for (t = 1; t < nthreads; ++t) { - found = false; - for (tptr = timers[t]->next; tptr && ! found; tptr = tptr->next) { - if (STRMATCH (ptr->name, tptr->name)) { - - /* Only print thread 0 when this timer found for other threads */ - if (first) { - first = false; - fprintf (fp, "%3.3d ", 0); - printstats (ptr, fp, 0, 0, false, self_ohd, parent_ohd); - } - - found = true; - foundany = true; - fprintf (fp, "%3.3d ", t); - printstats (tptr, fp, 0, 0, false, self_ohd, parent_ohd); - add (&sumstats, tptr); - } - } - } - - if (foundany) { - fprintf (fp, "SUM "); - printstats (&sumstats, fp, 0, 0, false, self_ohd, parent_ohd); - fprintf (fp, "\n"); - } - } - - /* Repeat overhead print in loop over threads */ - if (wallstats.enabled && overheadstats.enabled) { - osum = 0.; - for (t = 0; t < nthreads; ++t) { - fprintf (fp, "OVERHEAD.%3.3d (wallclock seconds) = %9.3g\n", t, sum[t]); - osum += sum[t]; - } - fprintf (fp, "OVERHEAD.SUM (wallclock seconds) = %9.3g\n", osum); - } - } - - /* - ** Print info about timers with multiple parents ONLY if imperfect nesting was not discovered - */ - if (dopr_multparent && ! imperfect_nest) { - for (t = 0; t < nthreads; ++t) { - bool some_multparents = false; /* thread has entries with multiple parents? */ - for (ptr = timers[t]->next; ptr; ptr = ptr->next) { - if (ptr->nparent > 1) { - some_multparents = true; - break; - } - } - - if (some_multparents) { - fprintf (fp, "\nMultiple parent info for thread %d:\n", t); - if (dopr_preamble && t == 0) { - fprintf (fp, "Columns are count and name for the listed child\n" - "Rows are each parent, with their common child being the last entry, " - "which is indented.\n" - "Count next to each parent is the number of times it called the child.\n" - "Count next to child is total number of times it was called by the " - "listed parents.\n\n"); - } - - for (ptr = timers[t]->next; ptr; ptr = ptr->next) - if (ptr->nparent > 1) - print_multparentinfo (fp, ptr); - } - } - } - - /* Print hash table stats */ - if (dopr_collision) - GPTLprint_hashstats (fp, nthreads, hashtable, tablesize); - - /* Stats on GPTL memory usage */ - GPTLprint_memstats (fp, timers, nthreads, tablesize, maxthreads); - - free (sum); - - if (fp != stderr && fclose (fp) != 0) - fprintf (stderr, "%s: Attempt to close %s failed\n", thisfunc, outfile); - - pr_has_been_called = true; - return 0; -} - -/* -** print_titles: Print headings to output file. If imperfect nesting was detected, print simply by -** following the linked list. Otherwise, indent use parent-child relationships. -** -** Input arguments: -** t: thread number -*/ -static void print_titles (int t, FILE *fp) -{ - int n; - static const char *thisfunc = "print_titles"; - /* - ** Construct tree for printing timers in parent/child form. get_max_depth() must be called - ** AFTER construct_tree() because it relies on the per-parent children arrays being complete. - */ - if (imperfect_nest) { - max_depth[t] = 0; /* No nesting will be printed since imperfect nesting was detected */ - } else { - if (construct_tree (timers[t], method) != 0) - printf ("GPTL: %s: failure from construct_tree: output will be incomplete\n", thisfunc); - max_depth[t] = get_max_depth (timers[t], 0); - } - - if (t > 0) - fprintf (fp, "\n"); - fprintf (fp, "Stats for thread %d:\n", t); - - for (n = 0; n < max_depth[t]+1; ++n) /* +1 to always indent timer name */ - fprintf (fp, " "); - for (n = 0; n < max_name_len[t]; ++n) /* longest timer name */ - fprintf (fp, " "); - fprintf (fp, "Called Recurse "); - - /* Print strings for enabled timer types */ - if (cpustats.enabled) - fprintf (fp, "%s", cpustats.str); - if (wallstats.enabled) { - fprintf (fp, "%s", wallstats.str); - if (percent && timers[0]->next) - fprintf (fp, "%%_of_%5.5s ", timers[0]->next->name); - if (overheadstats.enabled) - fprintf (fp, "%s", overheadstats.str); - } - -#ifdef ENABLE_PMPI - fprintf (fp, "AVG_MPI_BYTES "); -#endif - -#ifdef HAVE_PAPI - GPTL_PAPIprstr (fp); -#endif - - fprintf (fp, "\n"); - return; -} - -/* -** construct_tree: Build the parent->children tree starting with knowledge of -** parent list for each child. -** -** Input arguments: -** method: method to be used to define the links -** -** Input/Output arguments: -** timerst: Linked list of timers. "children" array for each timer will be constructed -** -** Return value: 0 (success) or GPTLerror (failure) -*/ -int construct_tree (Timer *timerst, Method method) -{ - Timer *ptr; /* loop through linked list */ - Timer *pptr = 0; /* parent (init to NULL to avoid compiler warning) */ - int nparent; /* number of parents */ - int maxcount; /* max calls by a single parent */ - int n; /* loop over nparent */ - static const char *thisfunc = "construct_tree"; - - /* - ** Walk the linked list to build the parent-child tree, using whichever - ** mechanism is in place. newchild() will prevent loops. - */ - for (ptr = timerst; ptr; ptr = ptr->next) { - switch (method) { - case GPTLfirst_parent: - if (ptr->nparent > 0) { - pptr = ptr->parent[0]; - if (newchild (pptr, ptr) != 0); - } - break; - case GPTLlast_parent: - if (ptr->nparent > 0) { - nparent = ptr->nparent; - pptr = ptr->parent[nparent-1]; - if (newchild (pptr, ptr) != 0); - } - break; - case GPTLmost_frequent: - maxcount = 0; - for (n = 0; n < ptr->nparent; ++n) { - if (ptr->parent_count[n] > maxcount) { - pptr = ptr->parent[n]; - maxcount = ptr->parent_count[n]; - } - } - if (maxcount > 0) { /* not an orphan */ - if (newchild (pptr, ptr) != 0); - } - break; - case GPTLfull_tree: - for (n = 0; n < ptr->nparent; ++n) { - pptr = ptr->parent[n]; - if (newchild (pptr, ptr) != 0); - } - break; - default: - return GPTLerror ("GPTL: %s: method %d is not known\n", thisfunc, method); - } - } - return 0; -} - -/* -** methodstr: Return a pointer to a string which represents the method -** -** Input arguments: -** method: method type -*/ -static char *methodstr (Method method) -{ - if (method == GPTLfirst_parent) - return "first_parent"; - else if (method == GPTLlast_parent) - return "last_parent"; - else if (method == GPTLmost_frequent) - return "most_frequent"; - else if (method == GPTLfull_tree) - return "full_tree"; - else - return "Unknown"; -} - -/* -** newchild: Add an entry to the children list of parent. Use function -** is_descendant() to prevent infinite loops. -** -** Input arguments: -** child: child to be added -** -** Input/output arguments: -** parent: parent node which will have "child" added to its "children" array -** -** Return value: 0 (success) or GPTLerror (failure) -*/ -static int newchild (Timer *parent, Timer *child) -{ - int nchildren; /* number of children (temporary) */ - Timer **chptr; /* array of pointers to children */ - static const char *thisfunc = "newchild"; - - if (parent == child) - return GPTLerror ("%s: child %s can't be a parent of itself\n", thisfunc, child->name); - - /* - ** To guarantee no loops, ensure that proposed parent isn't already a descendant of - ** proposed child - */ - if (is_descendant (child, parent)) { - return GPTLerror ("GPTL: %s: loop detected: NOT adding %s to descendant list of %s. " - "Proposed parent is in child's descendant path.\n", - thisfunc, child->name, parent->name); - } - - /* - ** Add child to parent's array of children if it isn't already there (e.g. by an earlier call - ** to GPTLpr*) - */ - if ( ! is_onlist (child, parent)) { - ++parent->nchildren; - nchildren = parent->nchildren; - chptr = (Timer **) realloc (parent->children, nchildren * sizeof (Timer *)); - if ( ! chptr) - return GPTLerror ("%s: realloc error\n", thisfunc); - parent->children = chptr; - parent->children[nchildren-1] = child; - } - - return 0; -} - -/* -** get_max_depth: Determine the maximum call tree depth by traversing the -** tree recursively -** -** Input arguments: -** ptr: Starting timer -** startdepth: current depth when function invoked -** -** Return value: maximum depth -*/ -static int get_max_depth (const Timer *ptr, const int startdepth) -{ - int maxdepth = startdepth; - int depth; - int n; - - for (n = 0; n < ptr->nchildren; ++n) - if ((depth = get_max_depth (ptr->children[n], startdepth+1)) > maxdepth) - maxdepth = depth; - - return maxdepth; -} - -/* -** is_descendant: Determine whether node2 is in the descendant list for -** node1 -** -** Input arguments: -** node1: starting node for recursive search -** node2: node to be searched for -** -** Return value: true or false -*/ -static int is_descendant (const Timer *node1, const Timer *node2) -{ - int n; - - /* Breadth before depth for efficiency */ - for (n = 0; n < node1->nchildren; ++n) - if (node1->children[n] == node2) - return 1; - - for (n = 0; n < node1->nchildren; ++n) - if (is_descendant (node1->children[n], node2)) - return 1; - - return 0; -} - -/* -** is_onlist: Determine whether child is in parent's list of children -** -** Input arguments: -** child: who to search for -** parent: search through his list of children -** -** Return value: true or false -*/ -static int is_onlist (const Timer *child, const Timer *parent) -{ - int n; - - for (n = 0; n < parent->nchildren; ++n) { - if (child == parent->children[n]) - return 1; - } - - return 0; -} - -/* -** printstats: print a single timer -** -** Input arguments: -** timer: timer for which to print stats -** fp: file descriptor to write to -** t: thread number -** depth: depth to indent timer -** doindent: whether indenting will be done -** tot_overhead: underlying timing routine overhead -*/ -static void printstats (const Timer *timer, - FILE *fp, - int t, - int depth, - bool doindent, - double self_ohd, - double parent_ohd) -{ - int i; /* index */ - int indent; /* index for indenting */ - int extraspace; /* for padding to length of longest name */ - float fusr; /* user time as float */ - float fsys; /* system time as float */ - float usrsys; /* usr + sys */ - float elapse; /* elapsed time */ - float wallmax; /* max wall time */ - float wallmin; /* min wall time */ - float ratio; /* percentage calc */ - static const char *thisfunc = "printstats"; - - if (timer->onflg && verbose) - fprintf (stderr, "GPTL: %s: timer %s had not been turned off\n", thisfunc, timer->name); - - /* Flag regions having multiple parents with a "*" in column 1 */ - if (doindent) { - if (timer->nparent > 1) - fprintf (fp, "* "); - else - fprintf (fp, " "); - - /* Indent to depth of this timer */ - for (indent = 0; indent < depth; ++indent) - fprintf (fp, " "); - } - - fprintf (fp, "%s", timer->name); - - /* Pad to length of longest name */ - extraspace = max_name_len[t] - strlen (timer->name); - for (i = 0; i < extraspace; ++i) - fprintf (fp, " "); - - /* Pad to max indent level */ - if (doindent) - for (indent = depth; indent < max_depth[t]; ++indent) - fprintf (fp, " "); - - /* - ** Don't print stats if the timer is currently on: too dangerous since the timer needs - ** to be stopped to have currently accurate timings - */ - if (timer->onflg) { - fprintf (fp, " NOT PRINTED: timer is currently ON\n"); - return; - } - -if (timer->count < PRTHRESH) { - if (timer->nrecurse > 0) - fprintf (fp, "%8lu %6lu ", timer->count, timer->nrecurse); - else - fprintf (fp, "%8lu - ", timer->count); - } else { - if (timer->nrecurse > 0) - fprintf (fp, "%8.1e %6.0e ", (float) timer->count, (float) timer->nrecurse); - else - fprintf (fp, "%8.1e - ", (float) timer->count); - } - - if (cpustats.enabled) { - fusr = timer->cpu.accum_utime / (float) ticks_per_sec; - fsys = timer->cpu.accum_stime / (float) ticks_per_sec; - usrsys = fusr + fsys; - fprintf (fp, "%9.3f %9.3f %9.3f ", fusr, fsys, usrsys); - } - - if (wallstats.enabled) { - elapse = timer->wall.accum; - wallmax = timer->wall.max; - wallmin = timer->wall.min; - - if (elapse < 0.01) - fprintf (fp, "%9.2e ", elapse); - else - fprintf (fp, "%9.3f ", elapse); - - if (wallmax < 0.01) - fprintf (fp, "%9.2e ", wallmax); - else - fprintf (fp, "%9.3f ", wallmax); - - if (wallmin < 0.01) - fprintf (fp, "%9.2e ", wallmin); - else - fprintf (fp, "%9.3f ", wallmin); - - if (percent && timers[0]->next) { - ratio = 0.; - if (timers[0]->next->wall.accum > 0.) - ratio = (timer->wall.accum * 100.) / timers[0]->next->wall.accum; - fprintf (fp, " %9.2f ", ratio); - } - - if (overheadstats.enabled) { - fprintf (fp, "%9.3f %9.3f ", timer->count*self_ohd, timer->count*parent_ohd); - } - } - -#ifdef ENABLE_PMPI - if (timer->nbytes == 0.) - fprintf (fp, " - "); - else - fprintf (fp, "%13.3e ", timer->nbytes / timer->count); -#endif - -#ifdef HAVE_PAPI - GPTL_PAPIpr (fp, &timer->aux, t, timer->count, timer->wall.accum); -#endif - - fprintf (fp, "\n"); -} - -/* -** print_multparentinfo: -** -** Input arguments: -** Input/output arguments: -*/ -void print_multparentinfo (FILE *fp, - Timer *ptr) -{ - int n; - - if (ptr->norphan > 0) { - if (ptr->norphan < PRTHRESH) - fprintf (fp, "%8u %-32s\n", ptr->norphan, "ORPHAN"); - else - fprintf (fp, "%8.1e %-32s\n", (float) ptr->norphan, "ORPHAN"); - } - - for (n = 0; n < ptr->nparent; ++n) { - if (ptr->parent_count[n] < PRTHRESH) - fprintf (fp, "%8d %-32s\n", ptr->parent_count[n], ptr->parent[n]->name); - else - fprintf (fp, "%8.1e %-32s\n", (float) ptr->parent_count[n], ptr->parent[n]->name); - } - - if (ptr->count < PRTHRESH) - fprintf (fp, "%8lu %-32s\n\n", ptr->count, ptr->name); - else - fprintf (fp, "%8.1e %-32s\n\n", (float) ptr->count, ptr->name); -} - -/* -** add: add the contents of tin to tout -** -** Input arguments: -** tin: input timer -** Input/output arguments: -** tout: output timer summed into -*/ -static void add (Timer *tout, - const Timer *tin) -{ - tout->count += tin->count; - - if (wallstats.enabled) { - tout->wall.accum += tin->wall.accum; - - tout->wall.max = MAX (tout->wall.max, tin->wall.max); - tout->wall.min = MIN (tout->wall.min, tin->wall.min); - } - - if (cpustats.enabled) { - tout->cpu.accum_utime += tin->cpu.accum_utime; - tout->cpu.accum_stime += tin->cpu.accum_stime; - } -#ifdef HAVE_PAPI - GPTL_PAPIadd (&tout->aux, &tin->aux); -#endif -} - -#ifdef HAVE_MPI - -/* -** GPTLbarrier: When MPI enabled, set and time an MPI barrier -** -** Input arguments: -** comm: commuicator (e.g. MPI_COMM_WORLD). If zero, use MPI_COMM_WORLD -** name: region name -** -** Return value: 0 (success) -*/ -int GPTLbarrier (MPI_Comm comm, const char *name) -{ - int ret; - static const char *thisfunc = "GPTLbarrier"; - - ret = GPTLstart (name); - if ((ret = MPI_Barrier (comm)) != MPI_SUCCESS) - return GPTLerror ("%s: Bad return from MPI_Barrier=%d", thisfunc, ret); - ret = GPTLstop (name); - return 0; -} -#endif /* HAVE_MPI */ - -/* -** get_cpustamp: Invoke the proper system timer and return stats. -** -** Output arguments: -** usr: user time -** sys: system time -** -** Return value: 0 (success) -*/ -static inline int get_cpustamp (long *usr, long *sys) -{ -#ifdef HAVE_TIMES - struct tms buf; - - (void) times (&buf); - *usr = buf.tms_utime; - *sys = buf.tms_stime; - return 0; -#else - return GPTLerror ("GPTL: get_cpustamp: times() not available\n"); -#endif -} - -/* -** GPTLquery: return current status info about a timer. If certain stats are not -** enabled, they should just have zeros in them. If PAPI is not enabled, input -** counter info is ignored. -** -** Input args: -** name: timer name -** maxcounters: max number of PAPI counters to get info for -** t: thread number (if < 0, the request is for the current thread) -** -** Output args: -** count: number of times this timer was called -** onflg: whether timer is currently on -** wallclock: accumulated wallclock time -** usr: accumulated user CPU time -** sys: accumulated system CPU time -** papicounters_out: accumulated PAPI counters -*/ -int GPTLquery (const char *name, - int t, - int *count, - int *onflg, - double *wallclock, - double *dusr, - double *dsys, - long long *papicounters_out, - const int maxcounters) -{ - Timer *ptr; /* linked list pointer */ - unsigned int indx; /* linked list index returned from getentry (unused) */ - static const char *thisfunc = "GPTLquery"; - - if ( ! initialized) - return GPTLerror ("%s: GPTLinitialize has not been called\n", thisfunc); - - /* If t is < 0, assume the request is for the current thread */ - if (t < 0) { - if ((t = get_thread_num ()) < 0) - return GPTLerror ("%s: get_thread_num failure\n", thisfunc); - } else { - if (t >= maxthreads) - return GPTLerror ("%s: requested thread %d is too big\n", thisfunc, t); - } - - indx = genhashidx (name); - ptr = getentry (hashtable[t], name, indx); - if ( !ptr) - return GPTLerror ("%s: requested timer %s does not have a name hash\n", thisfunc, name); - - *onflg = ptr->onflg; - *count = ptr->count; - *wallclock = ptr->wall.accum; - *dusr = ptr->cpu.accum_utime / (double) ticks_per_sec; - *dsys = ptr->cpu.accum_stime / (double) ticks_per_sec; -#ifdef HAVE_PAPI - GPTL_PAPIquery (&ptr->aux, papicounters_out, maxcounters); -#endif - return 0; -} - -/* -** GPTLquerycounters: return current PAPI counters for a timer. -** THIS ROUTINE IS DEPRECATED. USE GPTLget_eventvalue() instead -** -** Input args: -** name: timer name -** t: thread number (if < 0, the request is for the current thread) -** -** Output args: -** papicounters_out: accumulated PAPI counters -*/ -int GPTLquerycounters (const char *name, - int t, - long long *papicounters_out) -{ - Timer *ptr; /* linked list pointer */ - unsigned int indx; /* hash index returned from getentry */ - static const char *thisfunc = "GPTLquery_counters"; - - if ( ! initialized) - return GPTLerror ("%s: GPTLinitialize has not been called\n", thisfunc); - - /* - ** If t is < 0, assume the request is for the current thread - */ - - if (t < 0) { - if ((t = get_thread_num ()) < 0) - return GPTLerror ("%s: get_thread_num failure\n", thisfunc); - } else { - if (t >= maxthreads) - return GPTLerror ("%s: requested thread %d is too big\n", thisfunc, t); - } - - indx = genhashidx (name); - ptr = getentry (hashtable[t], name, indx); - if ( !ptr) - return GPTLerror ("%s: requested timer %s does not have a name hash\n", thisfunc, name); - -#ifdef HAVE_PAPI - /* MAX_AUX is the max possible number of PAPI-based events */ - GPTL_PAPIquery (&ptr->aux, papicounters_out, MAX_AUX); -#endif - return 0; -} - -/* -** GPTLget_wallclock: return wallclock accumulation for a timer. -** -** Input args: -** timername: timer name -** t: thread number (if < 0, the request is for the current thread) -** -** Output args: -** value: current wallclock accumulation for the timer -*/ -int GPTLget_wallclock (const char *timername, - int t, - double *value) -{ - void *self; /* timer address when hash entry generated with *_instr */ - Timer *ptr; /* linked list pointer */ - unsigned int indx; /* hash index returned from getentry (unused) */ - static const char *thisfunc = "GPTLget_wallclock"; - - if ( ! initialized) - return GPTLerror ("%s: GPTLinitialize has not been called\n", thisfunc); - - if ( ! wallstats.enabled) - return GPTLerror ("%s: wallstats not enabled\n", thisfunc); - - /* If t is < 0, assume the request is for the current thread */ - if (t < 0) { - if ((t = get_thread_num ()) < 0) - return GPTLerror ("%s: bad return from get_thread_num\n", thisfunc); - } else { - if (t >= maxthreads) - return GPTLerror ("%s: requested thread %d is too big\n", thisfunc, t); - } - - /* - ** Don't know whether hashtable entry for timername was generated with - ** *_instr() or not, so try both possibilities - */ - indx = genhashidx (timername); - ptr = getentry (hashtable[t], timername, indx); - if ( !ptr) { - if (sscanf (timername, "%lx", (unsigned long *) &self) < 1) - return GPTLerror ("%s: requested timer %s does not exist\n", thisfunc, timername); - ptr = getentry_instr (hashtable[t], self, &indx); - if ( !ptr) - return GPTLerror ("%s: requested timer %s does not exist\n", thisfunc, timername); - } - *value = ptr->wall.accum; - return 0; -} - -/* -** GPTLget_count: return number of start/stop calls for a timer. -** -** Input args: -** timername: timer name -** t: thread number (if < 0, the request is for the current thread) -** -** Output args: -** count: current number of start/stop calls for the timer -*/ -int GPTLget_count (const char *timername, - int t, - int *count) -{ - void *self; /* timer address when hash entry generated with *_instr */ - Timer *ptr; /* linked list pointer */ - unsigned int indx; /* hash index returned from getentry (unused) */ - static const char *thisfunc = "GPTLget_count"; - - if ( ! initialized) - return GPTLerror ("%s: GPTLinitialize has not been called\n", thisfunc); - - /* If t is < 0, assume the request is for the current thread */ - if (t < 0) { - if ((t = get_thread_num ()) < 0) - return GPTLerror ("%s: bad return from get_thread_num\n", thisfunc); - } else { - if (t >= maxthreads) - return GPTLerror ("%s: requested thread %d is too big\n", thisfunc, t); - } - - /* - ** Don't know whether hashtable entry for timername was generated with - ** *_instr() or not, so try both possibilities - */ - indx = genhashidx (timername); - ptr = getentry (hashtable[t], timername, indx); - if ( !ptr) { - if (sscanf (timername, "%lx", (unsigned long *) &self) < 1) - return GPTLerror ("%s: requested timer %s does not exist\n", thisfunc, timername); - ptr = getentry_instr (hashtable[t], self, &indx); - if ( !ptr) - return GPTLerror ("%s: requested timer %s does not exist\n", thisfunc, timername); - } - *count = ptr->count; - return 0; -} - -/* -** GPTLget_eventvalue: return PAPI-based event value for a timer. All values will be -** returned as doubles, even if the event is not derived. -** -** Input args: -** timername: timer name -** eventname: event name (must be currently enabled) -** t: thread number (if < 0, the request is for the current thread) -** -** Output args: -** value: current value of the event for this timer -*/ -int GPTLget_eventvalue (const char *timername, - const char *eventname, - int t, - double *value) -{ - void *self; /* timer address when hash entry generated with *_instr */ - Timer *ptr; /* linked list pointer */ - unsigned int indx; /* hash index returned from getentry (unused) */ - static const char *thisfunc = "GPTLget_eventvalue"; - - if ( ! initialized) - return GPTLerror ("%s: GPTLinitialize has not been called\n", thisfunc); - - /* If t is < 0, assume the request is for the current thread */ - if (t < 0) { - if ((t = get_thread_num ()) < 0) - return GPTLerror ("%s: get_thread_num failure\n", thisfunc); - } else { - if (t >= maxthreads) - return GPTLerror ("%s: requested thread %d is too big\n", thisfunc, t); - } - - /* - ** Don't know whether hashtable entry for timername was generated with - ** *_instr() or not, so try both possibilities - */ - indx = genhashidx (timername); - ptr = getentry (hashtable[t], timername, indx); - if ( !ptr) { - if (sscanf (timername, "%lx", (unsigned long *) &self) < 1) - return GPTLerror ("%s: requested timer %s does not exist\n", thisfunc, timername); - ptr = getentry_instr (hashtable[t], self, &indx); - if ( !ptr) - return GPTLerror ("%s: requested timer %s does not exist\n", thisfunc, timername); - } - -#ifdef HAVE_PAPI - return GPTL_PAPIget_eventvalue (eventname, &ptr->aux, value); -#else - return GPTLerror ("%s: PAPI not enabled\n", thisfunc); -#endif -} - -/* -** GPTLget_nregions: return number of regions (i.e. timer names) for this thread -** -** Input args: -** t: thread number (if < 0, the request is for the current thread) -** -** Output args: -** nregions: number of regions -*/ -int GPTLget_nregions (int t, - int *nregions) -{ - Timer *ptr; /* walk through linked list */ - static const char *thisfunc = "GPTLget_nregions"; - - if ( ! initialized) - return GPTLerror ("%s: GPTLinitialize has not been called\n", thisfunc); - - /* - ** If t is < 0, assume the request is for the current thread - */ - - if (t < 0) { - if ((t = get_thread_num ()) < 0) - return GPTLerror ("%s: get_thread_num failure\n", thisfunc); - } else { - if (t >= maxthreads) - return GPTLerror ("%s: requested thread %d is too big\n", thisfunc, t); - } - - *nregions = 0; - for (ptr = timers[t]->next; ptr; ptr = ptr->next) - ++*nregions; - - return 0; -} - -/* -** GPTLget_regionname: return region name for this thread -** -** Input args: -** t: thread number (if < 0, the request is for the current thread) -** region: region number -** nc: max number of chars to put in name -** -** Output args: -** name region name -*/ -int GPTLget_regionname (int t, /* thread number */ - int region, /* region number (0-based) */ - char *name, /* output region name */ - int nc) /* number of chars in name (free form Fortran) */ -{ - int ncpy; /* number of characters to copy */ - int i; /* index */ - Timer *ptr; /* walk through linked list */ - static const char *thisfunc = "GPTLget_regionname"; - - if ( ! initialized) - return GPTLerror ("%s: GPTLinitialize has not been called\n", thisfunc); - - /* - ** If t is < 0, assume the request is for the current thread - */ - - if (t < 0) { - if ((t = get_thread_num ()) < 0) - return GPTLerror ("%s: get_thread_num failure\n", thisfunc); - } else { - if (t >= maxthreads) - return GPTLerror ("%s: requested thread %d is too big\n", thisfunc, t); - } - - ptr = timers[t]->next; - for (i = 0; i < region; i++) { - if ( ! ptr) - return GPTLerror ("%s: timer number %d does not exist in thread %d\n", thisfunc, region, t); - ptr = ptr->next; - } - - if (ptr) { - ncpy = MIN (nc, strlen (ptr->name)); - strncpy (name, ptr->name, ncpy); - - /* Adding the \0 is only important when called from C */ - if (ncpy < nc) - name[ncpy] = '\0'; - } else { - return GPTLerror ("%s: timer number %d does not exist in thread %d\n", thisfunc, region, t); - } - return 0; -} - -/* -** GPTLis_initialized: Return whether GPTL has been initialized -*/ -int GPTLis_initialized (void) -{ - return (int) initialized; -} - -/* -** getentry_instr: find hash table entry and return a pointer to it -** -** Input args: -** hashtable: the hashtable (array) -** self: input address (from -finstrument-functions) -** Output args: -** indx: hashtable index -** -** Return value: pointer to the entry, or NULL if not found -*/ -static inline Timer *getentry_instr (const Hashentry *hashtable, /* hash table */ - void *self, /* address */ - unsigned int *indx) /* hash index */ -{ - int i; - Timer *ptr = 0; /* return value when entry not found */ - - /* - ** Hash index is timer address modulo the table size - ** On most machines, right-shifting the address helps because linkers often - ** align functions on even boundaries - */ - *indx = (((unsigned long) self) >> 4) % tablesize; - for (i = 0; i < hashtable[*indx].nument; ++i) { - if (hashtable[*indx].entries[i]->address == self) { - ptr = hashtable[*indx].entries[i]; - break; - } - } - return ptr; -} - -/* -** genhashidx: generate hash index -** -** Input args: -** name: string to be hashed on -** -** Return value: hash value -*/ -#define NEWWAY -static inline unsigned int genhashidx (const char *name) -{ - const unsigned char *c; /* pointer to elements of "name" */ - unsigned int indx; /* return value of function */ -#ifdef NEWWAY - unsigned int mididx, lastidx; /* mid and final index of name */ - - lastidx = strlen (name) - 1; - mididx = lastidx / 2; -#else - int i; /* iterator (OLDWAY only) */ -#endif - /* - ** Disallow a hash index of zero (by adding 1 at the end) since user input of an uninitialized - ** value, though an error, has a likelihood to be zero. - */ -#ifdef NEWWAY - c = (unsigned char *) name; - indx = (MAX_CHARS*c[0] + (MAX_CHARS-mididx)*c[mididx] + (MAX_CHARS-lastidx)*c[lastidx]) % tablesizem1 + 1; -#else - indx = 0; - i = MAX_CHARS; -#pragma unroll(2) - for (c = (unsigned char *) name; *c && i > 0; ++c) { - indx += i*(*c); - --i; - } - indx = indx % tablesizem1 + 1; -#endif - - return indx; -} - -/* -** getentry: find the entry in the hash table and return a pointer to it. -** -** Input args: -** hashtable: the hashtable (array) -** indx: hashtable index -** -** Return value: pointer to the entry, or NULL if not found -*/ -static inline Timer *getentry (const Hashentry *hashtable, /* hash table */ - const char *name, /* name to hash */ - unsigned int indx) /* hash index */ -{ - int i; /* loop index */ - Timer *ptr = 0; /* return value when entry not found */ - - /* - ** If nument exceeds 1 there was one or more hash collisions and we must search - ** linearly through the array of names with the same hash for a match - */ -#pragma novector - for (i = 0; i < hashtable[indx].nument; i++) { - if (STRMATCH (name, hashtable[indx].entries[i]->name)) { - ptr = hashtable[indx].entries[i]; - break; - } - } - return ptr; -} - -/* -** Add entry points for auto-instrumented codes -** Auto instrumentation flags for various compilers: -** -** gcc, pathcc, icc: -finstrument-functions -** pgcc: -Minstrument:functions -** xlc: -qdebug=function_trace -*/ -#ifdef __cplusplus -extern "C" { -#endif - -#ifdef _AIX -void __func_trace_enter (const char *function_name, - const char *file_name, - int line_number, - void **const user_data) -{ - char msg[MSGSIZ]; - int size, rss, share, text, datastack; - int world_iam; -#ifdef HAVE_MPI - int flag = 0; - int ret; -#endif - - if (dopr_memusage && get_thread_num() == 0) { - (void) GPTLget_memusage (&size, &rss, &share, &text, &datastack); - if (rss > rssmax) { - rssmax = rss; - world_iam = 0; -#ifdef HAVE_MPI - ret = MPI_Initialized (&flag); - if (ret == MPI_SUCCESS && flag) - ret = MPI_Comm_rank (MPI_COMM_WORLD, &world_iam); -#endif - snprintf (msg, MSGSIZ, "world_iam=%d begin %s rss grew", world_iam, function_name); - (void) GPTLprint_memusage (msg); - } - } - (void) GPTLstart (function_name); -} - -void __func_trace_exit (const char *function_name, - const char *file_name, - int line_number, - void **const user_data) -{ - char msg[MSGSIZ]; - int size, rss, share, text, datastack; - int world_iam; -#ifdef HAVE_MPI - int flag = 0; - int ret; -#endif - - (void) GPTLstop (function_name); - - if (dopr_memusage && get_thread_num() == 0) { - (void) GPTLget_memusage (&size, &rss, &share, &text, &datastack); - if (rss > rssmax) { - rssmax = rss; - world_iam = 0; -#ifdef HAVE_MPI - ret = MPI_Initialized (&flag); - if (ret == MPI_SUCCESS && flag) - ret = MPI_Comm_rank (MPI_COMM_WORLD, &world_iam); -#endif - snprintf (msg, MSGSIZ, "world_iam=%d end %s rss grew", world_iam, function_name); - (void) GPTLprint_memusage (msg); - } - } -} - -#else -//_AIX not defined - -void __cyg_profile_func_enter (void *this_fn, - void *call_site) -{ -#ifdef HAVE_BACKTRACE - void *buffer[2]; - int nptrs; - char **strings; -#endif - char msg[MSGSIZ]; - int size, rss, share, text, datastack; - int world_iam; -#ifdef HAVE_MPI - int flag = 0; - int ret; -#endif - - if (dopr_memusage && get_thread_num() == 0) { - (void) GPTLget_memusage (&size, &rss, &share, &text, &datastack); - if (rss > rssmax) { - rssmax = rss; - world_iam = 0; -#ifdef HAVE_MPI - ret = MPI_Initialized (&flag); - if (ret == MPI_SUCCESS && flag) - ret = MPI_Comm_rank (MPI_COMM_WORLD, &world_iam); -#endif - -#ifdef HAVE_BACKTRACE - nptrs = backtrace (buffer, 2); - strings = backtrace_symbols (buffer, nptrs); - snprintf (msg, MSGSIZ, "world_iam=%d begin %s rss grew", world_iam, strings[1]); - free (strings); /* needed because backtrace_symbols allocated the space */ -#else - snprintf (msg, MSGSIZ, "world_iam=%d begin %lx rss grew", world_iam, (unsigned long) this_fn); -#endif - (void) GPTLprint_memusage (msg); - } - } - (void) GPTLstart_instr (this_fn); -} - -void __cyg_profile_func_exit (void *this_fn, - void *call_site) -{ -#ifdef HAVE_BACKTRACE - void *buffer[2]; - int nptrs; - char **strings; -#endif - char msg[MSGSIZ]; - int size, rss, share, text, datastack; - int world_iam; -#ifdef HAVE_MPI - int flag = 0; - int ret; -#endif - - (void) GPTLstop_instr (this_fn); - - if (dopr_memusage && get_thread_num() == 0) { - (void) GPTLget_memusage (&size, &rss, &share, &text, &datastack); - if (rss > rssmax) { - rssmax = rss; - world_iam = 0; -#ifdef HAVE_MPI - ret = MPI_Initialized (&flag); - if (ret == MPI_SUCCESS && flag) - ret = MPI_Comm_rank (MPI_COMM_WORLD, &world_iam); -#endif -#ifdef HAVE_BACKTRACE - nptrs = backtrace (buffer, 2); - strings = backtrace_symbols (buffer, nptrs); - snprintf (msg, MSGSIZ, "world_iam=%d end %s rss grew", world_iam, (char *) strings[1]); - free (strings); /* needed because backtrace_symbols allocated the space */ -#else - snprintf (msg, MSGSIZ, "world_iam=%d end %lx rss grew", world_iam, (unsigned long) this_fn); -#endif - (void) GPTLprint_memusage (msg); - } - } -} -#endif -// _AIX false branch - -#ifdef __cplusplus -}; -#endif - -#ifdef HAVE_NANOTIME -/* Copied from PAPI library */ -static inline long long nanotime (void) -{ - long long val = 0; -#ifdef BIT64 - do { - unsigned int a, d; - asm volatile ("rdtsc":"=a" (a), "=d" (d)); - (val) = ((long long) a) | (((long long) d) << 32); - } while (0); -#else - __asm__ __volatile__("rdtsc":"=A" (val): ); -#endif - return val; -} - -#define LEN 4096 - -static float get_clockfreq () -{ - FILE *fd = 0; - char buf[LEN]; - int is; - float freq = -1.; /* clock frequency (MHz) */ - static const char *thisfunc = "get_clockfreq"; - static char *max_freq_fn = "/sys/devices/system/cpu/cpu0/cpufreq/cpuinfo_max_freq"; - static char *cpuinfo_fn = "/proc/cpuinfo"; - - /* First look for max_freq, but that isn't guaranteed to exist */ - - if ((fd = fopen (max_freq_fn, "r"))) { - if (fgets (buf, LEN, fd)) { - freq = 0.001 * (float) atof (buf); /* Convert from KHz to MHz */ - if (verbose) - printf ("GPTL: %s: Using max clock freq = %f for timing\n", thisfunc, freq); - (void) fclose (fd); - clock_source = max_freq_fn; - return freq; - } else { - (void) fclose (fd); - } - } - - /* - ** Next try /proc/cpuinfo. That has the disadvantage that it may give wrong info - ** for processors that have either idle or turbo mode - */ - if (verbose && freq < 0.) - printf ("GPTL: %s: CAUTION: Can't find max clock freq. Trying %s instead\n", - thisfunc, cpuinfo_fn); - - if ( ! (fd = fopen (cpuinfo_fn, "r"))) { - fprintf (stderr, "GPTL: %s: can't open %s\n", thisfunc, cpuinfo_fn); - return -1.; - } - - while (fgets (buf, LEN, fd)) { - if (strncmp (buf, "cpu MHz", 7) == 0) { - for (is = 7; buf[is] != '\0' && !isdigit (buf[is]); is++); - if (isdigit (buf[is])) { - freq = (float) atof (&buf[is]); - (void) fclose (fd); - clock_source = cpuinfo_fn; - return freq; - } - } - } - - (void) fclose (fd); - return -1.; -} -#endif - -/* -** The following are the set of underlying timing routines which may or may -** not be available. And their accompanying init routines. -** NANOTIME is currently only available on x86. -*/ -static int init_nanotime () -{ - static const char *thisfunc = "init_nanotime"; -#ifdef HAVE_NANOTIME - if ((cpumhz = get_clockfreq ()) < 0) - return GPTLerror ("%s: Can't get clock freq\n", thisfunc); - - if (verbose) - printf ("GPTL: %s: Clock rate = %f MHz\n", thisfunc, cpumhz); - - cyc2sec = 1./(cpumhz * 1.e6); - return 0; -#else - return GPTLerror ("GPTL: %s: not enabled\n", thisfunc); -#endif -} - -static inline double utr_nanotime () -{ -#ifdef HAVE_NANOTIME - double timestamp; - timestamp = nanotime () * cyc2sec; - return timestamp; -#else - static const char *thisfunc = "utr_nanotime"; - (void) GPTLerror ("GPTL: %s: not enabled\n", thisfunc); - return -1.; -#endif -} - -/* -** MPI_Wtime requires MPI lib. -*/ -static int init_mpiwtime () -{ -#ifdef HAVE_MPI - return 0; -#else - static const char *thisfunc = "init_mpiwtime"; - return GPTLerror ("GPTL: %s: not enabled\n", thisfunc); -#endif -} - -static inline double utr_mpiwtime () -{ -#ifdef HAVE_MPI - return MPI_Wtime (); -#else - static const char *thisfunc = "utr_mpiwtime"; - (void) GPTLerror ("GPTL: %s: not enabled\n", thisfunc); - return -1.; -#endif -} - -/* -** PAPI_get_real_usec requires PAPI lib. -*/ -static int init_papitime () -{ - static const char *thisfunc = "init_papitime"; -#ifdef HAVE_PAPI - ref_papitime = PAPI_get_real_usec (); - if (verbose) - printf ("GPTL: %s: ref_papitime=%ld\n", thisfunc, (long) ref_papitime); - return 0; -#else - return GPTLerror ("GPTL: %s: not enabled\n", thisfunc); -#endif -} - -static inline double utr_papitime () -{ -#ifdef HAVE_PAPI - return (PAPI_get_real_usec () - ref_papitime) * 1.e-6; -#else - static const char *thisfunc = "utr_papitime"; - (void) GPTLerror ("GPTL: %s: not enabled\n", thisfunc); - return -1.; -#endif -} - -/* -** Probably need to link with -lrt for this one to work -*/ -static int init_clock_gettime () -{ - static const char *thisfunc = "init_clock_gettime"; -#ifdef HAVE_LIBRT - struct timespec tp; - (void) clock_gettime (CLOCK_REALTIME, &tp); - ref_clock_gettime = tp.tv_sec; - if (verbose) - printf ("GPTL: %s: ref_clock_gettime=%ld\n", thisfunc, (long) ref_clock_gettime); - return 0; -#else - return GPTLerror ("GPTL: %s: not enabled\n", thisfunc); -#endif -} - -static inline double utr_clock_gettime () -{ -#ifdef HAVE_LIBRT - struct timespec tp; - (void) clock_gettime (CLOCK_REALTIME, &tp); - return (tp.tv_sec - ref_clock_gettime) + 1.e-9*tp.tv_nsec; -#else - static const char *thisfunc = "utr_clock_gettime"; - (void) GPTLerror ("GPTL: %s: not enabled\n", thisfunc); - return -1.; -#endif -} - -/* -** High-res timer on AIX: read_real_time -*/ -static int init_read_real_time () -{ - static const char *thisfunc = "init_read_real_time"; -#ifdef _AIX - timebasestruct_t ibmtime; - (void) read_real_time (&ibmtime, TIMEBASE_SZ); - (void) time_base_to_time (&ibmtime, TIMEBASE_SZ); - ref_read_real_time = ibmtime.tb_high; - if (verbose) - printf ("GPTL: %s: ref_read_real_time=%ld\n", thisfunc, (long) ref_read_real_time); - return 0; -#else - return GPTLerror ("GPTL: %s: not enabled\n", thisfunc); -#endif -} - -static inline double utr_read_real_time () -{ -#ifdef _AIX - timebasestruct_t ibmtime; - (void) read_real_time (&ibmtime, TIMEBASE_SZ); - (void) time_base_to_time (&ibmtime, TIMEBASE_SZ); - return (ibmtime.tb_high - ref_read_real_time) + 1.e-9*ibmtime.tb_low; -#else - static const char *thisfunc = "utr_read_real_time"; - return GPTLerror ("GPTL: %s: not enabled\n", thisfunc); -#endif -} - -/* -** Default available most places: gettimeofday -*/ -static int init_gettimeofday () -{ - static const char *thisfunc = "init_gettimeofday"; -#ifdef HAVE_GETTIMEOFDAY - struct timeval tp; - (void) gettimeofday (&tp, 0); - ref_gettimeofday = tp.tv_sec; - if (verbose) - printf ("GPTL: %s: ref_gettimeofday=%ld\n", thisfunc, (long) ref_gettimeofday); - return 0; -#else - return GPTLerror ("GPTL: %s: not enabled\n", thisfunc); -#endif -} - -static inline double utr_gettimeofday () -{ -#ifdef HAVE_GETTIMEOFDAY - struct timeval tp; - (void) gettimeofday (&tp, 0); - return (tp.tv_sec - ref_gettimeofday) + 1.e-6*tp.tv_usec; -#else - static const char *thisfunc = "utr_gettimeofday"; - return GPTLerror ("GPTL: %s: not enabled\n", thisfunc); -#endif -} - -/* -** placebo: does nothing and returns zero always. Useful for estimating overhead costs -*/ -static int init_placebo () -{ - return 0; -} - -static inline double utr_placebo () -{ - static const double zero = 0.; - return zero; -} - -/* -** printself_andchildren: Recurse through call tree, printing stats for self, then children -*/ -static void printself_andchildren (const Timer *ptr, - FILE *fp, - int t, - int depth, - double self_ohd, - double parent_ohd) -{ - int n; - - if (depth > -1) /* -1 flag is to avoid printing stats for dummy outer timer */ - printstats (ptr, fp, t, depth, true, self_ohd, parent_ohd); - - for (n = 0; n < ptr->nchildren; n++) - printself_andchildren (ptr->children[n], fp, t, depth+1, self_ohd, parent_ohd); -} - -/* -** GPTLget_nthreads: Return number of threads. NOT a public entry point -*/ -int GPTLget_nthreads () -{ - return nthreads; -} - -/* -** GPTLget_timersaddr: Return address of timers. NOT a public entry point -*/ -Timer **GPTLget_timersaddr () -{ - return timers; -} - -#ifdef ENABLE_PMPI -/* -** GPTLgetentry: called ONLY from pmpi.c (i.e. not a public entry point). Returns a pointer to the -** requested timer name by calling internal function getentry() -** -** Return value: 0 (NULL) or the return value of getentry() -*/ -Timer *GPTLgetentry (const char *name) -{ - int t; /* thread number */ - unsigned int indx; /* returned from getentry (unused) */ - static const char *thisfunc = "GPTLgetentry"; - - if ( ! initialized) { - (void) GPTLerror ("%s: initialization was not completed\n", thisfunc); - return 0; - } - - if ((t = get_thread_num ()) < 0) { - (void) GPTLerror ("%s: bad return from get_thread_num\n", thisfunc); - return 0; - } - - indx = genhashidx (name); - return (getentry (hashtable[t], name, indx)); -} - -/* -** GPTLpr_file_has_been_called: Called ONLY from pmpi.c (i.e. not a public entry point). Return -** whether GPTLpr_file has been called. MPI_Finalize wrapper needs -** to know whether it needs to call GPTLpr. -*/ -int GPTLpr_has_been_called (void) -{ - return (int) pr_has_been_called; -} - -#endif - -/*************************************************************************************/ - -/* -** Contents of inserted threadutil.c starts here. -** Moved to gptl.c to enable inlining -*/ - -/* -** -** Author: Jim Rosinski -** -** Utility functions handle thread-based GPTL needs. -*/ - -/**********************************************************************************/ -/* -** 3 sets of routines: OMP threading, PTHREADS, unthreaded -*/ - -#if ( defined THREADED_OMP ) - -/* -** threadinit: Allocate and initialize GPTLthreadid_omp; set max number of threads -** -** Output results: -** maxthreads: max number of threads -** -** GPTLthreadid_omp[] is allocated and initialized to -1 -** -** -** Return value: 0 (success) or GPTLerror (failure) -*/ -static int threadinit (void) -{ - int t; /* loop index */ - static const char *thisfunc = "threadinit"; - - if (omp_get_thread_num () != 0) - return GPTLerror ("OMP %s: MUST only be called by the master thread\n", thisfunc); - - /* - ** Allocate the threadid array which maps physical thread IDs to logical IDs - ** For OpenMP this will be just GPTLthreadid_omp[iam] = iam; - */ - if (GPTLthreadid_omp) - return GPTLerror ("OMP %s: has already been called.\nMaybe mistakenly called by multiple threads?", - thisfunc); - - /* - ** maxthreads may have been set by the user, in which case use that. But if as - ** yet uninitialized, set to the current value of OMP_NUM_THREADS. - */ - if (maxthreads == -1) - maxthreads = MAX ((1), (omp_get_max_threads ())); - - if ( ! (GPTLthreadid_omp = (int *) GPTLallocate (maxthreads * sizeof (int), thisfunc))) - return GPTLerror ("OMP %s: malloc failure for %d elements of GPTLthreadid_omp\n", thisfunc, maxthreads); - - /* - ** Initialize threadid array to flag values for use by get_thread_num(). - ** get_thread_num() will fill in the values on first use. - */ - for (t = 0; t < maxthreads; ++t) - GPTLthreadid_omp[t] = -1; - -#ifdef VERBOSE - printf ("GPTL: OMP %s: Set maxthreads=%d\n", thisfunc, maxthreads); -#endif - - return 0; -} - -/* -** Threadfinalize: clean up -** -** Output results: -** GPTLthreadid_omp array is freed and array pointer nullified -*/ -static void threadfinalize () -{ - free ((void *) GPTLthreadid_omp); - GPTLthreadid_omp = 0; -} - -/* -** get_thread_num: Determine thread number of the calling thread -** Start PAPI counters if enabled and first call for this thread. -** -** Output results: -** nthreads: Number of threads -** GPTLthreadid_omp: Our thread id added to list on 1st call -** -** Return value: thread number (success) or GPTLerror (failure) -*/ -static inline int get_thread_num (void) -{ - int t; /* thread number */ - static const char *thisfunc = "get_thread_num"; - - if ((t = omp_get_thread_num ()) >= maxthreads) - return GPTLerror ("OMP %s: returned id=%d exceeds maxthreads=%d\n", thisfunc, t, maxthreads); - - /* If our thread number has already been set in the list, we are done */ - if (t == GPTLthreadid_omp[t]) - return t; - - /* - ** Thread id not found. Modify GPTLthreadid_omp with our ID, then start PAPI events if required. - ** Due to the setting of GPTLthreadid_omp, everything below here will only execute once per thread. - */ - GPTLthreadid_omp[t] = t; - -#ifdef VERBOSE - printf ("GPTL: OMP %s: 1st call t=%d\n", thisfunc, t); -#endif - -#ifdef HAVE_PAPI - - /* - ** When HAVE_PAPI is true, if 1 or more PAPI events are enabled, - ** create and start an event set for the new thread. - */ - if (GPTLget_npapievents () > 0) { -#ifdef VERBOSE - printf ("GPTL: OMP %s: Starting EventSet t=%d\n", thisfunc, t); -#endif - - if (GPTLcreate_and_start_events (t) < 0) - return GPTLerror ("GPTL: OMP %s: error from GPTLcreate_and_start_events for thread %d\n", - thisfunc, t); - } -#endif - - /* nthreads = maxthreads based on setting in threadinit or user call to GPTLsetoption() */ - nthreads = maxthreads; -#ifdef VERBOSE - printf ("GPTL: OMP %s: nthreads=%d\n", thisfunc, nthreads); -#endif - - return t; -} - -/**********************************************************************************/ -/* -** PTHREADS -*/ - -#elif ( defined THREADED_PTHREADS ) - -/* -** threadinit: Allocate GPTLthreadid and initialize to -1; set max number of threads; -** Initialize the mutex for later use; Initialize nthreads to 0 -** -** Output results: -** nthreads: number of threads (init to zero here, increment later in get_thread_num) -** maxthreads: max number of threads (MAX_THREADS) -** -** GPTLthreadid[] is allocated and initialized to -1 -** mutex is initialized for future use -** -** Return value: 0 (success) or GPTLerror (failure) -*/ -static int threadinit (void) -{ - int t; /* thread number */ - int ret; /* return code */ - static const char *thisfunc = "threadinit"; - - /* - ** The following test is not rock-solid, but it's pretty close in terms of guaranteeing that - ** threadinit gets called by only 1 thread. Problem is, mutex hasn't yet been initialized - ** so we can't use it. - */ - if (nthreads == -1) - nthreads = 0; - else - return GPTLerror ("GPTL: PTHREADS %s: has already been called.\n" - "Maybe mistakenly called by multiple threads?\n", thisfunc); - - /* - ** Initialize the mutex required for critical regions. - ** Previously, t_mutex = PTHREAD_MUTEX_INITIALIZER on the static declaration line was - ** adequate to initialize the mutex. But this failed in programs that invoked - ** GPTLfinalize() followed by GPTLinitialize(). - ** "man pthread_mutex_init" indicates that passing NULL as the second argument to - ** pthread_mutex_init() should appropriately initialize the mutex, assuming it was - ** properly destroyed by a previous call to pthread_mutex_destroy(); - */ -#ifdef MUTEX_API - if ((ret = pthread_mutex_init ((pthread_mutex_t *) &t_mutex, NULL)) != 0) - return GPTLerror ("GPTL: PTHREADS %s: mutex init failure: ret=%d\n", thisfunc, ret); -#endif - - /* maxthreads is either its default initialization value, or set by a user - ** call to GPTLsetoption(). - ** Allocate the threadid array which maps physical thread IDs to logical IDs - */ - if (GPTLthreadid) - return GPTLerror ("GPTL: PTHREADS %s: GPTLthreadid not null\n", thisfunc); - else if ( ! (GPTLthreadid = (pthread_t *) GPTLallocate (maxthreads * sizeof (pthread_t), thisfunc))) - return GPTLerror ("GPTL: PTHREADS %s: malloc failure for %d elements of GPTLthreadid\n", - thisfunc, maxthreads); - - /* - ** Initialize GPTLthreadid array to flag values for use by get_thread_num(). - ** get_thread_num() will fill in the values on first use. - */ - for (t = 0; t < maxthreads; ++t) - GPTLthreadid[t] = (pthread_t) -1; - -#ifdef VERBOSE - printf ("GPTL: PTHREADS %s: Set maxthreads=%d nthreads=%d\n", thisfunc, maxthreads, nthreads); -#endif - - return 0; -} - -/* -** threadfinalize: Clean up -** -** Output results: -** GPTLthreadid array is freed and array pointer nullified -** mutex is destroyed -*/ -static void threadfinalize () -{ - int ret; - -#ifdef MUTEX_API - if ((ret = pthread_mutex_destroy ((pthread_mutex_t *) &t_mutex)) != 0) - printf ("GPTL: threadfinalize: failed attempt to destroy t_mutex: ret=%d\n", ret); -#endif - free ((void *) GPTLthreadid); - GPTLthreadid = 0; -} - -/* -** get_thread_num: Determine zero-based thread number of the calling thread. -** Update nthreads and maxthreads if necessary. -** Start PAPI counters if enabled and first call for this thread. -** -** Output results: -** nthreads: Updated number of threads -** GPTLthreadid: Our thread id added to list on 1st call -** -** Return value: thread number (success) or GPTLerror (failure) -*/ -static inline int get_thread_num (void) -{ - int t; /* logical thread number, defined by array index of found GPTLthreadid */ - pthread_t mythreadid; /* thread id from pthreads library */ - int retval = -1; /* value to return to caller: init to bad value to please compiler */ - bool foundit = false; /* thread id found in list */ - static const char *thisfunc = "get_thread_num"; - - mythreadid = pthread_self (); - - /* - ** If our thread number has already been set in the list, we are done - ** VECTOR code should run a bit faster on vector machines. - */ -#define VECTOR -#ifdef VECTOR - for (t = 0; t < nthreads; ++t) - if (pthread_equal (mythreadid, GPTLthreadid[t])) { - foundit = true; - retval = t; - } - - if (foundit) - return retval; -#else - for (t = 0; t < nthreads; ++t) - if (pthread_equal (mythreadid, GPTLthreadid[t])) - return t; -#endif - - /* - ** Thread id not found. Define a critical region, then start PAPI counters if - ** necessary and modify GPTLthreadid[] with our id. - */ - if (lock_mutex () < 0) - return GPTLerror ("GPTL: PTHREADS %s: mutex lock failure\n", thisfunc); - - /* - ** If our thread id is not in the known list, add to it after checking that - ** we do not have too many threads. - */ - if (nthreads >= maxthreads) { - if (unlock_mutex () < 0) - fprintf (stderr, "GPTL: PTHREADS %s: mutex unlock failure\n", thisfunc); - - return GPTLerror ("GPTL: THREADED_PTHREADS %s: thread index=%d is too big. Need to invoke \n" - "GPTLsetoption(GPTLmaxthreads,value) or recompile GPTL with a\n" - "larger value of MAX_THREADS\n", thisfunc, nthreads); - } - - GPTLthreadid[nthreads] = mythreadid; - -#ifdef VERBOSE - printf ("GPTL: PTHREADS %s: 1st call GPTLthreadid=%lu maps to location %d\n", - thisfunc, (unsigned long) mythreadid, nthreads); -#endif - -#ifdef HAVE_PAPI - - /* - ** When HAVE_PAPI is true, if 1 or more PAPI events are enabled, - ** create and start an event set for the new thread. - */ - if (GPTLget_npapievents () > 0) { -#ifdef VERBOSE - printf ("GPTL: PTHREADS %s: Starting EventSet GPTLthreadid=%lu location=%d\n", - thisfunc, (unsigned long) mythreadid, nthreads); -#endif - if (GPTLcreate_and_start_events (nthreads) < 0) { - if (unlock_mutex () < 0) - fprintf (stderr, "GPTL: PTHREADS %s: mutex unlock failure\n", thisfunc); - - return GPTLerror ("GPTL: PTHREADS %s: error from GPTLcreate_and_start_events for thread %d\n", - thisfunc, nthreads); - } - } -#endif - - /* - ** IMPORTANT to set return value before unlocking the mutex!!!! - ** "return nthreads-1" fails occasionally when another thread modifies - ** nthreads after it gets the mutex! - */ - retval = nthreads++; - -#ifdef VERBOSE - printf ("GPTL: PTHREADS %s: nthreads bumped to %d\n", thisfunc, nthreads); -#endif - - if (unlock_mutex () < 0) - return GPTLerror ("GPTL: PTHREADS %s: mutex unlock failure\n", thisfunc); - - return retval; -} - -/* -** lock_mutex: lock a mutex for private access -*/ -static int lock_mutex () -{ - static const char *thisfunc = "lock_mutex"; - - if (pthread_mutex_lock ((pthread_mutex_t *) &t_mutex) != 0) - return GPTLerror ("GPTL: %s: failure from pthread_lock_mutex\n", thisfunc); - - return 0; -} - -/* -** unlock_mutex: unlock a mutex from private access -*/ -static int unlock_mutex () -{ - static const char *thisfunc = "unlock_mutex"; - - if (pthread_mutex_unlock ((pthread_mutex_t *) &t_mutex) != 0) - return GPTLerror ("GPTL: %s: failure from pthread_unlock_mutex\n", thisfunc); - return 0; -} - -/**********************************************************************************/ -/* -** Unthreaded case -*/ - -#else - -static int threadinit (void) -{ - static const char *thisfunc = "threadinit"; - - if (nthreads != -1) - return GPTLerror ("GPTL: Unthreaded %s: MUST only be called once", thisfunc); - - nthreads = 0; - maxthreads = 1; - return 0; -} - -void threadfinalize () -{ - GPTLthreadid = -1; -} - -static inline int get_thread_num () -{ -#ifdef HAVE_PAPI - static const char *thisfunc = "get_thread_num"; - /* - ** When HAVE_PAPI is true, if 1 or more PAPI events are enabled, - ** create and start an event set for the new thread. - */ - if (GPTLthreadid == -1 && GPTLget_npapievents () > 0) { - if (GPTLcreate_and_start_events (0) < 0) - return GPTLerror ("GPTL: Unthreaded %s: error from GPTLcreate_and_start_events for thread %0\n", - thisfunc); - - GPTLthreadid = 0; - } -#endif - - nthreads = 1; - return 0; -} - -#endif /* Unthreaded case */ diff --git a/cesm/models/utils/timing/gptl/gptl.h b/cesm/models/utils/timing/gptl/gptl.h deleted file mode 100644 index c2c7e1c..0000000 --- a/cesm/models/utils/timing/gptl/gptl.h +++ /dev/null @@ -1,136 +0,0 @@ -/* -** $Id: gptl.h.template,v 1.3 2011-03-28 20:55:19 rosinski Exp $ -** -** Author: Jim Rosinski -** -** GPTL header file to be included in user code -*/ - -#ifndef GPTL_H -#define GPTL_H - -/* -** Options settable by a call to GPTLsetoption() (default in parens) -** These numbers need to be small integers because GPTLsetoption can -** be passed PAPI counters, and we need to avoid collisions in that -** integer space. PAPI presets are big negative integers, and PAPI -** native events are big positive integers. -*/ - -typedef enum { - GPTLsync_mpi = 0, /* Synchronize before certain MPI calls (PMPI-mode only) */ - GPTLwall = 1, /* Collect wallclock stats (true) */ - GPTLcpu = 2, /* Collect CPU stats (false)*/ - GPTLabort_on_error = 3, /* Abort on failure (false) */ - GPTLoverhead = 4, /* Estimate overhead of underlying timing routine (true) */ - GPTLdepthlimit = 5, /* Only print timers this depth or less in the tree (inf) */ - GPTLverbose = 6, /* Verbose output (false) */ - GPTLnarrowprint = 7, /* Print PAPI and derived stats in 8 columns not 16 (true) */ - GPTLpercent = 9, /* Add a column for percent of first timer (false) */ - GPTLpersec = 10, /* Add a PAPI column that prints "per second" stats (true) */ - GPTLmultiplex = 11, /* Allow PAPI multiplexing (false) */ - GPTLdopr_preamble = 12, /* Print preamble info (true) */ - GPTLdopr_threadsort = 13, /* Print sorted thread stats (true) */ - GPTLdopr_multparent = 14, /* Print multiple parent info (true) */ - GPTLdopr_collision = 15, /* Print hastable collision info (true) */ - GPTLdopr_memusage = 27, /* Call GPTLprint_memusage when auto-instrumented */ - GPTLprint_method = 16, /* Tree print method: first parent, last parent - most frequent, or full tree (most frequent) */ - GPTLtablesize = 50, /* per-thread size of hash table */ - GPTLmaxthreads = 51, /* maximum number of threads */ - /* - ** These are derived counters based on PAPI counters. All default to false - */ - GPTL_IPC = 17, /* Instructions per cycle */ - GPTL_CI = 18, /* Computational intensity */ - GPTL_FPC = 19, /* FP ops per cycle */ - GPTL_FPI = 20, /* FP ops per instruction */ - GPTL_LSTPI = 21, /* Load-store instruction fraction */ - GPTL_DCMRT = 22, /* L1 miss rate (fraction) */ - GPTL_LSTPDCM = 23, /* Load-stores per L1 miss */ - GPTL_L2MRT = 24, /* L2 miss rate (fraction) */ - GPTL_LSTPL2M = 25, /* Load-stores per L2 miss */ - GPTL_L3MRT = 26 /* L3 read miss rate (fraction) */ -} Option; - -/* -** Underlying wallclock timer: optimize for best granularity with least overhead. -** These numbers need not be distinct from the above because these are passed -** to GPTLsetutr() and the above are passed to GPTLsetoption() -*/ - -typedef enum { - GPTLgettimeofday = 1, /* the default */ - GPTLnanotime = 2, /* only available on x86 */ - GPTLmpiwtime = 4, /* MPI_Wtime */ - GPTLclockgettime = 5, /* clock_gettime */ - GPTLpapitime = 6, /* only if PAPI is available */ - GPTLplacebo = 7, /* do-nothing */ - GPTLread_real_time = 3 /* AIX only */ -} Funcoption; - -/* -** How to report parent/child relationships at print time (for children with multiple parents) -*/ - -typedef enum { - GPTLfirst_parent = 1, /* first parent found */ - GPTLlast_parent = 2, /* last parent found */ - GPTLmost_frequent = 3, /* most frequent parent (default) */ - GPTLfull_tree = 4 /* complete call tree */ -} Method; - -/* -** Function prototypes -*/ - -#ifdef __cplusplus -extern "C" { -#endif - -extern int GPTLsetoption (const int, const int); -extern int GPTLinitialize (void); -extern int GPTLstart (const char *); -extern int GPTLinit_handle (const char *, int *); -extern int GPTLstart_handle (const char *, int *); -extern int GPTLstop (const char *); -extern int GPTLstop_handle (const char *, int *); -extern int GPTLstamp (double *, double *, double *); -extern int GPTLpr (const int); -extern int GPTLpr_file (const char *); - -/* -** Use K&R prototype for these 3 because they require MPI -** C++ compilers can encounter problems -*/ -extern int GPTLpr_summary (); -extern int GPTLpr_summary_file (); -extern int GPTLbarrier (); - -extern int GPTLreset (void); -extern int GPTLfinalize (void); -extern int GPTLget_memusage (int *, int *, int *, int *, int *); -extern int GPTLprint_memusage (const char *); -extern int GPTLprint_rusage (const char *); -extern int GPTLenable (void); -extern int GPTLdisable (void); -extern int GPTLsetutr (const int); -extern int GPTLquery (const char *, int, int *, int *, double *, double *, double *, - long long *, const int); -extern int GPTLquerycounters (const char *, int, long long *); -extern int GPTLget_wallclock (const char *, int, double *); -extern int GPTLget_eventvalue (const char *, const char *, int, double *); -extern int GPTLget_nregions (int, int *); -extern int GPTLget_regionname (int, int, char *, int); -extern int GPTL_PAPIlibraryinit (void); -extern int GPTLevent_name_to_code (const char *, int *); -extern int GPTLevent_code_to_name (const int, char *); -extern int GPTLnum_errors (void); -extern int GPTLnum_warn (void); -extern int GPTLget_count (const char *, int, int *); - -#ifdef __cplusplus -}; -#endif - -#endif diff --git a/cesm/models/utils/timing/gptl/gptl.h.template b/cesm/models/utils/timing/gptl/gptl.h.template deleted file mode 100644 index a6cc5c5..0000000 --- a/cesm/models/utils/timing/gptl/gptl.h.template +++ /dev/null @@ -1,136 +0,0 @@ -/* -** $Id: gptl.h.template,v 1.3 2011-03-28 20:55:19 rosinski Exp $ -** -** Author: Jim Rosinski -** -** GPTL header file to be included in user code -*/ - -#ifndef GPTL_H -#define GPTL_H - -/* -** Options settable by a call to GPTLsetoption() (default in parens) -** These numbers need to be small integers because GPTLsetoption can -** be passed PAPI counters, and we need to avoid collisions in that -** integer space. PAPI presets are big negative integers, and PAPI -** native events are big positive integers. -*/ - -typedef enum { - GPTLsync_mpi = #GPTLsync_mpi, /* Synchronize before certain MPI calls (PMPI-mode only) */ - GPTLwall = #GPTLwall, /* Collect wallclock stats (true) */ - GPTLcpu = #GPTLcpu, /* Collect CPU stats (false)*/ - GPTLabort_on_error = #GPTLabort_on_error, /* Abort on failure (false) */ - GPTLoverhead = #GPTLoverhead, /* Estimate overhead of underlying timing routine (true) */ - GPTLdepthlimit = #GPTLdepthlimit, /* Only print timers this depth or less in the tree (inf) */ - GPTLverbose = #GPTLverbose, /* Verbose output (false) */ - GPTLnarrowprint = #GPTLnarrowprint, /* Print PAPI and derived stats in 8 columns not 16 (true) */ - GPTLpercent = #GPTLpercent, /* Add a column for percent of first timer (false) */ - GPTLpersec = #GPTLpersec, /* Add a PAPI column that prints "per second" stats (true) */ - GPTLmultiplex = #GPTLmultiplex, /* Allow PAPI multiplexing (false) */ - GPTLdopr_preamble = #GPTLdopr_preamble, /* Print preamble info (true) */ - GPTLdopr_threadsort = #GPTLdopr_threadsort, /* Print sorted thread stats (true) */ - GPTLdopr_multparent = #GPTLdopr_multparent, /* Print multiple parent info (true) */ - GPTLdopr_collision = #GPTLdopr_collision, /* Print hastable collision info (true) */ - GPTLdopr_memusage = #GPTLdopr_memusage, /* Call GPTLprint_memusage when auto-instrumented */ - GPTLprint_method = #GPTLprint_method, /* Tree print method: first parent, last parent - most frequent, or full tree (most frequent) */ - GPTLtablesize = #GPTLtablesize, /* per-thread size of hash table */ - GPTLmaxthreads = #GPTLmaxthreads, /* maximum number of threads */ - /* - ** These are derived counters based on PAPI counters. All default to false - */ - GPTL_IPC = #GPTL_IPC, /* Instructions per cycle */ - GPTL_CI = #GPTL_CI, /* Computational intensity */ - GPTL_FPC = #GPTL_FPC, /* FP ops per cycle */ - GPTL_FPI = #GPTL_FPI, /* FP ops per instruction */ - GPTL_LSTPI = #GPTL_LSTPI, /* Load-store instruction fraction */ - GPTL_DCMRT = #GPTL_DCMRT, /* L1 miss rate (fraction) */ - GPTL_LSTPDCM = #GPTL_LSTPDCM, /* Load-stores per L1 miss */ - GPTL_L2MRT = #GPTL_L2MRT, /* L2 miss rate (fraction) */ - GPTL_LSTPL2M = #GPTL_LSTPL2M, /* Load-stores per L2 miss */ - GPTL_L3MRT = #GPTL_L3MRT /* L3 read miss rate (fraction) */ -} Option; - -/* -** Underlying wallclock timer: optimize for best granularity with least overhead. -** These numbers need not be distinct from the above because these are passed -** to GPTLsetutr() and the above are passed to GPTLsetoption() -*/ - -typedef enum { - GPTLgettimeofday = #GPTLgettimeofday, /* the default */ - GPTLnanotime = #GPTLnanotime, /* only available on x86 */ - GPTLmpiwtime = #GPTLmpiwtime, /* MPI_Wtime */ - GPTLclockgettime = #GPTLclockgettime, /* clock_gettime */ - GPTLpapitime = #GPTLpapitime, /* only if PAPI is available */ - GPTLplacebo = #GPTLplacebo, /* do-nothing */ - GPTLread_real_time = #GPTLread_real_time /* AIX only */ -} Funcoption; - -/* -** How to report parent/child relationships at print time (for children with multiple parents) -*/ - -typedef enum { - GPTLfirst_parent = #GPTLfirst_parent, /* first parent found */ - GPTLlast_parent = #GPTLlast_parent, /* last parent found */ - GPTLmost_frequent = #GPTLmost_frequent, /* most frequent parent (default) */ - GPTLfull_tree = #GPTLfull_tree /* complete call tree */ -} Method; - -/* -** Function prototypes -*/ - -#ifdef __cplusplus -extern "C" { -#endif - -extern int GPTLsetoption (const int, const int); -extern int GPTLinitialize (void); -extern int GPTLstart (const char *); -extern int GPTLinit_handle (const char *, int *); -extern int GPTLstart_handle (const char *, int *); -extern int GPTLstop (const char *); -extern int GPTLstop_handle (const char *, int *); -extern int GPTLstamp (double *, double *, double *); -extern int GPTLpr (const int); -extern int GPTLpr_file (const char *); - -/* -** Use K&R prototype for these 3 because they require MPI -** C++ compilers can encounter problems -*/ -extern int GPTLpr_summary (); -extern int GPTLpr_summary_file (); -extern int GPTLbarrier (); - -extern int GPTLreset (void); -extern int GPTLfinalize (void); -extern int GPTLget_memusage (int *, int *, int *, int *, int *); -extern int GPTLprint_memusage (const char *); -extern int GPTLprint_rusage (const char *); -extern int GPTLenable (void); -extern int GPTLdisable (void); -extern int GPTLsetutr (const int); -extern int GPTLquery (const char *, int, int *, int *, double *, double *, double *, - long long *, const int); -extern int GPTLquerycounters (const char *, int, long long *); -extern int GPTLget_wallclock (const char *, int, double *); -extern int GPTLget_eventvalue (const char *, const char *, int, double *); -extern int GPTLget_nregions (int, int *); -extern int GPTLget_regionname (int, int, char *, int); -extern int GPTL_PAPIlibraryinit (void); -extern int GPTLevent_name_to_code (const char *, int *); -extern int GPTLevent_code_to_name (const int, char *); -extern int GPTLnum_errors (void); -extern int GPTLnum_warn (void); -extern int GPTLget_count (const char *, int, int *); - -#ifdef __cplusplus -}; -#endif - -#endif diff --git a/cesm/models/utils/timing/gptl/gptl.inc b/cesm/models/utils/timing/gptl/gptl.inc deleted file mode 100644 index aed3300..0000000 --- a/cesm/models/utils/timing/gptl/gptl.inc +++ /dev/null @@ -1,166 +0,0 @@ -! -! $Id: gptl.inc.template,v 1.3 2011-03-28 20:55:19 rosinski Exp $ -! -! Author: Jim Rosinski -! -! GPTL header file to be included in user code. Values match -! their counterparts in gptl.h. See that file or man pages -! or web-based documenation for descriptions of each value -! - integer GPTLsync_mpi - integer GPTLwall - integer GPTLcpu - integer GPTLabort_on_error - integer GPTLoverhead - integer GPTLdepthlimit - integer GPTLverbose - integer GPTLnarrowprint - integer GPTLpercent - integer GPTLpersec - integer GPTLmultiplex - integer GPTLdopr_preamble - integer GPTLdopr_threadsort - integer GPTLdopr_multparent - integer GPTLdopr_collision - integer GPTLdopr_memusage - integer GPTLprint_method - integer GPTLtablesize - integer GPTLmaxthreads - - integer GPTL_IPC - integer GPTL_CI - integer GPTL_FPC - integer GPTL_FPI - integer GPTL_LSTPI - integer GPTL_DCMRT - integer GPTL_LSTPDCM - integer GPTL_L2MRT - integer GPTL_LSTPL2M - integer GPTL_L3MRT - - integer GPTLnanotime - integer GPTLmpiwtime - integer GPTLclockgettime - integer GPTLgettimeofday - integer GPTLpapitime - integer GPTLplacebo - integer GPTLread_real_time - - integer GPTLfirst_parent - integer GPTLlast_parent - integer GPTLmost_frequent - integer GPTLfull_tree - - parameter (GPTLsync_mpi = 0) - parameter (GPTLwall = 1) - parameter (GPTLcpu = 2) - parameter (GPTLabort_on_error = 3) - parameter (GPTLoverhead = 4) - parameter (GPTLdepthlimit = 5) - parameter (GPTLverbose = 6) - parameter (GPTLnarrowprint = 7) - parameter (GPTLpercent = 9) - parameter (GPTLpersec = 10) - parameter (GPTLmultiplex = 11) - parameter (GPTLdopr_preamble = 12) - parameter (GPTLdopr_threadsort= 13) - parameter (GPTLdopr_multparent= 14) - parameter (GPTLdopr_collision = 15) - parameter (GPTLdopr_memusage = 27) - parameter (GPTLprint_method = 16) - parameter (GPTLtablesize = 50) - parameter (GPTLmaxthreads = 51) - - parameter (GPTL_IPC = 17) - parameter (GPTL_CI = 18) - parameter (GPTL_FPC = 19) - parameter (GPTL_FPI = 20) - parameter (GPTL_LSTPI = 21) - parameter (GPTL_DCMRT = 22) - parameter (GPTL_LSTPDCM = 23) - parameter (GPTL_L2MRT = 24) - parameter (GPTL_LSTPL2M = 25) - parameter (GPTL_L3MRT = 26) - - parameter (GPTLgettimeofday = 1) - parameter (GPTLnanotime = 2) - parameter (GPTLmpiwtime = 4) - parameter (GPTLclockgettime = 5) - parameter (GPTLpapitime = 6) - parameter (GPTLplacebo = 7) - parameter (GPTLread_real_time = 3) - - parameter (GPTLfirst_parent = 1) - parameter (GPTLlast_parent = 2) - parameter (GPTLmost_frequent = 3) - parameter (GPTLfull_tree = 4) - -! Externals - - integer gptlsetoption - integer gptlinitialize - integer gptlstart - integer gptlstart_handle - integer gptlinit_handle - integer gptlstop - integer gptlstop_handle - integer gptlstamp - integer gptlpr - integer gptlpr_file - integer gptlpr_summary - integer gptlpr_summary_file - integer gptlbarrier - integer gptlreset - integer gptlfinalize - integer gptlget_memusage - integer gptlprint_memusage - integer gptlprint_rusage - integer gptlenable - integer gptldisable - integer gptlsetutr - integer gptlquery - integer gptlquerycounters - integer gptlget_wallclock - integer gptlget_eventvalue - integer gptlget_nregions - integer gptlget_regionname - integer gptl_papilibraryinit - integer gptlevent_name_to_code - integer gptlevent_code_to_name - integer gptlnum_errors - integer gptlnum_warn - integer gptlget_count - - external gptlsetoption - external gptlinitialize - external gptlstart - external gptlstart_handle - external gptlinit_handle - external gptlstop - external gptlstop_handle - external gptlstamp - external gptlpr - external gptlpr_file - external gptlpr_summary - external gptlpr_summary_file - external gptlbarrier - external gptlreset - external gptlfinalize - external gptlget_memusage - external gptlprint_memusage - external gptlprint_rusage - external gptlenable - external gptldisable - external gptlsetutr - external gptlquery - external gptlquerycounters - external gptlget_wallclock - external gptlget_eventvalue - external gptlget_nregions - external gptlget_regionname - external gptl_papilibraryinit - external gptlevent_name_to_code - external gptlevent_code_to_name - external gptlnum_errors - external gptlnum_warn - external gptlget_count diff --git a/cesm/models/utils/timing/gptl/gptl.inc.template b/cesm/models/utils/timing/gptl/gptl.inc.template deleted file mode 100644 index 8e12c11..0000000 --- a/cesm/models/utils/timing/gptl/gptl.inc.template +++ /dev/null @@ -1,166 +0,0 @@ -! -! $Id: gptl.inc.template,v 1.3 2011-03-28 20:55:19 rosinski Exp $ -! -! Author: Jim Rosinski -! -! GPTL header file to be included in user code. Values match -! their counterparts in gptl.h. See that file or man pages -! or web-based documenation for descriptions of each value -! - integer GPTLsync_mpi - integer GPTLwall - integer GPTLcpu - integer GPTLabort_on_error - integer GPTLoverhead - integer GPTLdepthlimit - integer GPTLverbose - integer GPTLnarrowprint - integer GPTLpercent - integer GPTLpersec - integer GPTLmultiplex - integer GPTLdopr_preamble - integer GPTLdopr_threadsort - integer GPTLdopr_multparent - integer GPTLdopr_collision - integer GPTLdopr_memusage - integer GPTLprint_method - integer GPTLtablesize - integer GPTLmaxthreads - - integer GPTL_IPC - integer GPTL_CI - integer GPTL_FPC - integer GPTL_FPI - integer GPTL_LSTPI - integer GPTL_DCMRT - integer GPTL_LSTPDCM - integer GPTL_L2MRT - integer GPTL_LSTPL2M - integer GPTL_L3MRT - - integer GPTLnanotime - integer GPTLmpiwtime - integer GPTLclockgettime - integer GPTLgettimeofday - integer GPTLpapitime - integer GPTLplacebo - integer GPTLread_real_time - - integer GPTLfirst_parent - integer GPTLlast_parent - integer GPTLmost_frequent - integer GPTLfull_tree - - parameter (GPTLsync_mpi = #GPTLsync_mpi) - parameter (GPTLwall = #GPTLwall) - parameter (GPTLcpu = #GPTLcpu) - parameter (GPTLabort_on_error = #GPTLabort_on_error) - parameter (GPTLoverhead = #GPTLoverhead) - parameter (GPTLdepthlimit = #GPTLdepthlimit) - parameter (GPTLverbose = #GPTLverbose) - parameter (GPTLnarrowprint = #GPTLnarrowprint) - parameter (GPTLpercent = #GPTLpercent) - parameter (GPTLpersec = #GPTLpersec) - parameter (GPTLmultiplex = #GPTLmultiplex) - parameter (GPTLdopr_preamble = #GPTLdopr_preamble) - parameter (GPTLdopr_threadsort= #GPTLdopr_threadsort) - parameter (GPTLdopr_multparent= #GPTLdopr_multparent) - parameter (GPTLdopr_collision = #GPTLdopr_collision) - parameter (GPTLdopr_memusage = #GPTLdopr_memusage) - parameter (GPTLprint_method = #GPTLprint_method) - parameter (GPTLtablesize = #GPTLtablesize) - parameter (GPTLmaxthreads = #GPTLmaxthreads) - - parameter (GPTL_IPC = #GPTL_IPC) - parameter (GPTL_CI = #GPTL_CI) - parameter (GPTL_FPC = #GPTL_FPC) - parameter (GPTL_FPI = #GPTL_FPI) - parameter (GPTL_LSTPI = #GPTL_LSTPI) - parameter (GPTL_DCMRT = #GPTL_DCMRT) - parameter (GPTL_LSTPDCM = #GPTL_LSTPDCM) - parameter (GPTL_L2MRT = #GPTL_L2MRT) - parameter (GPTL_LSTPL2M = #GPTL_LSTPL2M) - parameter (GPTL_L3MRT = #GPTL_L3MRT) - - parameter (GPTLgettimeofday = #GPTLgettimeofday) - parameter (GPTLnanotime = #GPTLnanotime) - parameter (GPTLmpiwtime = #GPTLmpiwtime) - parameter (GPTLclockgettime = #GPTLclockgettime) - parameter (GPTLpapitime = #GPTLpapitime) - parameter (GPTLplacebo = #GPTLplacebo) - parameter (GPTLread_real_time = #GPTLread_real_time) - - parameter (GPTLfirst_parent = #GPTLfirst_parent) - parameter (GPTLlast_parent = #GPTLlast_parent) - parameter (GPTLmost_frequent = #GPTLmost_frequent) - parameter (GPTLfull_tree = #GPTLfull_tree) - -! Externals - - integer gptlsetoption - integer gptlinitialize - integer gptlstart - integer gptlstart_handle - integer gptlinit_handle - integer gptlstop - integer gptlstop_handle - integer gptlstamp - integer gptlpr - integer gptlpr_file - integer gptlpr_summary - integer gptlpr_summary_file - integer gptlbarrier - integer gptlreset - integer gptlfinalize - integer gptlget_memusage - integer gptlprint_memusage - integer gptlprint_rusage - integer gptlenable - integer gptldisable - integer gptlsetutr - integer gptlquery - integer gptlquerycounters - integer gptlget_wallclock - integer gptlget_eventvalue - integer gptlget_nregions - integer gptlget_regionname - integer gptl_papilibraryinit - integer gptlevent_name_to_code - integer gptlevent_code_to_name - integer gptlnum_errors - integer gptlnum_warn - integer gptlget_count - - external gptlsetoption - external gptlinitialize - external gptlstart - external gptlstart_handle - external gptlinit_handle - external gptlstop - external gptlstop_handle - external gptlstamp - external gptlpr - external gptlpr_file - external gptlpr_summary - external gptlpr_summary_file - external gptlbarrier - external gptlreset - external gptlfinalize - external gptlget_memusage - external gptlprint_memusage - external gptlprint_rusage - external gptlenable - external gptldisable - external gptlsetutr - external gptlquery - external gptlquerycounters - external gptlget_wallclock - external gptlget_eventvalue - external gptlget_nregions - external gptlget_regionname - external gptl_papilibraryinit - external gptlevent_name_to_code - external gptlevent_code_to_name - external gptlnum_errors - external gptlnum_warn - external gptlget_count diff --git a/cesm/models/utils/timing/gptl/gptl_papi.c b/cesm/models/utils/timing/gptl/gptl_papi.c deleted file mode 100644 index d67c345..0000000 --- a/cesm/models/utils/timing/gptl/gptl_papi.c +++ /dev/null @@ -1,1267 +0,0 @@ -/* -** $Id: gptl_papi.c,v 1.79 2011-03-28 20:55:19 rosinski Exp $ -** -** Author: Jim Rosinski -** -** Contains routines which interface to PAPI library -*/ - -#include "private.h" -#include "gptl.h" - -#ifdef HAVE_PAPI - -#include -#include -#include -#include - -#if ( defined THREADED_OMP ) -#include -#elif ( defined THREADED_PTHREADS ) -#include -#endif - -/* Mapping of PAPI counters to short and long printed strings */ - -static const Entry papitable [] = { - {PAPI_L1_DCM, "PAPI_L1_DCM", "L1_DCM ", "L1_Dcache_miss ", "Level 1 data cache misses"}, - {PAPI_L1_ICM, "PAPI_L1_ICM", "L1_ICM ", "L1_Icache_miss ", "Level 1 instruction cache misses"}, - {PAPI_L2_DCM, "PAPI_L2_DCM", "L2_DCM ", "L2_Dcache_miss ", "Level 2 data cache misses"}, - {PAPI_L2_ICM, "PAPI_L2_ICM", "L2_ICM ", "L2_Icache_miss ", "Level 2 instruction cache misses"}, - {PAPI_L3_DCM, "PAPI_L3_DCM", "L3_DCM ", "L3_Dcache_miss ", "Level 3 data cache misses"}, - {PAPI_L3_ICM, "PAPI_L3_ICM", "L3_ICM ", "L3_Icache_miss ", "Level 3 instruction cache misses"}, - {PAPI_L1_TCM, "PAPI_L1_TCM", "L1_TCM ", "L1_cache_miss ", "Level 1 total cache misses"}, - {PAPI_L2_TCM, "PAPI_L2_TCM", "L2_TCM ", "L2_cache_miss ", "Level 2 total cache misses"}, - {PAPI_L3_TCM, "PAPI_L3_TCM", "L3_TCM ", "L3_cache_miss ", "Level 3 total cache misses"}, - {PAPI_CA_SNP, "PAPI_CA_SNP", "CA_SNP ", "Snoops ", "Snoops "}, - {PAPI_CA_SHR, "PAPI_CA_SHR", "CA_SHR ", "PAPI_CA_SHR ", "Request for shared cache line (SMP)"}, - {PAPI_CA_CLN, "PAPI_CA_CLN", "CA_CLN ", "PAPI_CA_CLN ", "Request for clean cache line (SMP)"}, - {PAPI_CA_INV, "PAPI_CA_INV", "CA_INV ", "PAPI_CA_INV ", "Request for cache line Invalidation (SMP)"}, - {PAPI_CA_ITV, "PAPI_CA_ITV", "CA_ITV ", "PAPI_CA_ITV ", "Request for cache line Intervention (SMP)"}, - {PAPI_L3_LDM, "PAPI_L3_LDM", "L3_LDM ", "L3_load_misses ", "Level 3 load misses"}, - {PAPI_L3_STM, "PAPI_L3_STM", "L3_STM ", "L3_store_misses ", "Level 3 store misses"}, - {PAPI_BRU_IDL,"PAPI_BRU_IDL","BRU_IDL ", "PAPI_BRU_IDL ", "Cycles branch units are idle"}, - {PAPI_FXU_IDL,"PAPI_FXU_IDL","FXU_IDL ", "PAPI_FXU_IDL ", "Cycles integer units are idle"}, - {PAPI_FPU_IDL,"PAPI_FPU_IDL","FPU_IDL ", "PAPI_FPU_IDL ", "Cycles floating point units are idle"}, - {PAPI_LSU_IDL,"PAPI_LSU_IDL","LSU_IDL ", "PAPI_LSU_IDL ", "Cycles load/store units are idle"}, - {PAPI_TLB_DM, "PAPI_TLB_DM" "TLB_DM ", "Data_TLB_misses ", "Data translation lookaside buffer misses"}, - {PAPI_TLB_IM, "PAPI_TLB_IM", "TLB_IM ", "Inst_TLB_misses ", "Instr translation lookaside buffer misses"}, - {PAPI_TLB_TL, "PAPI_TLB_TL", "TLB_TL ", "Tot_TLB_misses ", "Total translation lookaside buffer misses"}, - {PAPI_L1_LDM, "PAPI_L1_LDM", "L1_LDM ", "L1_load_misses ", "Level 1 load misses"}, - {PAPI_L1_STM, "PAPI_L1_STM", "L1_STM ", "L1_store_misses ", "Level 1 store misses"}, - {PAPI_L2_LDM, "PAPI_L2_LDM", "L2_LDM ", "L2_load_misses ", "Level 2 load misses"}, - {PAPI_L2_STM, "PAPI_L2_STM", "L2_STM ", "L2_store_misses ", "Level 2 store misses"}, - {PAPI_BTAC_M, "PAPI_BTAC_M", "BTAC_M ", "BTAC_miss ", "BTAC miss"}, - {PAPI_PRF_DM, "PAPI_PRF_DM", "PRF_DM ", "PAPI_PRF_DM ", "Prefetch data instruction caused a miss"}, - {PAPI_L3_DCH, "PAPI_L3_DCH", "L3_DCH ", "L3_DCache_Hit ", "Level 3 Data Cache Hit"}, - {PAPI_TLB_SD, "PAPI_TLB_SD", "TLB_SD ", "PAPI_TLB_SD ", "Xlation lookaside buffer shootdowns (SMP)"}, - {PAPI_CSR_FAL,"PAPI_CSR_FAL","CSR_FAL ", "PAPI_CSR_FAL ", "Failed store conditional instructions"}, - {PAPI_CSR_SUC,"PAPI_CSR_SUC","CSR_SUC ", "PAPI_CSR_SUC ", "Successful store conditional instructions"}, - {PAPI_CSR_TOT,"PAPI_CSR_TOT","CSR_TOT ", "PAPI_CSR_TOT ", "Total store conditional instructions"}, - {PAPI_MEM_SCY,"PAPI_MEM_SCY","MEM_SCY ", "Cyc_Stalled_Mem ", "Cycles Stalled Waiting for Memory Access"}, - {PAPI_MEM_RCY,"PAPI_MEM_RCY","MEM_RCY ", "Cyc_Stalled_MemR", "Cycles Stalled Waiting for Memory Read"}, - {PAPI_MEM_WCY,"PAPI_MEM_WCY","MEM_WCY ", "Cyc_Stalled_MemW", "Cycles Stalled Waiting for Memory Write"}, - {PAPI_STL_ICY,"PAPI_STL_ICY","STL_ICY ", "Cyc_no_InstrIss ", "Cycles with No Instruction Issue"}, - {PAPI_FUL_ICY,"PAPI_FUL_ICY","FUL_ICY ", "Cyc_Max_InstrIss", "Cycles with Maximum Instruction Issue"}, - {PAPI_STL_CCY,"PAPI_STL_CCY","STL_CCY ", "Cyc_No_InstrComp", "Cycles with No Instruction Completion"}, - {PAPI_FUL_CCY,"PAPI_FUL_CCY","FUL_CCY ", "Cyc_Max_InstComp", "Cycles with Maximum Instruction Completion"}, - {PAPI_HW_INT, "PAPI_HW_INT", "HW_INT ", "HW_interrupts ", "Hardware interrupts"}, - {PAPI_BR_UCN, "PAPI_BR_UCN", "BR_UCN ", "Uncond_br_instr ", "Unconditional branch instructions executed"}, - {PAPI_BR_CN, "PAPI_BR_CN", "BR_CN ", "Cond_br_instr_ex", "Conditional branch instructions executed"}, - {PAPI_BR_TKN, "PAPI_BR_TKN", "BR_TKN ", "Cond_br_instr_tk", "Conditional branch instructions taken"}, - {PAPI_BR_NTK, "PAPI_BR_NTK", "BR_NTK ", "Cond_br_instrNtk", "Conditional branch instructions not taken"}, - {PAPI_BR_MSP, "PAPI_BR_MSP", "BR_MSP ", "Cond_br_instrMPR", "Conditional branch instructions mispred"}, - {PAPI_BR_PRC, "PAPI_BR_PRC", "BR_PRC ", "Cond_br_instrCPR", "Conditional branch instructions corr. pred"}, - {PAPI_FMA_INS,"PAPI_FMA_INS","FMA_INS ", "FMA_instr_comp ", "FMA instructions completed"}, - {PAPI_TOT_IIS,"PAPI_TOT_IIS","TOT_IIS ", "Total_instr_iss ", "Total instructions issued"}, - {PAPI_TOT_INS,"PAPI_TOT_INS","TOT_INS ", "Total_instr_ex ", "Total instructions executed"}, - {PAPI_INT_INS,"PAPI_INT_INS","INT_INS ", "Int_instr_ex ", "Integer instructions executed"}, - {PAPI_FP_INS, "PAPI_FP_INS", "FP_INS ", "FP_instr_ex ", "Floating point instructions executed"}, - {PAPI_LD_INS, "PAPI_LD_INS", "LD_INS ", "Load_instr_ex ", "Load instructions executed"}, - {PAPI_SR_INS, "PAPI_SR_INS", "SR_INS ", "Store_instr_ex ", "Store instructions executed"}, - {PAPI_BR_INS, "PAPI_BR_INS", "BR_INS ", "br_instr_ex ", "Total branch instructions executed"}, - {PAPI_VEC_INS,"PAPI_VEC_INS","VEC_INS ", "Vec/SIMD_instrEx", "Vector/SIMD instructions executed"}, - {PAPI_RES_STL,"PAPI_RES_STL","RES_STL ", "Cyc_proc_stalled", "Cycles processor is stalled on resource"}, - {PAPI_FP_STAL,"PAPI_FP_STAL","FP_STAL ", "Cyc_any_FP_stall", "Cycles any FP units are stalled"}, - {PAPI_TOT_CYC,"PAPI_TOT_CYC","TOT_CYC ", "Total_cycles ", "Total cycles"}, - {PAPI_LST_INS,"PAPI_LST_INS","LST_INS ", "Tot_L/S_inst_ex ", "Total load/store inst. executed"}, - {PAPI_SYC_INS,"PAPI_SYC_INS","SYC_INS ", "Sync._inst._ex ", "Sync. inst. executed"}, - {PAPI_L1_DCH, "PAPI_L1_DCH", "L1_DCH ", "L1_D_Cache_Hit ", "L1 D Cache Hit"}, - {PAPI_L2_DCH, "PAPI_L2_DCH", "L2_DCH ", "L2_D_Cache_Hit ", "L2 D Cache Hit"}, - {PAPI_L1_DCA, "PAPI_L1_DCA", "L1_DCA ", "L1_D_Cache_Acc ", "L1 D Cache Access"}, - {PAPI_L2_DCA, "PAPI_L2_DCA", "L2_DCA ", "L2_D_Cache_Acc ", "L2 D Cache Access"}, - {PAPI_L3_DCA, "PAPI_L3_DCA", "L3_DCA ", "L3_D_Cache_Acc ", "L3 D Cache Access"}, - {PAPI_L1_DCR, "PAPI_L1_DCR", "L1_DCR ", "L1_D_Cache_Read ", "L1 D Cache Read"}, - {PAPI_L2_DCR, "PAPI_L2_DCR", "L2_DCR ", "L2_D_Cache_Read ", "L2 D Cache Read"}, - {PAPI_L3_DCR, "PAPI_L3_DCR", "L3_DCR ", "L3_D_Cache_Read ", "L3 D Cache Read"}, - {PAPI_L1_DCW, "PAPI_L1_DCW", "L1_DCW ", "L1_D_Cache_Write", "L1 D Cache Write"}, - {PAPI_L2_DCW, "PAPI_L2_DCW", "L2_DCW ", "L2_D_Cache_Write", "L2 D Cache Write"}, - {PAPI_L3_DCW, "PAPI_L3_DCW", "L3_DCW ", "L3_D_Cache_Write", "L3 D Cache Write"}, - {PAPI_L1_ICH, "PAPI_L1_ICH", "L1_ICH ", "L1_I_cache_hits ", "L1 instruction cache hits"}, - {PAPI_L2_ICH, "PAPI_L2_ICH", "L2_ICH ", "L2_I_cache_hits ", "L2 instruction cache hits"}, - {PAPI_L3_ICH, "PAPI_L3_ICH", "L3_ICH ", "L3_I_cache_hits ", "L3 instruction cache hits"}, - {PAPI_L1_ICA, "PAPI_L1_ICA", "L1_ICA ", "L1_I_cache_acc ", "L1 instruction cache accesses"}, - {PAPI_L2_ICA, "PAPI_L2_ICA", "L2_ICA ", "L2_I_cache_acc ", "L2 instruction cache accesses"}, - {PAPI_L3_ICA, "PAPI_L3_ICA", "L3_ICA ", "L3_I_cache_acc ", "L3 instruction cache accesses"}, - {PAPI_L1_ICR, "PAPI_L1_ICR", "L1_ICR ", "L1_I_cache_reads", "L1 instruction cache reads"}, - {PAPI_L2_ICR, "PAPI_L2_ICR", "L2_ICR ", "L2_I_cache_reads", "L2 instruction cache reads"}, - {PAPI_L3_ICR, "PAPI_L3_ICR", "L3_ICR ", "L3_I_cache_reads", "L3 instruction cache reads"}, - {PAPI_L1_ICW, "PAPI_L1_ICW", "L1_ICW ", "L1_I_cache_write", "L1 instruction cache writes"}, - {PAPI_L2_ICW, "PAPI_L2_ICW", "L2_ICW ", "L2_I_cache_write", "L2 instruction cache writes"}, - {PAPI_L3_ICW, "PAPI_L3_ICW", "L3_ICW ", "L3_I_cache_write", "L3 instruction cache writes"}, - {PAPI_L1_TCH, "PAPI_L1_TCH", "L1_TCH ", "L1_cache_hits ", "L1 total cache hits"}, - {PAPI_L2_TCH, "PAPI_L2_TCH", "L2_TCH ", "L2_cache_hits ", "L2 total cache hits"}, - {PAPI_L3_TCH, "PAPI_L3_TCH", "L3_TCH ", "L3_cache_hits ", "L3 total cache hits"}, - {PAPI_L1_TCA, "PAPI_L1_TCA", "L1_TCA ", "L1_cache_access ", "L1 total cache accesses"}, - {PAPI_L2_TCA, "PAPI_L2_TCA", "L2_TCA ", "L2_cache_access ", "L2 total cache accesses"}, - {PAPI_L3_TCA, "PAPI_L3_TCA", "L3_TCA ", "L3_cache_access ", "L3 total cache accesses"}, - {PAPI_L1_TCR, "PAPI_L1_TCR", "L1_TCR ", "L1_cache_reads ", "L1 total cache reads"}, - {PAPI_L2_TCR, "PAPI_L2_TCR", "L2_TCR ", "L2_cache_reads ", "L2 total cache reads"}, - {PAPI_L3_TCR, "PAPI_L3_TCR", "L3_TCR ", "L3_cache_reads ", "L3 total cache reads"}, - {PAPI_L1_TCW, "PAPI_L1_TCW", "L1_TCW ", "L1_cache_writes ", "L1 total cache writes"}, - {PAPI_L2_TCW, "PAPI_L2_TCW", "L2_TCW ", "L2_cache_writes ", "L2 total cache writes"}, - {PAPI_L3_TCW, "PAPI_L3_TCW", "L3_TCW ", "L3_cache_writes ", "L3 total cache writes"}, - {PAPI_FML_INS,"PAPI_FML_INS","FML_INS ", "FM_ins ", "FM ins"}, - {PAPI_FAD_INS,"PAPI_FAD_INS","FAD_INS ", "FA_ins ", "FA ins"}, - {PAPI_FDV_INS,"PAPI_FDV_INS","FDV_INS ", "FD_ins ", "FD ins"}, - {PAPI_FSQ_INS,"PAPI_FSQ_INS","FSQ_INS ", "FSq_ins ", "FSq ins"}, - {PAPI_FNV_INS,"PAPI_FNV_INS","FNV_INS ", "Finv_ins ", "Finv ins"}, - {PAPI_FP_OPS, "PAPI_FP_OPS", "FP_OPS ", "FP_ops_executed ", "Floating point operations executed"} -}; - -static const int npapientries = sizeof (papitable) / sizeof (Entry); -static int papieventlist[MAX_AUX]; /* list of PAPI events to be counted */ -static Pr_event pr_event[MAX_AUX]; /* list of events (PAPI or derived) */ - -/* Derived events */ -static const Entry derivedtable [] = { - {GPTL_IPC, "GPTL_IPC", "IPC ", "Instr_per_cycle ", "Instructions per cycle"}, - {GPTL_CI, "GPTL_CI", "CI ", "Comp_Intensity ", "Computational intensity"}, - {GPTL_FPC, "GPTL_FPC", "Flop/Cyc", "FP_Ops_per_cycle", "Floating point ops per cycle"}, - {GPTL_FPI, "GPTL_FPI", "Flop/Ins", "FP_Ops_per_instr", "Floating point ops per instruction"}, - {GPTL_LSTPI, "GPTL_LSTPI", "LST_frac", "LST_fraction ", "Load-store instruction fraction"}, - {GPTL_DCMRT, "GPTL_DCMRT", "DCMISRAT", "L1_Miss_Rate ", "L1 miss rate (fraction)"}, - {GPTL_LSTPDCM,"GPTL_LSTPDCM", "LSTPDCM ", "LST_per_L1_miss ", "Load-store instructions per L1 miss"}, - {GPTL_L2MRT, "GPTL_L2MRT", "L2MISRAT", "L2_Miss_Rate ", "L2 miss rate (fraction)"}, - {GPTL_LSTPL2M,"GPTL_LSTPL2M", "LSTPL2M ", "LST_per_L2_miss ", "Load-store instructions per L2 miss"}, - {GPTL_L3MRT, "GPTL_L3MRT", "L3MISRAT", "L3_Miss_Rate ", "L3 read miss rate (fraction)"} -}; -static const int nderivedentries = sizeof (derivedtable) / sizeof (Entry); - -static int npapievents = 0; /* number of PAPI events: initialize to 0 */ -static int nevents = 0; /* number of events: initialize to 0 */ -static int *EventSet; /* list of events to be counted by PAPI */ -static long_long **papicounters; /* counters returned from PAPI */ - -static const int BADCOUNT = -999999; /* Set counters to this when they are bad */ -static bool is_multiplexed = false; /* whether multiplexed (always start false)*/ -static bool narrowprint = true; /* only use 8 digits not 16 for counter prints */ -static bool persec = true; /* print PAPI stats per second */ -static bool enable_multiplexing = false; /* whether to try multiplexing */ -static bool verbose = false; /* output verbosity */ - -/* Function prototypes */ - -static int canenable (int); -static int canenable2 (int, int); -static int papievent_is_enabled (int); -static int already_enabled (int); -static int enable (int); -static int getderivedidx (int); - -/* -** GPTL_PAPIsetoption: enable or disable PAPI event defined by "counter". Called -** from GPTLsetoption. Since all events are off by default, val=false degenerates -** to a no-op. Coded this way to be consistent with the rest of GPTL -** -** Input args: -** counter: PAPI counter -** val: true or false for enable or disable -** -** Return value: 0 (success) or GPTLerror (failure) -*/ - -int GPTL_PAPIsetoption (const int counter, /* PAPI counter (or option) */ - const int val) /* true or false for enable or disable */ -{ - int n; /* loop index */ - int ret; /* return code */ - int numidx; /* numerator index */ - int idx; /* derived counter index */ - char eventname[PAPI_MAX_STR_LEN]; /* returned from PAPI_event_code_to_name */ - static const char *thisfunc = "GPTL_PAPIsetoption"; - - /* - ** First, check for option which is not an actual counter - */ - switch (counter) { - case GPTLverbose: - /* don't printf here--that'd duplicate what's in gptl.c */ - verbose = (bool) val; - return 0; - case GPTLmultiplex: - enable_multiplexing = (bool) val; - if (verbose) - printf ("%s: boolean enable_multiplexing = %d\n", thisfunc, val); - return 0; - case GPTLnarrowprint: - narrowprint = (bool) val; - if (verbose) - printf ("%s: boolean narrowprint = %d\n", thisfunc, val); - return 0; - case GPTLpersec: - persec = (bool) val; - if (verbose) - printf ("%s: boolean persec = %d\n", thisfunc, val); - return 0; - default: - break; - } - - /* - ** If val is false, return an error if the event has already been enabled. - ** Otherwise just warn that attempting to disable a PAPI-based event - ** that has already been enabled doesn't work--for now it's just a no-op - */ - if (! val) { - if (already_enabled (counter)) - return GPTLerror ("%s: already enabled counter %d cannot be disabled\n", thisfunc, counter); - else - if (verbose) - printf ("%s: 'disable' %d currently is just a no-op\n", thisfunc, counter); - return 0; - } - - /* If the event has already been enabled for printing, exit */ - if (already_enabled (counter)) - return GPTLerror ("%s: counter %d has already been enabled\n", thisfunc, counter); - - /* - ** Initialize PAPI if it hasn't already been done. - ** From here on down we can assume the intent is to enable (not disable) an option - */ - if (GPTL_PAPIlibraryinit () < 0) - return GPTLerror ("%s: PAPI library init error\n", thisfunc); - - /* Ensure max nevents won't be exceeded */ - if (nevents+1 > MAX_AUX) - return GPTLerror ("%s: %d is too many events. Value defined in private.h\n", thisfunc, nevents+1); - - /* Check derived events */ - switch (counter) { - case GPTL_IPC: - if ( ! canenable2 (PAPI_TOT_INS, PAPI_TOT_CYC)) - return GPTLerror ("%s: GPTL_IPC unavailable\n", thisfunc); - - idx = getderivedidx (GPTL_IPC); - pr_event[nevents].event = derivedtable[idx]; - pr_event[nevents].numidx = enable (PAPI_TOT_INS); - pr_event[nevents].denomidx = enable (PAPI_TOT_CYC); - if (verbose) - printf ("%s: enabling derived event %s = PAPI_TOT_INS / PAPI_TOT_CYC\n", - thisfunc, pr_event[nevents].event.namestr); - ++nevents; - return 0; - case GPTL_CI: - idx = getderivedidx (GPTL_CI); - if (canenable2 (PAPI_FP_OPS, PAPI_LST_INS)) { - pr_event[nevents].event = derivedtable[idx]; - pr_event[nevents].numidx = enable (PAPI_FP_OPS); - pr_event[nevents].denomidx = enable (PAPI_LST_INS); - if (verbose) - printf ("%s: enabling derived event %s = PAPI_FP_OPS / PAPI_LST_INS\n", - thisfunc, pr_event[nevents].event.namestr); - } else if (canenable2 (PAPI_FP_OPS, PAPI_L1_DCA)) { - pr_event[nevents].event = derivedtable[idx]; - pr_event[nevents].numidx = enable (PAPI_FP_OPS); - pr_event[nevents].denomidx = enable (PAPI_L1_DCA); -#ifdef DEBUG - printf ("%s: pr_event %d is derived and will be PAPI event %d / %d\n", - thisfunc, nevents, pr_event[nevents].numidx, pr_event[nevents].denomidx); -#endif - if (verbose) - printf ("%s: enabling derived event %s = PAPI_FP_OPS / PAPI_L1_DCA\n", - thisfunc, pr_event[nevents].event.namestr); - } else { - return GPTLerror ("%s: GPTL_CI unavailable\n", thisfunc); - } - ++nevents; - return 0; - case GPTL_FPC: - if ( ! canenable2 (PAPI_FP_OPS, PAPI_TOT_CYC)) - return GPTLerror ("%s: GPTL_FPC unavailable\n", thisfunc); - - idx = getderivedidx (GPTL_FPC); - pr_event[nevents].event = derivedtable[idx]; - pr_event[nevents].numidx = enable (PAPI_FP_OPS); - pr_event[nevents].denomidx = enable (PAPI_TOT_CYC); - if (verbose) - printf ("%s: enabling derived event %s = PAPI_FP_OPS / PAPI_TOT_CYC\n", - thisfunc, pr_event[nevents].event.namestr); - ++nevents; - return 0; - case GPTL_FPI: - if ( ! canenable2 (PAPI_FP_OPS, PAPI_TOT_INS)) - return GPTLerror ("%s: GPTL_FPI unavailable\n", thisfunc); - - idx = getderivedidx (GPTL_FPI); - pr_event[nevents].event = derivedtable[idx]; - pr_event[nevents].numidx = enable (PAPI_FP_OPS); - pr_event[nevents].denomidx = enable (PAPI_TOT_INS); - if (verbose) - printf ("%s: enabling derived event %s = PAPI_FP_OPS / PAPI_TOT_INS\n", - thisfunc, pr_event[nevents].event.namestr); - ++nevents; - return 0; - case GPTL_LSTPI: - idx = getderivedidx (GPTL_LSTPI); - if (canenable2 (PAPI_LST_INS, PAPI_TOT_INS)) { - pr_event[nevents].event = derivedtable[idx]; - pr_event[nevents].numidx = enable (PAPI_LST_INS); - pr_event[nevents].denomidx = enable (PAPI_TOT_INS); - if (verbose) - printf ("%s: enabling derived event %s = PAPI_LST_INS / PAPI_TOT_INS\n", - thisfunc, pr_event[nevents].event.namestr); - } else if (canenable2 (PAPI_L1_DCA, PAPI_TOT_INS)) { - pr_event[nevents].event = derivedtable[idx]; - pr_event[nevents].numidx = enable (PAPI_L1_DCA); - pr_event[nevents].denomidx = enable (PAPI_TOT_INS); - if (verbose) - printf ("%s: enabling derived event %s = PAPI_L1_DCA / PAPI_TOT_INS\n", - thisfunc, pr_event[nevents].event.namestr); - } else { - return GPTLerror ("%s: GPTL_LSTPI unavailable\n", thisfunc); - } - ++nevents; - return 0; - case GPTL_DCMRT: - if ( ! canenable2 (PAPI_L1_DCM, PAPI_L1_DCA)) - return GPTLerror ("%s: GPTL_DCMRT unavailable\n", thisfunc); - - idx = getderivedidx (GPTL_DCMRT); - pr_event[nevents].event = derivedtable[idx]; - pr_event[nevents].numidx = enable (PAPI_L1_DCM); - pr_event[nevents].denomidx = enable (PAPI_L1_DCA); - if (verbose) - printf ("%s: enabling derived event %s = PAPI_L1_DCM / PAPI_L1_DCA\n", - thisfunc, pr_event[nevents].event.namestr); - ++nevents; - return 0; - case GPTL_LSTPDCM: - idx = getderivedidx (GPTL_LSTPDCM); - if (canenable2 (PAPI_LST_INS, PAPI_L1_DCM)) { - pr_event[nevents].event = derivedtable[idx]; - pr_event[nevents].numidx = enable (PAPI_LST_INS); - pr_event[nevents].denomidx = enable (PAPI_L1_DCM); - if (verbose) - printf ("%s: enabling derived event %s = PAPI_LST_INS / PAPI_L1_DCM\n", - thisfunc, pr_event[nevents].event.namestr); - } else if (canenable2 (PAPI_L1_DCA, PAPI_L1_DCM)) { - pr_event[nevents].event = derivedtable[idx]; - pr_event[nevents].numidx = enable (PAPI_L1_DCA); - pr_event[nevents].denomidx = enable (PAPI_L1_DCM); - if (verbose) - printf ("%s: enabling derived event %s = PAPI_L1_DCA / PAPI_L1_DCM\n", - thisfunc, pr_event[nevents].event.namestr); - } else { - return GPTLerror ("%s: GPTL_LSTPDCM unavailable\n", thisfunc); - } - ++nevents; - return 0; - /* - ** For L2 counts, use TC* instead of DC* to avoid PAPI derived events - */ - case GPTL_L2MRT: - if ( ! canenable2 (PAPI_L2_TCM, PAPI_L2_TCA)) - return GPTLerror ("%s: GPTL_L2MRT unavailable\n", thisfunc); - - idx = getderivedidx (GPTL_L2MRT); - pr_event[nevents].event = derivedtable[idx]; - pr_event[nevents].numidx = enable (PAPI_L2_TCM); - pr_event[nevents].denomidx = enable (PAPI_L2_TCA); - if (verbose) - printf ("%s: enabling derived event %s = PAPI_L2_TCM / PAPI_L2_TCA\n", - thisfunc, pr_event[nevents].event.namestr); - ++nevents; - return 0; - case GPTL_LSTPL2M: - idx = getderivedidx (GPTL_LSTPL2M); - if (canenable2 (PAPI_LST_INS, PAPI_L2_TCM)) { - pr_event[nevents].event = derivedtable[idx]; - pr_event[nevents].numidx = enable (PAPI_LST_INS); - pr_event[nevents].denomidx = enable (PAPI_L2_TCM); - if (verbose) - printf ("%s: enabling derived event %s = PAPI_LST_INS / PAPI_L2_TCM\n", - thisfunc, pr_event[nevents].event.namestr); - } else if (canenable2 (PAPI_L1_DCA, PAPI_L2_TCM)) { - pr_event[nevents].event = derivedtable[idx]; - pr_event[nevents].numidx = enable (PAPI_L1_DCA); - pr_event[nevents].denomidx = enable (PAPI_L2_TCM); - if (verbose) - printf ("%s: enabling derived event %s = PAPI_L1_DCA / PAPI_L2_TCM\n", - thisfunc, pr_event[nevents].event.namestr); - } else { - return GPTLerror ("%s: GPTL_LSTPL2M unavailable\n", thisfunc); - } - ++nevents; - return 0; - case GPTL_L3MRT: - if ( ! canenable2 (PAPI_L3_TCM, PAPI_L3_TCR)) - return GPTLerror ("%s: GPTL_L3MRT unavailable\n", thisfunc); - - idx = getderivedidx (GPTL_L3MRT); - pr_event[nevents].event = derivedtable[idx]; - pr_event[nevents].numidx = enable (PAPI_L3_TCM); - pr_event[nevents].denomidx = enable (PAPI_L3_TCR); - if (verbose) - printf ("%s: enabling derived event %s = PAPI_L3_TCM / PAPI_L3_TCR\n", - thisfunc, pr_event[nevents].event.namestr); - ++nevents; - return 0; - default: - break; - } - - /* Check PAPI presets */ - for (n = 0; n < npapientries; n++) { - if (counter == papitable[n].counter) { - if ((numidx = papievent_is_enabled (counter)) >= 0) { - pr_event[nevents].event = papitable[n]; - pr_event[nevents].numidx = numidx; - pr_event[nevents].denomidx = -1; /* flag says not derived (no denominator) */ - } else if (canenable (counter)) { - pr_event[nevents].event = papitable[n]; - pr_event[nevents].numidx = enable (counter); - pr_event[nevents].denomidx = -1; /* flag says not derived (no denominator) */ - } else { - return GPTLerror ("%s: Can't enable event \n", thisfunc, papitable[n].longstr); - } - if (verbose) - printf ("%s: enabling PAPI preset event %s\n", thisfunc, pr_event[nevents].event.namestr); - ++nevents; - return 0; - } - } - - /* - ** Check native events last: If PAPI_event_code_to_name fails, give up - */ - if ((ret = PAPI_event_code_to_name (counter, eventname)) != PAPI_OK) - return GPTLerror ("%s: name not found for counter %d: PAPI_strerror: %s\n", - thisfunc, counter, PAPI_strerror (ret)); - - /* - ** A table with predefined names of various lengths does not exist for - ** native events. Just truncate eventname. - */ - if ((numidx = papievent_is_enabled (counter)) >= 0) { - pr_event[nevents].event.counter = counter; - - pr_event[nevents].event.namestr = (char *) GPTLallocate (12+1, thisfunc); - strncpy (pr_event[nevents].event.namestr, eventname, 12); - pr_event[nevents].event.namestr[12] = '\0'; - - pr_event[nevents].event.str16 = (char *) GPTLallocate (16+1, thisfunc); - strncpy (pr_event[nevents].event.str16, eventname, 16); - pr_event[nevents].event.str16[16] = '\0'; - - pr_event[nevents].event.longstr = (char *) GPTLallocate (PAPI_MAX_STR_LEN, thisfunc); - strncpy (pr_event[nevents].event.longstr, eventname, PAPI_MAX_STR_LEN); - - pr_event[nevents].numidx = numidx; - pr_event[nevents].denomidx = -1; /* flag says not derived (no denominator) */ - } else if (canenable (counter)) { - pr_event[nevents].event.counter = counter; - - pr_event[nevents].event.namestr = (char *) GPTLallocate (12+1, thisfunc); - strncpy (pr_event[nevents].event.namestr, eventname, 12); - pr_event[nevents].event.namestr[12] = '\0'; - - pr_event[nevents].event.str16 = (char *) GPTLallocate (16+1, thisfunc); - strncpy (pr_event[nevents].event.str16, eventname, 16); - pr_event[nevents].event.str16[16] = '\0'; - - pr_event[nevents].event.longstr = (char *) GPTLallocate (PAPI_MAX_STR_LEN, thisfunc); - strncpy (pr_event[nevents].event.longstr, eventname, PAPI_MAX_STR_LEN); - - pr_event[nevents].numidx = enable (counter); - pr_event[nevents].denomidx = -1; /* flag says not derived (no denominator) */ - } else { - return GPTLerror ("%s: Can't enable event %s\n", thisfunc, eventname); - } - - if (verbose) - printf ("%s: enabling native event %s\n", thisfunc, pr_event[nevents].event.longstr); - - ++nevents; - return 0; -} - -/* -** canenable: determine whether a PAPI counter can be enabled -** -** Input args: -** counter: PAPI counter -** -** Return value: 0 (success) or non-zero (failure) -*/ -int canenable (int counter) -{ - char eventname[PAPI_MAX_STR_LEN]; /* returned from PAPI_event_code_to_name */ - - if (npapievents+1 > MAX_AUX) - return false; - - if (PAPI_query_event (counter) != PAPI_OK) { - (void) PAPI_event_code_to_name (counter, eventname); - fprintf (stderr, "GPTL: canenable: event %s not available on this arch\n", eventname); - return false; - } - - return true; -} - -/* -** canenable2: determine whether 2 PAPI counters can be enabled -** -** Input args: -** counter1: PAPI counter -** counter2: PAPI counter -** -** Return value: 0 (success) or non-zero (failure) -*/ -int canenable2 (int counter1, int counter2) -{ - char eventname[PAPI_MAX_STR_LEN]; /* returned from PAPI_event_code_to_name */ - - if (npapievents+2 > MAX_AUX) - return false; - - if (PAPI_query_event (counter1) != PAPI_OK) { - (void) PAPI_event_code_to_name (counter1, eventname); - return false; - } - - if (PAPI_query_event (counter2) != PAPI_OK) { - (void) PAPI_event_code_to_name (counter2, eventname); - return false; - } - - return true; -} - -/* -** papievent_is_enabled: determine whether a PAPI counter has already been -** enabled. Used internally to keep track of PAPI counters enabled. A given -** PAPI counter may occur in the computation of multiple derived events, as -** well as output directly. E.g. PAPI_FP_OPS is used to compute -** computational intensity, and floating point ops per instruction. -** -** Input args: -** counter: PAPI counter -** -** Return value: index into papieventlist (success) or negative (not found) -*/ -int papievent_is_enabled (int counter) -{ - int n; - - for (n = 0; n < npapievents; ++n) - if (papieventlist[n] == counter) - return n; - return -1; -} - -/* -** already_enabled: determine whether a PAPI-based event has already been -** enabled for printing. -** -** Input args: -** counter: PAPI or derived counter -** -** Return value: 1 (true) or 0 (false) -*/ -int already_enabled (int counter) -{ - int n; - - for (n = 0; n < nevents; ++n) - if (pr_event[n].event.counter == counter) - return 1; - return 0; -} - -/* -** enable: enable a PAPI event. ASSUMES that canenable() has already determined -** that the event can be enabled. -** -** Input args: -** counter: PAPI counter -** -** Return value: index into papieventlist -*/ -int enable (int counter) -{ - int n; - - /* If the event is already enabled, return its index */ - for (n = 0; n < npapievents; ++n) { - if (papieventlist[n] == counter) { -#ifdef DEBUG - printf ("GPTL: enable: PAPI event %d is %d\n", n, counter); -#endif - return n; - } - } - - /* New event */ - papieventlist[npapievents++] = counter; - return npapievents-1; -} - -/* -** getderivedidx: find the table index of a derived counter -** -** Input args: -** counter: derived counter -** -** Return value: index into derivedtable (success) or GPTLerror (failure) -*/ -int getderivedidx (int dcounter) -{ - int n; - - for (n = 0; n < nderivedentries; ++n) { - if (derivedtable[n].counter == dcounter) - return n; - } - return GPTLerror ("GPTL: getderivedidx: failed to find derived counter %d\n", dcounter); -} - -/* -** GPTL_PAPIlibraryinit: Call PAPI_library_init if necessary -** -** Return value: 0 (success) or GPTLerror (failure) -*/ -int GPTL_PAPIlibraryinit () -{ - int ret; - static const char *thisfunc = "GPTL_PAPIlibraryinit"; - - if ((ret = PAPI_is_initialized ()) == PAPI_NOT_INITED) { - if ((ret = PAPI_library_init (PAPI_VER_CURRENT)) != PAPI_VER_CURRENT) { - fprintf (stderr, "%s: ret=%d PAPI_VER_CURRENT=%d\n", thisfunc, ret, (int) PAPI_VER_CURRENT); - return GPTLerror ("%s: PAPI_library_init failure:%s\n", thisfunc, PAPI_strerror (ret)); - } - } - return 0; -} - -/* -** GPTL_PAPIinitialize(): Initialize the PAPI interface. Called from GPTLinitialize. -** PAPI_library_init must be called before any other PAPI routines. -** PAPI_thread_init is called subsequently if threading is enabled. -** Finally, allocate space for PAPI counters and start them. -** -** Input args: -** maxthreads: number of threads -** -** Return value: 0 (success) or GPTLerror or -1 (failure) -*/ -int GPTL_PAPIinitialize (const int maxthreads, /* number of threads */ - const bool verbose_flag, /* output verbosity */ - int *nevents_out, /* nevents needed by gptl.c */ - Entry *pr_event_out) /* events needed by gptl.c */ -{ - int ret; /* return code */ - int n; /* loop index */ - int t; /* thread index */ - static const char *thisfunc = "GPTL_PAPIinitialize"; - - verbose = verbose_flag; - - if (maxthreads < 1) - return GPTLerror ("%s: maxthreads = %d\n", thisfunc, maxthreads); - - /* Ensure that PAPI_library_init has already been called */ - if ((ret = GPTL_PAPIlibraryinit ()) < 0) - return GPTLerror ("%s: GPTL_PAPIlibraryinit failure\n", thisfunc); - - /* PAPI_thread_init needs to be called if threading enabled */ - -#if ( defined THREADED_OMP ) - if (PAPI_thread_init ((unsigned long (*)(void)) (omp_get_thread_num)) != PAPI_OK) - return GPTLerror ("%s: PAPI_thread_init failure\n", thisfunc); -#elif ( defined THREADED_PTHREADS ) - if (PAPI_thread_init ((unsigned long (*)(void)) (pthread_self)) != PAPI_OK) - return GPTLerror ("%s: PAPI_thread_init failure\n", thisfunc); -#endif - - /* allocate and initialize static local space */ - EventSet = (int *) GPTLallocate (maxthreads * sizeof (int), thisfunc); - papicounters = (long_long **) GPTLallocate (maxthreads * sizeof (long_long *), thisfunc); - - for (t = 0; t < maxthreads; t++) { - EventSet[t] = PAPI_NULL; - papicounters[t] = (long_long *) GPTLallocate (MAX_AUX * sizeof (long_long), thisfunc); - } - - *nevents_out = nevents; - for (n = 0; n < nevents; ++n) { - pr_event_out[n].counter = pr_event[n].event.counter; - pr_event_out[n].namestr = pr_event[n].event.namestr; - pr_event_out[n].str8 = pr_event[n].event.str8; - pr_event_out[n].str16 = pr_event[n].event.str16; - pr_event_out[n].longstr = pr_event[n].event.longstr; - } - return 0; -} - -/* -** GPTLcreate_and_start_events: Create and start the PAPI eventset. -** Threaded routine to create the "event set" (PAPI terminology) and start -** the counters. This is only done once, and is called from get_thread_num -** for the first time for the thread. -** -** Input args: -** t: thread number -** -** Return value: 0 (success) or GPTLerror (failure) -*/ -int GPTLcreate_and_start_events (const int t) /* thread number */ -{ - int ret; /* return code */ - int n; /* loop index over events */ - char eventname[PAPI_MAX_STR_LEN]; /* returned from PAPI_event_code_to_name */ - static const char *thisfunc = "GPTLcreate_and_start_events"; - - /* - ** Set the domain to count all contexts. Only needs to be set once for all threads - */ - if ((ret = PAPI_set_domain (PAPI_DOM_ALL)) != PAPI_OK) - return GPTLerror ("%s: thread %d failure setting PAPI domain: %s\n", - thisfunc, t, PAPI_strerror (ret)); - - /* Create the event set */ - if ((ret = PAPI_create_eventset (&EventSet[t])) != PAPI_OK) - return GPTLerror ("%s: thread %d failure creating eventset: %s\n", - thisfunc, t, PAPI_strerror (ret)); - - if (verbose) - printf ("%s: successfully created eventset for thread %d\n", thisfunc, t); - - /* Add requested events to the event set */ - for (n = 0; n < npapievents; n++) { - if ((ret = PAPI_add_event (EventSet[t], papieventlist[n])) != PAPI_OK) { - if (verbose) { - fprintf (stderr, "%s\n", PAPI_strerror (ret)); - ret = PAPI_event_code_to_name (papieventlist[n], eventname); - fprintf (stderr, "%s: failure adding event:%s\n", thisfunc, eventname); - } - - if (enable_multiplexing) { - if (verbose) - printf ("Trying multiplexing...\n"); - is_multiplexed = true; - break; - } else - return GPTLerror ("enable_multiplexing is false: giving up\n"); - } - } - - if (is_multiplexed) { - - /* Cleanup the eventset for multiplexing */ - if ((ret = PAPI_cleanup_eventset (EventSet[t])) != PAPI_OK) - return GPTLerror ("%s: %s\n", thisfunc, PAPI_strerror (ret)); - - if ((ret = PAPI_destroy_eventset (&EventSet[t])) != PAPI_OK) - return GPTLerror ("%s: %s\n", thisfunc, PAPI_strerror (ret)); - - if ((ret = PAPI_create_eventset (&EventSet[t])) != PAPI_OK) - return GPTLerror ("%s: failure creating eventset: %s\n", thisfunc, PAPI_strerror (ret)); - - /* - ** Assign EventSet to component 0 (cpu). This step is MANDATORY in recent PAPI releases - ** in order to enable event multiplexing - */ - if ((ret = PAPI_assign_eventset_component (EventSet[t], 0)) != PAPI_OK) - return GPTLerror ("%s: thread %d failure in PAPI_assign_eventset_component: %s\n", - thisfunc, t, PAPI_strerror (ret)); - - if ((ret = PAPI_multiplex_init ()) != PAPI_OK) - return GPTLerror ("%s: failure from PAPI_multiplex_init%s\n", thisfunc, PAPI_strerror (ret)); - - if ((ret = PAPI_set_multiplex (EventSet[t])) != PAPI_OK) - return GPTLerror ("%s: failure from PAPI_set_multiplex: %s\n", thisfunc, PAPI_strerror (ret)); - - for (n = 0; n < npapievents; n++) { - if ((ret = PAPI_add_event (EventSet[t], papieventlist[n])) != PAPI_OK) { - ret = PAPI_event_code_to_name (papieventlist[n], eventname); - return GPTLerror ("%s: failure adding event:%s Error was: %s\n", - thisfunc, eventname, PAPI_strerror (ret)); - } - } - } - - /* Start the event set. It will only be read from now on--never stopped */ - if ((ret = PAPI_start (EventSet[t])) != PAPI_OK) - return GPTLerror ("%s: failed to start event set: %s\n", thisfunc, PAPI_strerror (ret)); - - return 0; -} - -/* -** GPTL_PAPIstart: Start the PAPI counters (actually they are just read). -** Called from GPTLstart. -** -** Input args: -** t: thread number -** -** Output args: -** aux: struct containing the counters -** -** Return value: 0 (success) or GPTLerror (failure) -*/ -int GPTL_PAPIstart (const int t, /* thread number */ - Papistats *aux) /* struct containing PAPI stats */ -{ - int ret; /* return code from PAPI lib calls */ - int n; /* loop index */ - static const char *thisfunc = "GPTL_PAPIstart"; - - /* If no events are to be counted just return */ - if (npapievents == 0) - return 0; - - /* Read the counters */ - if ((ret = PAPI_read (EventSet[t], papicounters[t])) != PAPI_OK) - return GPTLerror ("%s: %s\n", thisfunc, PAPI_strerror (ret)); - - /* - ** Store the counter values. When GPTL_PAPIstop is called, the counters - ** will again be read, and differenced with the values saved here. - */ - for (n = 0; n < npapievents; n++) - aux->last[n] = papicounters[t][n]; - - return 0; -} - -/* -** GPTL_PAPIstop: Stop the PAPI counters (actually they are just read). -** Called from GPTLstop. -** -** Input args: -** t: thread number -** -** Input/output args: -** aux: struct containing the counters -** -** Return value: 0 (success) or GPTLerror (failure) -*/ -int GPTL_PAPIstop (const int t, /* thread number */ - Papistats *aux) /* struct containing PAPI stats */ -{ - int ret; /* return code from PAPI lib calls */ - int n; /* loop index */ - long_long delta; /* change in counters from previous read */ - static const char *thisfunc = "GPTL_PAPIstop"; - - /* If no events are to be counted just return */ - if (npapievents == 0) - return 0; - - /* Read the counters */ - if ((ret = PAPI_read (EventSet[t], papicounters[t])) != PAPI_OK) - return GPTLerror ("%s: %s\n", thisfunc, PAPI_strerror (ret)); - - /* - ** Accumulate the difference since timer start in aux. - ** Negative accumulation can happen when multiplexing is enabled, so don't - ** set count to BADCOUNT in that case. - */ - for (n = 0; n < npapievents; n++) { -#ifdef DEBUG - printf ("%s: event %d counter value is %ld\n", thisfunc, n, (long) papicounters[t][n]); -#endif - delta = papicounters[t][n] - aux->last[n]; - if ( ! is_multiplexed && delta < 0) - aux->accum[n] = BADCOUNT; - else - aux->accum[n] += delta; - } - return 0; -} - -/* -** GPTL_PAPIprstr: Print the descriptive string for all enabled PAPI events. -** Called from GPTLpr. -** -** Input args: -** fp: file descriptor -*/ -void GPTL_PAPIprstr (FILE *fp) -{ - int n; - - if (narrowprint) { - for (n = 0; n < nevents; n++) { - fprintf (fp, "%8.8s ", pr_event[n].event.str8); - - /* Test on < 0 says it's a PAPI preset */ - if (persec && pr_event[n].event.counter < 0) - fprintf (fp, "e6_/_sec "); - } - } else { - for (n = 0; n < nevents; n++) { - fprintf (fp, "%16.16s ", pr_event[n].event.str16); - - /* Test on < 0 says it's a PAPI preset */ - if (persec && pr_event[n].event.counter < 0) - fprintf (fp, "e6_/_sec "); - } - } -} - -/* -** GPTL_PAPIpr: Print PAPI counter values for all enabled events, including -** derived events. Called from GPTLpr. -** -** Input args: -** fp: file descriptor -** aux: struct containing the counters -*/ -void GPTL_PAPIpr (FILE *fp, /* file descriptor to write to */ - const Papistats *aux, /* stats to write */ - const int t, /* thread number */ - const int count, /* number of invocations */ - const double wcsec) /* wallclock time (sec) */ -{ - const char *shortintfmt = "%8ld "; - const char *longintfmt = "%16ld "; - const char *shortfloatfmt = "%8.2e "; - const char *longfloatfmt = "%16.10e "; - const char *intfmt; /* integer format */ - const char *floatfmt; /* floating point format */ - - int n; /* loop index */ - int numidx; /* index pointer to appropriated (derived) numerator */ - int denomidx; /* index pointer to appropriated (derived) denominator */ - double val; /* value to be printed */ - static const char *thisfunc = "GPTL_PAPIpr"; - - intfmt = narrowprint ? shortintfmt : longintfmt; - floatfmt = narrowprint ? shortfloatfmt : longfloatfmt; - - for (n = 0; n < nevents; n++) { - numidx = pr_event[n].numidx; - if (pr_event[n].denomidx > -1) { /* derived event */ - denomidx = pr_event[n].denomidx; - -#ifdef DEBUG - printf ("%s: derived event: numidx=%d denomidx=%d values = %ld %ld\n", - thisfunc, numidx, denomidx, (long) aux->accum[numidx], (long) aux->accum[denomidx]); -#endif - /* Protect against divide by zero */ - if (aux->accum[denomidx] > 0) - val = (double) aux->accum[numidx] / (double) aux->accum[denomidx]; - else - val = 0.; - fprintf (fp, floatfmt, val); - - } else { /* Raw PAPI event */ - -#ifdef DEBUG - printf ("%s: raw event: numidx=%d value = %ld\n", - thisfunc, numidx, (long) aux->accum[numidx]); -#endif - if (aux->accum[numidx] < PRTHRESH) - fprintf (fp, intfmt, (long) aux->accum[numidx]); - else - fprintf (fp, floatfmt, (double) aux->accum[numidx]); - - if (persec) { - if (wcsec > 0.) - fprintf (fp, "%8.2f ", aux->accum[numidx] * 1.e-6 / wcsec); - else - fprintf (fp, "%8.2f ", 0.); - } - } - } -} - -/* -** GPTL_PAPIprintenabled: Print list of enabled timers -** -** Input args: -** fp: file descriptor -*/ -void GPTL_PAPIprintenabled (FILE *fp) -{ - int n, nn; - PAPI_event_info_t info; /* returned from PAPI_get_event_info */ - char eventname[PAPI_MAX_STR_LEN]; /* returned from PAPI_event_code_to_name */ - - if (nevents > 0) { - fprintf (fp, "Description of printed events (PAPI and derived):\n"); - for (n = 0; n < nevents; n++) { - if (strncmp (pr_event[n].event.namestr, "GPTL", 4) == 0) { - fprintf (fp, " %s: %s\n", pr_event[n].event.namestr, pr_event[n].event.longstr); - } else { - nn = pr_event[n].event.counter; - if (PAPI_get_event_info (nn, &info) == PAPI_OK) { - fprintf (fp, " %s\n", info.short_descr); - fprintf (fp, " %s\n", info.note); - } - } - } - fprintf (fp, "\n"); - - fprintf (fp, "PAPI events enabled (including those required for derived events):\n"); - for (n = 0; n < npapievents; n++) - if (PAPI_event_code_to_name (papieventlist[n], eventname) == PAPI_OK) - fprintf (fp, " %s\n", eventname); - fprintf (fp, "\n"); - } -} - -/* -** GPTL_PAPIadd: Accumulate PAPI counters. Called from add. -** -** Input/Output args: -** auxout: auxout = auxout + auxin -** -** Input args: -** auxin: counters to be summed into auxout -*/ -void GPTL_PAPIadd (Papistats *auxout, /* output struct */ - const Papistats *auxin) /* input struct */ -{ - int n; - - for (n = 0; n < npapievents; n++) - if (auxin->accum[n] == BADCOUNT || auxout->accum[n] == BADCOUNT) - auxout->accum[n] = BADCOUNT; - else - auxout->accum[n] += auxin->accum[n]; -} - -/* -** GPTL_PAPIfinalize: finalization routine must be called from single-threaded -** region. Free all malloc'd space -*/ -void GPTL_PAPIfinalize (int maxthreads) -{ - int t; /* thread index */ - int ret; /* return code */ - - for (t = 0; t < maxthreads; t++) { - ret = PAPI_stop (EventSet[t], papicounters[t]); - free (papicounters[t]); - ret = PAPI_cleanup_eventset (EventSet[t]); - ret = PAPI_destroy_eventset (&EventSet[t]); - } - - free (EventSet); - free (papicounters); - - /* Reset initial values */ - npapievents = 0; - nevents = 0; - is_multiplexed = false; - narrowprint = true; - persec = true; - enable_multiplexing = false; - verbose = false; -} - -/* -** GPTL_PAPIquery: return current PAPI counter info. Return into a long for best -** compatibility possibilities with Fortran. -** -** Input args: -** aux: struct containing the counters -** ncounters: max number of counters to return -** -** Output args: -** papicounters_out: current value of PAPI counters -*/ -void GPTL_PAPIquery (const Papistats *aux, - long long *papicounters_out, - int ncounters) -{ - int n; - - if (ncounters > 0) { - for (n = 0; n < ncounters && n < npapievents; n++) { - papicounters_out[n] = (long long) aux->accum[n]; - } - } -} - -/* -** GPTL_PAPIget_eventvalue: return current value for an enabled event. -** -** Input args: -** eventname: event name to check (whether derived or raw PAPI counter) -** aux: struct containing the counter(s) for the event -** -** Output args: -** value: current value of the event -** -** Return value: 0 (success) or GPTLerror (failure) -*/ -int GPTL_PAPIget_eventvalue (const char *eventname, - const Papistats *aux, - double *value) -{ - int n; /* loop index through enabled events */ - int numidx; /* numerator index into papicounters */ - int denomidx; /* denominator index into papicounters */ - static const char *thisfunc = "GPTL_PAPIget_eventvalue"; - - for (n = 0; n < nevents; ++n) { - if (STRMATCH (eventname, pr_event[n].event.namestr)) { - numidx = pr_event[n].numidx; - if (pr_event[n].denomidx > -1) { /* derived event */ - denomidx = pr_event[n].denomidx; - if (aux->accum[denomidx] > 0) /* protect against divide by zero */ - *value = (double) aux->accum[numidx] / (double) aux->accum[denomidx]; - else - *value = 0.; - } else { /* Raw PAPI event */ - *value = (double) aux->accum[numidx]; - } - break; - } - } - if (n == nevents) - return GPTLerror ("%s: event %s not enabled\n", thisfunc, eventname); - return 0; -} - -/* -** GPTL_PAPIis_multiplexed: return status of whether events are being multiplexed -*/ -bool GPTL_PAPIis_multiplexed () -{ - return is_multiplexed; -} - -/* -** The following functions are publicly available -*/ -void read_counters1000 () -{ - int i; - int ret; - long_long counters[MAX_AUX]; - -#pragma unroll(10) - for (i = 0; i < 1000; ++i) { - ret = PAPI_read (EventSet[0], counters); - } - return; -} - -/* -** GPTLevent_name_to_code: convert a string to a PAPI code -** or derived event code. -** -** Input arguments: -** arg: string to convert -** -** Output arguments: -** code: PAPI or GPTL derived code -** -** Return value: 0 (success) or GPTLerror (failure) -*/ -int GPTLevent_name_to_code (const char *name, int *code) -{ - int ret; /* return code */ - int n; /* loop over derived entries */ - static const char *thisfunc = "GPTLevent_name_to_code"; - - /* First check derived events */ - for (n = 0; n < nderivedentries; ++n) { - if (STRMATCH (name, derivedtable[n].namestr)) { - *code = derivedtable[n].counter; - return 0; - } - } - - /* - ** Next check PAPI events--note that PAPI must be initialized before the - ** name_to_code function can be invoked. - */ - if ((ret = GPTL_PAPIlibraryinit ()) < 0) - return GPTLerror ("%s: GPTL_PAPIlibraryinit failure\n", thisfunc); - - if ((PAPI_event_name_to_code ((char *) name, code)) != PAPI_OK) - return GPTLerror ("%s: PAPI_event_name_to_code failure\n", thisfunc); - - return 0; -} - -/* -** GPTLevent_code_to_name: convert a string to a PAPI code -** or derived event code. -** -** Input arguments: -** code: event code (PAPI or derived) -** -** Output arguments: -** name: string corresponding to code -** -** Return value: 0 (success) or GPTLerror (failure) -*/ -int GPTLevent_code_to_name (const int code, char *name) -{ - int ret; /* return code */ - int n; /* loop over derived entries */ - static const char *thisfunc = "GPTLevent_code_to_name"; - - /* First check derived events */ - for (n = 0; n < nderivedentries; ++n) { - if (code == derivedtable[n].counter) { - strcpy (name, derivedtable[n].namestr); - return 0; - } - } - - /* - ** Next check PAPI events--note that PAPI must be initialized before the - ** code_to_name function can be invoked. - */ - if ((ret = GPTL_PAPIlibraryinit ()) < 0) - return GPTLerror ("%s: GPTL_PAPIlibraryinit failure\n", thisfunc); - - if (PAPI_event_code_to_name (code, name) != PAPI_OK) - return GPTLerror ("%s: PAPI_event_code_to_name failure\n", thisfunc); - - return 0; -} - -int GPTLget_npapievents (void) -{ - return npapievents; -} - -#else - -/* -** HAVE_PAPI not defined branch: "Should not be called" entry points for public routines -*/ -int GPTLevent_name_to_code (const char *name, int *code) -{ - return GPTLerror ("GPTLevent_name_to_code: PAPI not enabled\n"); -} - -int GPTLevent_code_to_name (int code, char *name) -{ - return GPTLerror ("GPTLevent_code_to_name: PAPI not enabled\n"); -} - -#endif /* HAVE_PAPI */ diff --git a/cesm/models/utils/timing/gptl/gptlf.F90 b/cesm/models/utils/timing/gptl/gptlf.F90 deleted file mode 100644 index 2a60a14..0000000 --- a/cesm/models/utils/timing/gptl/gptlf.F90 +++ /dev/null @@ -1,233 +0,0 @@ -module gptl -! GPTL module file for user code. Parameter values match their counterparts -! in gptl.h. This file also contains an interface block for parameter checking. - - implicit none - public - -! User-accessible integers - - integer, parameter :: GPTLsync_mpi = 0 - integer, parameter :: GPTLwall = 1 - integer, parameter :: GPTLcpu = 2 - integer, parameter :: GPTLabort_on_error = 3 - integer, parameter :: GPTLoverhead = 4 - integer, parameter :: GPTLdepthlimit = 5 - integer, parameter :: GPTLverbose = 6 - integer, parameter :: GPTLnarrowprint = 7 - integer, parameter :: GPTLpercent = 9 - integer, parameter :: GPTLpersec = 10 - integer, parameter :: GPTLmultiplex = 11 - integer, parameter :: GPTLdopr_preamble = 12 - integer, parameter :: GPTLdopr_threadsort= 13 - integer, parameter :: GPTLdopr_multparent= 14 - integer, parameter :: GPTLdopr_collision = 15 - integer, parameter :: GPTLdopr_memusage = 27 - integer, parameter :: GPTLprint_method = 16 - integer, parameter :: GPTLtablesize = 50 - integer, parameter :: GPTLmaxthreads = 51 - - integer, parameter :: GPTL_IPC = 17 - integer, parameter :: GPTL_CI = 18 - integer, parameter :: GPTL_FPC = 19 - integer, parameter :: GPTL_FPI = 20 - integer, parameter :: GPTL_LSTPI = 21 - integer, parameter :: GPTL_DCMRT = 22 - integer, parameter :: GPTL_LSTPDCM = 23 - integer, parameter :: GPTL_L2MRT = 24 - integer, parameter :: GPTL_LSTPL2M = 25 - integer, parameter :: GPTL_L3MRT = 26 - - integer, parameter :: GPTLgettimeofday = 1 - integer, parameter :: GPTLnanotime = 2 - integer, parameter :: GPTLmpiwtime = 4 - integer, parameter :: GPTLclockgettime = 5 - integer, parameter :: GPTLpapitime = 6 - integer, parameter :: GPTLplacebo = 7 - integer, parameter :: GPTLread_real_time = 3 - - integer, parameter :: GPTLfirst_parent = 1 - integer, parameter :: GPTLlast_parent = 2 - integer, parameter :: GPTLmost_frequent = 3 - integer, parameter :: GPTLfull_tree = 4 - -! Function prototypes - - interface - subroutine gptlprocess_namelist (filename, unitno, outret) - character(len=*) :: filename - integer :: unitno - integer :: outret - end subroutine gptlprocess_namelist - - integer function gptlinitialize () - end function gptlinitialize - - integer function gptlfinalize () - end function gptlfinalize - - integer function gptlpr (procid) - integer :: procid - end function gptlpr - - integer function gptlpr_file (file) - character(len=*) :: file - end function gptlpr_file - -#ifdef HAVE_MPI - integer function gptlpr_summary (fcomm) - integer :: fcomm - end function gptlpr_summary - - integer function gptlpr_summary_file (fcomm, name) - integer :: fcomm - character(len=*) :: name - end function gptlpr_summary_file - - integer function gptlbarrier (fcomm, name) - integer :: fcomm - character(len=*) :: name - end function gptlbarrier -#else - integer function gptlpr_summary () - end function gptlpr_summary - - integer function gptlpr_summary_file (name) - character(len=*) :: name - end function gptlpr_summary_file - - integer function gptlbarrier () - end function gptlbarrier -#endif - - integer function gptlreset () - end function gptlreset - - integer function gptlstamp (wall, usr, sys) - real(8) :: wall, usr, sys - end function gptlstamp - - integer function gptlstart (name) - character(len=*) :: name - end function gptlstart - - integer function gptlinit_handle (name, handle) - character(len=*) :: name - integer :: handle - end function gptlinit_handle - - integer function gptlstart_handle (name, handle) - character(len=*) :: name - integer :: handle - end function gptlstart_handle - - integer function gptlstop (name) - character(len=*) :: name - end function gptlstop - - integer function gptlstop_handle (name, handle) - character(len=*) :: name - integer :: handle - end function gptlstop_handle - - integer function gptlsetoption (option, val) - integer :: option, val - end function gptlsetoption - - integer function gptlenable () - end function gptlenable - - integer function gptldisable () - end function gptldisable - - integer function gptlsetutr (option) - integer :: option - end function gptlsetutr - - integer function gptlquery (name, t, count, onflg, wallclock, & - usr, sys, papicounters_out, maxcounters) - character(len=*) :: name - integer :: t, count - integer :: onflg - real(8) :: wallclock, usr, sys - integer(8) :: papicounters_out - integer :: maxcounters - end function gptlquery - - integer function gptlquerycounters (name, t, papicounters_out) - character(len=*) :: name - integer :: t - integer(8) :: papicounters_out - end function gptlquerycounters - - integer function gptlget_wallclock (name, t, value) - character(len=*) :: name - integer :: t - real(8) :: value - end function gptlget_wallclock - - integer function gptlget_eventvalue (timername, eventname, t, value) - character(len=*) :: timername - character(len=*) :: eventname - integer :: t - real(8) :: value - end function gptlget_eventvalue - - integer function gptlget_nregions (t, nregions) - integer :: t - integer :: nregions - end function gptlget_nregions - - integer function gptlget_regionname (t, region, name) - integer :: t - integer :: region - character(len=*) :: name - end function gptlget_regionname - - integer function gptlget_memusage (size, rss, share, text, datastack) - integer :: size, rss, share, text, datastack - end function gptlget_memusage - - integer function gptlprint_memusage (str) - character(len=*) :: str - end function gptlprint_memusage - - integer function gptlprint_rusage (str) - character(len=*) :: str - end function gptlprint_rusage - - integer function gptlnum_errors () - end function gptlnum_errors - - integer function gptlnum_warn () - end function gptlnum_warn - - integer function gptlget_count (name, t, count) - character(len=*) :: name - integer :: t - integer :: count - end function gptlget_count - -#ifdef HAVE_PAPI - integer function gptl_papilibraryinit () - end function gptl_papilibraryinit - - integer function gptlevent_name_to_code (str, code) - character(len=*) :: str - integer :: code - end function gptlevent_name_to_code - - integer function gptlevent_code_to_name (code, str) - integer :: code - character(len=*) :: str - end function gptlevent_code_to_name -#endif - - end interface - - contains -! Do-nothing stub needed because some compilers otherwise generate no symbols -! which can cause ar to barf - subroutine gptldo_nothing - end subroutine gptldo_nothing -end module gptl diff --git a/cesm/models/utils/timing/gptl/gptlf.F90.template b/cesm/models/utils/timing/gptl/gptlf.F90.template deleted file mode 100644 index de0d875..0000000 --- a/cesm/models/utils/timing/gptl/gptlf.F90.template +++ /dev/null @@ -1,233 +0,0 @@ -module gptl -! GPTL module file for user code. Parameter values match their counterparts -! in gptl.h. This file also contains an interface block for parameter checking. - - implicit none - public - -! User-accessible integers - - integer, parameter :: GPTLsync_mpi = #GPTLsync_mpi - integer, parameter :: GPTLwall = #GPTLwall - integer, parameter :: GPTLcpu = #GPTLcpu - integer, parameter :: GPTLabort_on_error = #GPTLabort_on_error - integer, parameter :: GPTLoverhead = #GPTLoverhead - integer, parameter :: GPTLdepthlimit = #GPTLdepthlimit - integer, parameter :: GPTLverbose = #GPTLverbose - integer, parameter :: GPTLnarrowprint = #GPTLnarrowprint - integer, parameter :: GPTLpercent = #GPTLpercent - integer, parameter :: GPTLpersec = #GPTLpersec - integer, parameter :: GPTLmultiplex = #GPTLmultiplex - integer, parameter :: GPTLdopr_preamble = #GPTLdopr_preamble - integer, parameter :: GPTLdopr_threadsort= #GPTLdopr_threadsort - integer, parameter :: GPTLdopr_multparent= #GPTLdopr_multparent - integer, parameter :: GPTLdopr_collision = #GPTLdopr_collision - integer, parameter :: GPTLdopr_memusage = #GPTLdopr_memusage - integer, parameter :: GPTLprint_method = #GPTLprint_method - integer, parameter :: GPTLtablesize = #GPTLtablesize - integer, parameter :: GPTLmaxthreads = #GPTLmaxthreads - - integer, parameter :: GPTL_IPC = #GPTL_IPC - integer, parameter :: GPTL_CI = #GPTL_CI - integer, parameter :: GPTL_FPC = #GPTL_FPC - integer, parameter :: GPTL_FPI = #GPTL_FPI - integer, parameter :: GPTL_LSTPI = #GPTL_LSTPI - integer, parameter :: GPTL_DCMRT = #GPTL_DCMRT - integer, parameter :: GPTL_LSTPDCM = #GPTL_LSTPDCM - integer, parameter :: GPTL_L2MRT = #GPTL_L2MRT - integer, parameter :: GPTL_LSTPL2M = #GPTL_LSTPL2M - integer, parameter :: GPTL_L3MRT = #GPTL_L3MRT - - integer, parameter :: GPTLgettimeofday = #GPTLgettimeofday - integer, parameter :: GPTLnanotime = #GPTLnanotime - integer, parameter :: GPTLmpiwtime = #GPTLmpiwtime - integer, parameter :: GPTLclockgettime = #GPTLclockgettime - integer, parameter :: GPTLpapitime = #GPTLpapitime - integer, parameter :: GPTLplacebo = #GPTLplacebo - integer, parameter :: GPTLread_real_time = #GPTLread_real_time - - integer, parameter :: GPTLfirst_parent = #GPTLfirst_parent - integer, parameter :: GPTLlast_parent = #GPTLlast_parent - integer, parameter :: GPTLmost_frequent = #GPTLmost_frequent - integer, parameter :: GPTLfull_tree = #GPTLfull_tree - -! Function prototypes - - interface - subroutine gptlprocess_namelist (filename, unitno, outret) - character(len=*) :: filename - integer :: unitno - integer :: outret - end subroutine gptlprocess_namelist - - integer function gptlinitialize () - end function gptlinitialize - - integer function gptlfinalize () - end function gptlfinalize - - integer function gptlpr (procid) - integer :: procid - end function gptlpr - - integer function gptlpr_file (file) - character(len=*) :: file - end function gptlpr_file - -#ifdef HAVE_MPI - integer function gptlpr_summary (fcomm) - integer :: fcomm - end function gptlpr_summary - - integer function gptlpr_summary_file (fcomm, name) - integer :: fcomm - character(len=*) :: name - end function gptlpr_summary_file - - integer function gptlbarrier (fcomm, name) - integer :: fcomm - character(len=*) :: name - end function gptlbarrier -#else - integer function gptlpr_summary () - end function gptlpr_summary - - integer function gptlpr_summary_file (name) - character(len=*) :: name - end function gptlpr_summary_file - - integer function gptlbarrier () - end function gptlbarrier -#endif - - integer function gptlreset () - end function gptlreset - - integer function gptlstamp (wall, usr, sys) - real(8) :: wall, usr, sys - end function gptlstamp - - integer function gptlstart (name) - character(len=*) :: name - end function gptlstart - - integer function gptlinit_handle (name, handle) - character(len=*) :: name - integer :: handle - end function gptlinit_handle - - integer function gptlstart_handle (name, handle) - character(len=*) :: name - integer :: handle - end function gptlstart_handle - - integer function gptlstop (name) - character(len=*) :: name - end function gptlstop - - integer function gptlstop_handle (name, handle) - character(len=*) :: name - integer :: handle - end function gptlstop_handle - - integer function gptlsetoption (option, val) - integer :: option, val - end function gptlsetoption - - integer function gptlenable () - end function gptlenable - - integer function gptldisable () - end function gptldisable - - integer function gptlsetutr (option) - integer :: option - end function gptlsetutr - - integer function gptlquery (name, t, count, onflg, wallclock, & - usr, sys, papicounters_out, maxcounters) - character(len=*) :: name - integer :: t, count - integer :: onflg - real(8) :: wallclock, usr, sys - integer(8) :: papicounters_out - integer :: maxcounters - end function gptlquery - - integer function gptlquerycounters (name, t, papicounters_out) - character(len=*) :: name - integer :: t - integer(8) :: papicounters_out - end function gptlquerycounters - - integer function gptlget_wallclock (name, t, value) - character(len=*) :: name - integer :: t - real(8) :: value - end function gptlget_wallclock - - integer function gptlget_eventvalue (timername, eventname, t, value) - character(len=*) :: timername - character(len=*) :: eventname - integer :: t - real(8) :: value - end function gptlget_eventvalue - - integer function gptlget_nregions (t, nregions) - integer :: t - integer :: nregions - end function gptlget_nregions - - integer function gptlget_regionname (t, region, name) - integer :: t - integer :: region - character(len=*) :: name - end function gptlget_regionname - - integer function gptlget_memusage (size, rss, share, text, datastack) - integer :: size, rss, share, text, datastack - end function gptlget_memusage - - integer function gptlprint_memusage (str) - character(len=*) :: str - end function gptlprint_memusage - - integer function gptlprint_rusage (str) - character(len=*) :: str - end function gptlprint_rusage - - integer function gptlnum_errors () - end function gptlnum_errors - - integer function gptlnum_warn () - end function gptlnum_warn - - integer function gptlget_count (name, t, count) - character(len=*) :: name - integer :: t - integer :: count - end function gptlget_count - -#ifdef HAVE_PAPI - integer function gptl_papilibraryinit () - end function gptl_papilibraryinit - - integer function gptlevent_name_to_code (str, code) - character(len=*) :: str - integer :: code - end function gptlevent_name_to_code - - integer function gptlevent_code_to_name (code, str) - integer :: code - character(len=*) :: str - end function gptlevent_code_to_name -#endif - - end interface - - contains -! Do-nothing stub needed because some compilers otherwise generate no symbols -! which can cause ar to barf - subroutine gptldo_nothing - end subroutine gptldo_nothing -end module gptl diff --git a/cesm/models/utils/timing/gptl/hashstats.c b/cesm/models/utils/timing/gptl/hashstats.c deleted file mode 100644 index a14cdcd..0000000 --- a/cesm/models/utils/timing/gptl/hashstats.c +++ /dev/null @@ -1,91 +0,0 @@ -#include "private.h" -#include - -static float meanhashvalue (Hashentry *, int); - -void GPTLprint_hashstats (FILE *fp, int nthreads, Hashentry **hashtable, int tablesize) -{ - int t; /* thread index */ - int i, ii; - int totent; /* per-thread collision count (diagnostic) */ - int nument; /* per-index collision count (diagnostic) */ - /* - ** Diagnostics for collisions and GPTL memory usage - */ - int num_zero; /* number of buckets with 0 collisions */ - int num_one; /* number of buckets with 1 collision */ - int num_two; /* number of buckets with 2 collisions */ - int num_more; /* number of buckets with more than 2 collisions */ - int most; /* biggest collision count */ - bool first; - - for (t = 0; t < nthreads; t++) { - first = true; - totent = 0; - num_zero = 0; - num_one = 0; - num_two = 0; - num_more = 0; - most = 0; - - for (i = 0; i < tablesize; i++) { - nument = hashtable[t][i].nument; - if (nument > 1) { - totent += nument-1; - if (first) { - first = false; - fprintf (fp, "\nthread %d had some hash collisions:\n", t); - } - fprintf (fp, "hashtable[%d][%d] had %d entries:", t, i, nument); - for (ii = 0; ii < nument; ii++) - fprintf (fp, " %s", hashtable[t][i].entries[ii]->name); - fprintf (fp, "\n"); - } - switch (nument) { - case 0: - ++num_zero; - break; - case 1: - ++num_one; - break; - case 2: - ++num_two; - break; - default: - ++num_more; - break; - } - most = MAX (most, nument); - } - - if (totent > 0) { - fprintf (fp, "Total collisions thread %d = %d\n", t, totent); - fprintf (fp, "Entry information:\n"); - fprintf (fp, "num_zero = %d num_one = %d num_two = %d num_more = %d\n", - num_zero, num_one, num_two, num_more); - fprintf (fp, "Most = %d\n", most); - } - } - fprintf (fp, "Size of hash table was %d\n", tablesize); - fprintf (fp, "Mean hash index for thread 0 was %f\n", meanhashvalue (hashtable[0], tablesize)); -} - -static float meanhashvalue (Hashentry *hashtable, int tablesize) -{ - float sum = 0.; /* used to calculate mean */ - int nument; - int totent = 0; /* number of entries */ - int i; - - for (i = 1; i < tablesize; ++i) { - nument = hashtable[i].nument; - if (nument > 0) { - sum += (float) (nument * i); - totent += hashtable[i].nument; - } - } - if (totent == 0) - return (float) 0.; - else - return sum / totent; -} diff --git a/cesm/models/utils/timing/gptl/hex2name.pl b/cesm/models/utils/timing/gptl/hex2name.pl deleted file mode 100755 index d15c6d7..0000000 --- a/cesm/models/utils/timing/gptl/hex2name.pl +++ /dev/null @@ -1,238 +0,0 @@ -#!/usr/bin/perl - -# jr-resolve.pl - convert timing lib output addresses to names -# hacked from cyg-profile script found on web. - -use strict; -use warnings; -no warnings 'portable'; -use diagnostics; -use English; - -my (%symtab); # symbol table derived from executable -my ($binfile); # executable -my ($timingout); # timer file (normally timing.[0-9]*) -my ($demangle); # whether to demangle the symbols -my ($arg); # cmd-line arg -my ($PRTHRESH) = 1000000; # This needs to match what is in the GPTL lib -our ($max_sym) = 0; - -$OUTPUT_AUTOFLUSH = 1; - -&help() if ($#ARGV < 1 || $#ARGV > 2); - -while ($arg = shift (@ARGV)) { - if ($arg eq "-demangle") { - $demangle = 1; - } elsif ( ! defined ($binfile)) { - $binfile = $arg; - } else { - $timingout = $arg; - } -} - -&help() if ($binfile =~ /--help/); -&help() if (!defined ($binfile)); -&help() if (!defined ($timingout)); - -&main(); - -# ==== Subs - -sub help() -{ - printf ("Usage: $0 [-demangle] executable timing_file\n"); - exit; -} - -sub main() -{ - my ($offset); # offset into a.out (to match timing output) - my ($type); # symbol type - my ($function); # name of function in symtab - my ($nsym) = 0; # number of symbols - my ($nfunc) = 0; # number of functions - my ($sym); # symbol - my ($begofline); - my ($off1); - my ($spaftsym); - my ($ncalls); - my ($restofline); - my ($numsp); # number of spaces before rest of line - my ($spaces); # text containing spaces before rest of line - my ($thread) = -1; # thread number (init to -1 - my ($doparse) = 0; # logical flag: true indicates between "Statas for thread..." - # and "Number of calls..." - my ($indent); - my (@max_chars); # longest symbol name + indentation (per thread) - my ($statsforthread) = 0; # Inside region "Stats for thread ..." - my ($sortedbytimer) = 0; # Inside region "Same stats sorted by ..." - my ($countnexttochild) = 0; # Inside region "Count next to child ..." - - if ($demangle) { - open (NM, "nm $binfile | c++filt | ") or die ("Unable to run 'nm $binfile | c++filt': $!\n"); - } else { - open (NM, "nm $binfile |") or die ("Unable to run 'nm $binfile': $!\n"); - } - - printf ("Loading symbols from $binfile ... "); - - while () { - $nsym++; - next if (!/^([0-9A-F]+) (.) (.+)$/i); - $offset = hex($1); - $type = $2; - $function = $3; - next if ($type !~ /[tT]/); - $nfunc++; - $symtab{$offset} = $function; - } - printf("OK\nSeen %d symbols, stored %d function offsets\n", $nsym, $nfunc); - close(NM); - - @max_chars = &get_max_chars ("$timingout"); - - open (TEXT, "<$timingout") or die ("Unable to open '$timingout': $!\n"); - - while () { - - # 3 types of input line will need parsing - - if (/^Stats for thread /) { # beginning of main region - $statsforthread = 1; - $sortedbytimer = 0; - $countnexttochild = 0; - ++$thread; - print $_; - next; - } elsif (/^(Thd) (Called.*)$/) { # Sorted by timer - $statsforthread = 0; - $sortedbytimer = 1; - $countnexttochild = 0; - $spaces = " " x $max_sym; - printf ("%s%s%s\n", $1, $spaces, $2); - next; - } elsif (/^Count next to child /) { # Parent-child stats - $statsforthread = 0; - $sortedbytimer = 0; - $countnexttochild = 1; - print $_; - next; - } elsif ( ! $statsforthread && ! $sortedbytimer && ! $countnexttochild) { # header--just print - print $_; - next; - } - - if ($statsforthread) { - if (/^ *(Called Recurse.*)$/) { # heading - $numsp = $max_chars[$thread]; - $spaces = " " x $numsp; - printf ("%s %s\n", $spaces, $1); - } elsif (/(^\*? *)([[:xdigit:]]+)( +)([0-9.Ee+]+)(.*)$/) { # hex entry - $begofline = $1; - $off1 = hex($2); - $ncalls = $4; - $restofline = $5; - if (defined ($symtab{$off1})) { - $sym = $symtab{$off1}; - } else { - $sym = "???"; - } - $numsp = $max_chars[$thread] - length ($begofline) - length ($sym); - $spaces = " " x $numsp; - printf ("%s%s%s %9s %s\n", $begofline, $sym, $spaces, $ncalls, $restofline); - } elsif (/(^\*? *)(\w+)( +)([0-9.Ee+]+)(.*)$/) { # standard entry - $begofline = $1; - $sym = $2; - $ncalls = $4; - $restofline = $5; - $numsp = $max_chars[$thread] - length ($begofline) - length ($sym); - $spaces = " " x $numsp; - printf ("%s%s%s %9s %s\n", $begofline, $sym, $spaces, $ncalls, $restofline); - } else { # unknown: just print it - print $_; - } - } elsif ($sortedbytimer) { - if (/^([0-9][0-9][0-9] )([[:xdigit:]]+)( +)(.*)$/ || - /^(SUM )([[:xdigit:]]+)( +)(.*)$/) { - $off1 = hex($2); - if (defined ($symtab{$off1})) { - $sym = $symtab{$off1}; - } else { - $sym = "???"; - } - $numsp = length($3) + $max_sym - length ($sym) - 1; - $spaces = " " x $numsp; - printf ("%s%s%s%s\n", $1, $sym, $spaces, $4); - } else { - print $_; - } - } elsif ($countnexttochild) { - if (/(^ *)([0-9.Ee+]+)( +)([[:xdigit:]]+)( *)$/) { -# -# Hex entry in multiple parent region -# - $ncalls = $2; - $indent = $3; - $off1 = hex($4); - if (defined ($symtab{$off1})) { - $sym = $symtab{$off1}; - } else { - $sym = "???"; - } - $restofline = $5; - printf ("%8s%s%s%s\n", $ncalls, $indent, $sym, $restofline); - } else { # unknown: just print it - print $_; - next; - } - } - } - close (TEXT); - printf("done\n"); -} - -sub get_max_chars () -{ - my ($file) = $_[0]; - my ($thread) = -1; - my ($tmp); - my ($sym); - my ($off1); - my ($doparse) = 0; - my ($lensym); - my (@max_chars); - our ($max_sym) = 0; - - open (TEXT, "<$file") or die ("Unable to open '$file': $!\n"); - - while () { - - # Parse the line if it's a hex number followed by a number - - if (/Stats for thread /) { - $doparse = 1; - ++$thread; - $max_chars[$thread] = 0; - } elsif (/^Total calls /) { - $doparse = 0; - } elsif ($doparse && /(^\*? *)([[:xdigit:]]+)/) { - $off1 = hex($2); - if (defined ($symtab{$off1})) { - $sym = $symtab{$off1}; - } else { - $sym = "???"; - } - $lensym = length ($sym); - $tmp = length ($1) + $lensym; - if ($tmp > $max_chars[$thread]) { - $max_chars[$thread] = $tmp; - } - if ($lensym > $max_sym) { - $max_sym = $lensym; - } - } - } - close (TEXT); - return @max_chars; -} diff --git a/cesm/models/utils/timing/gptl/jrmacros/macros.make.bluefire b/cesm/models/utils/timing/gptl/jrmacros/macros.make.bluefire deleted file mode 100644 index 42e91c3..0000000 --- a/cesm/models/utils/timing/gptl/jrmacros/macros.make.bluefire +++ /dev/null @@ -1,168 +0,0 @@ -# This file contains macro settings which are used by the Makefile. Some require -# "yes" or "no", where various subflags are required if the value is -# "yes". The intent is for the user to edit whichever parts of this file are -# necessary, save to a file named "macros.make", then run "make" to build the -# GPTL library. - -########################################################################## - -# Where to install GPTL library and include files -INSTALLDIR = $(HOME)/aix - -# Where to install man pages (if blank, defaults to $INSTALLDIR) -MANDIR = - -# C compiler: For AIX set in HAVE_MPI section because it's MPI-dependent -#CC = mpcc_r - -# Whether to build debug lib or optimized lib, and associated flags -DEBUG = no -ifeq ($(DEBUG),yes) - CFLAGS = -g -O0 -qfullpath -qstrict -else - CFLAGS = -O4 -qfullpath -qstrict -endif - -# Set compiler flags for non-default ABIs (e.g. 64-bit addressing). -# Normally this can be blank. -ABIFLAGS = - -# Is the /proc filesystem available? On most Linux systems it is. If available, get_memusage() -# reads from it to find memory usage info. Otherwise get_memusage() will use get_rusage() -HAVE_SLASHPROC = no - -# GPTL can enable threading either via OPENMP=yes, or PTHREADS=yes. Since -# most OpenMP implementations are built on top of pthreads, OpenMP -# applications linked with GPTL as built with PTHREADS=yes should work fine. -# Thus COMPFLAG should be set to the compiler flag that enables OpenMP directives -# if either OPENMP=yes, or PTHREADS=yes. If OPENMP=no and PTHREADS=no, GPTL -# will not be thread-safe. -OPENMP = no -COMPFLAG = -qsmp=omp -# Set PTHREADS if available and OPENMP=no -ifeq ($(OPENMP),no) - PTHREADS = yes -endif - -# For gcc, -Dinline=inline is a no-op. For other C compilers, things like -# -Dinline=__inline__ may be required. To find your compiler's definition, try -# running "./suggestions CC=". -INLINEFLAG = -Dinline="" - -# To get some C compilers such as gcc to behave properly with -O0 and no inlining, -# need to effectively delete the "inline" keyword -ifeq ($(DEBUG),yes) - INLINEFLAG = -Dinline= -endif - -# To build the Fortran interface, set FORTRAN=yes and define the entries under -# ifeq ($(FORTRAN),yes). Otherwise, set FORTRAN=no and skip this section. -FORTRAN = yes -ifeq ($(FORTRAN),yes) -# Fortran name mangling: possibilities are: leave UNDERSCORING blank meaning none -# (e.g. xlf90), -DFORTRANDOUBLEUNDERSCORE (e.g. g77), and -DFORTRANUNDERSCORE -# (e.g. gfortran, pathf95) -# -UNDERSCORING = -# UNDERSCORING = -DFORTRANDOUBLEUNDERSCORE -# UNDERSCORING = -DFORTRANUNDERSCORE - -# Set Fortran compiler, flags, and OpenMP compiler flag. Note that Fortran -# OpenMP tests are possible with OPENMP=no as long as PTHREADS=yes -# These settings are only used by the Fortran test applications in ftests/. - -# Fortran compiler: For AIX set in HAVE_MPI section because it's MPI-dependent -# FC = xlf90_r - FFLAGS = -g -O2 -qfullpath - FOMPFLAG = -qsmp=omp -endif - -# Archiver: normally it's just ar -AR = ar - -# PAPI: If a recent version of PAPI is installed, set HAVE_PAPI=yes and set inc and lib -# info as appropriate. -HAVE_PAPI = no -ifeq ($(HAVE_PAPI),yes) -# These work on the NCAR bluefire machine - PAPI_INCFLAGS = -I/contrib/papi-3.6.2/include - PAPI_LIBFLAGS = -L/contrib/papi-3.6.2/lib -lpapi -lpmapi -# PAPI_INCFLAGS = -I -# PAPI_LIBFLAGS = -L -lpapi -lpmapi -endif - -# Whether to build GPTL with MPI support. Set inc and lib info if needed. -# If CC=mpicc, MPI_INCFLAGS and MPI_LIBFLAGS can be blank. -HAVE_MPI = yes -ifeq ($(HAVE_MPI),yes) -# C compiler for MPI - CC = mpcc_r -# Hopefully MPI_Comm_f2c() exists, but if not, set HAVE_COMM_F2C = no - HAVE_COMM_F2C = yes - MPI_INCFLAGS = - MPI_LIBFLAGS = -# Want 2 MPI tasks. On AIX this is specified by the batch system - MPICMD = -# Fortran compiler for MPI - ifeq ($(FORTRAN),yes) - FC = mpxlf90_r - endif -else -# C and Fortran compilers for no MPI - CC = cc_r - ifeq ($(FORTRAN),yes) - FC = xlf90_r - endif -endif - -# clock_gettime() in librt.a is an option for gathering wallclock time stats -# on some machines. Setting HAVE_LIBRT=yes enables this, but will probably -# require linking applications with -lrt -HAVE_LIBRT = no - -# Only define HAVE_NANOTIME if this is a x86. It provides by far the finest grained, -# lowest overhead wallclock timer on that architecture. -# If HAVE_NANOTIME=yes, set BIT64=yes if this is an x86_64 -HAVE_NANOTIME = no -ifeq ($(HAVE_NANOTIME),yes) - BIT64 = no -endif - -# Some old compilers don't support vprintf. Set to "no" in this case -HAVE_VPRINTF = yes - -# Some old compilers don't support the C times() function. Set to "no" in this case -HAVE_TIMES = yes - -# gettimeofday() should be available everywhere. But if not, set to "no" -HAVE_GETTIMEOFDAY = yes - -# Whether to test auto-profiling (adds 2 tests to "make test"). If compiler is gcc or -# pathscale, set INSTRFLAG to -finstrument-functions. PGI 8.0.2 and later provide -# -Minstrument:functions. -TEST_AUTOPROFILE = yes -ifeq ($(TEST_AUTOPROFILE),yes) - INSTRFLAG = "-qdebug=function_trace" - CXX = mpCC -endif - -# Whether to enable PMPI wrappers. Turning this on will result in automatic -# start/stop entries for a number of MPI calls. -ifeq ($(HAVE_MPI),yes) - ENABLE_PMPI = no - ifeq ($(ENABLE_PMPI),yes) -# Some newer MPI releases change the prototype of some input arguments from "void *" -# to "const void *". The prototype for these functions inside GPTL must match the -# MPI library in use. For ENABLE_PMPI=yes, set MPI_CONST to yes or no appropriately. - MPI_CONST = no -# Yet another (Fortran-only) wart: the value of MPI_STATUS_SIZE varies among MPI distributions. -# Normal values are 5 or 10. AIX and very new MPICH versions it is 10. Set it here--if you get it -# wrong your instrumented code will tell you at run time the proper value. Or run ftests/pmpi - MPI_STATUS_SIZE_IN_INTS = 10 - endif -# If Fortran is enabled, the ability to automatically initialize GPTL from -# mpi_init can be enabled if iargc() and getarg() are available. - ifeq ($(FORTRAN),yes) - HAVE_IARGCGETARG = no - endif -endif diff --git a/cesm/models/utils/timing/gptl/jrmacros/macros.make.cray b/cesm/models/utils/timing/gptl/jrmacros/macros.make.cray deleted file mode 100644 index 5d8dbe9..0000000 --- a/cesm/models/utils/timing/gptl/jrmacros/macros.make.cray +++ /dev/null @@ -1,164 +0,0 @@ -# This file contains macro settings which are used by the Makefile. Some require -# "yes" or "no", where various subflags are required if the value is -# "yes". The intent is for the user to edit whichever parts of this file are -# necessary, save to a file named "macros.make", then run "make" to build the -# GPTL library. - -########################################################################## - -# Where to install GPTL library and include files. -# if "git" is not available, set REVNO by hand -REVNO = $(shell git describe) -INSTALLDIR = $(HOME)/gptl-$(REVNO)/cray_mpi - -# Where to install man pages (if blank, defaults to $INSTALLDIR) -MANDIR = - -# C compiler -CC = cc - -# Whether to build debug lib or optimized lib, and associated flags -DEBUG = no -ifeq ($(DEBUG),yes) - CFLAGS = -g -O0 -else - CFLAGS = -g -O3 -endif - -# Set compiler flags for non-default ABIs (e.g. 64-bit addressing). -# Normally this can be blank. -ABIFLAGS = - -# Is the /proc filesystem available? On most Linux systems it is. If available, get_memusage() -# reads from it to find memory usage info. Otherwise get_memusage() will use get_rusage() -HAVE_SLASHPROC = yes - -# GPTL can enable threading either via OPENMP=yes, or PTHREADS=yes. Since -# most OpenMP implementations are built on top of pthreads, OpenMP -# applications linked with GPTL as built with PTHREADS=yes should work fine. -# Thus COMPFLAG should be set to the compiler flag that enables OpenMP directives -# if either OPENMP=yes, or PTHREADS=yes. If OPENMP=no and PTHREADS=no, GPTL -# will not be thread-safe. -OPENMP = yes -COMPFLAG = -homp -# Set PTHREADS if available and OPENMP=no -ifeq ($(OPENMP),no) - PTHREADS = yes -endif - -# For gcc, -Dinline=inline is a no-op. For other C compilers, things like -# -Dinline=__inline__ may be required. To find your compiler's definition, try -# running "./suggestions CC=". -INLINEFLAG = -Dinline=inline - -# To get some C compilers such as gcc to behave properly with -O0 and no inlining, -# need to effectively delete the "inline" keyword -ifeq ($(DEBUG),yes) - INLINEFLAG = -Dinline= -endif - -# To build the Fortran interface, set FORTRAN=yes and define the entries under -# ifeq ($(FORTRAN),yes). Otherwise, set FORTRAN=no and skip this section. -FORTRAN = yes -ifeq ($(FORTRAN),yes) -# Fortran name mangling: possibilities are: leave UNDERSCORING blank meaning none -# (e.g. xlf90), -DFORTRANDOUBLEUNDERSCORE (e.g. g77), and -DFORTRANUNDERSCORE -# (e.g. gfortran, pathf95) -# -# UNDERSCORING = -# UNDERSCORING = -DFORTRANDOUBLEUNDERSCORE - UNDERSCORING = -DFORTRANUNDERSCORE - -# Set Fortran compiler, flags, and OpenMP compiler flag. Note that Fortran -# OpenMP tests are possible with OPENMP=no as long as PTHREADS=yes -# These settings are only used by the Fortran test applications in ftests/. - FC = ftn - FFLAGS = -O2 - FOMPFLAG = -homp -endif - -# Archiver: normally it's just ar -AR = ar - -# PAPI: If a recent version of PAPI is installed, set HAVE_PAPI=yes and set inc and lib -# info as appropriate. -HAVE_PAPI = no -ifeq ($(HAVE_PAPI),yes) - PAPI_INCFLAGS = -I/contrib/papi/5.0.1/include - PAPI_LIBFLAGS = -L/contrib/papi/5.0.1/lib -lpapi -endif - -# Whether to build GPTL with MPI support. Set inc and lib info if needed. -# If CC=mpicc, MPI_INCFLAGS and MPI_LIBFLAGS can be blank. -HAVE_MPI = yes -ifeq ($(HAVE_MPI),yes) -# Hopefully MPI_Comm_f2c() exists, but if not, set HAVE_COMM_F2C = no - HAVE_COMM_F2C = yes - MPI_INCFLAGS = - MPI_LIBFLAGS = -# Want 2 MPI tasks - MPICMD = aprun -n 2 -endif - -# clock_gettime() in librt.a is an option for gathering wallclock time stats -# on some machines. Setting HAVE_LIBRT=yes enables this, but will probably -# require linking applications with -lrt -HAVE_LIBRT = no - -# Only define HAVE_NANOTIME if this is a x86. It provides by far the finest grained, -# lowest overhead wallclock timer on that architecture. -# If HAVE_NANOTIME=yes, set BIT64=yes if this is an x86_64 -HAVE_NANOTIME = no -ifeq ($(HAVE_NANOTIME),yes) - BIT64 = yes -endif - - -# Some old compilers don't support vprintf. Set to "no" in this case -HAVE_VPRINTF = yes - -# Some old compilers don't support the C times() function. Set to "no" in this case -HAVE_TIMES = yes - -# gettimeofday() should be available everywhere. But if not, set to "no" -HAVE_GETTIMEOFDAY = yes - -# Whether to test auto-profiling (adds 2 tests to "make test"). If compiler is gcc or -# pathscale, set INSTRFLAG to -finstrument-functions. PGI 8.0.2 and later provide -# -Minstrument:functions. -TEST_AUTOPROFILE = no -ifeq ($(TEST_AUTOPROFILE),yes) - INSTRFLAG = -finstrument-functions - CXX = CC -endif - -# Whether to enable PMPI wrappers. Turning this on will result in automatic -# start/stop entries for a number of MPI calls. -ifeq ($(HAVE_MPI),yes) - ENABLE_PMPI = no - ifeq ($(ENABLE_PMPI),yes) -# Some newer MPI releases change the prototype of some input arguments from "void *" -# to "const void *". The prototype for these functions inside GPTL must match the -# MPI library in use. For ENABLE_PMPI=yes, set MPI_CONST to yes or no appropriately. - MPI_CONST = yes -# Yet another (Fortran-only) wart: the value of MPI_STATUS_SIZE varies among MPI distributions. -# Normal values are 5 or 10. AIX and very new MPICH versions it is 10. Set it here--if you get it -# wrong your instrumented code will tell you at run time the proper value. Or run ftests/pmpi - MPI_STATUS_SIZE_IN_INTS = 10 - endif -# If Fortran is enabled, the ability to automatically initialize GPTL from -# mpi_init can be enabled if iargc() and getarg() are available. - ifeq ($(FORTRAN),yes) - HAVE_IARGCGETARG = no - endif -endif - -# Whether system functions backtrace() and backtrace_symbols() exist. Setting HAVE_BACKTRACE=yes -# will enable auto-generation of function name when auto-profiling and GPTLdopr_memusage has been -# enabled at run-time. If HAVE_BACKTRACE=no, function address will be printed instead. -# GNU compilers: compile application code with -finstrument-functions -rdynamic -# Intel compilers: compile application code with -finstrument-functions -rdynamic -g -HAVE_BACKTRACE = no -ifeq ($(HAVE_BACKTRACE),yes) - CFLAGS += -DHAVE_BACKTRACE -endif diff --git a/cesm/models/utils/timing/gptl/jrmacros/macros.make.craynompi b/cesm/models/utils/timing/gptl/jrmacros/macros.make.craynompi deleted file mode 100644 index 4c5a8b2..0000000 --- a/cesm/models/utils/timing/gptl/jrmacros/macros.make.craynompi +++ /dev/null @@ -1,164 +0,0 @@ -# This file contains macro settings which are used by the Makefile. Some require -# "yes" or "no", where various subflags are required if the value is -# "yes". The intent is for the user to edit whichever parts of this file are -# necessary, save to a file named "macros.make", then run "make" to build the -# GPTL library. - -########################################################################## - -# Where to install GPTL library and include files. -# if "git" is not available, set REVNO by hand -REVNO = $(shell git describe) -INSTALLDIR = $(HOME)/gptl-$(REVNO)/cray_nompi - -# Where to install man pages (if blank, defaults to $INSTALLDIR) -MANDIR = - -# C compiler -CC = cc - -# Whether to build debug lib or optimized lib, and associated flags -DEBUG = no -ifeq ($(DEBUG),yes) - CFLAGS = -g -O0 -else - CFLAGS = -g -O3 -endif - -# Set compiler flags for non-default ABIs (e.g. 64-bit addressing). -# Normally this can be blank. -ABIFLAGS = - -# Is the /proc filesystem available? On most Linux systems it is. If available, get_memusage() -# reads from it to find memory usage info. Otherwise get_memusage() will use get_rusage() -HAVE_SLASHPROC = yes - -# GPTL can enable threading either via OPENMP=yes, or PTHREADS=yes. Since -# most OpenMP implementations are built on top of pthreads, OpenMP -# applications linked with GPTL as built with PTHREADS=yes should work fine. -# Thus COMPFLAG should be set to the compiler flag that enables OpenMP directives -# if either OPENMP=yes, or PTHREADS=yes. If OPENMP=no and PTHREADS=no, GPTL -# will not be thread-safe. -OPENMP = yes -COMPFLAG = -homp -# Set PTHREADS if available and OPENMP=no -ifeq ($(OPENMP),no) - PTHREADS = yes -endif - -# For gcc, -Dinline=inline is a no-op. For other C compilers, things like -# -Dinline=__inline__ may be required. To find your compiler's definition, try -# running "./suggestions CC=". -INLINEFLAG = -Dinline=inline - -# To get some C compilers such as gcc to behave properly with -O0 and no inlining, -# need to effectively delete the "inline" keyword -ifeq ($(DEBUG),yes) - INLINEFLAG = -Dinline= -endif - -# To build the Fortran interface, set FORTRAN=yes and define the entries under -# ifeq ($(FORTRAN),yes). Otherwise, set FORTRAN=no and skip this section. -FORTRAN = yes -ifeq ($(FORTRAN),yes) -# Fortran name mangling: possibilities are: leave UNDERSCORING blank meaning none -# (e.g. xlf90), -DFORTRANDOUBLEUNDERSCORE (e.g. g77), and -DFORTRANUNDERSCORE -# (e.g. gfortran, pathf95) -# -# UNDERSCORING = -# UNDERSCORING = -DFORTRANDOUBLEUNDERSCORE - UNDERSCORING = -DFORTRANUNDERSCORE - -# Set Fortran compiler, flags, and OpenMP compiler flag. Note that Fortran -# OpenMP tests are possible with OPENMP=no as long as PTHREADS=yes -# These settings are only used by the Fortran test applications in ftests/. - FC = ftn - FFLAGS = -O2 - FOMPFLAG = -homp -endif - -# Archiver: normally it's just ar -AR = ar - -# PAPI: If a recent version of PAPI is installed, set HAVE_PAPI=yes and set inc and lib -# info as appropriate. -HAVE_PAPI = no -ifeq ($(HAVE_PAPI),yes) - PAPI_INCFLAGS = -I/contrib/papi/5.0.1/include - PAPI_LIBFLAGS = -L/contrib/papi/5.0.1/lib -lpapi -endif - -# Whether to build GPTL with MPI support. Set inc and lib info if needed. -# If CC=mpicc, MPI_INCFLAGS and MPI_LIBFLAGS can be blank. -HAVE_MPI = no -ifeq ($(HAVE_MPI),yes) -# Hopefully MPI_Comm_f2c() exists, but if not, set HAVE_COMM_F2C = no - HAVE_COMM_F2C = yes - MPI_INCFLAGS = - MPI_LIBFLAGS = -# Want 2 MPI tasks - MPICMD = aprun -n 2 -endif - -# clock_gettime() in librt.a is an option for gathering wallclock time stats -# on some machines. Setting HAVE_LIBRT=yes enables this, but will probably -# require linking applications with -lrt -HAVE_LIBRT = no - -# Only define HAVE_NANOTIME if this is a x86. It provides by far the finest grained, -# lowest overhead wallclock timer on that architecture. -# If HAVE_NANOTIME=yes, set BIT64=yes if this is an x86_64 -HAVE_NANOTIME = no -ifeq ($(HAVE_NANOTIME),yes) - BIT64 = yes -endif - - -# Some old compilers don't support vprintf. Set to "no" in this case -HAVE_VPRINTF = yes - -# Some old compilers don't support the C times() function. Set to "no" in this case -HAVE_TIMES = yes - -# gettimeofday() should be available everywhere. But if not, set to "no" -HAVE_GETTIMEOFDAY = yes - -# Whether to test auto-profiling (adds 2 tests to "make test"). If compiler is gcc or -# pathscale, set INSTRFLAG to -finstrument-functions. PGI 8.0.2 and later provide -# -Minstrument:functions. -TEST_AUTOPROFILE = no -ifeq ($(TEST_AUTOPROFILE),yes) - INSTRFLAG = -finstrument-functions - CXX = CC -endif - -# Whether to enable PMPI wrappers. Turning this on will result in automatic -# start/stop entries for a number of MPI calls. -ifeq ($(HAVE_MPI),yes) - ENABLE_PMPI = no - ifeq ($(ENABLE_PMPI),yes) -# Some newer MPI releases change the prototype of some input arguments from "void *" -# to "const void *". The prototype for these functions inside GPTL must match the -# MPI library in use. For ENABLE_PMPI=yes, set MPI_CONST to yes or no appropriately. - MPI_CONST = yes -# Yet another (Fortran-only) wart: the value of MPI_STATUS_SIZE varies among MPI distributions. -# Normal values are 5 or 10. AIX and very new MPICH versions it is 10. Set it here--if you get it -# wrong your instrumented code will tell you at run time the proper value. Or run ftests/pmpi - MPI_STATUS_SIZE_IN_INTS = 10 - endif -# If Fortran is enabled, the ability to automatically initialize GPTL from -# mpi_init can be enabled if iargc() and getarg() are available. - ifeq ($(FORTRAN),yes) - HAVE_IARGCGETARG = no - endif -endif - -# Whether system functions backtrace() and backtrace_symbols() exist. Setting HAVE_BACKTRACE=yes -# will enable auto-generation of function name when auto-profiling and GPTLdopr_memusage has been -# enabled at run-time. If HAVE_BACKTRACE=no, function address will be printed instead. -# GNU compilers: compile application code with -finstrument-functions -rdynamic -# Intel compilers: compile application code with -finstrument-functions -rdynamic -g -HAVE_BACKTRACE = no -ifeq ($(HAVE_BACKTRACE),yes) - CFLAGS += -DHAVE_BACKTRACE -endif diff --git a/cesm/models/utils/timing/gptl/jrmacros/macros.make.jet b/cesm/models/utils/timing/gptl/jrmacros/macros.make.jet deleted file mode 100644 index dbce67a..0000000 --- a/cesm/models/utils/timing/gptl/jrmacros/macros.make.jet +++ /dev/null @@ -1,163 +0,0 @@ -# This file contains macro settings which are used by the Makefile. Some require -# "yes" or "no", where various subflags are required if the value is -# "yes". The intent is for the user to edit whichever parts of this file are -# necessary, save to a file named "macros.make", then run "make" to build the -# GPTL library. - -########################################################################## - -# Where to install GPTL library and include files. -# if "git" is not available, set REVNO by hand -REVNO = $(shell git describe) -INSTALLDIR = /home/hpc/GPTL/gptl-$(REVNO)/mvapich - -# Where to install man pages (if blank, defaults to $INSTALLDIR) -MANDIR = - -# C compiler -CC = mpicc - -# Whether to build debug lib or optimized lib, and associated flags -DEBUG = no -ifeq ($(DEBUG),yes) - CFLAGS = -g -O0 -Wall -fno-inline -else - CFLAGS = -g -O3 -finline-functions -Winline -Wall -endif - -# Set compiler flags for non-default ABIs (e.g. 64-bit addressing). -# Normally this can be blank. -ABIFLAGS = - -# Is the /proc filesystem available? On most Linux systems it is. If available, get_memusage() -# reads from it to find memory usage info. Otherwise get_memusage() will use get_rusage() -HAVE_SLASHPROC = yes - -# GPTL can enable threading either via OPENMP=yes, or PTHREADS=yes. Since -# most OpenMP implementations are built on top of pthreads, OpenMP -# applications linked with GPTL as built with PTHREADS=yes should work fine. -# Thus COMPFLAG should be set to the compiler flag that enables OpenMP directives -# if either OPENMP=yes, or PTHREADS=yes. If OPENMP=no and PTHREADS=no, GPTL -# will not be thread-safe. -OPENMP = no -COMPFLAG = -openmp -# Set PTHREADS if available and OPENMP=no -ifeq ($(OPENMP),no) - PTHREADS = yes -endif - -# For gcc, -Dinline=inline is a no-op. For other C compilers, things like -# -Dinline=__inline__ may be required. To find your compiler's definition, try -# running "./suggestions CC=". -INLINEFLAG = -Dinline=inline - -# To get some C compilers such as gcc to behave properly with -O0 and no inlining, -# need to effectively delete the "inline" keyword -ifeq ($(DEBUG),yes) - INLINEFLAG = -Dinline= -endif - -# To build the Fortran interface, set FORTRAN=yes and define the entries under -# ifeq ($(FORTRAN),yes). Otherwise, set FORTRAN=no and skip this section. -FORTRAN = yes -ifeq ($(FORTRAN),yes) -# Fortran name mangling: possibilities are: leave UNDERSCORING blank meaning none -# (e.g. xlf90), -DFORTRANDOUBLEUNDERSCORE (e.g. g77), and -DFORTRANUNDERSCORE -# (e.g. gfortran, pathf95) -# -# UNDERSCORING = -# UNDERSCORING = -DFORTRANDOUBLEUNDERSCORE - UNDERSCORING = -DFORTRANUNDERSCORE - -# Set Fortran compiler, flags, and OpenMP compiler flag. Note that Fortran -# OpenMP tests are possible with OPENMP=no as long as PTHREADS=yes -# These settings are only used by the Fortran test applications in ftests/. - FC = mpif90 - FFLAGS = -g -O2 - FOMPFLAG = -openmp -endif - -# Archiver: normally it's just ar -AR = ar - -# PAPI: If a recent version of PAPI is installed, set HAVE_PAPI=yes and set inc and lib -# info as appropriate. -HAVE_PAPI = no -ifeq ($(HAVE_PAPI),yes) - PAPI_INCFLAGS = -I/contrib/papi/5.3.2/include - PAPI_LIBFLAGS = -L/contrib/papi/5.3.2/lib -lpapi -endif - -# Whether to build GPTL with MPI support. Set inc and lib info if needed. -# If CC=mpicc, MPI_INCFLAGS and MPI_LIBFLAGS can be blank. -HAVE_MPI = yes -ifeq ($(HAVE_MPI),yes) -# Hopefully MPI_Comm_f2c() exists, but if not, set HAVE_COMM_F2C = no - HAVE_COMM_F2C = yes - MPI_INCFLAGS = - MPI_LIBFLAGS = -# Want 2 MPI tasks - MPICMD = mpiexec -n 2 -endif - -# clock_gettime() in librt.a is an option for gathering wallclock time stats -# on some machines. Setting HAVE_LIBRT=yes enables this, but will probably -# require linking applications with -lrt -HAVE_LIBRT = no - -# Only define HAVE_NANOTIME if this is a x86. It provides by far the finest grained, -# lowest overhead wallclock timer on that architecture. -# If HAVE_NANOTIME=yes, set BIT64=yes if this is an x86_64 -HAVE_NANOTIME = yes -ifeq ($(HAVE_NANOTIME),yes) - BIT64 = yes -endif - -# Some old compilers don't support vprintf. Set to "no" in this case -HAVE_VPRINTF = yes - -# Some old compilers don't support the C times() function. Set to "no" in this case -HAVE_TIMES = yes - -# gettimeofday() should be available everywhere. But if not, set to "no" -HAVE_GETTIMEOFDAY = yes - -# Whether to test auto-profiling (adds 2 tests to "make test"). If compiler is gcc or -# pathscale, set INSTRFLAG to -finstrument-functions. PGI 8.0.2 and later provide -# -Minstrument:functions. -TEST_AUTOPROFILE = yes -ifeq ($(TEST_AUTOPROFILE),yes) - INSTRFLAG = -finstrument-functions - CXX = mpicxx -endif - -# Whether to enable PMPI wrappers. Turning this on will result in automatic -# start/stop entries for a number of MPI calls. -ifeq ($(HAVE_MPI),yes) - ENABLE_PMPI = no - ifeq ($(ENABLE_PMPI),yes) -# Some newer MPI releases change the prototype of some input arguments from "void *" -# to "const void *". The prototype for these functions inside GPTL must match the -# MPI library in use. For ENABLE_PMPI=yes, set MPI_CONST to yes or no appropriately. - MPI_CONST = no -# Yet another (Fortran-only) wart: the value of MPI_STATUS_SIZE varies among MPI distributions. -# Normal values are 5 or 10. AIX and very new MPICH versions it is 10. Set it here--if you get it -# wrong your instrumented code will tell you at run time the proper value. Or run ftests/pmpi - MPI_STATUS_SIZE_IN_INTS = 5 - endif -# If Fortran is enabled, the ability to automatically initialize GPTL from -# mpi_init can be enabled if iargc() and getarg() are available. - ifeq ($(FORTRAN),yes) - HAVE_IARGCGETARG = no - endif -endif - -# Whether system functions backtrace() and backtrace_symbols() exist. Setting HAVE_BACKTRACE=yes -# will enable auto-generation of function name when auto-profiling and GPTLdopr_memusage has been -# enabled at run-time. If HAVE_BACKTRACE=no, function address will be printed instead. -# GNU compilers: compile application code with -finstrument-functions -rdynamic -# Intel compilers: compile application code with -finstrument-functions -rdynamic -g -HAVE_BACKTRACE = yes -ifeq ($(HAVE_BACKTRACE),yes) - CFLAGS += -DHAVE_BACKTRACE -endif diff --git a/cesm/models/utils/timing/gptl/jrmacros/macros.make.jetnompi b/cesm/models/utils/timing/gptl/jrmacros/macros.make.jetnompi deleted file mode 100644 index a5fd3c8..0000000 --- a/cesm/models/utils/timing/gptl/jrmacros/macros.make.jetnompi +++ /dev/null @@ -1,163 +0,0 @@ -# This file contains macro settings which are used by the Makefile. Some require -# "yes" or "no", where various subflags are required if the value is -# "yes". The intent is for the user to edit whichever parts of this file are -# necessary, save to a file named "macros.make", then run "make" to build the -# GPTL library. - -########################################################################## - -# Where to install GPTL library and include files. -# if "git" is not available, set REVNO by hand -REVNO = $(shell git describe) -INSTALLDIR = /home/hpc/GPTL/gptl-$(REVNO)/intel_nompi - -# Where to install man pages (if blank, defaults to $INSTALLDIR) -MANDIR = - -# C compiler -CC = icc - -# Whether to build debug lib or optimized lib, and associated flags -DEBUG = no -ifeq ($(DEBUG),yes) - CFLAGS = -g -O0 -Wall -fno-inline -else - CFLAGS = -g -O3 -finline-functions -Winline -Wall -endif - -# Set compiler flags for non-default ABIs (e.g. 64-bit addressing). -# Normally this can be blank. -ABIFLAGS = - -# Is the /proc filesystem available? On most Linux systems it is. If available, get_memusage() -# reads from it to find memory usage info. Otherwise get_memusage() will use get_rusage() -HAVE_SLASHPROC = yes - -# GPTL can enable threading either via OPENMP=yes, or PTHREADS=yes. Since -# most OpenMP implementations are built on top of pthreads, OpenMP -# applications linked with GPTL as built with PTHREADS=yes should work fine. -# Thus COMPFLAG should be set to the compiler flag that enables OpenMP directives -# if either OPENMP=yes, or PTHREADS=yes. If OPENMP=no and PTHREADS=no, GPTL -# will not be thread-safe. -OPENMP = no -COMPFLAG = -openmp -# Set PTHREADS if available and OPENMP=no -ifeq ($(OPENMP),no) - PTHREADS = yes -endif - -# For gcc, -Dinline=inline is a no-op. For other C compilers, things like -# -Dinline=__inline__ may be required. To find your compiler's definition, try -# running "./suggestions CC=". -INLINEFLAG = -Dinline=inline - -# To get some C compilers such as gcc to behave properly with -O0 and no inlining, -# need to effectively delete the "inline" keyword -ifeq ($(DEBUG),yes) - INLINEFLAG = -Dinline= -endif - -# To build the Fortran interface, set FORTRAN=yes and define the entries under -# ifeq ($(FORTRAN),yes). Otherwise, set FORTRAN=no and skip this section. -FORTRAN = yes -ifeq ($(FORTRAN),yes) -# Fortran name mangling: possibilities are: leave UNDERSCORING blank meaning none -# (e.g. xlf90), -DFORTRANDOUBLEUNDERSCORE (e.g. g77), and -DFORTRANUNDERSCORE -# (e.g. gfortran, pathf95) -# -# UNDERSCORING = -# UNDERSCORING = -DFORTRANDOUBLEUNDERSCORE - UNDERSCORING = -DFORTRANUNDERSCORE - -# Set Fortran compiler, flags, and OpenMP compiler flag. Note that Fortran -# OpenMP tests are possible with OPENMP=no as long as PTHREADS=yes -# These settings are only used by the Fortran test applications in ftests/. - FC = ifort - FFLAGS = -g -O2 - FOMPFLAG = -openmp -endif - -# Archiver: normally it's just ar -AR = ar - -# PAPI: If a recent version of PAPI is installed, set HAVE_PAPI=yes and set inc and lib -# info as appropriate. -HAVE_PAPI = no -ifeq ($(HAVE_PAPI),yes) - PAPI_INCFLAGS = -I/contrib/papi/5.3.2/include - PAPI_LIBFLAGS = -L/contrib/papi/5.3.2/lib -lpapi -endif - -# Whether to build GPTL with MPI support. Set inc and lib info if needed. -# If CC=mpicc, MPI_INCFLAGS and MPI_LIBFLAGS can be blank. -HAVE_MPI = no -ifeq ($(HAVE_MPI),yes) -# Hopefully MPI_Comm_f2c() exists, but if not, set HAVE_COMM_F2C = no - HAVE_COMM_F2C = yes - MPI_INCFLAGS = - MPI_LIBFLAGS = -# Want 2 MPI tasks - MPICMD = mpiexec -n 2 -endif - -# clock_gettime() in librt.a is an option for gathering wallclock time stats -# on some machines. Setting HAVE_LIBRT=yes enables this, but will probably -# require linking applications with -lrt -HAVE_LIBRT = no - -# Only define HAVE_NANOTIME if this is a x86. It provides by far the finest grained, -# lowest overhead wallclock timer on that architecture. -# If HAVE_NANOTIME=yes, set BIT64=yes if this is an x86_64 -HAVE_NANOTIME = yes -ifeq ($(HAVE_NANOTIME),yes) - BIT64 = yes -endif - -# Some old compilers don't support vprintf. Set to "no" in this case -HAVE_VPRINTF = yes - -# Some old compilers don't support the C times() function. Set to "no" in this case -HAVE_TIMES = yes - -# gettimeofday() should be available everywhere. But if not, set to "no" -HAVE_GETTIMEOFDAY = yes - -# Whether to test auto-profiling (adds 2 tests to "make test"). If compiler is gcc or -# pathscale, set INSTRFLAG to -finstrument-functions. PGI 8.0.2 and later provide -# -Minstrument:functions. -TEST_AUTOPROFILE = yes -ifeq ($(TEST_AUTOPROFILE),yes) - INSTRFLAG = -finstrument-functions - CXX = icpc -endif - -# Whether to enable PMPI wrappers. Turning this on will result in automatic -# start/stop entries for a number of MPI calls. -ifeq ($(HAVE_MPI),yes) - ENABLE_PMPI = no - ifeq ($(ENABLE_PMPI),yes) -# Some newer MPI releases change the prototype of some input arguments from "void *" -# to "const void *". The prototype for these functions inside GPTL must match the -# MPI library in use. For ENABLE_PMPI=yes, set MPI_CONST to yes or no appropriately. - MPI_CONST = no -# Yet another (Fortran-only) wart: the value of MPI_STATUS_SIZE varies among MPI distributions. -# Normal values are 5 or 10. AIX and very new MPICH versions it is 10. Set it here--if you get it -# wrong your instrumented code will tell you at run time the proper value. Or run ftests/pmpi - MPI_STATUS_SIZE_IN_INTS = 5 - endif -# If Fortran is enabled, the ability to automatically initialize GPTL from -# mpi_init can be enabled if iargc() and getarg() are available. - ifeq ($(FORTRAN),yes) - HAVE_IARGCGETARG = no - endif -endif - -# Whether system functions backtrace() and backtrace_symbols() exist. Setting HAVE_BACKTRACE=yes -# will enable auto-generation of function name when auto-profiling and GPTLdopr_memusage has been -# enabled at run-time. If HAVE_BACKTRACE=no, function address will be printed instead. -# GNU compilers: compile application code with -finstrument-functions -rdynamic -# Intel compilers: compile application code with -finstrument-functions -rdynamic -g -HAVE_BACKTRACE = yes -ifeq ($(HAVE_BACKTRACE),yes) - CFLAGS += -DHAVE_BACKTRACE -endif diff --git a/cesm/models/utils/timing/gptl/jrmacros/macros.make.m1 b/cesm/models/utils/timing/gptl/jrmacros/macros.make.m1 deleted file mode 100644 index 201b2c6..0000000 --- a/cesm/models/utils/timing/gptl/jrmacros/macros.make.m1 +++ /dev/null @@ -1,163 +0,0 @@ -# This file contains macro settings which are used by the Makefile. Some require -# "yes" or "no", where various subflags are required if the value is -# "yes". The intent is for the user to edit whichever parts of this file are -# necessary, save to a file named "macros.make", then run "make" to build the -# GPTL library. - -########################################################################## - -# Where to install GPTL library and include files. -# if "git" is not available, set REVNO by hand -REVNO = $(shell git describe) -INSTALLDIR = $(HOME)/gptl-$(REVNO)/m1 - -# Where to install man pages (if blank, defaults to $INSTALLDIR) -MANDIR = - -# C compiler. If HAVE_MPI=yes (see below), this should probably be set to the wrapper script. -CC = mpiicc - -# Whether to build debug lib or optimized lib, and associated flags -DEBUG = no -ifeq ($(DEBUG),yes) - CFLAGS = -g -O0 -Wall -fno-inline -else - CFLAGS = -g -O3 -finline-functions -Winline -Wall -endif - -# Set compiler flags for non-default ABIs (e.g. 64-bit addressing). -# Normally this can be blank. -ABIFLAGS = - -# Is the /proc filesystem available? On most Linux systems it is. If available, get_memusage() -# reads from it to find memory usage info. Otherwise get_memusage() will use get_rusage() -HAVE_SLASHPROC = yes - -# GPTL can enable threading either via OPENMP=yes, or PTHREADS=yes. Since -# most OpenMP implementations are built on top of pthreads, OpenMP -# applications linked with GPTL as built with PTHREADS=yes should work fine. -# Thus COMPFLAG should be set to the compiler flag that enables OpenMP directives -# if either OPENMP=yes, or PTHREADS=yes. If OPENMP=no and PTHREADS=no, GPTL -# will not be thread-safe. -OPENMP = yes -COMPFLAG = -openmp -# Set PTHREADS if available and OPENMP=no -ifeq ($(OPENMP),no) - PTHREADS = no -endif - -# For gcc, -Dinline=inline is a no-op. For other C compilers, things like -# -Dinline=__inline__ may be required. To find your compiler's definition, try -# running "./suggestions CC=". -INLINEFLAG = -Dinline=inline - -# To get some C compilers such as gcc to behave properly with -O0 and no inlining, -# need to effectively delete the "inline" keyword -ifeq ($(DEBUG),yes) - INLINEFLAG = -Dinline= -endif - -# To build the Fortran interface, set FORTRAN=yes and define the entries under -# ifeq ($(FORTRAN),yes). Otherwise, set FORTRAN=no and skip this section. -FORTRAN = yes -ifeq ($(FORTRAN),yes) -# Fortran name mangling: possibilities are: leave UNDERSCORING blank meaning none -# (e.g. xlf90), -DFORTRANDOUBLEUNDERSCORE (e.g. g77), and -DFORTRANUNDERSCORE -# (e.g. gfortran, pathf95) -# -# UNDERSCORING = -# UNDERSCORING = -DFORTRANDOUBLEUNDERSCORE - UNDERSCORING = -DFORTRANUNDERSCORE - -# Set Fortran compiler, flags, and OpenMP compiler flag. Note that Fortran -# OpenMP tests are possible with OPENMP=no as long as PTHREADS=yes -# These settings are only used by the Fortran test applications in ftests/. - FC = mpiifort - FFLAGS = -g -O2 - FOMPFLAG = -openmp -endif - -# Archiver: normally it's just ar -AR = ar - -# PAPI: If a recent version of PAPI is installed, set HAVE_PAPI=yes and set inc and lib -# info as appropriate. -HAVE_PAPI = no -ifeq ($(HAVE_PAPI),yes) - PAPI_INCFLAGS = -I/contrib/papi/5.0.1/include - PAPI_LIBFLAGS = -L/contrib/papi/5.0.1/lib -lpapi -endif - -# Whether to build GPTL with MPI support. Set inc and lib info if needed. -# If CC=mpicc or equivalent MPI driver, MPI_INCFLAGS and MPI_LIBFLAGS can be blank. -HAVE_MPI = yes -ifeq ($(HAVE_MPI),yes) -# Hopefully MPI_Comm_f2c() exists, but if not, set HAVE_COMM_F2C = no - HAVE_COMM_F2C = yes - MPI_INCFLAGS = - MPI_LIBFLAGS = -# Want 2 MPI tasks - MPICMD = mpiexec -n 2 -endif - -# clock_gettime() in librt.a is an option for gathering wallclock time stats -# on some machines. Setting HAVE_LIBRT=yes enables this, but will probably -# require linking applications with -lrt -HAVE_LIBRT = no - -# Only define HAVE_NANOTIME if this is a x86. It provides by far the finest grained, -# lowest overhead wallclock timer on that architecture. -# If HAVE_NANOTIME=yes, set BIT64=yes if this is an x86_64 -HAVE_NANOTIME = yes -ifeq ($(HAVE_NANOTIME),yes) - BIT64 = yes -endif - -# Some old compilers don't support vprintf. Set to "no" in this case -HAVE_VPRINTF = yes - -# Some old compilers don't support the C times() function. Set to "no" in this case -HAVE_TIMES = yes - -# gettimeofday() should be available everywhere. But if not, set to "no" -HAVE_GETTIMEOFDAY = yes - -# Whether to test auto-profiling (adds 2 tests to "make test"). If compiler is gcc or -# pathscale, set INSTRFLAG to -finstrument-functions. PGI 8.0.2 and later provide -# -Minstrument:functions. -TEST_AUTOPROFILE = yes -ifeq ($(TEST_AUTOPROFILE),yes) - INSTRFLAG = -finstrument-functions - CXX = mpiicpc -endif - -# Whether to enable PMPI wrappers. Turning this on will result in automatic -# start/stop entries for a number of MPI calls. -ifeq ($(HAVE_MPI),yes) - ENABLE_PMPI = no - ifeq ($(ENABLE_PMPI),yes) -# Some newer MPI releases change the prototype of some input arguments from "void *" -# to "const void *". The prototype for these functions inside GPTL must match the -# MPI library in use. For ENABLE_PMPI=yes, set MPI_CONST to yes or no appropriately. - MPI_CONST = no -# Yet another (Fortran-only) wart: the value of MPI_STATUS_SIZE varies among MPI distributions. -# Normal values are 5 or 10. AIX and very new MPICH versions it is 10. Set it here--if you get it -# wrong your instrumented code will tell you at run time the proper value. Or run ftests/pmpi - MPI_STATUS_SIZE_IN_INTS = 5 - endif -# If Fortran is enabled, the ability to automatically initialize GPTL from -# mpi_init can be enabled if iargc() and getarg() are available. - ifeq ($(FORTRAN),yes) - HAVE_IARGCGETARG = no - endif -endif - -# Whether system functions backtrace() and backtrace_symbols() exist. Setting HAVE_BACKTRACE=yes -# will enable auto-generation of function name when auto-profiling and GPTLdopr_memusage has been -# enabled at run-time. If HAVE_BACKTRACE=no, function address will be printed instead. -# GNU compilers: compile application code with -finstrument-functions -rdynamic -# Intel compilers: compile application code with -finstrument-functions -rdynamic -g -HAVE_BACKTRACE = yes -ifeq ($(HAVE_BACKTRACE),yes) - CFLAGS += -DHAVE_BACKTRACE -endif diff --git a/cesm/models/utils/timing/gptl/jrmacros/macros.make.m1xeonphi b/cesm/models/utils/timing/gptl/jrmacros/macros.make.m1xeonphi deleted file mode 100644 index ba6f78c..0000000 --- a/cesm/models/utils/timing/gptl/jrmacros/macros.make.m1xeonphi +++ /dev/null @@ -1,163 +0,0 @@ -# This file contains macro settings which are used by the Makefile. Some require -# "yes" or "no", where various subflags are required if the value is -# "yes". The intent is for the user to edit whichever parts of this file are -# necessary, save to a file named "macros.make", then run "make" to build the -# GPTL library. - -########################################################################## - -# Where to install GPTL library and include files. -# if "git" is not available, set REVNO by hand -REVNO = $(shell git describe) -INSTALLDIR = $(HOME)/gptl-$(REVNO)/m1xeonphi - -# Where to install man pages (if blank, defaults to $INSTALLDIR) -MANDIR = - -# C compiler. If HAVE_MPI=yes (see below), this should probably be set to the wrapper script. -CC = mpiicc - -# Whether to build debug lib or optimized lib, and associated flags -DEBUG = no -ifeq ($(DEBUG),yes) - CFLAGS = -g -mmic -O0 -Wall -fno-inline -else - CFLAGS = -g -mmic -O3 -finline-functions -Winline -Wall -endif - -# Set compiler flags for non-default ABIs (e.g. 64-bit addressing). -# Normally this can be blank. -ABIFLAGS = - -# Is the /proc filesystem available? On most Linux systems it is. If available, get_memusage() -# reads from it to find memory usage info. Otherwise get_memusage() will use get_rusage() -HAVE_SLASHPROC = yes - -# GPTL can enable threading either via OPENMP=yes, or PTHREADS=yes. Since -# most OpenMP implementations are built on top of pthreads, OpenMP -# applications linked with GPTL as built with PTHREADS=yes should work fine. -# Thus COMPFLAG should be set to the compiler flag that enables OpenMP directives -# if either OPENMP=yes, or PTHREADS=yes. If OPENMP=no and PTHREADS=no, GPTL -# will not be thread-safe. -OPENMP = yes -COMPFLAG = -openmp -# Set PTHREADS if available and OPENMP=no -ifeq ($(OPENMP),no) - PTHREADS = no -endif - -# For gcc, -Dinline=inline is a no-op. For other C compilers, things like -# -Dinline=__inline__ may be required. To find your compiler's definition, try -# running "./suggestions CC=". -INLINEFLAG = -Dinline=inline - -# To get some C compilers such as gcc to behave properly with -O0 and no inlining, -# need to effectively delete the "inline" keyword -ifeq ($(DEBUG),yes) - INLINEFLAG = -Dinline= -endif - -# To build the Fortran interface, set FORTRAN=yes and define the entries under -# ifeq ($(FORTRAN),yes). Otherwise, set FORTRAN=no and skip this section. -FORTRAN = yes -ifeq ($(FORTRAN),yes) -# Fortran name mangling: possibilities are: leave UNDERSCORING blank meaning none -# (e.g. xlf90), -DFORTRANDOUBLEUNDERSCORE (e.g. g77), and -DFORTRANUNDERSCORE -# (e.g. gfortran, pathf95) -# -# UNDERSCORING = -# UNDERSCORING = -DFORTRANDOUBLEUNDERSCORE - UNDERSCORING = -DFORTRANUNDERSCORE - -# Set Fortran compiler, flags, and OpenMP compiler flag. Note that Fortran -# OpenMP tests are possible with OPENMP=no as long as PTHREADS=yes -# These settings are only used by the Fortran test applications in ftests/. - FC = mpiifort - FFLAGS = -g -O2 -mmic - FOMPFLAG = -openmp -endif - -# Archiver: normally it's just ar -AR = ar - -# PAPI: If a recent version of PAPI is installed, set HAVE_PAPI=yes and set inc and lib -# info as appropriate. -HAVE_PAPI = no -ifeq ($(HAVE_PAPI),yes) - PAPI_INCFLAGS = -I/contrib/papi/5.0.1/include - PAPI_LIBFLAGS = -L/contrib/papi/5.0.1/lib -lpapi -endif - -# Whether to build GPTL with MPI support. Set inc and lib info if needed. -# If CC=mpicc or equivalent MPI driver, MPI_INCFLAGS and MPI_LIBFLAGS can be blank. -HAVE_MPI = yes -ifeq ($(HAVE_MPI),yes) -# Hopefully MPI_Comm_f2c() exists, but if not, set HAVE_COMM_F2C = no - HAVE_COMM_F2C = yes - MPI_INCFLAGS = - MPI_LIBFLAGS = -# Want 2 MPI tasks - MPICMD = mpiexec -n 2 -endif - -# clock_gettime() in librt.a is an option for gathering wallclock time stats -# on some machines. Setting HAVE_LIBRT=yes enables this, but will probably -# require linking applications with -lrt -HAVE_LIBRT = no - -# Only define HAVE_NANOTIME if this is a x86. It provides by far the finest grained, -# lowest overhead wallclock timer on that architecture. -# If HAVE_NANOTIME=yes, set BIT64=yes if this is an x86_64 -HAVE_NANOTIME = yes -ifeq ($(HAVE_NANOTIME),yes) - BIT64 = yes -endif - -# Some old compilers don't support vprintf. Set to "no" in this case -HAVE_VPRINTF = yes - -# Some old compilers don't support the C times() function. Set to "no" in this case -HAVE_TIMES = yes - -# gettimeofday() should be available everywhere. But if not, set to "no" -HAVE_GETTIMEOFDAY = yes - -# Whether to test auto-profiling (adds 2 tests to "make test"). If compiler is gcc or -# pathscale, set INSTRFLAG to -finstrument-functions. PGI 8.0.2 and later provide -# -Minstrument:functions. -TEST_AUTOPROFILE = yes -ifeq ($(TEST_AUTOPROFILE),yes) - INSTRFLAG = -finstrument-functions - CXX = mpiicpc -endif - -# Whether to enable PMPI wrappers. Turning this on will result in automatic -# start/stop entries for a number of MPI calls. -ifeq ($(HAVE_MPI),yes) - ENABLE_PMPI = no - ifeq ($(ENABLE_PMPI),yes) -# Some newer MPI releases change the prototype of some input arguments from "void *" -# to "const void *". The prototype for these functions inside GPTL must match the -# MPI library in use. For ENABLE_PMPI=yes, set MPI_CONST to yes or no appropriately. - MPI_CONST = no -# Yet another (Fortran-only) wart: the value of MPI_STATUS_SIZE varies among MPI distributions. -# Normal values are 5 or 10. AIX and very new MPICH versions it is 10. Set it here--if you get it -# wrong your instrumented code will tell you at run time the proper value. Or run ftests/pmpi - MPI_STATUS_SIZE_IN_INTS = 5 - endif -# If Fortran is enabled, the ability to automatically initialize GPTL from -# mpi_init can be enabled if iargc() and getarg() are available. - ifeq ($(FORTRAN),yes) - HAVE_IARGCGETARG = no - endif -endif - -# Whether system functions backtrace() and backtrace_symbols() exist. Setting HAVE_BACKTRACE=yes -# will enable auto-generation of function name when auto-profiling and GPTLdopr_memusage has been -# enabled at run-time. If HAVE_BACKTRACE=no, function address will be printed instead. -# GNU compilers: compile application code with -finstrument-functions -rdynamic -# Intel compilers: compile application code with -finstrument-functions -rdynamic -g -HAVE_BACKTRACE = yes -ifeq ($(HAVE_BACKTRACE),yes) - CFLAGS += -DHAVE_BACKTRACE -endif diff --git a/cesm/models/utils/timing/gptl/jrmacros/macros.make.ornlintel b/cesm/models/utils/timing/gptl/jrmacros/macros.make.ornlintel deleted file mode 100644 index d521287..0000000 --- a/cesm/models/utils/timing/gptl/jrmacros/macros.make.ornlintel +++ /dev/null @@ -1,163 +0,0 @@ -# This file contains macro settings which are used by the Makefile. Some require -# "yes" or "no", where various subflags are required if the value is -# "yes". The intent is for the user to edit whichever parts of this file are -# necessary, save to a file named "macros.make", then run "make" to build the -# GPTL library. - -########################################################################## - -# Where to install GPTL library and include files. -# if "git" is not available, set REVNO by hand -REVNO = $(shell git describe) -INSTALLDIR = $(HOME)/GPTL/gptl-$(REVNO)/intel_mpi - -# Where to install man pages (if blank, defaults to $INSTALLDIR) -MANDIR = - -# C compiler -CC = cc - -# Whether to build debug lib or optimized lib, and associated flags -DEBUG = no -ifeq ($(DEBUG),yes) - CFLAGS = -g -O0 -Wall -fno-inline -else - CFLAGS = -g -O3 -finline-functions -Winline -Wall -endif - -# Set compiler flags for non-default ABIs (e.g. 64-bit addressing). -# Normally this can be blank. -ABIFLAGS = - -# Is the /proc filesystem available? On most Linux systems it is. If available, get_memusage() -# reads from it to find memory usage info. Otherwise get_memusage() will use get_rusage() -HAVE_SLASHPROC = yes - -# GPTL can enable threading either via OPENMP=yes, or PTHREADS=yes. Since -# most OpenMP implementations are built on top of pthreads, OpenMP -# applications linked with GPTL as built with PTHREADS=yes should work fine. -# Thus COMPFLAG should be set to the compiler flag that enables OpenMP directives -# if either OPENMP=yes, or PTHREADS=yes. If OPENMP=no and PTHREADS=no, GPTL -# will not be thread-safe. -OPENMP = no -COMPFLAG = -openmp -# Set PTHREADS if available and OPENMP=no -ifeq ($(OPENMP),no) - PTHREADS = yes -endif - -# For gcc, -Dinline=inline is a no-op. For other C compilers, things like -# -Dinline=__inline__ may be required. To find your compiler's definition, try -# running "./suggestions CC=". -INLINEFLAG = -Dinline=inline - -# To get some C compilers such as gcc to behave properly with -O0 and no inlining, -# need to effectively delete the "inline" keyword -ifeq ($(DEBUG),yes) - INLINEFLAG = -Dinline= -endif - -# To build the Fortran interface, set FORTRAN=yes and define the entries under -# ifeq ($(FORTRAN),yes). Otherwise, set FORTRAN=no and skip this section. -FORTRAN = yes -ifeq ($(FORTRAN),yes) -# Fortran name mangling: possibilities are: leave UNDERSCORING blank meaning none -# (e.g. xlf90), -DFORTRANDOUBLEUNDERSCORE (e.g. g77), and -DFORTRANUNDERSCORE -# (e.g. gfortran, pathf95) -# -# UNDERSCORING = -# UNDERSCORING = -DFORTRANDOUBLEUNDERSCORE - UNDERSCORING = -DFORTRANUNDERSCORE - -# Set Fortran compiler, flags, and OpenMP compiler flag. Note that Fortran -# OpenMP tests are possible with OPENMP=no as long as PTHREADS=yes -# These settings are only used by the Fortran test applications in ftests/. - FC = ftn - FFLAGS = -g -O2 - FOMPFLAG = -openmp -endif - -# Archiver: normally it's just ar -AR = ar - -# PAPI: If a recent version of PAPI is installed, set HAVE_PAPI=yes and set inc and lib -# info as appropriate. -HAVE_PAPI = no -ifeq ($(HAVE_PAPI),yes) - PAPI_INCFLAGS = -I/contrib/papi/5.0.1/include - PAPI_LIBFLAGS = -L/contrib/papi/5.0.1/lib -lpapi -endif - -# Whether to build GPTL with MPI support. Set inc and lib info if needed. -# If CC=mpicc, MPI_INCFLAGS and MPI_LIBFLAGS can be blank. -HAVE_MPI = yes -ifeq ($(HAVE_MPI),yes) -# Hopefully MPI_Comm_f2c() exists, but if not, set HAVE_COMM_F2C = no - HAVE_COMM_F2C = yes - MPI_INCFLAGS = - MPI_LIBFLAGS = -# Want 2 MPI tasks - MPICMD = aprun -n 2 -endif - -# clock_gettime() in librt.a is an option for gathering wallclock time stats -# on some machines. Setting HAVE_LIBRT=yes enables this, but will probably -# require linking applications with -lrt -HAVE_LIBRT = no - -# Only define HAVE_NANOTIME if this is a x86. It provides by far the finest grained, -# lowest overhead wallclock timer on that architecture. -# If HAVE_NANOTIME=yes, set BIT64=yes if this is an x86_64 -HAVE_NANOTIME = yes -ifeq ($(HAVE_NANOTIME),yes) - BIT64 = yes -endif - -# Some old compilers don't support vprintf. Set to "no" in this case -HAVE_VPRINTF = yes - -# Some old compilers don't support the C times() function. Set to "no" in this case -HAVE_TIMES = yes - -# gettimeofday() should be available everywhere. But if not, set to "no" -HAVE_GETTIMEOFDAY = yes - -# Whether to test auto-profiling (adds 2 tests to "make test"). If compiler is gcc or -# pathscale, set INSTRFLAG to -finstrument-functions. PGI 8.0.2 and later provide -# -Minstrument:functions. -TEST_AUTOPROFILE = yes -ifeq ($(TEST_AUTOPROFILE),yes) - INSTRFLAG = -finstrument-functions - CXX = CC -endif - -# Whether to enable PMPI wrappers. Turning this on will result in automatic -# start/stop entries for a number of MPI calls. -ifeq ($(HAVE_MPI),yes) - ENABLE_PMPI = no - ifeq ($(ENABLE_PMPI),yes) -# Some newer MPI releases change the prototype of some input arguments from "void *" -# to "const void *". The prototype for these functions inside GPTL must match the -# MPI library in use. For ENABLE_PMPI=yes, set MPI_CONST to yes or no appropriately. - MPI_CONST = no -# Yet another (Fortran-only) wart: the value of MPI_STATUS_SIZE varies among MPI distributions. -# Normal values are 5 or 10. AIX and very new MPICH versions it is 10. Set it here--if you get it -# wrong your instrumented code will tell you at run time the proper value. Or run ftests/pmpi - MPI_STATUS_SIZE_IN_INTS = 10 - endif -# If Fortran is enabled, the ability to automatically initialize GPTL from -# mpi_init can be enabled if iargc() and getarg() are available. - ifeq ($(FORTRAN),yes) - HAVE_IARGCGETARG = no - endif -endif - -# Whether system functions backtrace() and backtrace_symbols() exist. Setting HAVE_BACKTRACE=yes -# will enable auto-generation of function name when auto-profiling and GPTLdopr_memusage has been -# enabled at run-time. If HAVE_BACKTRACE=no, function address will be printed instead. -# GNU compilers: compile application code with -finstrument-functions -rdynamic -# Intel compilers: compile application code with -finstrument-functions -rdynamic -g -HAVE_BACKTRACE = yes -ifeq ($(HAVE_BACKTRACE),yes) - CFLAGS += -DHAVE_BACKTRACE -endif diff --git a/cesm/models/utils/timing/gptl/jrmacros/macros.make.tacc b/cesm/models/utils/timing/gptl/jrmacros/macros.make.tacc deleted file mode 100644 index 8d700e4..0000000 --- a/cesm/models/utils/timing/gptl/jrmacros/macros.make.tacc +++ /dev/null @@ -1,163 +0,0 @@ -# This file contains macro settings which are used by the Makefile. Some require -# "yes" or "no", where various subflags are required if the value is -# "yes". The intent is for the user to edit whichever parts of this file are -# necessary, save to a file named "macros.make", then run "make" to build the -# GPTL library. - -########################################################################## - -# Where to install GPTL library and include files. -# if "git" is not available, set REVNO by hand -REVNO = $(shell git describe) -INSTALLDIR = $(HOME)/gptl-$(REVNO)/xeon_mpi - -# Where to install man pages (if blank, defaults to $INSTALLDIR) -MANDIR = - -# C compiler. If HAVE_MPI=yes (see below), this should probably be set to the wrapper script. -CC = mpiicc - -# Whether to build debug lib or optimized lib, and associated flags -DEBUG = no -ifeq ($(DEBUG),yes) - CFLAGS = -g -O0 -Wall -fno-inline -else - CFLAGS = -g -O3 -finline-functions -Winline -Wall -endif - -# Set compiler flags for non-default ABIs (e.g. 64-bit addressing). -# Normally this can be blank. -ABIFLAGS = - -# Is the /proc filesystem available? On most Linux systems it is. If available, get_memusage() -# reads from it to find memory usage info. Otherwise get_memusage() will use get_rusage() -HAVE_SLASHPROC = yes - -# GPTL can enable threading either via OPENMP=yes, or PTHREADS=yes. Since -# most OpenMP implementations are built on top of pthreads, OpenMP -# applications linked with GPTL as built with PTHREADS=yes should work fine. -# Thus COMPFLAG should be set to the compiler flag that enables OpenMP directives -# if either OPENMP=yes, or PTHREADS=yes. If OPENMP=no and PTHREADS=no, GPTL -# will not be thread-safe. -OPENMP = yes -COMPFLAG = -openmp -# Set PTHREADS if available and OPENMP=no -ifeq ($(OPENMP),no) - PTHREADS = yes -endif - -# For gcc, -Dinline=inline is a no-op. For other C compilers, things like -# -Dinline=__inline__ may be required. To find your compiler's definition, try -# running "./suggestions CC=". -INLINEFLAG = -Dinline=inline - -# To get some C compilers such as gcc to behave properly with -O0 and no inlining, -# need to effectively delete the "inline" keyword -ifeq ($(DEBUG),yes) - INLINEFLAG = -Dinline= -endif - -# To build the Fortran interface, set FORTRAN=yes and define the entries under -# ifeq ($(FORTRAN),yes). Otherwise, set FORTRAN=no and skip this section. -FORTRAN = yes -ifeq ($(FORTRAN),yes) -# Fortran name mangling: possibilities are: leave UNDERSCORING blank meaning none -# (e.g. xlf90), -DFORTRANDOUBLEUNDERSCORE (e.g. g77), and -DFORTRANUNDERSCORE -# (e.g. gfortran, pathf95) -# -# UNDERSCORING = -# UNDERSCORING = -DFORTRANDOUBLEUNDERSCORE - UNDERSCORING = -DFORTRANUNDERSCORE - -# Set Fortran compiler, flags, and OpenMP compiler flag. Note that Fortran -# OpenMP tests are possible with OPENMP=no as long as PTHREADS=yes -# These settings are only used by the Fortran test applications in ftests/. - FC = mpiifort - FFLAGS = -g -O2 - FOMPFLAG = -openmp -endif - -# Archiver: normally it's just ar -AR = ar - -# PAPI: If a recent version of PAPI is installed, set HAVE_PAPI=yes and set inc and lib -# info as appropriate. -HAVE_PAPI = no -ifeq ($(HAVE_PAPI),yes) - PAPI_INCFLAGS = -I/opt/apps/papi/5.2RC/include - PAPI_LIBFLAGS = -L/opt/apps/papi/5.2RC/lib -lpapi -lpfm -endif - -# Whether to build GPTL with MPI support. Set inc and lib info if needed. -# If CC=mpicc or equivalent MPI driver, MPI_INCFLAGS and MPI_LIBFLAGS can be blank. -HAVE_MPI = yes -ifeq ($(HAVE_MPI),yes) -# Hopefully MPI_Comm_f2c() exists, but if not, set HAVE_COMM_F2C = no - HAVE_COMM_F2C = yes - MPI_INCFLAGS = - MPI_LIBFLAGS = -# Want 2 MPI tasks - MPICMD = mpiexec -n 2 -endif - -# clock_gettime() in librt.a is an option for gathering wallclock time stats -# on some machines. Setting HAVE_LIBRT=yes enables this, but will probably -# require linking applications with -lrt -HAVE_LIBRT = no - -# Only define HAVE_NANOTIME if this is a x86. It provides by far the finest grained, -# lowest overhead wallclock timer on that architecture. -# If HAVE_NANOTIME=yes, set BIT64=yes if this is an x86_64 -HAVE_NANOTIME = yes -ifeq ($(HAVE_NANOTIME),yes) - BIT64 = yes -endif - -# Some old compilers don't support vprintf. Set to "no" in this case -HAVE_VPRINTF = yes - -# Some old compilers don't support the C times() function. Set to "no" in this case -HAVE_TIMES = yes - -# gettimeofday() should be available everywhere. But if not, set to "no" -HAVE_GETTIMEOFDAY = yes - -# Whether to test auto-profiling (adds 2 tests to "make test"). If compiler is gcc or -# pathscale, set INSTRFLAG to -finstrument-functions. PGI 8.0.2 and later provide -# -Minstrument:functions. -TEST_AUTOPROFILE = yes -ifeq ($(TEST_AUTOPROFILE),yes) - INSTRFLAG = -finstrument-functions - CXX = mpiicpc -endif - -# Whether to enable PMPI wrappers. Turning this on will result in automatic -# start/stop entries for a number of MPI calls. -ifeq ($(HAVE_MPI),yes) - ENABLE_PMPI = no - ifeq ($(ENABLE_PMPI),yes) -# Some newer MPI releases change the prototype of some input arguments from "void *" -# to "const void *". The prototype for these functions inside GPTL must match the -# MPI library in use. For ENABLE_PMPI=yes, set MPI_CONST to yes or no appropriately. - MPI_CONST = no -# Yet another (Fortran-only) wart: the value of MPI_STATUS_SIZE varies among MPI distributions. -# Normal values are 5 or 10. AIX and very new MPICH versions it is 10. Set it here--if you get it -# wrong your instrumented code will tell you at run time the proper value. Or run ftests/pmpi - MPI_STATUS_SIZE_IN_INTS = 5 - endif -# If Fortran is enabled, the ability to automatically initialize GPTL from -# mpi_init can be enabled if iargc() and getarg() are available. - ifeq ($(FORTRAN),yes) - HAVE_IARGCGETARG = no - endif -endif - -# Whether system functions backtrace() and backtrace_symbols() exist. Setting HAVE_BACKTRACE=yes -# will enable auto-generation of function name when auto-profiling and GPTLdopr_memusage has been -# enabled at run-time. If HAVE_BACKTRACE=no, function address will be printed instead. -# GNU compilers: compile application code with -finstrument-functions -rdynamic -# Intel compilers: compile application code with -finstrument-functions -rdynamic -g -HAVE_BACKTRACE = yes -ifeq ($(HAVE_BACKTRACE),yes) - CFLAGS += -DHAVE_BACKTRACE -endif diff --git a/cesm/models/utils/timing/gptl/jrmacros/macros.make.taccxeonphi b/cesm/models/utils/timing/gptl/jrmacros/macros.make.taccxeonphi deleted file mode 100644 index 8d3b913..0000000 --- a/cesm/models/utils/timing/gptl/jrmacros/macros.make.taccxeonphi +++ /dev/null @@ -1,163 +0,0 @@ -# This file contains macro settings which are used by the Makefile. Some require -# "yes" or "no", where various subflags are required if the value is -# "yes". The intent is for the user to edit whichever parts of this file are -# necessary, save to a file named "macros.make", then run "make" to build the -# GPTL library. - -########################################################################## - -# Where to install GPTL library and include files. -# if "git" is not available, set REVNO by hand -REVNO = $(shell git describe) -INSTALLDIR = $(HOME)/gptl-$(REVNO)/xeonphi_mpi - -# Where to install man pages (if blank, defaults to $INSTALLDIR) -MANDIR = - -# C compiler. If HAVE_MPI=yes (see below), this should probably be set to the wrapper script. -CC = mpiicc - -# Whether to build debug lib or optimized lib, and associated flags -DEBUG = no -ifeq ($(DEBUG),yes) - CFLAGS = -g -mmic -O0 -Wall -fno-inline -else - CFLAGS = -g -mmic -O3 -finline-functions -Winline -Wall -endif - -# Set compiler flags for non-default ABIs (e.g. 64-bit addressing). -# Normally this can be blank. -ABIFLAGS = - -# Is the /proc filesystem available? On most Linux systems it is. If available, get_memusage() -# reads from it to find memory usage info. Otherwise get_memusage() will use get_rusage() -HAVE_SLASHPROC = yes - -# GPTL can enable threading either via OPENMP=yes, or PTHREADS=yes. Since -# most OpenMP implementations are built on top of pthreads, OpenMP -# applications linked with GPTL as built with PTHREADS=yes should work fine. -# Thus COMPFLAG should be set to the compiler flag that enables OpenMP directives -# if either OPENMP=yes, or PTHREADS=yes. If OPENMP=no and PTHREADS=no, GPTL -# will not be thread-safe. -OPENMP = yes -COMPFLAG = -openmp -# Set PTHREADS if available and OPENMP=no -ifeq ($(OPENMP),no) - PTHREADS = yes -endif - -# For gcc, -Dinline=inline is a no-op. For other C compilers, things like -# -Dinline=__inline__ may be required. To find your compiler's definition, try -# running "./suggestions CC=". -INLINEFLAG = -Dinline=inline - -# To get some C compilers such as gcc to behave properly with -O0 and no inlining, -# need to effectively delete the "inline" keyword -ifeq ($(DEBUG),yes) - INLINEFLAG = -Dinline= -endif - -# To build the Fortran interface, set FORTRAN=yes and define the entries under -# ifeq ($(FORTRAN),yes). Otherwise, set FORTRAN=no and skip this section. -FORTRAN = yes -ifeq ($(FORTRAN),yes) -# Fortran name mangling: possibilities are: leave UNDERSCORING blank meaning none -# (e.g. xlf90), -DFORTRANDOUBLEUNDERSCORE (e.g. g77), and -DFORTRANUNDERSCORE -# (e.g. gfortran, pathf95) -# -# UNDERSCORING = -# UNDERSCORING = -DFORTRANDOUBLEUNDERSCORE - UNDERSCORING = -DFORTRANUNDERSCORE - -# Set Fortran compiler, flags, and OpenMP compiler flag. Note that Fortran -# OpenMP tests are possible with OPENMP=no as long as PTHREADS=yes -# These settings are only used by the Fortran test applications in ftests/. - FC = mpiifort - FFLAGS = -g -O2 -mmic - FOMPFLAG = -openmp -endif - -# Archiver: normally it's just ar -AR = ar - -# PAPI: If a recent version of PAPI is installed, set HAVE_PAPI=yes and set inc and lib -# info as appropriate. -HAVE_PAPI = no -ifeq ($(HAVE_PAPI),yes) - PAPI_INCFLAGS = -I/opt/apps/papi/5.2RC/include - PAPI_LIBFLAGS = -L/opt/apps/papi/5.2RC/lib -lpapi -lpfm -endif - -# Whether to build GPTL with MPI support. Set inc and lib info if needed. -# If CC=mpicc or equivalent MPI driver, MPI_INCFLAGS and MPI_LIBFLAGS can be blank. -HAVE_MPI = yes -ifeq ($(HAVE_MPI),yes) -# Hopefully MPI_Comm_f2c() exists, but if not, set HAVE_COMM_F2C = no - HAVE_COMM_F2C = yes - MPI_INCFLAGS = - MPI_LIBFLAGS = -# Want 2 MPI tasks - MPICMD = mpiexec -n 2 -endif - -# clock_gettime() in librt.a is an option for gathering wallclock time stats -# on some machines. Setting HAVE_LIBRT=yes enables this, but will probably -# require linking applications with -lrt -HAVE_LIBRT = no - -# Only define HAVE_NANOTIME if this is a x86. It provides by far the finest grained, -# lowest overhead wallclock timer on that architecture. -# If HAVE_NANOTIME=yes, set BIT64=yes if this is an x86_64 -HAVE_NANOTIME = yes -ifeq ($(HAVE_NANOTIME),yes) - BIT64 = yes -endif - -# Some old compilers don't support vprintf. Set to "no" in this case -HAVE_VPRINTF = yes - -# Some old compilers don't support the C times() function. Set to "no" in this case -HAVE_TIMES = yes - -# gettimeofday() should be available everywhere. But if not, set to "no" -HAVE_GETTIMEOFDAY = yes - -# Whether to test auto-profiling (adds 2 tests to "make test"). If compiler is gcc or -# pathscale, set INSTRFLAG to -finstrument-functions. PGI 8.0.2 and later provide -# -Minstrument:functions. -TEST_AUTOPROFILE = yes -ifeq ($(TEST_AUTOPROFILE),yes) - INSTRFLAG = -finstrument-functions - CXX = mpiicpc -endif - -# Whether to enable PMPI wrappers. Turning this on will result in automatic -# start/stop entries for a number of MPI calls. -ifeq ($(HAVE_MPI),yes) - ENABLE_PMPI = no - ifeq ($(ENABLE_PMPI),yes) -# Some newer MPI releases change the prototype of some input arguments from "void *" -# to "const void *". The prototype for these functions inside GPTL must match the -# MPI library in use. For ENABLE_PMPI=yes, set MPI_CONST to yes or no appropriately. - MPI_CONST = no -# Yet another (Fortran-only) wart: the value of MPI_STATUS_SIZE varies among MPI distributions. -# Normal values are 5 or 10. AIX and very new MPICH versions it is 10. Set it here--if you get it -# wrong your instrumented code will tell you at run time the proper value. Or run ftests/pmpi - MPI_STATUS_SIZE_IN_INTS = 5 - endif -# If Fortran is enabled, the ability to automatically initialize GPTL from -# mpi_init can be enabled if iargc() and getarg() are available. - ifeq ($(FORTRAN),yes) - HAVE_IARGCGETARG = no - endif -endif - -# Whether system functions backtrace() and backtrace_symbols() exist. Setting HAVE_BACKTRACE=yes -# will enable auto-generation of function name when auto-profiling and GPTLdopr_memusage has been -# enabled at run-time. If HAVE_BACKTRACE=no, function address will be printed instead. -# GNU compilers: compile application code with -finstrument-functions -rdynamic -# Intel compilers: compile application code with -finstrument-functions -rdynamic -g -HAVE_BACKTRACE = yes -ifeq ($(HAVE_BACKTRACE),yes) - CFLAGS += -DHAVE_BACKTRACE -endif diff --git a/cesm/models/utils/timing/gptl/jrmacros/macros.make.zeus b/cesm/models/utils/timing/gptl/jrmacros/macros.make.zeus deleted file mode 100644 index 9d2b35e..0000000 --- a/cesm/models/utils/timing/gptl/jrmacros/macros.make.zeus +++ /dev/null @@ -1,163 +0,0 @@ -# This file contains macro settings which are used by the Makefile. Some require -# "yes" or "no", where various subflags are required if the value is -# "yes". The intent is for the user to edit whichever parts of this file are -# necessary, save to a file named "macros.make", then run "make" to build the -# GPTL library. - -########################################################################## - -# Where to install GPTL library and include files. -# if "git" is not available, set REVNO by hand -REVNO = $(shell git describe) -INSTALLDIR = /scratch1/portfolios/BMC/fim/GPTL/gptl-$(REVNO)/intel_mpi - -# Where to install man pages (if blank, defaults to $INSTALLDIR) -MANDIR = - -# C compiler -CC = mpicc - -# Whether to build debug lib or optimized lib, and associated flags -DEBUG = no -ifeq ($(DEBUG),yes) - CFLAGS = -g -O0 -Wall -fno-inline -else - CFLAGS = -g -O3 -finline-functions -Winline -Wall -endif - -# Set compiler flags for non-default ABIs (e.g. 64-bit addressing). -# Normally this can be blank. -ABIFLAGS = - -# Is the /proc filesystem available? On most Linux systems it is. If available, get_memusage() -# reads from it to find memory usage info. Otherwise get_memusage() will use get_rusage() -HAVE_SLASHPROC = yes - -# GPTL can enable threading either via OPENMP=yes, or PTHREADS=yes. Since -# most OpenMP implementations are built on top of pthreads, OpenMP -# applications linked with GPTL as built with PTHREADS=yes should work fine. -# Thus COMPFLAG should be set to the compiler flag that enables OpenMP directives -# if either OPENMP=yes, or PTHREADS=yes. If OPENMP=no and PTHREADS=no, GPTL -# will not be thread-safe. -OPENMP = no -COMPFLAG = -openmp -# Set PTHREADS if available and OPENMP=no -ifeq ($(OPENMP),no) - PTHREADS = yes -endif - -# For gcc, -Dinline=inline is a no-op. For other C compilers, things like -# -Dinline=__inline__ may be required. To find your compiler's definition, try -# running "./suggestions CC=". -INLINEFLAG = -Dinline=inline - -# To get some C compilers such as gcc to behave properly with -O0 and no inlining, -# need to effectively delete the "inline" keyword -ifeq ($(DEBUG),yes) - INLINEFLAG = -Dinline= -endif - -# To build the Fortran interface, set FORTRAN=yes and define the entries under -# ifeq ($(FORTRAN),yes). Otherwise, set FORTRAN=no and skip this section. -FORTRAN = yes -ifeq ($(FORTRAN),yes) -# Fortran name mangling: possibilities are: leave UNDERSCORING blank meaning none -# (e.g. xlf90), -DFORTRANDOUBLEUNDERSCORE (e.g. g77), and -DFORTRANUNDERSCORE -# (e.g. gfortran, pathf95) -# -# UNDERSCORING = -# UNDERSCORING = -DFORTRANDOUBLEUNDERSCORE - UNDERSCORING = -DFORTRANUNDERSCORE - -# Set Fortran compiler, flags, and OpenMP compiler flag. Note that Fortran -# OpenMP tests are possible with OPENMP=no as long as PTHREADS=yes -# These settings are only used by the Fortran test applications in ftests/. - FC = mpif90 - FFLAGS = -g -O2 - FOMPFLAG = -openmp -endif - -# Archiver: normally it's just ar -AR = ar - -# PAPI: If a recent version of PAPI is installed, set HAVE_PAPI=yes and set inc and lib -# info as appropriate. -HAVE_PAPI = no -ifeq ($(HAVE_PAPI),yes) - PAPI_INCFLAGS = -I$(PAPI_ROOT)/include - PAPI_LIBFLAGS = -L$(PAPI_ROOT)/lib -lpapi -endif - -# Whether to build GPTL with MPI support. Set inc and lib info if needed. -# If CC=mpicc, MPI_INCFLAGS and MPI_LIBFLAGS can be blank. -HAVE_MPI = yes -ifeq ($(HAVE_MPI),yes) -# Hopefully MPI_Comm_f2c() exists, but if not, set HAVE_COMM_F2C = no - HAVE_COMM_F2C = yes - MPI_INCFLAGS = - MPI_LIBFLAGS = -# Want 2 MPI tasks - MPICMD = mpiexec_mpt -n 2 -endif - -# clock_gettime() in librt.a is an option for gathering wallclock time stats -# on some machines. Setting HAVE_LIBRT=yes enables this, but will probably -# require linking applications with -lrt -HAVE_LIBRT = no - -# Only define HAVE_NANOTIME if this is a x86. It provides by far the finest grained, -# lowest overhead wallclock timer on that architecture. -# If HAVE_NANOTIME=yes, set BIT64=yes if this is an x86_64 -HAVE_NANOTIME = yes -ifeq ($(HAVE_NANOTIME),yes) - BIT64 = yes -endif - -# Some old compilers don't support vprintf. Set to "no" in this case -HAVE_VPRINTF = yes - -# Some old compilers don't support the C times() function. Set to "no" in this case -HAVE_TIMES = yes - -# gettimeofday() should be available everywhere. But if not, set to "no" -HAVE_GETTIMEOFDAY = yes - -# Whether to test auto-profiling (adds 2 tests to "make test"). If compiler is gcc or -# pathscale, set INSTRFLAG to -finstrument-functions. PGI 8.0.2 and later provide -# -Minstrument:functions. -TEST_AUTOPROFILE = yes -ifeq ($(TEST_AUTOPROFILE),yes) - INSTRFLAG = -finstrument-functions - CXX = mpicxx -endif - -# Whether to enable PMPI wrappers. Turning this on will result in automatic -# start/stop entries for a number of MPI calls. -ifeq ($(HAVE_MPI),yes) - ENABLE_PMPI = no - ifeq ($(ENABLE_PMPI),yes) -# Some newer MPI releases change the prototype of some input arguments from "void *" -# to "const void *". The prototype for these functions inside GPTL must match the -# MPI library in use. For ENABLE_PMPI=yes, set MPI_CONST to yes or no appropriately. - MPI_CONST = no -# Yet another (Fortran-only) wart: the value of MPI_STATUS_SIZE varies among MPI distributions. -# Normal values are 5 or 10. AIX and very new MPICH versions it is 10. Set it here--if you get it -# wrong your instrumented code will tell you at run time the proper value. Or run ftests/pmpi - MPI_STATUS_SIZE_IN_INTS = 5 - endif -# If Fortran is enabled, the ability to automatically initialize GPTL from -# mpi_init can be enabled if iargc() and getarg() are available. - ifeq ($(FORTRAN),yes) - HAVE_IARGCGETARG = no - endif -endif - -# Whether system functions backtrace() and backtrace_symbols() exist. Setting HAVE_BACKTRACE=yes -# will enable auto-generation of function name when auto-profiling and GPTLdopr_memusage has been -# enabled at run-time. If HAVE_BACKTRACE=no, function address will be printed instead. -# GNU compilers: compile application code with -finstrument-functions -rdynamic -# Intel compilers: compile application code with -finstrument-functions -rdynamic -g -HAVE_BACKTRACE = yes -ifeq ($(HAVE_BACKTRACE),yes) - CFLAGS += -DHAVE_BACKTRACE -endif diff --git a/cesm/models/utils/timing/gptl/jrmacros/macros.make.zeusnompi b/cesm/models/utils/timing/gptl/jrmacros/macros.make.zeusnompi deleted file mode 100644 index 65fde09..0000000 --- a/cesm/models/utils/timing/gptl/jrmacros/macros.make.zeusnompi +++ /dev/null @@ -1,163 +0,0 @@ -# This file contains macro settings which are used by the Makefile. Some require -# "yes" or "no", where various subflags are required if the value is -# "yes". The intent is for the user to edit whichever parts of this file are -# necessary, save to a file named "macros.make", then run "make" to build the -# GPTL library. - -########################################################################## - -# Where to install GPTL library and include files. -# if "git" is not available, set REVNO by hand -REVNO = $(shell git describe) -INSTALLDIR = /scratch1/portfolios/BMC/fim/GPTL/gptl-$(REVNO)/intel_nompi - -# Where to install man pages (if blank, defaults to $INSTALLDIR) -MANDIR = - -# C compiler -CC = icc - -# Whether to build debug lib or optimized lib, and associated flags -DEBUG = no -ifeq ($(DEBUG),yes) - CFLAGS = -g -O0 -Wall -fno-inline -else - CFLAGS = -g -O3 -finline-functions -Winline -Wall -endif - -# Set compiler flags for non-default ABIs (e.g. 64-bit addressing). -# Normally this can be blank. -ABIFLAGS = - -# Is the /proc filesystem available? On most Linux systems it is. If available, get_memusage() -# reads from it to find memory usage info. Otherwise get_memusage() will use get_rusage() -HAVE_SLASHPROC = yes - -# GPTL can enable threading either via OPENMP=yes, or PTHREADS=yes. Since -# most OpenMP implementations are built on top of pthreads, OpenMP -# applications linked with GPTL as built with PTHREADS=yes should work fine. -# Thus COMPFLAG should be set to the compiler flag that enables OpenMP directives -# if either OPENMP=yes, or PTHREADS=yes. If OPENMP=no and PTHREADS=no, GPTL -# will not be thread-safe. -OPENMP = no -COMPFLAG = -openmp -# Set PTHREADS if available and OPENMP=no -ifeq ($(OPENMP),no) - PTHREADS = yes -endif - -# For gcc, -Dinline=inline is a no-op. For other C compilers, things like -# -Dinline=__inline__ may be required. To find your compiler's definition, try -# running "./suggestions CC=". -INLINEFLAG = -Dinline=inline - -# To get some C compilers such as gcc to behave properly with -O0 and no inlining, -# need to effectively delete the "inline" keyword -ifeq ($(DEBUG),yes) - INLINEFLAG = -Dinline= -endif - -# To build the Fortran interface, set FORTRAN=yes and define the entries under -# ifeq ($(FORTRAN),yes). Otherwise, set FORTRAN=no and skip this section. -FORTRAN = yes -ifeq ($(FORTRAN),yes) -# Fortran name mangling: possibilities are: leave UNDERSCORING blank meaning none -# (e.g. xlf90), -DFORTRANDOUBLEUNDERSCORE (e.g. g77), and -DFORTRANUNDERSCORE -# (e.g. gfortran, pathf95) -# -# UNDERSCORING = -# UNDERSCORING = -DFORTRANDOUBLEUNDERSCORE - UNDERSCORING = -DFORTRANUNDERSCORE - -# Set Fortran compiler, flags, and OpenMP compiler flag. Note that Fortran -# OpenMP tests are possible with OPENMP=no as long as PTHREADS=yes -# These settings are only used by the Fortran test applications in ftests/. - FC = ifort - FFLAGS = -g -O2 - FOMPFLAG = -openmp -endif - -# Archiver: normally it's just ar -AR = ar - -# PAPI: If a recent version of PAPI is installed, set HAVE_PAPI=yes and set inc and lib -# info as appropriate. -HAVE_PAPI = no -ifeq ($(HAVE_PAPI),yes) - PAPI_INCFLAGS = -I$(PAPI_ROOT)/include - PAPI_LIBFLAGS = -L$(PAPI_ROOT)/lib -lpapi -endif - -# Whether to build GPTL with MPI support. Set inc and lib info if needed. -# If CC=mpicc, MPI_INCFLAGS and MPI_LIBFLAGS can be blank. -HAVE_MPI = no -ifeq ($(HAVE_MPI),yes) -# Hopefully MPI_Comm_f2c() exists, but if not, set HAVE_COMM_F2C = no - HAVE_COMM_F2C = yes - MPI_INCFLAGS = - MPI_LIBFLAGS = -# Want 2 MPI tasks - MPICMD = mpiexec_mpt -n 2 -endif - -# clock_gettime() in librt.a is an option for gathering wallclock time stats -# on some machines. Setting HAVE_LIBRT=yes enables this, but will probably -# require linking applications with -lrt -HAVE_LIBRT = no - -# Only define HAVE_NANOTIME if this is a x86. It provides by far the finest grained, -# lowest overhead wallclock timer on that architecture. -# If HAVE_NANOTIME=yes, set BIT64=yes if this is an x86_64 -HAVE_NANOTIME = yes -ifeq ($(HAVE_NANOTIME),yes) - BIT64 = yes -endif - -# Some old compilers don't support vprintf. Set to "no" in this case -HAVE_VPRINTF = yes - -# Some old compilers don't support the C times() function. Set to "no" in this case -HAVE_TIMES = yes - -# gettimeofday() should be available everywhere. But if not, set to "no" -HAVE_GETTIMEOFDAY = yes - -# Whether to test auto-profiling (adds 2 tests to "make test"). If compiler is gcc or -# pathscale, set INSTRFLAG to -finstrument-functions. PGI 8.0.2 and later provide -# -Minstrument:functions. -TEST_AUTOPROFILE = yes -ifeq ($(TEST_AUTOPROFILE),yes) - INSTRFLAG = -finstrument-functions - CXX = icpc -endif - -# Whether to enable PMPI wrappers. Turning this on will result in automatic -# start/stop entries for a number of MPI calls. -ifeq ($(HAVE_MPI),yes) - ENABLE_PMPI = no - ifeq ($(ENABLE_PMPI),yes) -# Some newer MPI releases change the prototype of some input arguments from "void *" -# to "const void *". The prototype for these functions inside GPTL must match the -# MPI library in use. For ENABLE_PMPI=yes, set MPI_CONST to yes or no appropriately. - MPI_CONST = no -# Yet another (Fortran-only) wart: the value of MPI_STATUS_SIZE varies among MPI distributions. -# Normal values are 5 or 10. AIX and very new MPICH versions it is 10. Set it here--if you get it -# wrong your instrumented code will tell you at run time the proper value. Or run ftests/pmpi - MPI_STATUS_SIZE_IN_INTS = 5 - endif -# If Fortran is enabled, the ability to automatically initialize GPTL from -# mpi_init can be enabled if iargc() and getarg() are available. - ifeq ($(FORTRAN),yes) - HAVE_IARGCGETARG = no - endif -endif - -# Whether system functions backtrace() and backtrace_symbols() exist. Setting HAVE_BACKTRACE=yes -# will enable auto-generation of function name when auto-profiling and GPTLdopr_memusage has been -# enabled at run-time. If HAVE_BACKTRACE=no, function address will be printed instead. -# GNU compilers: compile application code with -finstrument-functions -rdynamic -# Intel compilers: compile application code with -finstrument-functions -rdynamic -g -HAVE_BACKTRACE = yes -ifeq ($(HAVE_BACKTRACE),yes) - CFLAGS += -DHAVE_BACKTRACE -endif diff --git a/cesm/models/utils/timing/gptl/macros.make.AIX b/cesm/models/utils/timing/gptl/macros.make.AIX deleted file mode 100644 index 10ee27f..0000000 --- a/cesm/models/utils/timing/gptl/macros.make.AIX +++ /dev/null @@ -1,170 +0,0 @@ -# This file contains macro settings which are used by the Makefile. Some require -# "yes" or "no", where various subflags are required if the value is -# "yes". The intent is for the user to edit whichever parts of this file are -# necessary, save to a file named "macros.make", then run "make" to build the -# GPTL library. - -########################################################################## - -# Where to install GPTL library and include files. -# if "git" is not available, set REVNO by hand -REVNO = $(shell git describe) -INSTALLDIR = $(HOME)/gptl-$(REVNO)/aix - -# Where to install man pages (if blank, defaults to $INSTALLDIR) -MANDIR = - -# C compiler: For AIX set in HAVE_MPI section because it's MPI-dependent -#CC = mpcc_r - -# Whether to build debug lib or optimized lib, and associated flags -DEBUG = no -ifeq ($(DEBUG),yes) - CFLAGS = -g -O0 -qfullpath -else - CFLAGS = -O4 -qfullpath -endif - -# Set compiler flags for non-default ABIs (e.g. 64-bit addressing). -# Normally this can be blank. -ABIFLAGS = - -# Is the /proc filesystem available? On most Linux systems it is. If available, get_memusage() -# reads from it to find memory usage info. Otherwise get_memusage() will use get_rusage() -HAVE_SLASHPROC = no - -# GPTL can enable threading either via OPENMP=yes, or PTHREADS=yes. Since -# most OpenMP implementations are built on top of pthreads, OpenMP -# applications linked with GPTL as built with PTHREADS=yes should work fine. -# Thus COMPFLAG should be set to the compiler flag that enables OpenMP directives -# if either OPENMP=yes, or PTHREADS=yes. If OPENMP=no and PTHREADS=no, GPTL -# will not be thread-safe. -OPENMP = no -COMPFLAG = -qsmp=omp -# Set PTHREADS if available and OPENMP=no -ifeq ($(OPENMP),no) - PTHREADS = yes -endif - -# For gcc, -Dinline=inline is a no-op. For other C compilers, things like -# -Dinline=__inline__ may be required. To find your compiler's definition, try -# running "./suggestions CC=". -INLINEFLAG = -Dinline="" - -# To get some C compilers such as gcc to behave properly with -O0 and no inlining, -# need to effectively delete the "inline" keyword -ifeq ($(DEBUG),yes) - INLINEFLAG = -Dinline= -endif - -# To build the Fortran interface, set FORTRAN=yes and define the entries under -# ifeq ($(FORTRAN),yes). Otherwise, set FORTRAN=no and skip this section. -FORTRAN = yes -ifeq ($(FORTRAN),yes) -# Fortran name mangling: possibilities are: leave UNDERSCORING blank meaning none -# (e.g. xlf90), -DFORTRANDOUBLEUNDERSCORE (e.g. g77), and -DFORTRANUNDERSCORE -# (e.g. gfortran, pathf95) -# -UNDERSCORING = -# UNDERSCORING = -DFORTRANDOUBLEUNDERSCORE -# UNDERSCORING = -DFORTRANUNDERSCORE - -# Set Fortran compiler, flags, and OpenMP compiler flag. Note that Fortran -# OpenMP tests are possible with OPENMP=no as long as PTHREADS=yes -# These settings are only used by the Fortran test applications in ftests/. - -# Fortran compiler: For AIX set in HAVE_MPI section because it's MPI-dependent -# FC = xlf90_r - FFLAGS = -g -O2 -qfullpath - FOMPFLAG = -qsmp=omp -endif - -# Archiver: normally it's just ar -AR = ar - -# PAPI: If a recent version of PAPI is installed, set HAVE_PAPI=yes and set inc and lib -# info as appropriate. -HAVE_PAPI = no -ifeq ($(HAVE_PAPI),yes) -# These work on the NCAR bluefire machine -# PAPI_INCFLAGS = -I/contrib/papi-3.6.2/include -# PAPI_LIBFLAGS = -L/contrib/papi-3.6.2/lib -lpapi -lpmapi - PAPI_INCFLAGS = -I - PAPI_LIBFLAGS = -L -lpapi -lpmapi -endif - -# Whether to build GPTL with MPI support. Set inc and lib info if needed. -# If CC=mpicc, MPI_INCFLAGS and MPI_LIBFLAGS can be blank. -HAVE_MPI = yes -ifeq ($(HAVE_MPI),yes) -# C compiler for MPI - CC = mpcc_r -# Hopefully MPI_Comm_f2c() exists, but if not, set HAVE_COMM_F2C = no - HAVE_COMM_F2C = yes - MPI_INCFLAGS = - MPI_LIBFLAGS = -# Want 2 MPI tasks. On AIX this is specified by the batch system - MPICMD = mpirun.lsf -# Fortran compiler for MPI - ifeq ($(FORTRAN),yes) - FC = mpxlf90_r - endif -else -# C and Fortran compilers for no MPI - CC = cc_r - ifeq ($(FORTRAN),yes) - FC = xlf90_r - endif -endif - -# clock_gettime() in librt.a is an option for gathering wallclock time stats -# on some machines. Setting HAVE_LIBRT=yes enables this, but will probably -# require linking applications with -lrt -HAVE_LIBRT = no - -# Only define HAVE_NANOTIME if this is a x86. It provides by far the finest grained, -# lowest overhead wallclock timer on that architecture. -# If HAVE_NANOTIME=yes, set BIT64=yes if this is an x86_64 -HAVE_NANOTIME = no -ifeq ($(HAVE_NANOTIME),yes) - BIT64 = no -endif - -# Some old compilers don't support vprintf. Set to "no" in this case -HAVE_VPRINTF = yes - -# Some old compilers don't support the C times() function. Set to "no" in this case -HAVE_TIMES = yes - -# gettimeofday() should be available everywhere. But if not, set to "no" -HAVE_GETTIMEOFDAY = yes - -# Whether to test auto-profiling (adds 2 tests to "make test"). If compiler is gcc or -# pathscale, set INSTRFLAG to -finstrument-functions. PGI 8.0.2 and later provide -# -Minstrument:functions. -TEST_AUTOPROFILE = yes -ifeq ($(TEST_AUTOPROFILE),yes) - INSTRFLAG = "-qdebug=function_trace" - CXX = mpCC -endif - -# Whether to enable PMPI wrappers. Turning this on will result in automatic -# start/stop entries for a number of MPI calls. -ifeq ($(HAVE_MPI),yes) - ENABLE_PMPI = no - ifeq ($(ENABLE_PMPI),yes) -# Some newer MPI releases change the prototype of some input arguments from "void *" -# to "const void *". The prototype for these functions inside GPTL must match the -# MPI library in use. For ENABLE_PMPI=yes, set MPI_CONST to yes or no appropriately. - MPI_CONST = no -# Yet another (Fortran-only) wart: the value of MPI_STATUS_SIZE varies among MPI distributions. -# Normal values are 5 or 10. AIX and very new MPICH versions it is 10. Set it here--if you get it -# wrong your instrumented code will tell you at run time the proper value. Or run ftests/pmpi - MPI_STATUS_SIZE_IN_INTS = 10 - endif -# If Fortran is enabled, the ability to automatically initialize GPTL from -# mpi_init can be enabled if iargc() and getarg() are available. - ifeq ($(FORTRAN),yes) - HAVE_IARGCGETARG = no - endif -endif diff --git a/cesm/models/utils/timing/gptl/macros.make.bluegene b/cesm/models/utils/timing/gptl/macros.make.bluegene deleted file mode 100644 index ef84019..0000000 --- a/cesm/models/utils/timing/gptl/macros.make.bluegene +++ /dev/null @@ -1,167 +0,0 @@ -# This file contains macro settings which are used by the Makefile. Some require -# "yes" or "no", where various subflags are required if the value is -# "yes". The intent is for the user to edit whichever parts of this file are -# necessary, save to a file named "macros.make", then run "make" to build the -# GPTL library. - -########################################################################## - -# Where to install GPTL library and include files. -# if "git" is not available, set REVNO by hand -REVNO = $(shell git describe) -INSTALLDIR = $(HOME)/gptl-$(REVNO)/bluegene - -# Where to install man pages (if blank, defaults to $INSTALLDIR) -MANDIR = - -# C compiler: For AIX set in HAVE_MPI section because it's MPI-dependent -#CC = mpcc_r - -# Whether to build debug lib or optimized lib, and associated flags -DEBUG = no -ifeq ($(DEBUG),yes) - CFLAGS = -g -O0 -qfullpath -else - CFLAGS = -O3 -qfullpath -endif - -# Set compiler flags for non-default ABIs (e.g. 64-bit addressing). -# Normally this can be blank. -ABIFLAGS = - -# Is the /proc filesystem available? On most Linux systems it is. If available, get_memusage() -# reads from it to find memory usage info. Otherwise get_memusage() will use get_rusage() -HAVE_SLASHPROC = no - -# GPTL can enable threading either via OPENMP=yes, or PTHREADS=yes. Since -# most OpenMP implementations are built on top of pthreads, OpenMP -# applications linked with GPTL as built with PTHREADS=yes should work fine. -# Thus COMPFLAG should be set to the compiler flag that enables OpenMP directives -# if either OPENMP=yes, or PTHREADS=yes. If OPENMP=no and PTHREADS=no, GPTL -# will not be thread-safe. -OPENMP = no -COMPFLAG = -qsmp=omp -# Set PTHREADS if available and OPENMP=no -ifeq ($(OPENMP),no) - PTHREADS = yes -endif - -# For gcc, -Dinline=inline is a no-op. For other C compilers, things like -# -Dinline=__inline__ may be required. To find your compiler's definition, try -# running "./suggestions CC=". -INLINEFLAG = -Dinline="" - -# To get some C compilers such as gcc to behave properly with -O0 and no inlining, -# need to effectively delete the "inline" keyword -ifeq ($(DEBUG),yes) - INLINEFLAG = -Dinline= -endif - -# To build the Fortran interface, set FORTRAN=yes and define the entries under -# ifeq ($(FORTRAN),yes). Otherwise, set FORTRAN=no and skip this section. -FORTRAN = yes -ifeq ($(FORTRAN),yes) -# Fortran name mangling: possibilities are: leave UNDERSCORING blank meaning none -# (e.g. xlf90), -DFORTRANDOUBLEUNDERSCORE (e.g. g77), and -DFORTRANUNDERSCORE -# (e.g. gfortran, pathf95) -# -UNDERSCORING = -# UNDERSCORING = -DFORTRANDOUBLEUNDERSCORE -# UNDERSCORING = -DFORTRANUNDERSCORE - -# Set Fortran compiler, flags, and OpenMP compiler flag. Note that Fortran -# OpenMP tests are possible with OPENMP=no as long as PTHREADS=yes -# These settings are only used by the Fortran test applications in ftests/. - -# Fortran compiler: For AIX set in HAVE_MPI section because it's MPI-dependent -# FC = xlf90_r - FFLAGS = -g -O2 -qfullpath - FOMPFLAG = -qsmp=omp -endif - -# Archiver: normally it's just ar -AR = ar - -# PAPI: If a recent version of PAPI is installed, set HAVE_PAPI=yes and set inc and lib -# info as appropriate. -HAVE_PAPI = no -ifeq ($(HAVE_PAPI),yes) - PAPI_INCFLAGS = -I - PAPI_LIBFLAGS = -L -lpapi -lpmapi -endif - -# Whether to build GPTL with MPI support. Set inc and lib info if needed. -# If CC=mpicc, MPI_INCFLAGS and MPI_LIBFLAGS can be blank. -HAVE_MPI = yes -ifeq ($(HAVE_MPI),yes) -# C compiler for MPI - CC = mpixlc_r -# Hopefully MPI_Comm_f2c() exists, but if not, set HAVE_COMM_F2C = no - HAVE_COMM_F2C = yes - MPI_INCFLAGS = - MPI_LIBFLAGS = -# Want 2 MPI tasks. On AIX this is specified by the batch system - MPICMD = mpirun.lsf -# Fortran compiler for MPI - ifeq ($(FORTRAN),yes) - FC = mpixlf90_r - endif -else -# C and Fortran compilers - CC = cc_r - ifeq ($(FORTRAN),yes) - FC = xlf90_r - endif -endif - -# clock_gettime() in librt.a is an option for gathering wallclock time stats -# on some machines. Setting HAVE_LIBRT=yes enables this, but will probably -# require linking applications with -lrt -HAVE_LIBRT = no - -# Only define HAVE_NANOTIME if this is a x86. It provides by far the finest grained, -# lowest overhead wallclock timer on that architecture. -# If HAVE_NANOTIME=yes, set BIT64=yes if this is an x86_64 -HAVE_NANOTIME = no -ifeq ($(HAVE_NANOTIME),yes) - BIT64 = no -endif - -# Some old compilers don't support vprintf. Set to "no" in this case -HAVE_VPRINTF = yes - -# Some old compilers don't support the C times() function. Set to "no" in this case -HAVE_TIMES = yes - -# gettimeofday() should be available everywhere. But if not, set to "no" -HAVE_GETTIMEOFDAY = yes - -# Whether to test auto-profiling (adds 2 tests to "make test"). If compiler is gcc or -# pathscale, set INSTRFLAG to -finstrument-functions. PGI 8.0.2 and later provide -# -Minstrument:functions. -TEST_AUTOPROFILE = no -ifeq ($(TEST_AUTOPROFILE),yes) - INSTRFLAG = -auto_instrumentation_not_available_on_AIX - CXX = mpCC -endif - -# Whether to enable PMPI wrappers. Turning this on will result in automatic -# start/stop entries for a number of MPI calls. -ifeq ($(HAVE_MPI),yes) - ENABLE_PMPI = no - ifeq ($(ENABLE_PMPI),yes) -# Some newer MPI releases change the prototype of some input arguments from "void *" -# to "const void *". The prototype for these functions inside GPTL must match the -# MPI library in use. For ENABLE_PMPI=yes, set MPI_CONST to yes or no appropriately. - MPI_CONST = no -# Yet another (Fortran-only) wart: the value of MPI_STATUS_SIZE varies among MPI distributions. -# Normal values are 5 or 10. AIX and very new MPICH versions it is 10. Set it here--if you get it -# wrong your instrumented code will tell you at run time the proper value. Or run ftests/pmpi - MPI_STATUS_SIZE_IN_INTS = 10 - endif -# If Fortran is enabled, the ability to automatically initialize GPTL from -# mpi_init can be enabled if iargc() and getarg() are available. - ifeq ($(FORTRAN),yes) - HAVE_IARGCGETARG = no - endif -endif diff --git a/cesm/models/utils/timing/gptl/macros.make.cray b/cesm/models/utils/timing/gptl/macros.make.cray deleted file mode 100644 index 7365e59..0000000 --- a/cesm/models/utils/timing/gptl/macros.make.cray +++ /dev/null @@ -1,164 +0,0 @@ -# This file contains macro settings which are used by the Makefile. Some require -# "yes" or "no", where various subflags are required if the value is -# "yes". The intent is for the user to edit whichever parts of this file are -# necessary, save to a file named "macros.make", then run "make" to build the -# GPTL library. - -########################################################################## - -# Where to install GPTL library and include files. -# if "git" is not available, set REVNO by hand -REVNO = $(shell git describe) -INSTALLDIR = $(HOME)/gptl-$(REVNO)/cray_mpi - -# Where to install man pages (if blank, defaults to $INSTALLDIR) -MANDIR = - -# C compiler -CC = cc - -# Whether to build debug lib or optimized lib, and associated flags -DEBUG = no -ifeq ($(DEBUG),yes) - CFLAGS = -g -O0 -else - CFLAGS = -g -O3 -endif - -# Set compiler flags for non-default ABIs (e.g. 64-bit addressing). -# Normally this can be blank. -ABIFLAGS = - -# Is the /proc filesystem available? On most Linux systems it is. If available, get_memusage() -# reads from it to find memory usage info. Otherwise get_memusage() will use get_rusage() -HAVE_SLASHPROC = yes - -# GPTL can enable threading either via OPENMP=yes, or PTHREADS=yes. Since -# most OpenMP implementations are built on top of pthreads, OpenMP -# applications linked with GPTL as built with PTHREADS=yes should work fine. -# Thus COMPFLAG should be set to the compiler flag that enables OpenMP directives -# if either OPENMP=yes, or PTHREADS=yes. If OPENMP=no and PTHREADS=no, GPTL -# will not be thread-safe. -OPENMP = yes -COMPFLAG = -homp -# Set PTHREADS if available and OPENMP=no -ifeq ($(OPENMP),no) - PTHREADS = yes -endif - -# For gcc, -Dinline=inline is a no-op. For other C compilers, things like -# -Dinline=__inline__ may be required. To find your compiler's definition, try -# running "./suggestions CC=". -INLINEFLAG = -Dinline=inline - -# To get some C compilers such as gcc to behave properly with -O0 and no inlining, -# need to effectively delete the "inline" keyword -ifeq ($(DEBUG),yes) - INLINEFLAG = -Dinline= -endif - -# To build the Fortran interface, set FORTRAN=yes and define the entries under -# ifeq ($(FORTRAN),yes). Otherwise, set FORTRAN=no and skip this section. -FORTRAN = yes -ifeq ($(FORTRAN),yes) -# Fortran name mangling: possibilities are: leave UNDERSCORING blank meaning none -# (e.g. xlf90), -DFORTRANDOUBLEUNDERSCORE (e.g. g77), and -DFORTRANUNDERSCORE -# (e.g. gfortran, pathf95) -# -# UNDERSCORING = -# UNDERSCORING = -DFORTRANDOUBLEUNDERSCORE - UNDERSCORING = -DFORTRANUNDERSCORE - -# Set Fortran compiler, flags, and OpenMP compiler flag. Note that Fortran -# OpenMP tests are possible with OPENMP=no as long as PTHREADS=yes -# These settings are only used by the Fortran test applications in ftests/. - FC = ftn - FFLAGS = -O2 - FOMPFLAG = -homp -endif - -# Archiver: normally it's just ar -AR = ar - -# PAPI: If a recent version of PAPI is installed, set HAVE_PAPI=yes and set inc and lib -# info as appropriate. -HAVE_PAPI = no -ifeq ($(HAVE_PAPI),yes) - PAPI_INCFLAGS = -I/contrib/papi/5.0.1/include - PAPI_LIBFLAGS = -L/contrib/papi/5.0.1/lib -lpapi -endif - -# Whether to build GPTL with MPI support. Set inc and lib info if needed. -# If CC=mpicc, MPI_INCFLAGS and MPI_LIBFLAGS can be blank. -HAVE_MPI = yes -ifeq ($(HAVE_MPI),yes) -# Hopefully MPI_Comm_f2c() exists, but if not, set HAVE_COMM_F2C = no - HAVE_COMM_F2C = yes - MPI_INCFLAGS = - MPI_LIBFLAGS = -# Want 2 MPI tasks - MPICMD = aprun -n 2 -endif - -# clock_gettime() in librt.a is an option for gathering wallclock time stats -# on some machines. Setting HAVE_LIBRT=yes enables this, but will probably -# require linking applications with -lrt -HAVE_LIBRT = no - -# Only define HAVE_NANOTIME if this is a x86. It provides by far the finest grained, -# lowest overhead wallclock timer on that architecture. -# If HAVE_NANOTIME=yes, set BIT64=yes if this is an x86_64 -HAVE_NANOTIME = no -ifeq ($(HAVE_NANOTIME),yes) - BIT64 = yes -endif - - -# Some old compilers don't support vprintf. Set to "no" in this case -HAVE_VPRINTF = yes - -# Some old compilers don't support the C times() function. Set to "no" in this case -HAVE_TIMES = yes - -# gettimeofday() should be available everywhere. But if not, set to "no" -HAVE_GETTIMEOFDAY = yes - -# Whether to test auto-profiling (adds 2 tests to "make test"). If compiler is gcc or -# pathscale, set INSTRFLAG to -finstrument-functions. PGI 8.0.2 and later provide -# -Minstrument:functions. -TEST_AUTOPROFILE = no -ifeq ($(TEST_AUTOPROFILE),yes) - INSTRFLAG = -finstrument-functions - CXX = CC -endif - -# Whether to enable PMPI wrappers. Turning this on will result in automatic -# start/stop entries for a number of MPI calls. -ifeq ($(HAVE_MPI),yes) - ENABLE_PMPI = no - ifeq ($(ENABLE_PMPI),yes) -# Some newer MPI releases change the prototype of some input arguments from "void *" -# to "const void *". The prototype for these functions inside GPTL must match the -# MPI library in use. For ENABLE_PMPI=yes, set MPI_CONST to yes or no appropriately. - MPI_CONST = no -# Yet another (Fortran-only) wart: the value of MPI_STATUS_SIZE varies among MPI distributions. -# Normal values are 5 or 10. AIX and very new MPICH versions it is 10. Set it here--if you get it -# wrong your instrumented code will tell you at run time the proper value. Or run ftests/pmpi - MPI_STATUS_SIZE_IN_INTS = 10 - endif -# If Fortran is enabled, the ability to automatically initialize GPTL from -# mpi_init can be enabled if iargc() and getarg() are available. - ifeq ($(FORTRAN),yes) - HAVE_IARGCGETARG = no - endif -endif - -# Whether system functions backtrace() and backtrace_symbols() exist. Setting HAVE_BACKTRACE=yes -# will enable auto-generation of function name when auto-profiling and GPTLdopr_memusage has been -# enabled at run-time. If HAVE_BACKTRACE=no, function address will be printed instead. -# GNU compilers: compile application code with -finstrument-functions -rdynamic -# Intel compilers: compile application code with -finstrument-functions -rdynamic -g -HAVE_BACKTRACE = yes -ifeq ($(HAVE_BACKTRACE),yes) - CFLAGS += -DHAVE_BACKTRACE -endif diff --git a/cesm/models/utils/timing/gptl/macros.make.lahey b/cesm/models/utils/timing/gptl/macros.make.lahey deleted file mode 100644 index 01c9574..0000000 --- a/cesm/models/utils/timing/gptl/macros.make.lahey +++ /dev/null @@ -1,163 +0,0 @@ -# This file contains macro settings which are used by the Makefile. Some require -# "yes" or "no", where various subflags are required if the value is -# "yes". The intent is for the user to edit whichever parts of this file are -# necessary, save to a file named "macros.make", then run "make" to build the -# GPTL library. - -########################################################################## - -# Where to install GPTL library and include files. -# if "git" is not available, set REVNO by hand -REVNO = $(shell git describe) -INSTALLDIR = $(HOME)/gptl-$(REVNO)/lahey_nompi - -# Where to install man pages (if blank, defaults to $INSTALLDIR) -MANDIR = - -# C compiler -CC = gcc - -# Whether to build debug lib or optimized lib, and associated flags -DEBUG = no -ifeq ($(DEBUG),yes) - CFLAGS = -g -O0 -Wall -fno-inline -else - CFLAGS = -g -O3 -finline-functions -Winline -Wall -endif - -# Set compiler flags for non-default ABIs (e.g. 64-bit addressing). -# Normally this can be blank. -ABIFLAGS = - -# Is the /proc filesystem available? On most Linux systems it is. If available, get_memusage() -# reads from it to find memory usage info. Otherwise get_memusage() will use get_rusage() -HAVE_SLASHPROC = yes - -# GPTL can enable threading either via OPENMP=yes, or PTHREADS=yes. Since -# most OpenMP implementations are built on top of pthreads, OpenMP -# applications linked with GPTL as built with PTHREADS=yes should work fine. -# Thus COMPFLAG should be set to the compiler flag that enables OpenMP directives -# if either OPENMP=yes, or PTHREADS=yes. If OPENMP=no and PTHREADS=no, GPTL -# will not be thread-safe. -OPENMP = no -COMPFLAG = -fopenmp -# Set PTHREADS if available and OPENMP=no -ifeq ($(OPENMP),no) - PTHREADS = yes -endif - -# For gcc, -Dinline=inline is a no-op. For other C compilers, things like -# -Dinline=__inline__ may be required. To find your compiler's definition, try -# running "./suggestions CC=". -INLINEFLAG = -Dinline=inline - -# To get some C compilers such as gcc to behave properly with -O0 and no inlining, -# need to effectively delete the "inline" keyword -ifeq ($(DEBUG),yes) - INLINEFLAG = -Dinline= -endif - -# To build the Fortran interface, set FORTRAN=yes and define the entries under -# ifeq ($(FORTRAN),yes). Otherwise, set FORTRAN=no and skip this section. -FORTRAN = yes -ifeq ($(FORTRAN),yes) -# Fortran name mangling: possibilities are: leave UNDERSCORING blank meaning none -# (e.g. xlf90), -DFORTRANDOUBLEUNDERSCORE (e.g. g77), and -DFORTRANUNDERSCORE -# (e.g. gfortran, pathf95) -# -# UNDERSCORING = -# UNDERSCORING = -DFORTRANDOUBLEUNDERSCORE - UNDERSCORING = -DFORTRANUNDERSCORE - -# Set Fortran compiler, flags, and OpenMP compiler flag. Note that Fortran -# OpenMP tests are possible with OPENMP=no as long as PTHREADS=yes -# These settings are only used by the Fortran test applications in ftests/. - FC = lf95 - FFLAGS = -g -O2 - FOMPFLAG = -endif - -# Archiver: normally it's just ar -AR = ar - -# PAPI: If a recent version of PAPI is installed, set HAVE_PAPI=yes and set inc and lib -# info as appropriate. -HAVE_PAPI = yes -ifeq ($(HAVE_PAPI),yes) - PAPI_INCFLAGS = -I/opt/papi/4.1.0/include - PAPI_LIBFLAGS = -L/opt/papi/4.1.0/lib -lpapi -endif - -# Whether to build GPTL with MPI support. Set inc and lib info if needed. -# If CC=mpicc, MPI_INCFLAGS and MPI_LIBFLAGS can be blank. -HAVE_MPI = no -ifeq ($(HAVE_MPI),yes) -# Hopefully MPI_Comm_f2c() exists, but if not, set HAVE_COMM_F2C = no - HAVE_COMM_F2C = yes - MPI_INCFLAGS = - MPI_LIBFLAGS = -# Want 2 MPI tasks - MPICMD = mpiexec -n 2 -endif - -# clock_gettime() in librt.a is an option for gathering wallclock time stats -# on some machines. Setting HAVE_LIBRT=yes enables this, but will probably -# require linking applications with -lrt -HAVE_LIBRT = no - -# Only define HAVE_NANOTIME if this is a x86. It provides by far the finest grained, -# lowest overhead wallclock timer on that architecture. -# If HAVE_NANOTIME=yes, set BIT64=yes if this is an x86_64 -HAVE_NANOTIME = yes -ifeq ($(HAVE_NANOTIME),yes) - BIT64 = yes -endif - -# Some old compilers don't support vprintf. Set to "no" in this case -HAVE_VPRINTF = yes - -# Some old compilers don't support the C times() function. Set to "no" in this case -HAVE_TIMES = yes - -# gettimeofday() should be available everywhere. But if not, set to "no" -HAVE_GETTIMEOFDAY = yes - -# Whether to test auto-profiling (adds 2 tests to "make test"). If compiler is gcc or -# pathscale, set INSTRFLAG to -finstrument-functions. PGI 8.0.2 and later provide -# -Minstrument:functions. -TEST_AUTOPROFILE = yes -ifeq ($(TEST_AUTOPROFILE),yes) - INSTRFLAG = -finstrument-functions - CXX = g++ -endif - -# Whether to enable PMPI wrappers. Turning this on will result in automatic -# start/stop entries for a number of MPI calls. -ifeq ($(HAVE_MPI),yes) - ENABLE_PMPI = no - ifeq ($(ENABLE_PMPI),yes) -# Some newer MPI releases change the prototype of some input arguments from "void *" -# to "const void *". The prototype for these functions inside GPTL must match the -# MPI library in use. For ENABLE_PMPI=yes, set MPI_CONST to yes or no appropriately. - MPI_CONST = no -# Yet another (Fortran-only) wart: the value of MPI_STATUS_SIZE varies among MPI distributions. -# Normal values are 5 or 10. AIX and very new MPICH versions it is 10. Set it here--if you get it -# wrong your instrumented code will tell you at run time the proper value. Or run ftests/pmpi - MPI_STATUS_SIZE_IN_INTS = 5 - endif -# If Fortran is enabled, the ability to automatically initialize GPTL from -# mpi_init can be enabled if iargc() and getarg() are available. - ifeq ($(FORTRAN),yes) - HAVE_IARGCGETARG = no - endif -endif - -# Whether system functions backtrace() and backtrace_symbols() exist. Setting HAVE_BACKTRACE=yes -# will enable auto-generation of function name when auto-profiling and GPTLdopr_memusage has been -# enabled at run-time. If HAVE_BACKTRACE=no, function address will be printed instead. -# GNU compilers: compile application code with -finstrument-functions -rdynamic -# Intel compilers: compile application code with -finstrument-functions -rdynamic -g -HAVE_BACKTRACE = no -ifeq ($(HAVE_BACKTRACE),yes) - CFLAGS += -DHAVE_BACKTRACE -endif diff --git a/cesm/models/utils/timing/gptl/macros.make.linux b/cesm/models/utils/timing/gptl/macros.make.linux deleted file mode 100644 index 9066354..0000000 --- a/cesm/models/utils/timing/gptl/macros.make.linux +++ /dev/null @@ -1,163 +0,0 @@ -# This file contains macro settings which are used by the Makefile. Some require -# "yes" or "no", where various subflags are required if the value is -# "yes". The intent is for the user to edit whichever parts of this file are -# necessary, save to a file named "macros.make", then run "make" to build the -# GPTL library. - -########################################################################## - -# Where to install GPTL library and include files -# if "git" is not available, set REVNO by hand -REVNO = $(shell git describe) -INSTALLDIR = /usr/local/gptl-$(REVNO) - -# Where to install man pages (if blank, defaults to $INSTALLDIR) -MANDIR = - -# C compiler -CC = mpicc - -# Whether to build debug lib or optimized lib, and associated flags -DEBUG = no -ifeq ($(DEBUG),yes) - CFLAGS = -g -O0 -Wall -fno-inline -else - CFLAGS = -g -O3 -finline-functions -Winline -Wall -endif - -# Set compiler flags for non-default ABIs (e.g. 64-bit addressing). -# Normally this can be blank. -ABIFLAGS = - -# Is the /proc filesystem available? On most Linux systems it is. If available, get_memusage() -# reads from it to find memory usage info. Otherwise get_memusage() will use get_rusage() -HAVE_SLASHPROC = yes - -# GPTL can enable threading either via OPENMP=yes, or PTHREADS=yes. Since -# most OpenMP implementations are built on top of pthreads, OpenMP -# applications linked with GPTL as built with PTHREADS=yes should work fine. -# Thus COMPFLAG should be set to the compiler flag that enables OpenMP directives -# if either OPENMP=yes, or PTHREADS=yes. If OPENMP=no and PTHREADS=no, GPTL -# will not be thread-safe. -OPENMP = no -COMPFLAG = -fopenmp -# Set PTHREADS if available and OPENMP=no -ifeq ($(OPENMP),no) - PTHREADS = yes -endif - -# For gcc, -Dinline=inline is a no-op. For other C compilers, things like -# -Dinline=__inline__ may be required. To find your compiler's definition, try -# running "./suggestions CC=". -INLINEFLAG = -Dinline=inline - -# To get some C compilers such as gcc to behave properly with -O0 and no inlining, -# need to effectively delete the "inline" keyword -ifeq ($(DEBUG),yes) - INLINEFLAG = -Dinline= -endif - -# To build the Fortran interface, set FORTRAN=yes and define the entries under -# ifeq ($(FORTRAN),yes). Otherwise, set FORTRAN=no and skip this section. -FORTRAN = yes -ifeq ($(FORTRAN),yes) -# Fortran name mangling: possibilities are: leave UNDERSCORING blank meaning none -# (e.g. xlf90), -DFORTRANDOUBLEUNDERSCORE (e.g. g77), and -DFORTRANUNDERSCORE -# (e.g. gfortran, pathf95) -# -# UNDERSCORING = -# UNDERSCORING = -DFORTRANDOUBLEUNDERSCORE - UNDERSCORING = -DFORTRANUNDERSCORE - -# Set Fortran compiler, flags, and OpenMP compiler flag. Note that Fortran -# OpenMP tests are possible with OPENMP=no as long as PTHREADS=yes -# These settings are only used by the Fortran test applications in ftests/. - FC = mpif90 - FFLAGS = -g -O2 - FOMPFLAG = -fopenmp -endif - -# Archiver: normally it's just ar -AR = ar - -# PAPI: If a recent version of PAPI is installed, set HAVE_PAPI=yes and set inc and lib -# info as appropriate. -HAVE_PAPI = no -ifeq ($(HAVE_PAPI),yes) - PAPI_INCFLAGS = -I/usr/local/include - PAPI_LIBFLAGS = -L/usr/local/lib -lpapi -endif - -# Whether to build GPTL with MPI support. Set inc and lib info if needed. -# If CC=mpicc, MPI_INCFLAGS and MPI_LIBFLAGS can be blank. -HAVE_MPI = yes -ifeq ($(HAVE_MPI),yes) -# Hopefully MPI_Comm_f2c() exists, but if not, set HAVE_COMM_F2C = no - HAVE_COMM_F2C = yes - MPI_INCFLAGS = - MPI_LIBFLAGS = -# Want 2 MPI tasks - MPICMD = mpiexec -n 2 -endif - -# clock_gettime() in librt.a is an option for gathering wallclock time stats -# on some machines. Setting HAVE_LIBRT=yes enables this, but will probably -# require linking applications with -lrt -HAVE_LIBRT = no - -# Only define HAVE_NANOTIME if this is a x86. It provides by far the finest grained, -# lowest overhead wallclock timer on that architecture. -# If HAVE_NANOTIME=yes, set BIT64=yes if this is an x86_64 -HAVE_NANOTIME = yes -ifeq ($(HAVE_NANOTIME),yes) - BIT64 = yes -endif - -# Some old compilers don't support vprintf. Set to "no" in this case -HAVE_VPRINTF = yes - -# Some old compilers don't support the C times() function. Set to "no" in this case -HAVE_TIMES = yes - -# gettimeofday() should be available everywhere. But if not, set to "no" -HAVE_GETTIMEOFDAY = yes - -# Whether to test auto-profiling (adds 2 tests to "make test"). If compiler is gcc or -# pathscale or intel, set INSTRFLAG to -finstrument-functions. PGI 8.0.2 and later provide -# -Minstrument:functions. -TEST_AUTOPROFILE = yes -ifeq ($(TEST_AUTOPROFILE),yes) - INSTRFLAG = -finstrument-functions - CXX = mpicxx -endif - -# Whether to enable PMPI wrappers. Turning this on will result in automatic -# start/stop entries for a number of MPI calls. -ifeq ($(HAVE_MPI),yes) - ENABLE_PMPI = no - ifeq ($(ENABLE_PMPI),yes) -# Some newer MPI releases change the prototype of some input arguments from "void *" -# to "const void *". The prototype for these functions inside GPTL must match the -# MPI library in use. For ENABLE_PMPI=yes, set MPI_CONST to yes or no appropriately. - MPI_CONST = yes -# Yet another (Fortran-only) wart: the value of MPI_STATUS_SIZE varies among MPI distributions. -# Normal values are 5 or 10. AIX and very new MPICH versions it is 10. Set it here--if you get it -# wrong your instrumented code will tell you at run time the proper value. Or run ftests/pmpi - MPI_STATUS_SIZE_IN_INTS = 10 - endif -# If Fortran is enabled, the ability to automatically initialize GPTL from -# mpi_init can be enabled if iargc() and getarg() are available. - ifeq ($(FORTRAN),yes) - HAVE_IARGCGETARG = no - endif -endif - -# Whether system functions backtrace() and backtrace_symbols() exist. Setting HAVE_BACKTRACE=yes -# will enable auto-generation of function name when auto-profiling and GPTLdopr_memusage has been -# enabled at run-time. If HAVE_BACKTRACE=no, function address will be printed instead. -# GNU compilers: compile application code with -finstrument-functions -rdynamic -# Intel compilers: compile application code with -finstrument-functions -rdynamic -g -HAVE_BACKTRACE = yes -ifeq ($(HAVE_BACKTRACE),yes) - CFLAGS += -DHAVE_BACKTRACE -endif diff --git a/cesm/models/utils/timing/gptl/macros.make.macos b/cesm/models/utils/timing/gptl/macros.make.macos deleted file mode 100644 index 992e88d..0000000 --- a/cesm/models/utils/timing/gptl/macros.make.macos +++ /dev/null @@ -1,164 +0,0 @@ -# This file contains macro settings which are used by the Makefile. Some require -# "yes" or "no", where various subflags are required if the value is -# "yes". The intent is for the user to edit whichever parts of this file are -# necessary, save to a file named "macros.make", then run "make" to build the -# GPTL library. - -########################################################################## - -# Where to install GPTL library and include files. -# if "git" is not available, set REVNO by hand -REVNO = $(shell git describe) -INSTALLDIR = $(HOME)/gptl-$(REVNO)/macos - -# Where to install man pages (if blank, defaults to $INSTALLDIR) -MANDIR = - -# C compiler -CC = mpicc - -# Whether to build debug lib or optimized lib, and associated flags -DEBUG = no -ifeq ($(DEBUG),yes) - CFLAGS = -g -O0 -Wall -fno-inline -else - CFLAGS = -g -O3 -finline-functions -Winline -Wall -endif - -# Set compiler flags for non-default ABIs (e.g. 64-bit addressing). -# Normally this can be blank. -ABIFLAGS = - -# Is the /proc filesystem available? On most Linux systems it is. If available, get_memusage() -# reads from it to find memory usage info. Otherwise get_memusage() will use get_rusage() -HAVE_SLASHPROC = no - -# GPTL can enable threading either via OPENMP=yes, or PTHREADS=yes. Since -# most OpenMP implementations are built on top of pthreads, OpenMP -# applications linked with GPTL as built with PTHREADS=yes should work fine. -# Thus COMPFLAG should be set to the compiler flag that enables OpenMP directives -# if either OPENMP=yes, or PTHREADS=yes. If OPENMP=no and PTHREADS=no, GPTL -# will not be thread-safe. -OPENMP = no -COMPFLAG = -# Set PTHREADS if available and OPENMP=no -ifeq ($(OPENMP),no) - PTHREADS = no -endif - -# For gcc, -Dinline=inline is a no-op. For other C compilers, things like -# -Dinline=__inline__ may be required. To find your compiler's definition, try -# running "./suggestions CC=". -INLINEFLAG = -Dinline=inline - -# To get some C compilers such as gcc to behave properly with -O0 and no inlining, -# need to effectively delete the "inline" keyword -ifeq ($(DEBUG),yes) - INLINEFLAG = -Dinline= -endif - -# To build the Fortran interface, set FORTRAN=yes and define the entries under -# ifeq ($(FORTRAN),yes). Otherwise, set FORTRAN=no and skip this section. -FORTRAN = yes -ifeq ($(FORTRAN),yes) -# Fortran name mangling: possibilities are: leave UNDERSCORING blank meaning none -# (e.g. xlf90), -DFORTRANDOUBLEUNDERSCORE (e.g. g77), and -DFORTRANUNDERSCORE -# (e.g. gfortran, pathf95) -# -# UNDERSCORING = -# UNDERSCORING = -DFORTRANDOUBLEUNDERSCORE - UNDERSCORING = -DFORTRANUNDERSCORE - -# Set Fortran compiler, flags, and OpenMP compiler flag. Note that Fortran -# OpenMP tests are possible with OPENMP=no as long as PTHREADS=yes -# These settings are only used by the Fortran test applications in ftests/. - FC = mpif90 - FFLAGS = -g -O2 - FOMPFLAG = -endif - -# Archiver: normally it's just ar -AR = ar - -# PAPI: If a recent version of PAPI is installed, set HAVE_PAPI=yes and set inc and lib -# info as appropriate. -HAVE_PAPI = no -ifeq ($(HAVE_PAPI),yes) - PAPI_INCFLAGS = -I/usr/local/include - PAPI_LIBFLAGS = -L/usr/local/lib -lpapi -endif - -# Whether to build GPTL with MPI support. Set inc and lib info if needed. -# If CC=mpicc, MPI_INCFLAGS and MPI_LIBFLAGS can be blank. -HAVE_MPI = yes -ifeq ($(HAVE_MPI),yes) -# Hopefully MPI_Comm_f2c() exists, but if not, set HAVE_COMM_F2C = no - HAVE_COMM_F2C = yes - MPI_INCFLAGS = - MPI_LIBFLAGS = - MPICMD = mpiexec -# Want 2 MPI tasks - MPICMD = mpiexec -n 2 -endif - -# clock_gettime() in librt.a is an option for gathering wallclock time stats -# on some machines. Setting HAVE_LIBRT=yes enables this, but will probably -# require linking applications with -lrt -HAVE_LIBRT = no - -# Only define HAVE_NANOTIME if this is a x86. It provides by far the finest grained, -# lowest overhead wallclock timer on that architecture. -# If HAVE_NANOTIME=yes, set BIT64=yes if this is an x86_64 -HAVE_NANOTIME = no -ifeq ($(HAVE_NANOTIME),yes) - BIT64 = no -endif - -# Some old compilers don't support vprintf. Set to "no" in this case -HAVE_VPRINTF = yes - -# Some old compilers don't support the C times() function. Set to "no" in this case -HAVE_TIMES = yes - -# gettimeofday() should be available everywhere. But if not, set to "no" -HAVE_GETTIMEOFDAY = yes - -# Whether to test auto-profiling (adds 2 tests to "make test"). If compiler is gcc or -# pathscale, set INSTRFLAG to -finstrument-functions. PGI 8.0.2 and later provide -# -Minstrument:functions. -TEST_AUTOPROFILE = yes -ifeq ($(TEST_AUTOPROFILE),yes) - INSTRFLAG = -finstrument-functions - CXX = mpicxx -endif - -# Whether to enable PMPI wrappers. Turning this on will result in automatic -# start/stop entries for a number of MPI calls. -ifeq ($(HAVE_MPI),yes) - ENABLE_PMPI = no - ifeq ($(ENABLE_PMPI),yes) -# Some newer MPI releases change the prototype of some input arguments from "void *" -# to "const void *". The prototype for these functions inside GPTL must match the -# MPI library in use. For ENABLE_PMPI=yes, set MPI_CONST to yes or no appropriately. - MPI_CONST = no -# Yet another (Fortran-only) wart: the value of MPI_STATUS_SIZE varies among MPI distributions. -# Normal values are 5 or 10. AIX and very new MPICH versions it is 10. Set it here--if you get it -# wrong your instrumented code will tell you at run time the proper value. Or run ftests/pmpi - MPI_STATUS_SIZE_IN_INTS = 10 - endif -# If Fortran is enabled, the ability to automatically initialize GPTL from -# mpi_init can be enabled if iargc() and getarg() are available. - ifeq ($(FORTRAN),yes) - HAVE_IARGCGETARG = no - endif -endif - -# Whether system functions backtrace() and backtrace_symbols() exist. Setting HAVE_BACKTRACE=yes -# will enable auto-generation of function name when auto-profiling and GPTLdopr_memusage has been -# enabled at run-time. If HAVE_BACKTRACE=no, function address will be printed instead. -# GNU compilers: compile application code with -finstrument-functions -rdynamic -# Intel compilers: compile application code with -finstrument-functions -rdynamic -g -HAVE_BACKTRACE = yes -ifeq ($(HAVE_BACKTRACE),yes) - CFLAGS += -DHAVE_BACKTRACE -endif diff --git a/cesm/models/utils/timing/gptl/macros.make.pgi b/cesm/models/utils/timing/gptl/macros.make.pgi deleted file mode 100644 index 8d8d620..0000000 --- a/cesm/models/utils/timing/gptl/macros.make.pgi +++ /dev/null @@ -1,163 +0,0 @@ -# This file contains macro settings which are used by the Makefile. Some require -# "yes" or "no", where various subflags are required if the value is -# "yes". The intent is for the user to edit whichever parts of this file are -# necessary, save to a file named "macros.make", then run "make" to build the -# GPTL library. - -########################################################################## - -# Where to install GPTL library and include files. -# if "git" is not available, set REVNO by hand -REVNO = $(shell git describe) -INSTALLDIR = $(HOME)/gptl-$(REVNO)/pgi_nompi - -# Where to install man pages (if blank, defaults to $INSTALLDIR) -MANDIR = - -# C compiler -CC = pgcc - -# Whether to build debug lib or optimized lib, and associated flags -DEBUG = no -ifeq ($(DEBUG),yes) - CFLAGS = -g -O0 -else - CFLAGS = -g -fast -endif - -# Set compiler flags for non-default ABIs (e.g. 64-bit addressing). -# Normally this can be blank. -ABIFLAGS = - -# Is the /proc filesystem available? On most Linux systems it is. If available, get_memusage() -# reads from it to find memory usage info. Otherwise get_memusage() will use get_rusage() -HAVE_SLASHPROC = yes - -# GPTL can enable threading either via OPENMP=yes, or PTHREADS=yes. Since -# most OpenMP implementations are built on top of pthreads, OpenMP -# applications linked with GPTL as built with PTHREADS=yes should work fine. -# Thus COMPFLAG should be set to the compiler flag that enables OpenMP directives -# if either OPENMP=yes, or PTHREADS=yes. If OPENMP=no and PTHREADS=no, GPTL -# will not be thread-safe. -OPENMP = no -COMPFLAG = -mp -# Set PTHREADS if available and OPENMP=no -ifeq ($(OPENMP),no) - PTHREADS = yes -endif - -# For gcc, -Dinline=inline is a no-op. For other C compilers, things like -# -Dinline=__inline__ may be required. To find your compiler's definition, try -# running "./suggestions CC=". -INLINEFLAG = -Dinline=inline - -# To get some C compilers such as gcc to behave properly with -O0 and no inlining, -# need to effectively delete the "inline" keyword -ifeq ($(DEBUG),yes) - INLINEFLAG = -Dinline= -endif - -# To build the Fortran interface, set FORTRAN=yes and define the entries under -# ifeq ($(FORTRAN),yes). Otherwise, set FORTRAN=no and skip this section. -FORTRAN = yes -ifeq ($(FORTRAN),yes) -# Fortran name mangling: possibilities are: leave UNDERSCORING blank meaning none -# (e.g. xlf90), -DFORTRANDOUBLEUNDERSCORE (e.g. g77), and -DFORTRANUNDERSCORE -# (e.g. gfortran, pathf95) -# -# UNDERSCORING = -# UNDERSCORING = -DFORTRANDOUBLEUNDERSCORE - UNDERSCORING = -DFORTRANUNDERSCORE - -# Set Fortran compiler, flags, and OpenMP compiler flag. Note that Fortran -# OpenMP tests are possible with OPENMP=no as long as PTHREADS=yes -# These settings are only used by the Fortran test applications in ftests/. - FC = pgf90 - FFLAGS = -g -O2 - FOMPFLAG = -mp -endif - -# Archiver: normally it's just ar -AR = ar - -# PAPI: If a recent version of PAPI is installed, set HAVE_PAPI=yes and set inc and lib -# info as appropriate. -HAVE_PAPI = no -ifeq ($(HAVE_PAPI),yes) - PAPI_INCFLAGS = -I/contrib/papi/5.0.1/include - PAPI_LIBFLAGS = -L/contrib/papi/5.0.1/lib -lpapi -endif - -# Whether to build GPTL with MPI support. Set inc and lib info if needed. -# If CC=mpicc, MPI_INCFLAGS and MPI_LIBFLAGS can be blank. -HAVE_MPI = no -ifeq ($(HAVE_MPI),yes) -# Hopefully MPI_Comm_f2c() exists, but if not, set HAVE_COMM_F2C = no - HAVE_COMM_F2C = yes - MPI_INCFLAGS = - MPI_LIBFLAGS = -# Want 2 MPI tasks - MPICMD = mpiexec -n 2 -endif - -# clock_gettime() in librt.a is an option for gathering wallclock time stats -# on some machines. Setting HAVE_LIBRT=yes enables this, but will probably -# require linking applications with -lrt -HAVE_LIBRT = no - -# Only define HAVE_NANOTIME if this is a x86. It provides by far the finest grained, -# lowest overhead wallclock timer on that architecture. -# If HAVE_NANOTIME=yes, set BIT64=yes if this is an x86_64 -HAVE_NANOTIME = yes -ifeq ($(HAVE_NANOTIME),yes) - BIT64 = yes -endif - -# Some old compilers don't support vprintf. Set to "no" in this case -HAVE_VPRINTF = yes - -# Some old compilers don't support the C times() function. Set to "no" in this case -HAVE_TIMES = yes - -# gettimeofday() should be available everywhere. But if not, set to "no" -HAVE_GETTIMEOFDAY = yes - -# Whether to test auto-profiling (adds 2 tests to "make test"). If compiler is gcc or -# pathscale, set INSTRFLAG to -finstrument-functions. PGI 12 and later provide -# -Minstrument=functions. -TEST_AUTOPROFILE = yes -ifeq ($(TEST_AUTOPROFILE),yes) - INSTRFLAG = -Minstrument=functions - CXX = pgCC -endif - -# Whether to enable PMPI wrappers. Turning this on will result in automatic -# start/stop entries for a number of MPI calls. -ifeq ($(HAVE_MPI),yes) - ENABLE_PMPI = no - ifeq ($(ENABLE_PMPI),yes) -# Some newer MPI releases change the prototype of some input arguments from "void *" -# to "const void *". The prototype for these functions inside GPTL must match the -# MPI library in use. For ENABLE_PMPI=yes, set MPI_CONST to yes or no appropriately. - MPI_CONST = no -# Yet another (Fortran-only) wart: the value of MPI_STATUS_SIZE varies among MPI distributions. -# Normal values are 5 or 10. AIX and very new MPICH versions it is 10. Set it here--if you get it -# wrong your instrumented code will tell you at run time the proper value. Or run ftests/pmpi - MPI_STATUS_SIZE_IN_INTS = 5 - endif -# If Fortran is enabled, the ability to automatically initialize GPTL from -# mpi_init can be enabled if iargc() and getarg() are available. - ifeq ($(FORTRAN),yes) - HAVE_IARGCGETARG = no - endif -endif - -# Whether system functions backtrace() and backtrace_symbols() exist. Setting HAVE_BACKTRACE=yes -# will enable auto-generation of function name when auto-profiling and GPTLdopr_memusage has been -# enabled at run-time. If HAVE_BACKTRACE=no, function address will be printed instead. -# GNU compilers: compile application code with -finstrument-functions -rdynamic -# Intel compilers: compile application code with -finstrument-functions -rdynamic -g -HAVE_BACKTRACE = no -ifeq ($(HAVE_BACKTRACE),yes) - CFLAGS += -DHAVE_BACKTRACE -endif diff --git a/cesm/models/utils/timing/gptl/macros.make.xeon b/cesm/models/utils/timing/gptl/macros.make.xeon deleted file mode 100644 index b079f9a..0000000 --- a/cesm/models/utils/timing/gptl/macros.make.xeon +++ /dev/null @@ -1,163 +0,0 @@ -# This file contains macro settings which are used by the Makefile. Some require -# "yes" or "no", where various subflags are required if the value is -# "yes". The intent is for the user to edit whichever parts of this file are -# necessary, save to a file named "macros.make", then run "make" to build the -# GPTL library. - -########################################################################## - -# Where to install GPTL library and include files. -# if "git" is not available, set REVNO by hand -REVNO = $(shell git describe) -INSTALLDIR = $(HOME)/gptl-$(REVNO)/xeon - -# Where to install man pages (if blank, defaults to $INSTALLDIR) -MANDIR = - -# C compiler -CC = icc - -# Whether to build debug lib or optimized lib, and associated flags -DEBUG = no -ifeq ($(DEBUG),yes) - CFLAGS = -g -O0 -Wall -fno-inline -else - CFLAGS = -g -O3 -finline-functions -Winline -Wall -endif - -# Set compiler flags for non-default ABIs (e.g. 64-bit addressing). -# Normally this can be blank. -ABIFLAGS = - -# Is the /proc filesystem available? On most Linux systems it is. If available, get_memusage() -# reads from it to find memory usage info. Otherwise get_memusage() will use get_rusage() -HAVE_SLASHPROC = yes - -# GPTL can enable threading either via OPENMP=yes, or PTHREADS=yes. Since -# most OpenMP implementations are built on top of pthreads, OpenMP -# applications linked with GPTL as built with PTHREADS=yes should work fine. -# Thus COMPFLAG should be set to the compiler flag that enables OpenMP directives -# if either OPENMP=yes, or PTHREADS=yes. If OPENMP=no and PTHREADS=no, GPTL -# will not be thread-safe. -OPENMP = no -COMPFLAG = -openmp -# Set PTHREADS if available and OPENMP=no -ifeq ($(OPENMP),no) - PTHREADS = yes -endif - -# For gcc, -Dinline=inline is a no-op. For other C compilers, things like -# -Dinline=__inline__ may be required. To find your compiler's definition, try -# running "./suggestions CC=". -INLINEFLAG = -Dinline=inline - -# To get some C compilers such as gcc to behave properly with -O0 and no inlining, -# need to effectively delete the "inline" keyword -ifeq ($(DEBUG),yes) - INLINEFLAG = -Dinline= -endif - -# To build the Fortran interface, set FORTRAN=yes and define the entries under -# ifeq ($(FORTRAN),yes). Otherwise, set FORTRAN=no and skip this section. -FORTRAN = yes -ifeq ($(FORTRAN),yes) -# Fortran name mangling: possibilities are: leave UNDERSCORING blank meaning none -# (e.g. xlf90), -DFORTRANDOUBLEUNDERSCORE (e.g. g77), and -DFORTRANUNDERSCORE -# (e.g. gfortran, pathf95) -# -# UNDERSCORING = -# UNDERSCORING = -DFORTRANDOUBLEUNDERSCORE - UNDERSCORING = -DFORTRANUNDERSCORE - -# Set Fortran compiler, flags, and OpenMP compiler flag. Note that Fortran -# OpenMP tests are possible with OPENMP=no as long as PTHREADS=yes -# These settings are only used by the Fortran test applications in ftests/. - FC = ifort - FFLAGS = -g -O2 - FOMPFLAG = -openmp -endif - -# Archiver: normally it's just ar -AR = ar - -# PAPI: If a recent version of PAPI is installed, set HAVE_PAPI=yes and set inc and lib -# info as appropriate. -HAVE_PAPI = no -ifeq ($(HAVE_PAPI),yes) - PAPI_INCFLAGS = -I/contrib/papi/5.0.1/include - PAPI_LIBFLAGS = -L/contrib/papi/5.0.1/lib -lpapi -endif - -# Whether to build GPTL with MPI support. Set inc and lib info if needed. -# If CC=mpicc, MPI_INCFLAGS and MPI_LIBFLAGS can be blank. -HAVE_MPI = no -ifeq ($(HAVE_MPI),yes) -# Hopefully MPI_Comm_f2c() exists, but if not, set HAVE_COMM_F2C = no - HAVE_COMM_F2C = yes - MPI_INCFLAGS = - MPI_LIBFLAGS = -# Want 2 MPI tasks - MPICMD = mpiexec -n 2 -endif - -# clock_gettime() in librt.a is an option for gathering wallclock time stats -# on some machines. Setting HAVE_LIBRT=yes enables this, but will probably -# require linking applications with -lrt -HAVE_LIBRT = no - -# Only define HAVE_NANOTIME if this is a x86. It provides by far the finest grained, -# lowest overhead wallclock timer on that architecture. -# If HAVE_NANOTIME=yes, set BIT64=yes if this is an x86_64 -HAVE_NANOTIME = yes -ifeq ($(HAVE_NANOTIME),yes) - BIT64 = yes -endif - -# Some old compilers don't support vprintf. Set to "no" in this case -HAVE_VPRINTF = yes - -# Some old compilers don't support the C times() function. Set to "no" in this case -HAVE_TIMES = yes - -# gettimeofday() should be available everywhere. But if not, set to "no" -HAVE_GETTIMEOFDAY = yes - -# Whether to test auto-profiling (adds 2 tests to "make test"). If compiler is gcc or -# pathscale, set INSTRFLAG to -finstrument-functions. PGI 8.0.2 and later provide -# -Minstrument:functions. -TEST_AUTOPROFILE = yes -ifeq ($(TEST_AUTOPROFILE),yes) - INSTRFLAG = -finstrument-functions - CXX = icpc -endif - -# Whether to enable PMPI wrappers. Turning this on will result in automatic -# start/stop entries for a number of MPI calls. -ifeq ($(HAVE_MPI),yes) - ENABLE_PMPI = no - ifeq ($(ENABLE_PMPI),yes) -# Some newer MPI releases change the prototype of some input arguments from "void *" -# to "const void *". The prototype for these functions inside GPTL must match the -# MPI library in use. For ENABLE_PMPI=yes, set MPI_CONST to yes or no appropriately. - MPI_CONST = no -# Yet another (Fortran-only) wart: the value of MPI_STATUS_SIZE varies among MPI distributions. -# Normal values are 5 or 10. AIX and very new MPICH versions it is 10. Set it here--if you get it -# wrong your instrumented code will tell you at run time the proper value. Or run ftests/pmpi - MPI_STATUS_SIZE_IN_INTS = 5 - endif -# If Fortran is enabled, the ability to automatically initialize GPTL from -# mpi_init can be enabled if iargc() and getarg() are available. - ifeq ($(FORTRAN),yes) - HAVE_IARGCGETARG = no - endif -endif - -# Whether system functions backtrace() and backtrace_symbols() exist. Setting HAVE_BACKTRACE=yes -# will enable auto-generation of function name when auto-profiling and GPTLdopr_memusage has been -# enabled at run-time. If HAVE_BACKTRACE=no, function address will be printed instead. -# GNU compilers: compile application code with -finstrument-functions -rdynamic -# Intel compilers: compile application code with -finstrument-functions -rdynamic -g -HAVE_BACKTRACE = yes -ifeq ($(HAVE_BACKTRACE),yes) - CFLAGS += -DHAVE_BACKTRACE -endif diff --git a/cesm/models/utils/timing/gptl/macros.make.xeonphi b/cesm/models/utils/timing/gptl/macros.make.xeonphi deleted file mode 100644 index 729c5cc..0000000 --- a/cesm/models/utils/timing/gptl/macros.make.xeonphi +++ /dev/null @@ -1,163 +0,0 @@ -# This file contains macro settings which are used by the Makefile. Some require -# "yes" or "no", where various subflags are required if the value is -# "yes". The intent is for the user to edit whichever parts of this file are -# necessary, save to a file named "macros.make", then run "make" to build the -# GPTL library. - -########################################################################## - -# Where to install GPTL library and include files. -# if "git" is not available, set REVNO by hand -REVNO = $(shell git describe) -INSTALLDIR = $(HOME)/gptl-$(REVNO)/xeonphi - -# Where to install man pages (if blank, defaults to $INSTALLDIR) -MANDIR = - -# C compiler. If HAVE_MPI=yes (see below), this should probably be set to the wrapper script. -CC = mpiicc - -# Whether to build debug lib or optimized lib, and associated flags -DEBUG = no -ifeq ($(DEBUG),yes) - CFLAGS = -g -mmic -O0 -Wall -fno-inline -else - CFLAGS = -g -mmic -O3 -finline-functions -Winline -Wall -endif - -# Set compiler flags for non-default ABIs (e.g. 64-bit addressing). -# Normally this can be blank. -ABIFLAGS = - -# Is the /proc filesystem available? On most Linux systems it is. If available, get_memusage() -# reads from it to find memory usage info. Otherwise get_memusage() will use get_rusage() -HAVE_SLASHPROC = yes - -# GPTL can enable threading either via OPENMP=yes, or PTHREADS=yes. Since -# most OpenMP implementations are built on top of pthreads, OpenMP -# applications linked with GPTL as built with PTHREADS=yes should work fine. -# Thus COMPFLAG should be set to the compiler flag that enables OpenMP directives -# if either OPENMP=yes, or PTHREADS=yes. If OPENMP=no and PTHREADS=no, GPTL -# will not be thread-safe. -OPENMP = yes -COMPFLAG = -openmp -# Set PTHREADS if available and OPENMP=no -ifeq ($(OPENMP),no) - PTHREADS = yes -endif - -# For gcc, -Dinline=inline is a no-op. For other C compilers, things like -# -Dinline=__inline__ may be required. To find your compiler's definition, try -# running "./suggestions CC=". -INLINEFLAG = -Dinline=inline - -# To get some C compilers such as gcc to behave properly with -O0 and no inlining, -# need to effectively delete the "inline" keyword -ifeq ($(DEBUG),yes) - INLINEFLAG = -Dinline= -endif - -# To build the Fortran interface, set FORTRAN=yes and define the entries under -# ifeq ($(FORTRAN),yes). Otherwise, set FORTRAN=no and skip this section. -FORTRAN = yes -ifeq ($(FORTRAN),yes) -# Fortran name mangling: possibilities are: leave UNDERSCORING blank meaning none -# (e.g. xlf90), -DFORTRANDOUBLEUNDERSCORE (e.g. g77), and -DFORTRANUNDERSCORE -# (e.g. gfortran, pathf95) -# -# UNDERSCORING = -# UNDERSCORING = -DFORTRANDOUBLEUNDERSCORE - UNDERSCORING = -DFORTRANUNDERSCORE - -# Set Fortran compiler, flags, and OpenMP compiler flag. Note that Fortran -# OpenMP tests are possible with OPENMP=no as long as PTHREADS=yes -# These settings are only used by the Fortran test applications in ftests/. - FC = mpiifort - FFLAGS = -g -O2 -mmic - FOMPFLAG = -openmp -endif - -# Archiver: normally it's just ar -AR = ar - -# PAPI: If a recent version of PAPI is installed, set HAVE_PAPI=yes and set inc and lib -# info as appropriate. -HAVE_PAPI = no -ifeq ($(HAVE_PAPI),yes) - PAPI_INCFLAGS = -I/contrib/papi/5.0.1/include - PAPI_LIBFLAGS = -L/contrib/papi/5.0.1/lib -lpapi -endif - -# Whether to build GPTL with MPI support. Set inc and lib info if needed. -# If CC=mpicc or equivalent MPI driver, MPI_INCFLAGS and MPI_LIBFLAGS can be blank. -HAVE_MPI = yes -ifeq ($(HAVE_MPI),yes) -# Hopefully MPI_Comm_f2c() exists, but if not, set HAVE_COMM_F2C = no - HAVE_COMM_F2C = yes - MPI_INCFLAGS = - MPI_LIBFLAGS = -# Want 2 MPI tasks - MPICMD = mpiexec -n 2 -endif - -# clock_gettime() in librt.a is an option for gathering wallclock time stats -# on some machines. Setting HAVE_LIBRT=yes enables this, but will probably -# require linking applications with -lrt -HAVE_LIBRT = no - -# Only define HAVE_NANOTIME if this is a x86. It provides by far the finest grained, -# lowest overhead wallclock timer on that architecture. -# If HAVE_NANOTIME=yes, set BIT64=yes if this is an x86_64 -HAVE_NANOTIME = yes -ifeq ($(HAVE_NANOTIME),yes) - BIT64 = yes -endif - -# Some old compilers don't support vprintf. Set to "no" in this case -HAVE_VPRINTF = yes - -# Some old compilers don't support the C times() function. Set to "no" in this case -HAVE_TIMES = yes - -# gettimeofday() should be available everywhere. But if not, set to "no" -HAVE_GETTIMEOFDAY = yes - -# Whether to test auto-profiling (adds 2 tests to "make test"). If compiler is gcc or -# pathscale, set INSTRFLAG to -finstrument-functions. PGI 8.0.2 and later provide -# -Minstrument:functions. -TEST_AUTOPROFILE = yes -ifeq ($(TEST_AUTOPROFILE),yes) - INSTRFLAG = -finstrument-functions - CXX = mpiicpc -endif - -# Whether to enable PMPI wrappers. Turning this on will result in automatic -# start/stop entries for a number of MPI calls. -ifeq ($(HAVE_MPI),yes) - ENABLE_PMPI = no - ifeq ($(ENABLE_PMPI),yes) -# Some newer MPI releases change the prototype of some input arguments from "void *" -# to "const void *". The prototype for these functions inside GPTL must match the -# MPI library in use. For ENABLE_PMPI=yes, set MPI_CONST to yes or no appropriately. - MPI_CONST = no -# Yet another (Fortran-only) wart: the value of MPI_STATUS_SIZE varies among MPI distributions. -# Normal values are 5 or 10. AIX and very new MPICH versions it is 10. Set it here--if you get it -# wrong your instrumented code will tell you at run time the proper value. Or run ftests/pmpi - MPI_STATUS_SIZE_IN_INTS = 5 - endif -# If Fortran is enabled, the ability to automatically initialize GPTL from -# mpi_init can be enabled if iargc() and getarg() are available. - ifeq ($(FORTRAN),yes) - HAVE_IARGCGETARG = no - endif -endif - -# Whether system functions backtrace() and backtrace_symbols() exist. Setting HAVE_BACKTRACE=yes -# will enable auto-generation of function name when auto-profiling and GPTLdopr_memusage has been -# enabled at run-time. If HAVE_BACKTRACE=no, function address will be printed instead. -# GNU compilers: compile application code with -finstrument-functions -rdynamic -# Intel compilers: compile application code with -finstrument-functions -rdynamic -g -HAVE_BACKTRACE = yes -ifeq ($(HAVE_BACKTRACE),yes) - CFLAGS += -DHAVE_BACKTRACE -endif diff --git a/cesm/models/utils/timing/gptl/man/man3/GPTL.3 b/cesm/models/utils/timing/gptl/man/man3/GPTL.3 deleted file mode 100644 index 759b07b..0000000 --- a/cesm/models/utils/timing/gptl/man/man3/GPTL.3 +++ /dev/null @@ -1,125 +0,0 @@ -.\" $Id$ -.TH GPTL 3 "October, 2013" "GPTL" - -.SH NAME -GPTL \- General Purpose Timing Library - -.SH SYNOPSIS -GPTL is a library for timing and profiling application codes written in C, -C++, and Fortran. The Fortran calling interface matches the C/C++ interface, -except that Fortran is case-insensitive. Code instrumentation with GPTL can -be manual, automatic, or a mix of the two. - -Manual instrumentation is done by inserting calls to GPTLstart("region_name") -and GPTLstop("region_name") wherever the user wishes. "region_name" is an -arbitrary character string which will be reported in the output file when one -of the GPTL print routines GPTLpr() or GPTLpr_file() is called. There is no -limit to the number of start/stop pairs that can be defined. The pairs can -be nested to an arbitrary depth. GPTL retains knowledge of these parent-child -relationships, and reports them by indenting the output appropriately. - -Automatic instrumentation can be done at function entry and exit points when -the compiler supports an auto-instrumentation feature. For example, --finstrument-functions under gcc, or -Minstrument:functions with the PGI -compilers. Since GPTL understands parent-child relationships of profiled -regions, this provides an easy mechanism to generate a dynamic call tree. - -The second method to auto-instrument application codes is by using profiling -hooks provided by most MPI distributions. This option is enabled in GPTL by -setting ENABLE_PMPI=yes in macros.make prior to building the GPTL -library. Time taken in the MPI routines, and bytes transferred per task, are -reported. Also, if runtime option sync_mpi is enabled, GPTL will call -MPI_Barrier prior to relevant MPI calls and report both the synchronization -time and the actual MPI transfer time. - -Currently, only a subset of the most commonly used MPI routines has -been implemented with this automatic instrumentation feature. But adding more -is a straightforward task. Using this auto-profiling method alone, or in -conjunction with compiler-generated auto-instrumention described, application -performance profiles can be generated without any user modifications to the -application source. - -GPTL is thread-safe. Per-thread timig information is maintined within the -library, and reported in the output file. Normally there is one output file -per MPI process. - -There is an optional namelist parsing routine for Fortran codes, -gptlprocess_namelist(), that can optionally be used to set GPTL options from -Fortran via a namelist. - -If the PAPI library is installed, GPTL provides an easy to use -interface to most of the functionality provided by that library. GPTL also -defines a set of derived events based on PAPI, such as computational -intensity and L1 miss rate. - -See http://jmrosinski.github.com/GPTL/ for a set of usage -examples and further details on using the library. The file README which -comes with the GPTL distribution also outlines simple usage examples. - -The rest of this page lists all the available GPTL functions. Each has its -own man page with usage details. The order of the functions listed here -matches the sequence one would normally use to invoke GPTL functions in an -application. - -.SH Primary GPTL functions -.LP -.nf -.BR GPTLevent_name_to_code(3) " convert a GPTL (or PAPI) event name to its -integer code" -.BR GPTLevent_code_to_name(3) " convert a GPTL (or PAPI) integer event code -to its name" -.BR GPTLsetoption(3) " - set a GPTL option (e.g. enable a PAPI counter)" -.BR GPTLsetutr(3) " - set the default underlying timing routine" -.BR gptlprocess_namelist(3) " - (Fortran only) set GPTL options by reading a Fortran namelist" -.BR GPTLinitialize(3) " - initialize the GPTL library. Must be called after all calls to GPTLsetoption/GPTLsetutr/gptlprocess_namelist, and before all calls to GPTLstart, GPTLstop, and GPTLpr" -.BR GPTLstart(3) " - start a region timer" -.BR GPTLstart_handle(3) " - start a region timer with a handle (more efficient than GPTLstart)" -.BR GPTLstop(3) " - stop a region timer" -.BR GPTLstop_handle(3) " - stop a region timer with a handle (more efficient than GPTLstop)" -.BR GPTLbarrier(3) " - if MPI is enabled, set and time an MPI_Barrier" -.BR GPTLreset(3) " - reset all existing GPTL regions to zero" -.BR GPTLdisable(3) " - disable subsequent calls to GPTLstart/GPTLstop" -.BR GPTLenable(3) " - enable subsequent calls to GPTLstart/GPTLstop" -.BR GPTLget_wallclock(3) " - get the current wallclock time accumulation for -a region" -.BR GPTLget_eventvalue(3) " - get the current value of an event (e.g. PAPI -counter value) for a region" -.BR GPTLget_nregions(3) " - get the current number of regions being timed" -.BR GPTLget_regionname(3) " - get the name of a region" -.BR GPTLquery(3) " - get current values for a region being timed" -.BR GPTLquerycounters(3) " - get current PAPI values for a region being -timed" -.BR GPTLpr(3) " - print info for all regions" -.BR GPTLpr_file(3) " - print info for all regions to a user-specified file" -.BR GPTLpr_summary(3) " - for an MPI code, print a summary for all regions -across all ranks" -.BR GPTLfinalize(3) " - finalize the GPTL library" -.fi - -.SH Utility GPTL functions. These can be called independently of any other GPTL function. -.LP -.nf -.BR GPTLstamp(3) " - get a timestamp for wallclock, user time, and system -time" -.BR GPTLget_memusage(3) " - get stats on current memory usage" -.BR GPTLprint_memusage(3) " - print stats on current memory usage" -.fi - -.SH Utility GPTL executables -.LP -.nf -.BR gptl_avail " - print a list of available PAPI-based derived events" -.BR gptl_knownflopcount " tests PAPI directly (not wrapped by GPTL) for a -known flop count" - -.SH Post-processing GPTL scripts -.LP -.nf -.BR parsegptlout.pl(3) " - for multiprocessed-codes, print summary of an -event stats across all threads and tasks" -.BR hex2name.pl(3) " - for auto-instrumented codes, convert region addresses -to human-readable names" -.fi - -.SH SEE ALSO -README, INSTALL, and the GPTL Web site: http://www.burningserver.net/rosinski/gptl diff --git a/cesm/models/utils/timing/gptl/man/man3/GPTL_PAPIlibraryinit.3 b/cesm/models/utils/timing/gptl/man/man3/GPTL_PAPIlibraryinit.3 deleted file mode 100644 index 6d7cbc5..0000000 --- a/cesm/models/utils/timing/gptl/man/man3/GPTL_PAPIlibraryinit.3 +++ /dev/null @@ -1,44 +0,0 @@ -.\" $Id: GPTL_PAPIlibraryinit.3,v 1.4 2009-01-04 21:14:41 rosinski Exp $ -.TH GPTL_PAPIlibraryinit 3 "January, 2009" "GPTL" - -.SH NAME -.nf -GPTL_PAPIlibraryinit \- Ensure PAPI library is initialized -.fi - -.SH SYNOPSIS -.B C Interface: -.nf -int GPTL_PAPIlibraryinit (void); -.fi - -.B Fortran Interface: -.nf -integer gptl_papilibraryinit () -.fi - -.SH DESCRIPTION -.B GPTL_PAPIlibraryinit(): -Ensure that the PAPI library is initialized. There should no longer be any -need to call this function from user code, since the GPTL library itself -ensures that the PAPI library is properly initialized before making any calls -to it. -.B - -.SH RESTRICTIONS -None. - -.SH RETURN VALUES -On success, 0 is returned. -On error, a negative error code is returned and a descriptive message -printed. - -.SH EXAMPLES -.nf -.if t .ft CW - -(void) GPTL_PAPIlibraryinit (); -(void) GPTLsetoption (L2_LD, 1); - -.if t .ft P -.fi diff --git a/cesm/models/utils/timing/gptl/man/man3/GPTLbarrier.3 b/cesm/models/utils/timing/gptl/man/man3/GPTLbarrier.3 deleted file mode 100644 index 4f9bff9..0000000 --- a/cesm/models/utils/timing/gptl/man/man3/GPTLbarrier.3 +++ /dev/null @@ -1,47 +0,0 @@ -.\" $Id$ -.TH GPTLbarrier 3 "December, 2012" "GPTL" - -.SH NAME -GPTLbarrier \- Set an MPI barrier and time it - -.SH SYNOPSIS -.B C Interface: -.nf -int GPTLbarrier (MPI_Comm comm, const char *name); -.fi - -.B Fortran Interface: -.nf -integer gptlbarrier (integer comm, character(len=*) name) -.fi - -.SH DESCRIPTION -Call -.B MPI_Barrier() -, and time its execution with -.B GPTLstart() -and -.B GPTLstop() -. This routine is only available if GPTL was built with MPI enabled. - -.SH ARGUMENTS -.I comm --- Communicator for MPI_Barrier() -.I name --- Region name for GPTLstart() and GPTLstop() - -.SH RESTRICTIONS -.B GPTLinitialize() -must have been called. Must be between calls to -.B MPI_Initialize() -and -.B MPI_Finalize() - -.SH RETURN VALUES -On success, this function returns 0. -On error, a negative error code is returned and a descriptive message -printed. - -.SH SEE ALSO -.BR GPTLstart "(3)" -.BR GPTLstop "(3)" diff --git a/cesm/models/utils/timing/gptl/man/man3/GPTLdisable.3 b/cesm/models/utils/timing/gptl/man/man3/GPTLdisable.3 deleted file mode 100644 index 874b183..0000000 --- a/cesm/models/utils/timing/gptl/man/man3/GPTLdisable.3 +++ /dev/null @@ -1 +0,0 @@ -.so man3/GPTLenable.3 diff --git a/cesm/models/utils/timing/gptl/man/man3/GPTLenable.3 b/cesm/models/utils/timing/gptl/man/man3/GPTLenable.3 deleted file mode 100644 index 4b81dab..0000000 --- a/cesm/models/utils/timing/gptl/man/man3/GPTLenable.3 +++ /dev/null @@ -1,56 +0,0 @@ -.\" $Id$ -.TH GPTLenable 3 "December, 2012" "GPTL" - -.SH NAME -.nf -GPTLenable \- Enable timer start/stop calls -GPTLdisable \- Disable timer start/stop calls -.fi - -.SH SYNOPSIS -.B C Interface: -.nf -int GPTLenable (void); -int GPTLdisable (void); -.fi - -.B Fortran Interface: -.nf -integer gptlenable () -integer gptldisable () -.fi - -.SH DESCRIPTION -.B GPTLenable(): -Subsequent calls to -.B GPTLstart() -and -.B GPTLstop() -will be recognized. This is the initial state of the GPTL library. - -.B GPTLdisable(): -Subsequent calls to -.B GPTLstart() -and -.B GPTLstop() -will be ignored. - -.SH RESTRICTIONS -None. - -.SH RETURN VALUES -These functions always return 0 (success). - -.SH EXAMPLES -.nf -.if t .ft CW - -ret = GPTLenable (); -ret = GPTLstart ("timer1"); // this will be recognized -ret = GPTLstop ("timer1"); // this will be recognized -ret = GPTLdisable (); -ret = GPTLstart ("timer2"); // this will be ignored -ret = GPTLstop ("timer2"); // this will be ignored - -.if t .ft P -.fi diff --git a/cesm/models/utils/timing/gptl/man/man3/GPTLevent_code_to_name.3 b/cesm/models/utils/timing/gptl/man/man3/GPTLevent_code_to_name.3 deleted file mode 100644 index 401d52c..0000000 --- a/cesm/models/utils/timing/gptl/man/man3/GPTLevent_code_to_name.3 +++ /dev/null @@ -1,48 +0,0 @@ -.\" $Id$ -.TH GPTLevent_code_to_name 3 "October, 2008" "GPTL" - -.SH NAME -GPTLevent_code_to_name \- Convert a PAPI event or derived event to a string -.TP -GPTLevent_name_to_code \- Convert a string to a PAPI event id or derived event id - -.SH SYNOPSIS -.B C Interface: -.nf -int GPTLevent_code_to_name (const int code, char *name); -int GPTLevent_name_to_code (const char *name, int *code); -.fi - -.B Fortran Interface: -.nf -integer gptlevent_code_to_name (integer code, character(len=*) name) -integer gptlevent_name_to_code (character(len=*) name, integer code) -.fi - -.SH DESCRIPTION -.B GPTLevent_code_to_name() -converts an input PAPI or derived event id into a string. Derived events -involve taking the ratio of two PAPI events. An example is L1 miss rate -(GPTL_DCMRT), which is defined by PAPI_L1_DCM / PAPI_L1_DCA. -.B GPTLevent_name_to_code() -converts a string into a PAPI or derived event id (whichever applies). - -.SH ARGUMENTS -.TP -.I code --- PAPI event code or GPTL derived event id. The code can be subsequently passed into -.B GPTLsetoption() - -.TP -.I name --- name corresponding to code. - -.SH RESTRICTIONS -.B none - -.SH RETURN VALUE -On success, this function returns 0. -On error, -1 is returned. - -.SH SEE ALSO -.BR GPTLsetoption "(3)" diff --git a/cesm/models/utils/timing/gptl/man/man3/GPTLevent_name_to_code.3 b/cesm/models/utils/timing/gptl/man/man3/GPTLevent_name_to_code.3 deleted file mode 100644 index 8a46242..0000000 --- a/cesm/models/utils/timing/gptl/man/man3/GPTLevent_name_to_code.3 +++ /dev/null @@ -1 +0,0 @@ -.so man3/GPTLevent_code_to_name.3 diff --git a/cesm/models/utils/timing/gptl/man/man3/GPTLfinalize.3 b/cesm/models/utils/timing/gptl/man/man3/GPTLfinalize.3 deleted file mode 100644 index c2b65de..0000000 --- a/cesm/models/utils/timing/gptl/man/man3/GPTLfinalize.3 +++ /dev/null @@ -1,49 +0,0 @@ -.\" $Id$ -.TH GPTfinalize 3 "February, 2007" "GPTL" - -.SH NAME -GPTLfinalize \- Finalize the GPTL environment (free memory, etc). - -.SH SYNOPSIS -.B C Interface: -.nf -int GPTLfinalize (void); -.fi - -.B Fortran Interface: -.nf -integer gptfinalize () -.fi - -.SH DESCRIPTION -Finalizes the GPTL environment. All internally allocated space is freed. - -.SH RESTRICTIONS -This routine must be called only by the master thread. Further use of the -library after -.B GPTLfinalize() -requires another invocation of -.B GPTLinitialize() - -.SH RETURN VALUES -On success, this function returns 0. -On error, a negative error code is returned and a descriptive message -printed. - -.SH EXAMPLES -.nf -.if t .ft CW - -if (GPTLfinalize () != 0) - handle_error (1); - -.if t .ft P -.fi - -.SH BUGS -It is not adequate to call this function and then subsequently invoke -.B GPTLinitialize() -again. It should be but the code isn't there yet. - -.SH SEE ALSO -.BR GPTLinitialize "(3)" diff --git a/cesm/models/utils/timing/gptl/man/man3/GPTLget_eventvalue.3 b/cesm/models/utils/timing/gptl/man/man3/GPTLget_eventvalue.3 deleted file mode 100644 index 7729f8b..0000000 --- a/cesm/models/utils/timing/gptl/man/man3/GPTLget_eventvalue.3 +++ /dev/null @@ -1,63 +0,0 @@ -.\" $Id$ -.TH GPTLget_eventvalue 3 "December, 2008" "GPTL" - -.SH NAME -GPTLget_eventvalue \- Request current value of PAPI or derived counter - -.SH SYNOPSIS -.B C Interface: -.nf -int GPTLget_eventvalue (const char *name, const char *eventname, int t, - double *value); -.fi - -.B Fortran Interface: -.nf -integer gptlget_eventvalue (character(len=*) name, character(len=*) eventname, integer t, - real*8 value) -.fi - -.SH DESCRIPTION -.B GPTLget_eventvalue() -Returns current value of PAPI-based event -.IR eventname -in region -.IR name -in user-supplied argument -.IR value . -Whether the event is derived (e.g. GPTL_CI) or a simple PAPI counter -(e.g. PAPI_FP_OPS), the result is returned in floating-point format. - -.SH ARGUMENTS -.TP -.I name --- existing timer name -.TP -.I eventname --- event name (e.g. GPTL_CI) -.TP -.I t --- thread number. If < 0, return results for the current thread. -.TP -.I *value --- output 64-bit current value of the event. - -.SH RESTRICTIONS -.B GPTLinitialize() -must have been called, -.I eventname -enabled with a call to -.B GPTLsetoption() -and at least one pair of calls to -.B GPTLstart() -and -.B GPTLstop() -for the desired region. - -.SH RETURN VALUE -On success, 0 is returned. -On error, a negative error code is returned and a descriptive message -printed. - -.SH SEE ALSO -.BR GPTLsetoption "(3)" diff --git a/cesm/models/utils/timing/gptl/man/man3/GPTLget_memusage.3 b/cesm/models/utils/timing/gptl/man/man3/GPTLget_memusage.3 deleted file mode 100644 index 072d816..0000000 --- a/cesm/models/utils/timing/gptl/man/man3/GPTLget_memusage.3 +++ /dev/null @@ -1,48 +0,0 @@ -.\" $Id$ -.TH GPTLget_memusage 3 "February, 2007" "GPTL" - -.SH NAME -GPTLget_memusage \- Return current memory usage info - -.SH SYNOPSIS -.B C Interface: -.nf -int GPTLget_memusage (int *size, int *rss, int *share, - int *text, int *datastack); -.fi - -.B Fortran Interface: -.nf -integer gptlget_memusage (integer size, integer rss, integer share, - integer text, integer datastack) -.fi - -.SH DESCRIPTION -returns information about current memory usage of the process. - -.SH ARGUMENTS -.TP -.I *size --- Total process size (KB) -.TP -.I *rss --- Resident set size (KB) -.TP -.I *share --- Number of pages that are shared -.TP -.I *text --- Number of pages that are code -.TP -.I *datastack --- Number of pages that are data/stack - -.SH RESTRICTIONS -None - -.SH RETURN VALUE -On success, this function returns 0. -On error, -1 is returned. - -.SH SEE ALSO -.BR GPTLprint_memusage "(3)" diff --git a/cesm/models/utils/timing/gptl/man/man3/GPTLget_nregions.3 b/cesm/models/utils/timing/gptl/man/man3/GPTLget_nregions.3 deleted file mode 100644 index 533f469..0000000 --- a/cesm/models/utils/timing/gptl/man/man3/GPTLget_nregions.3 +++ /dev/null @@ -1,39 +0,0 @@ -.\" $Id: GPTLget_nregions.3,v 1.1 2007-04-17 20:09:03 rosinski Exp $ -.TH GPTLget_nregions 3 "March, 2007" "GPTL" - -.SH NAME -GPTLget_nregions \- Return the number of regions (timers) for a thread - -.SH SYNOPSIS -.B C Interface: -.nf -int GPTLget_nregions (int t, int *nregions); -.fi - -.B Fortran Interface: -.nf -integer gptlget_nregions (integer t, integer nregions) -.fi - -.SH DESCRIPTION -returns the current number of separate regions which have been enabled via -calls to GPTLstart() - -.SH ARGUMENTS -.TP -.I t --- thread number. If < 0, return results for the current thread. -.TP -.I *nregions --- number of regions (output) - -.SH RESTRICTIONS -.B GPTLinitialize() -must have been called. - -.SH RETURN VALUE -On success, this function returns 0. -On error, -1 is returned. - -.SH SEE ALSO -.BR GPTLget_regionname "(3)" diff --git a/cesm/models/utils/timing/gptl/man/man3/GPTLget_regionname.3 b/cesm/models/utils/timing/gptl/man/man3/GPTLget_regionname.3 deleted file mode 100644 index 1ed63fc..0000000 --- a/cesm/models/utils/timing/gptl/man/man3/GPTLget_regionname.3 +++ /dev/null @@ -1,42 +0,0 @@ -.\" $Id: GPTLget_regionname.3,v 1.1 2007-04-17 20:09:03 rosinski Exp $ -.TH GPTLget_regionname 3 "March, 2007" "GPTL" - -.SH NAME -GPTLget_regionname \- Return the number of regions (timers) for a thread - -.SH SYNOPSIS -.B C Interface: -.nf -int GPTLget_regionname (int t, int region, char *name, int nc); -.fi - -.B Fortran Interface: -.nf -integer gptlget_regionname (integer t, integer region, character(len=*) name) -.fi - -.SH DESCRIPTION -finds the region name corresponding to a given region number. The total -number of regions can be found by calling GPTLget_nregions(). - -.SH ARGUMENTS -.TP -.I t --- thread number. If < 0, return results for the current thread. -.TP -.I region --- region number -.TP -.I name --- name (output) corresponding to input region number - -.SH RESTRICTIONS -.B GPTLinitialize() -must have been called. - -.SH RETURN VALUE -On success, this function returns 0. -On error, -1 is returned. - -.SH SEE ALSO -.BR GPTLget_nregions "(3)" diff --git a/cesm/models/utils/timing/gptl/man/man3/GPTLget_wallclock.3 b/cesm/models/utils/timing/gptl/man/man3/GPTLget_wallclock.3 deleted file mode 100644 index 8bae19d..0000000 --- a/cesm/models/utils/timing/gptl/man/man3/GPTLget_wallclock.3 +++ /dev/null @@ -1,48 +0,0 @@ -.\" $Id: GPTLget_wallclock.3,v 1.1 2009-01-15 21:08:05 rosinski Exp $ -.TH GPTLget_wallclock 3 "Janary, 2009" "GPTL" - -.SH NAME -GPTLget_wallclock \- Request current wallclock accumulation for a timer - -.SH SYNOPSIS -.B C Interface: -.nf -int GPTLget_wallclock (const char *name, int t, double *value); -.fi - -.B Fortran Interface: -.nf -integer gptlget_wallclock (character(len=*) name, integer t, real*8 value) -.fi - -.SH DESCRIPTION -.B GPTLget_wallclock() -Returns current wallclock time for the region -.IR name. - -.SH ARGUMENTS -.TP -.I name --- existing region name -.TP -.I t --- thread number. If < 0, return results for the current thread. -.TP -.I *value --- output 64-bit current wallclock accumulation for the region. - -.SH RESTRICTIONS -.B GPTLinitialize() -must have been called, and at least one pair of calls to -.B GPTLstart() -and -.B GPTLstop() -for the desired region. - -.SH RETURN VALUE -On success, 0 is returned. -On error, a negative error code is returned and a descriptive message -printed. - -.SH SEE ALSO -.BR GPTLsetoption "(3)" diff --git a/cesm/models/utils/timing/gptl/man/man3/GPTLinit_handle.3 b/cesm/models/utils/timing/gptl/man/man3/GPTLinit_handle.3 deleted file mode 100644 index f783bf0..0000000 --- a/cesm/models/utils/timing/gptl/man/man3/GPTLinit_handle.3 +++ /dev/null @@ -1,97 +0,0 @@ -.\" $Id$ -.TH GPTLinit_handle 3 "October, 2013" "GPTL" - -.SH NAME -GPTLinit_handle \- Initializer for GPTLstart_handle and GPTLstop_handle - -.SH SYNOPSIS -.B C Interface: -.nf -int GPTLinit_handle (const char *name, int *handle); -.fi - -.B Fortran Interface: -.nf -integer gptlinit_handle (character(len=*) name, integer handle) -.fi - -.SH DESCRIPTION -.B GPTLinit_handle() -Initialize the handle variable for later use by -.B GPTLstart_handle() -and -.B GPTLstop_handle(). -Use of this function is -.B optional. -Its purpose is to avoid some of the overhead incurred on the initial call to -.B GPTLstart_handle() -when the handle variable is in an unitialized state (zero). In addition to -isolating this one-time initialization overhead, -.B GPTLinit_handle() -is particularly useful when subsequent -.B GPTLstart_handle() -and -.B GPTLstop_handle() -calls are within threaded regions of user code. Invoking -.B GPTLinit_handle() -outside the threaded region avoids the one-time case of multiple threads -initializing the handle variable. - -.SH ARGUMENTS -.I name --- name of timer for which to initialize its handle variable. Only the first 63 characters are -significant. This limit can be modified in the GPTL library code by changing -the value of MAX_CHARS in private.h. - -.I handle --- output value to be used later by the GPTL library. It is the hash value of -the -.B -name -variable. - -.SH RESTRICTIONS -For -.B GPTLstop() -or -.B GPTLstop_handle() -, a previous call to -.B GPTLstart() -or -.B GPTLstart_handle() -with the same -.I name -and handle must have been made. - -.SH RETURN VALUE -On success, these functions return 0. -On error, a negative error code is returned and a descriptive message -printed. - -.SH EXAMPLES -A sequence of GPTL library calls using -.B GPTLinit_handle() -prior to a threaded region utilizing -.B GPTLstart_handle() -and -.B GPTLstop_handle() -might look something like the following: -.nf -.if t .ft CW - -int handle; /* for calling _handle GPTL routines */ -... -ret = GPTLinitialize(); /* initialize the GPTL library */ -ret = GPTLinit_handle ("inner", &handle); /* initialize the handle */ -... -#pragma omp parallel for private(ret) /* OMP loop */ -for (i=0; i<1000; ++i) { - ret = GPTLstart_handle ("inner", &handle); /* start a timer */ - do_work(); /* do some work */ - ret = GPTLstop_handle ("inner", &handle); /* stop a timer */ -} -.if t .ft P -.fi - -.SH SEE ALSO -.BR GPTLstart "(3)" diff --git a/cesm/models/utils/timing/gptl/man/man3/GPTLinitialize.3 b/cesm/models/utils/timing/gptl/man/man3/GPTLinitialize.3 deleted file mode 100644 index 62e92fc..0000000 --- a/cesm/models/utils/timing/gptl/man/man3/GPTLinitialize.3 +++ /dev/null @@ -1,46 +0,0 @@ -.\" $Id: GPTLinitialize.3,v 1.3 2009-01-04 21:14:41 rosinski Exp $ -.TH GPTLinitialize 3 "January, 2009" "GPTL" - -.SH NAME -GPTLinitialize \- Initialize the GPTL library. - -.SH SYNOPSIS -.B C Interface: -.nf -int GPTLinitialize (void); -.fi - -.B Fortran Interface: -.nf -integer gptinitialize () -.fi - -.SH DESCRIPTION -Initializes the GPTL library. - -.SH RESTRICTIONS -This function must be called after all calls to -.B GPTLsetoption() -and -.B GPTLsetutr(), -and before all calls to -.B GPTLstart() -and -.B GPTLstop(). -There must be only one call to this routine, so it is better to invoke it -from an unthreaded region. - -.SH RETURN VALUE -On success, this function returns 0. -On error, a negative error code is returned and a descriptive message -printed. - -.SH EXAMPLES -.nf -.if t .ft CW - -if (GPTLinitialize () != 0) - abort(); - -.if t .ft P -.fi diff --git a/cesm/models/utils/timing/gptl/man/man3/GPTLnum_errors.3 b/cesm/models/utils/timing/gptl/man/man3/GPTLnum_errors.3 deleted file mode 100644 index d24a762..0000000 --- a/cesm/models/utils/timing/gptl/man/man3/GPTLnum_errors.3 +++ /dev/null @@ -1,30 +0,0 @@ -.\" $Id$ -.TH GPTLnum_errors 3 "January, 2014" "GPTL" - -.SH NAME -GPTLnum_errors \- Return the number of times GPTLerror() was returned by the GPTL library - -.SH SYNOPSIS -.B C Interface: -.nf -int GPTLnum_errors (void); -.fi - -.B Fortran Interface: -.nf -integer gptlnum_errors () -.fi - -.SH DESCRIPTION -.B GPTLnum_errors (): -Returns number of times -.B GPTLerror() -has been called. - -.SH RESTRICTIONS -None. - -.SH RETURN VALUE -Current value of internal scalar -.B num_errors -. diff --git a/cesm/models/utils/timing/gptl/man/man3/GPTLpr.3 b/cesm/models/utils/timing/gptl/man/man3/GPTLpr.3 deleted file mode 100644 index 2e99376..0000000 --- a/cesm/models/utils/timing/gptl/man/man3/GPTLpr.3 +++ /dev/null @@ -1,143 +0,0 @@ -.\" $Id: GPTLpr.3,v 1.6 2009-01-04 21:14:41 rosinski Exp $ -.TH GPTLpr 3 "January, 2009" "GPTL" - -.SH NAME -GPTLpr \- Print the values associated with all timers -GPTLpr_file \- Print the values associated with all timers - -.SH SYNOPSIS -.B C Interface: -.nf -int GPTLpr (const int tag); -int GPTLpr_file (const char *filename); -.fi - -.B Fortran Interface: -.nf -integer gptlpr (integer tag) -integer gptlpr_file (character(len=*) filename) -.fi - -.SH DESCRIPTION -.B GPTLpr() -opens a file named timing. and writes the values for all timers to it. -The value of the tag can be anything the user wishes. Typically for MPI runs, -the rank of the process is used in order to obtain unique file names for all tasks. -.B GPTLpr_file() -opens a file named for writing. Otherwise functions the same as -.B GPTLpr() -See -.B EXAMPLE OUTPUT -below for a sample output file and description of contents. - -.SH ARGUMENTS -.I tag --- GPTLpr() will write a file named timing. -.I filename --- GPTLpr_file will write a file named filename. - -.SH RESTRICTIONS -.B GPTLinitialize() -must have been called. To obtain any useful data, one or more -pairs of -.B GPTLstart()/GPTLstop() -calls need to have been exercised. - -.SH RETURN VALUES -On success, these functions return 0. -On error, a negative error code is returned and a descriptive message -printed. - -.SH EXAMPLE OUTPUT -Here is sample output produced by a call to -.B GPTLpr() -, where wallclock timing -and the PAPI counter for floating point ops were enabled. Threading -was enabled in the sample run, so individual per-thread statistics -are printed. Strings on the left are the names of the various timers input to -.B GPTLstart() -and -.B GPTLstop(). -Timers subsumed within other timers are indented. The number of -start/stop pairs is output in the "Called" column. When wallclock times are -being gathered, max and min stats for any single start/stop pair are also -printed. By default, if wallclock times and/or total cycles are being -counted, an attempt is made to estimate the overhead incurred by -the underlying timing routine (UTR Overhead). Finally, the results of any -PAPI-based counters enabled are printed, along with normalization to "million per -second". - -.nf -.if t .ft CW -PAPI event multiplexing was OFF -Description of printed events (PAPI and derived): - FP operations - PAPI_FP_OPS counts retired x87 and scalar_DP SSE uops tagged with 1. - -PAPI events enabled (including those required for derived events): - PAPI_FP_OPS - -Underlying timing routine was gettimeofday. -Per-call utr overhead est: 2.9e-07 sec. -Per-call PAPI overhead est: 1.4e-07 sec. -If overhead stats are printed, roughly half the estimated number is -embedded in the wallclock stats for each timer. -Print method was most_frequent. -If a '%_of' field is present, it is w.r.t. the first timer for thread 0. -If a 'e6_per_sec' field is present, it is in millions of PAPI counts per sec. - -A '*' in column 1 below means the timer had multiple parents, though the -values printed are for all calls. Further down the listing is more detailed -information about multiple parents. Look for 'Multiple parent info' - -Stats for thread 0: - Called Recurse Wallclock max min UTR_Overhead FP_OPS e6_/_sec - total 1 - 0.744 0.744 0.744 0.000 6.40e+07 86.00 - 1e+05additions 64 - 0.119 0.013 0.001 0.000 6.40e+06 53.81 - 1e+05multiplies 64 - 0.110 0.017 0.001 0.000 6.40e+06 58.16 - 1e+05multadds 64 - 0.123 0.013 0.001 0.000 1.92e+07 155.76 - 1e+05divides 64 - 0.291 0.018 0.002 0.000 6.40e+06 22.00 - 1e+05compares 64 - 0.052 0.012 0.000 0.000 2.56e+07 488.38 -Overhead sum = 0.000276 wallclock seconds -Total calls = 321 -Total recursive calls = 0 - -Stats for thread 1: - Called Recurse Wallclock max min UTR_Overhead FP_OPS e6_/_sec - 1e+05additions 64 - 0.095 0.013 0.001 0.000 6.40e+06 67.68 - 1e+05multiplies 64 - 0.117 0.013 0.001 0.000 6.40e+06 54.62 - 1e+05multadds 64 - 0.141 0.017 0.001 0.000 1.92e+07 136.09 - 1e+05divides 64 - 0.310 0.030 0.002 0.000 6.40e+06 20.61 - 1e+05compares 64 - 0.064 0.013 0.000 0.000 2.56e+07 397.52 -Overhead sum = 0.000275 wallclock seconds -Total calls = 320 -Total recursive calls = 0 - -Same stats sorted by timer for threaded regions: -Thd Called Recurse Wallclock max min UTR_Overhead FP_OPS e6_/_sec -000 1e+05additions 64 - 0.119 0.013 0.001 0.000 6.40e+06 53.81 -001 1e+05additions 64 - 0.095 0.013 0.001 0.000 6.40e+06 67.68 -SUM 1e+05additions 128 - 0.214 0.013 0.001 0.000 1.28e+07 59.95 - -000 1e+05multiplies 64 - 0.110 0.017 0.001 0.000 6.40e+06 58.16 -001 1e+05multiplies 64 - 0.117 0.013 0.001 0.000 6.40e+06 54.62 -SUM 1e+05multiplies 128 - 0.227 0.017 0.001 0.000 1.28e+07 56.33 - -000 1e+05multadds 64 - 0.123 0.013 0.001 0.000 1.92e+07 155.76 -001 1e+05multadds 64 - 0.141 0.017 0.001 0.000 1.92e+07 136.09 -SUM 1e+05multadds 128 - 0.264 0.017 0.001 0.000 3.84e+07 145.26 - -000 1e+05divides 64 - 0.291 0.018 0.002 0.000 6.40e+06 22.00 -001 1e+05divides 64 - 0.310 0.030 0.002 0.000 6.40e+06 20.61 -SUM 1e+05divides 128 - 0.601 0.030 0.002 0.000 1.28e+07 21.28 - -000 1e+05compares 64 - 0.052 0.012 0.000 0.000 2.56e+07 488.38 -001 1e+05compares 64 - 0.064 0.013 0.000 0.000 2.56e+07 397.52 -SUM 1e+05compares 128 - 0.117 0.013 0.000 0.000 5.12e+07 438.30 - -OVERHEAD.000 (wallclock seconds) = 0.000276 -OVERHEAD.001 (wallclock seconds) = 0.000275 -OVERHEAD.SUM (wallclock seconds) = 0.000551 -.if t .ft P -.fi - diff --git a/cesm/models/utils/timing/gptl/man/man3/GPTLpr_file.3 b/cesm/models/utils/timing/gptl/man/man3/GPTLpr_file.3 deleted file mode 100644 index 89b02bb..0000000 --- a/cesm/models/utils/timing/gptl/man/man3/GPTLpr_file.3 +++ /dev/null @@ -1 +0,0 @@ -.so man3/GPTLpr.3 diff --git a/cesm/models/utils/timing/gptl/man/man3/GPTLpr_summary.3 b/cesm/models/utils/timing/gptl/man/man3/GPTLpr_summary.3 deleted file mode 100644 index 63032ad..0000000 --- a/cesm/models/utils/timing/gptl/man/man3/GPTLpr_summary.3 +++ /dev/null @@ -1,88 +0,0 @@ -.\" $Id$ -.TH GPTLpr_summary 3 "December, 2012" "GPTL" - -.SH NAME -GPTLpr_summary \- Print a statistical summary of region times across all threads and tasks - -.SH SYNOPSIS -.B C Interface: -.nf -int GPTLpr_summary (MPI_Comm comm); /* when built with HAVE_MPI */ -int GPTLpr_summary (); /* when built without HAVE_MPI */ -.fi - -.B Fortran Interface: -.nf -integer gptlpr_summary (integer comm) ! when built with HAVE_MPI -integer gptlpr_summary () ! when built without HAVE_MPI -.fi - -.SH DESCRIPTION -When built with HAVE_MPI=yes, GPTLpr_summary() provides max, min, mean, and standard -deviation stats for all timed regions across all threads and tasks. The data are -written to a file named -.B timing.summary. -If PAPI counters were enabled, they are included in the summary. -.P -The computation algorithm uses a binary tree so it scales easily to many thousands of cores -with minimal additional per-core memory. Mean and standard deviation stats use the one-pass -algorithm described in http://en.wikipedia.org/wiki/Algorithms_for_calculating_variance -Mean and standard deviation are across -.B ranks, -where each data point is represented by the maximum time across threads owned by the rank. -.P -If GPTL was built with HAVE_MPI=no, GPTLpr_summary() does everything mentioned above, except -for aggration across MPI tasks. Of course mean and standard deviation stats are not printed -because they have no meaning on only one task. Users should note that calling this routine -with mulitple MPI tasks when GPTL was built with HAVE_MPI=no will not produce the desired -behavior. - -.SH ARGUMENTS -.I comm --- MPI communicator to sum across. An input of 0 means use MPI_COMM_WORLD - -.SH RESTRICTIONS -.B GPTLinitialize() -must have been called. Must be between calls to -.B MPI_Initialize() -and -.B MPI_Finalize() - -.SH RETURN VALUES -On success, this function returns 0. On error, a negative error code is returned and a -descriptive message printed. - -.SH EXAMPLE OUTPUT -Below is GPTLpr_summary output from a simple 2-rank, 4-thread run with 4 regions timed. -.P -.nf -.if t .ft CW -total ranks in communicator=2 -nthreads on rank 0=1 -'N' used for mean, std. dev. calcs.: 'ncalls'/'nthreads' -'ncalls': number of times the region was invoked across tasks and threads. -'nranks' is the number of ranks which invoked the region. -mean and std. dev. are across tasks for max time taken by any thread. -wallmax and wallmin are across tasks and threads. - -name ncalls nranks mean_time std_dev wallmax (rank thread) wallmin (rank thread) -total 2 2 0.754 0.639 1.206 ( 1 0) 0.303 ( 0 0) -region1 4 2 0.250 0.071 0.300 ( 0 1) 0.100 ( 1 0) -region2 4 2 0.000 0.000 0.000 ( 0 0) 0.000 ( 1 1) -region3 1 1 1.000 0.000 1.000 ( 1 0) 1.000 ( 1 0) -.if t .ft P -.fi - -.SH NOTES -Building GPTL with MPI enabled means all executables linked with GPTL will require linking -with the MPI library as well. -.P -C and C++ applications must be linked with the -.B -lm -flag because standard deviation calculations require the square root function. - -.SH AUTHOR -Jim Rosinski. With inspiration from Pat Worley. -.SH SEE ALSO -.BR GPTLpr "(3)" -.BR GPTLpr_file "(3)" diff --git a/cesm/models/utils/timing/gptl/man/man3/GPTLpr_summary_file.3 b/cesm/models/utils/timing/gptl/man/man3/GPTLpr_summary_file.3 deleted file mode 100644 index 5332775..0000000 --- a/cesm/models/utils/timing/gptl/man/man3/GPTLpr_summary_file.3 +++ /dev/null @@ -1,92 +0,0 @@ -.\" $Id$ -.TH GPTLpr_summary_file 3 "November, 2014" "GPTL" - -.SH NAME -GPTLpr_summary_file \- Print a statistical summary of region times across all threads and tasks - -.SH SYNOPSIS -.B C Interface: -.nf -int GPTLpr_summary_file (MPI_Comm comm, char *outfile); /* HAVE_MPI=yes */ -int GPTLpr_summary_file (char *outfile); /* HAVE_MPI=no */ -.fi - -.B Fortran Interface: -.nf -integer gptlpr_summary_file (integer comm, character*(*) outfile) ! HAVE_MPI=yes -integer gptlpr_summary_file (character*(*) outfile) ! HAVE_MPI=no -.fi - -.SH DESCRIPTION -When built with HAVE_MPI=yes, GPTLpr_summary_file() provides max, min, mean, and standard -deviation stats for all timed regions across all threads and tasks. The data are -written to a file named -.B timing.summary. -If PAPI counters were enabled, they are included in the summary. -.P -The computation algorithm uses a binary tree so it scales easily to many thousands of cores -with minimal additional per-core memory. Mean and standard deviation stats use the one-pass -algorithm described in http://en.wikipedia.org/wiki/Algorithms_for_calculating_variance -Mean and standard deviation are across -.B ranks, -where each data point is represented by the maximum time across threads owned by the rank. -.P -If GPTL was built with HAVE_MPI=no, GPTLpr_summary_file() does everything mentioned above, except -for aggration across MPI tasks. Of course mean and standard deviation stats are not printed -because they have no meaning on only one task. Users should note that calling this routine -with mulitple MPI tasks when GPTL was built with HAVE_MPI=no will not produce the desired -behavior. - -.SH ARGUMENTS -.TP -.I comm --- MPI communicator to sum across. An input of 0 means use MPI_COMM_WORLD -.TP -.I outfile --- Name of file to open and write summary information - -.SH RESTRICTIONS -.B GPTLinitialize() -must have been called. Must be between calls to -.B MPI_Initialize() -and -.B MPI_Finalize() - -.SH RETURN VALUES -On success, this function returns 0. On error, a negative error code is returned and a -descriptive message printed. - -.SH EXAMPLE OUTPUT -Below is GPTLpr_summary_file output from a simple 2-rank, 4-thread run with 4 regions timed. -.P -.nf -.if t .ft CW -total ranks in communicator=2 -nthreads on rank 0=1 -'N' used for mean, std. dev. calcs.: 'ncalls'/'nthreads' -'ncalls': number of times the region was invoked across tasks and threads. -'nranks' is the number of ranks which invoked the region. -mean and std. dev. are across tasks for max time taken by any thread. -wallmax and wallmin are across tasks and threads. - -name ncalls nranks mean_time std_dev wallmax (rank thread) wallmin (rank thread) -total 2 2 0.754 0.639 1.206 ( 1 0) 0.303 ( 0 0) -region1 4 2 0.250 0.071 0.300 ( 0 1) 0.100 ( 1 0) -region2 4 2 0.000 0.000 0.000 ( 0 0) 0.000 ( 1 1) -region3 1 1 1.000 0.000 1.000 ( 1 0) 1.000 ( 1 0) -.if t .ft P -.fi - -.SH NOTES -Building GPTL with MPI enabled means all executables linked with GPTL will require linking -with the MPI library as well. -.P -C and C++ applications must be linked with the -.B -lm -flag because standard deviation calculations require the square root function. - -.SH AUTHOR -Jim Rosinski. With inspiration from Pat Worley. -.SH SEE ALSO -.BR GPTLpr "(3)" -.BR GPTLpr_file "(3)" diff --git a/cesm/models/utils/timing/gptl/man/man3/GPTLprint_memusage.3 b/cesm/models/utils/timing/gptl/man/man3/GPTLprint_memusage.3 deleted file mode 100644 index 91b9bbc..0000000 --- a/cesm/models/utils/timing/gptl/man/man3/GPTLprint_memusage.3 +++ /dev/null @@ -1,46 +0,0 @@ -.\" $Id$ -.TH GPTLprint_memusage 3 "December, 2012" "GPTL" - -.SH NAME -GPTLprint_memusage \- Print current memory usage info - -.SH SYNOPSIS -.B C Interface: -.nf -int GPTLprint_memusage (const char *str); -.fi - -.B Fortran Interface: -.nf -integer gptlprint_memusage (character(len=*) str) -.fi - -.SH DESCRIPTION -.B GPTLprint_memusage -prints information about current memory usage of the process. - -.SH ARGUMENTS -.I str --- input string gets printed ahead of the other information. Normally used -as a tag to identify where in the code the call was made. - -.SH RESTRICTIONS -None - -.SH RETURN VALUE -On success, this function returns 0. -On error, -1 is returned. - -.SH EXAMPLES -.nf -.if t .ft CW -... -ret = GPTLprint_memusage ("start"); // print memory usage info at program start -ret = do_work(); -ret = GPTLprint_memusage ("end"); // print memory usage info at program end - -.if t .ft P -.fi - -.SH SEE ALSO -.BR GPTLget_memusage "(3)" diff --git a/cesm/models/utils/timing/gptl/man/man3/GPTLprint_rusage.3 b/cesm/models/utils/timing/gptl/man/man3/GPTLprint_rusage.3 deleted file mode 100644 index 260678d..0000000 --- a/cesm/models/utils/timing/gptl/man/man3/GPTLprint_rusage.3 +++ /dev/null @@ -1,49 +0,0 @@ -.\" $Id$ -.TH GPTLprint_rusage 3 "April, 2014" "GPTL" - -.SH NAME -GPTLprint_rusage \- Print info from getrusage() - -.SH SYNOPSIS -.B C Interface: -.nf -int GPTLprint_rusage (const char *str); -.fi - -.B Fortran Interface: -.nf -integer gptlprint_rusage (character(len=*) str) -.fi - -.SH DESCRIPTION -.B GPTLprint_rusage -prints info from getrusage(): max memory usage in MB, number of minor page -faults in K (no I/O activity), number of major page faults in K (I/O activity -required), and number of voluntary context switches in K (normally due to -waiting on a resource). - -.SH ARGUMENTS -.I str --- input string gets printed ahead of the other information. Normally used -as a tag to identify where in the code the call was made. - -.SH RESTRICTIONS -None - -.SH RETURN VALUE -On success, this function returns 0. -On error, -1 is returned. - -.SH EXAMPLES -.nf -.if t .ft CW -... -ret = GPTLprint_rusage ("start"); // print rusage stats at program start -ret = do_work(); -ret = GPTLprint_rusage ("end"); // print rusage stats at program end - -.if t .ft P -.fi - -.SH SEE ALSO -.BR GPTLprint_memusage "(3)" diff --git a/cesm/models/utils/timing/gptl/man/man3/GPTLquery.3 b/cesm/models/utils/timing/gptl/man/man3/GPTLquery.3 deleted file mode 100644 index cfb9f6f..0000000 --- a/cesm/models/utils/timing/gptl/man/man3/GPTLquery.3 +++ /dev/null @@ -1,95 +0,0 @@ -.\" $Id$ -.TH GPTLquery 3 "January, 2009" "GPTL" - -.SH NAME -GPTLquery \- Request current values of all data for an existing timer -.TP -GPTLquerycounters \- Request current values of PAPI counters for an existing timer - -.SH SYNOPSIS -.B C Interface: -.nf -int GPTLquery (const char *name, int t, int *count, - int *onflg, double *wallclock, double *usr, double *sys, - long long *counters, const int maxcounters); -int GPTLquerycounters (const char *name, int t, long long *counters); -.fi - -.B Fortran Interface: -.nf -integer gptlquery (character(len=*) name, integer t, integer count, - integer onflg, real*8 wallclock, real*8 usr, real*8 sys, - integer*8 counters, integer maxcounters) -integer gptlquerycounters (character(len=*) name, integer t, integer*8 counters) -.fi - -.SH DESCRIPTION -If PAPI and/or derived event information is desired, consider using -.B GPTLget_eventvalue() -instead of either of these functions. -.B GPTLquery() -Requests all information about the timer identified by -.IR name . -.B GPTLquerycounters() -Requests PAPI counter information about the timer identified by -.IR name . - -Only the first 15 characters of -.IR name -are significant, but this limit can be modified in the GPTL library code via the -.B #define -of MAX_CHARS. Longer names are truncated. All -statistics set by earlier calls to -.B GPTLsetoption() -(e.g. cpu time), or otherwise on by default (e.g. wallclock time), are counted. - -.SH ARGUMENTS -.TP -.I name --- existing timer name -.TP -.I t --- thread number. If < 0, return results for the current thread. -.TP -.I count --- the number of start/stop pairs that have been invoked (output). -.TP -.I onflg --- non-zero returned value (true) means the timer is currently on. zero means -the timer is currently off (output). -.TP -.I wallclock --- accumulated wallclock time (output). -.TP -.I usr --- accumulated user CPU time (output). -.TP -.I sys --- accumulated system CPU time (output). -.TP -.I counters --- an array to hold the values of the PAPI counters (output). -.TP -.I maxcounters --- maximum number of PAPI counters to return. Note that this argument is not -present in -.B GPTLquerycounters(). -In this case, the -.B counters -array must be large enough to hold all enabled PAPI counters. - -.SH RESTRICTIONS -.B GPTLinitialize() -must have been called. To obtain any useful data, one or more -pairs of -.B GPTLstart()/GPTLstop() -calls need to have been exercised (or their variants such as -.B GPTLstart_handle() - -.SH RETURN VALUE -On success, these functions return 0. -On error, a negative error code is returned and a descriptive message -printed. - -.SH SEE ALSO -.BR GPTLsetoption "(3)" diff --git a/cesm/models/utils/timing/gptl/man/man3/GPTLquerycounters.3 b/cesm/models/utils/timing/gptl/man/man3/GPTLquerycounters.3 deleted file mode 100644 index 9508145..0000000 --- a/cesm/models/utils/timing/gptl/man/man3/GPTLquerycounters.3 +++ /dev/null @@ -1 +0,0 @@ -.so man3/GPTLquery.3 diff --git a/cesm/models/utils/timing/gptl/man/man3/GPTLreset.3 b/cesm/models/utils/timing/gptl/man/man3/GPTLreset.3 deleted file mode 100644 index be5e2d4..0000000 --- a/cesm/models/utils/timing/gptl/man/man3/GPTLreset.3 +++ /dev/null @@ -1,38 +0,0 @@ -.\" $Id$ -.TH GPTLreset 3 "January, 2009" "GPTL" - -.SH NAME -GPTLreset \- Reset all timer contents to zero. - -.SH SYNOPSIS -.B C Interface: -.nf -int GPTLreset (void); -.fi - -.B Fortran Interface: -.nf -integer gptlreset () -.fi - -.SH DESCRIPTION -Reset all timer contents to zero. This includes any embedded PAPI counters. - -.SH RESTRICTIONS -.B GPTLinitialize() -must have been called. This function must be called by the master thread only. - -.SH RETURN VALUES -On success, this function returns 0. -On error, a negative error code is returned and a descriptive message -printed. - -.SH EXAMPLES -.nf -.if t .ft CW - -if (GPTLreset () != 0) - handle_error (1); - -.if t .ft P -.fi diff --git a/cesm/models/utils/timing/gptl/man/man3/GPTLsetoption.3 b/cesm/models/utils/timing/gptl/man/man3/GPTLsetoption.3 deleted file mode 100644 index 9e32f6e..0000000 --- a/cesm/models/utils/timing/gptl/man/man3/GPTLsetoption.3 +++ /dev/null @@ -1,110 +0,0 @@ -.\" $Id$ -.TH GPTLsetoption 3 "January, 2009" "GPTL" - -.SH NAME -GPTLsetoption \- Enable or disable a GPTL, PAPI, or derived event. - -.SH SYNOPSIS -.B C Interface: -.nf -#include -int GPTLsetoption (const int option, const int val); -.fi - -.B Fortran Interface: -.nf -#include -integer gptlsetoption (integer option, integer val) -.fi - -.SH DESCRIPTION -Set a GPTL option to a value. Examples include gathering CPU stats, enabling a PAPI -counter such as PAPI_FP_OPS, or a derived event such as computational -intensity. Most options take boolean values. An exception is -GPTLprint_method, which takes various integer values which define the -mechanism to use when printing the call tree. This function MUST be called BEFORE -.B GPTLinitialize(). - -.SH ARGUMENTS -.I "option" --- an integer specifying the option to be enabled or disabled. Available -options are defined in -.B gptl.h -( -.B gptl.inc -for Fortran). And in -.B papi.h -( -.B fpapi.h -for Fortran) if PAPI support is enabled. -.BR -.LP -.I val --- an integer defining whether to enable or disable -.BR option. -Non-zero values mean enable, and zero means to disable the option. Available -options, along with default settings in parens are listed here (using -C-syntax. Case-insensitive Fortran names are identical): -.nf -.if t .ft CW - -GPTLsync_mpi // Synchronize before certain MPI calls (PMPI-mode only) -GPTLwall // Collect wallclock time stats (true) -GPTLcpu // Collect CPU stats (false) -GPTLabort_on_error // Abort on failure (false) -GPTLoverhead // Estimate overhead of underlying timing routine (true) -GPTLdepthlimit // Only print timers this depth or less in the tree (inf) -GPTLverbose // Verbose output (false) -GPTLnarrowprint // Print PAPI and derived stats in 8 columns not 16 (true) -GPTLpercent // Add a column for percent of first timer (false) -GPTLpersec // Add a PAPI column that prints "per second" stats (true) -GPTLmultiplex // Allow PAPI multiplexing (true) -GPTLdopr_preamble // Print preamble info (true) -GPTLdopr_threadsort // Print sorted thread stats (true) -GPTLdopr_multparent // Print multiple parent info (true) -GPTLdopr_collision // Print hastable collision info (true) -GPTLprint_method // Tree print method: first parent, last parent - // most frequent, or full tree (most frequent) - -// In addition to the above options, GPTLsetoption accepts any available -// PAPI counter, and the following derived events. The event codes can be -// found by using GPTLevent_name_to_code(). - -GPTL_IPC // Instructions per cycle -GPTL_CI // Computational intensity -GPTL_FPC // FP ops per cycle -GPTL_FPI // FP ops per instruction -GPTL_LSTPI // Load-store instruction fraction -GPTL_DCMRT // L1 miss rate (fraction) -GPTL_LSTPDCM // Load-stores per L1 miss -GPTL_L2MRT // L2 miss rate (fraction) -GPTL_LSTPL2M // Load-stores per L2 miss -GPTL_L3MRT // L3 read miss rate (fraction) - -.if t .ft P -.fi - -.SH RESTRICTIONS -Zero or more invocations of this function must be made prior to -GPTLinitialize. It cannot be called after -.B GPTLinitialize(). - -.SH RETURN VALUES -On success, this function returns 0. -On error, a negative error code is returned and a descriptive message -printed. - -.SH EXAMPLES -.nf -.if t .ft CW - -if (GPTLsetoption (GPTLcpu, 1) != 0) /* Enable cpu timing */ - handle_error (1); -if (GPTLsetoption (PAPI_TOT_CYC, 1) != 0) /* Enable counting total cycles */ - handle_error (1); - -.if t .ft P -.fi - -.SH SEE ALSO -.BR GPTLinitialize "(3)" diff --git a/cesm/models/utils/timing/gptl/man/man3/GPTLsetutr.3 b/cesm/models/utils/timing/gptl/man/man3/GPTLsetutr.3 deleted file mode 100644 index 0fce9a5..0000000 --- a/cesm/models/utils/timing/gptl/man/man3/GPTLsetutr.3 +++ /dev/null @@ -1,56 +0,0 @@ -.\" $Id$ -.TH GPTLsetutr 3 "December, 2012" "GPTL" - -.SH NAME -GPTLsetutr \- Choose a different underlying timing routine than the default. - -.SH SYNOPSIS -.B C Interface: -.nf -#include -int GPTLsetutr (const int routine); -.fi - -.B Fortran Interface: -.nf -#include -integer gptlsetutr (integer routine) -.fi - -.SH DESCRIPTION -Sets the underlying timing routine to one of the supported -values. -.B gettimeofday() -is the default. See -.B gptl.h -(or -.B gptl.inc -for Fortran) for the list of supported underlying timing -routines. gettimeofday() is generally the slowest option. But it is -available almost everywhere. - -.SH ARGUMENTS -.I routine --- routine identifier (see gptl.h or gptl.inc for available routines) - -.SH RESTRICTIONS -Any calls to this routine must be done prior to GPTLinitialize. It should be -called from an unthreaded region. - -.SH RETURN VALUES -On success, this function returns 0. -On error, a negative error code is returned and a descriptive message -printed. - -.SH EXAMPLES -.nf -.if t .ft CW - -if (GPTLsetutr (GPTLmpiwtime) != 0) - handle_error (1); - -.if t .ft P -.fi - -.SH SEE ALSO -.BR GPTLinitialize "(3)" diff --git a/cesm/models/utils/timing/gptl/man/man3/GPTLstamp.3 b/cesm/models/utils/timing/gptl/man/man3/GPTLstamp.3 deleted file mode 100644 index ea6a9c0..0000000 --- a/cesm/models/utils/timing/gptl/man/man3/GPTLstamp.3 +++ /dev/null @@ -1,48 +0,0 @@ -.\" $Id$ -.TH GPTLstamp 3 "February, 2007" "GPTL" - -.SH NAME -GPTLstamp \- Return wallclock, user time, and system time stamps to the caller. - -.SH SYNOPSIS -.B C Interface: -.nf -int GPTLstamp (double *wall, double *usr, double *sys); -.fi - -.B Fortran Interface: -.nf -integer gptlstamp (real*8 wall, real*8 usr, real*8 sys) -.fi - -.SH DESCRIPTION -Return current timestamps for wallclock time, user CPU time, and system CPU -time. - -.SH ARGUMENTS -.I wall --- wallclock time (seconds) -.I usr --- user CPU time (seconds) -.I sys --- system CPU time (seconds) - -.SH RESTRICTIONS -.B GPTLinitialize() -must have been called. - -.SH RETURN VALUE -On success, this function returns 0. -On error, a negative error code is returned and a descriptive message -printed. - -.SH EXAMPLES -.nf -.if t .ft CW - -double wall, usr, sys; -if (GPTLstamp (&wall, &usr, &sys) != 0) - handle_error (1); - -.if t .ft P -.fi diff --git a/cesm/models/utils/timing/gptl/man/man3/GPTLstart.3 b/cesm/models/utils/timing/gptl/man/man3/GPTLstart.3 deleted file mode 100644 index e548ab5..0000000 --- a/cesm/models/utils/timing/gptl/man/man3/GPTLstart.3 +++ /dev/null @@ -1,120 +0,0 @@ -.\" $Id$ -.TH GPTLstart 3 "October, 2013" "GPTL" - -.SH NAME -GPTLstart \- Start a timer -.TP -GPTLstop \- Stop a timer -.P -GPTLstart_handle \- Start a timer with a given handle -.TP -GPTLstop_handle \- Stop a timer with a given handle - -.SH SYNOPSIS -.B C Interface: -.nf -int GPTLstart (const char *name); -int GPTLstop (const char *name); -.P -int GPTLstart_handle (const char *name, int *handle); -int GPTLstop_handle (const char *name, int *handle); -.fi - -.B Fortran Interface: -.nf -integer gptlstart (character(len=*) name) -integer gptlstop (character(len=*) name) -.P -integer gptlstart_handle (character(len=*) name, integer handle) -integer gptlstop_handle (character(len=*) name, integer handle) -.fi - -.SH DESCRIPTION -.B GPTLstart() -and -.B GPTLstart_handle() -start a timer defined by -.I name. -.B GPTLstop() -and -.B GPTLstop_handle() -stop a timer defined by -.I name. - -.SH ARGUMENTS -.I name --- name of timer to start/stop. Only the first 63 characters are -significant. This limit can be modified in the GPTL library code by changing -the value of MAX_CHARS in private.h. -.P -The -.B _handle -versions of these routines are designed to be more efficient. They take a second argument -(integer), which must be initialized by the user to zero. A different -.I handle -is required for each region to be timed. On first invocation for each region, -GPTL writes an internal hash index into -.I handle. -On subsequent invocations, GPTL uses this index directly, rather than going through -the hash-table lookup procedure required by GPTLstart() and GPTLstop(). This can save -substantial overhead when timing fine grained regions that are invoked many times -over the course of the run being timed. -.P -The -.B _handle -versions work correctly within threaded code. For OpenMP codes, the handle should have -scope -.B shared. -This is because for a given region name, all threads will use the same value for the handle -variable. -.P -It is possible to mix use of GPTLstart()/GPTLstop() with use of -GPTLstart_handle()/GPTLstop_handle(), even for the same region. - -.SH RESTRICTIONS -.B GPTLinitialize() -must have been called. For -.B GPTLstop() -, a previous call to -.B GPTLstart() -with the same -.I name -must have been made. Likewise for the -.B _handle -versions of these routines. - -.SH RETURN VALUE -On success, these functions return 0. -On error, a negative error code is returned and a descriptive message -printed. - -.SH EXAMPLES -A complete sequence of GPTL library calls within a program might look -something like the following: -.nf -.if t .ft CW - -int handle = 0; /* for calling _handle GPTL routines */ -ret = GPTLsetoption (GPTLcpu, 1); /* enable cpu timings: default false */ -ret = GPTLsetoption (GPTLwall, 0); /* disable wallclock timings: default true */ -ret = GPTLsetoption (PAPI_TOT_CYC, 1); /* use PAPI to count total cycles */ -... -ret = GPTLinitialize(); /* initialize the GPTL library */ -ret = GPTLstart ("total"); /* start a timer */ -... -ret = GPTLstart ("do_work"); /* start another timer */ -do_work(); /* do some work */ -ret = GPTLstop ("do_work"); /* stop a timer */ -ret = GPTLstart_handle ("work2", &handle); /* start a timer and give it a handle */ -do_work2(); -ret = GPTLstop_handle ("work2", &handle); /* stop a timer with a handle */ -ret = GPTLstop ("total"); /* stop a timer */ -... -ret = GPTLpr (mympitaskid); /* print results to timing. */ - -.if t .ft P -.fi - -.SH SEE ALSO -.BR GPTLpr "(3)" -.BR GPTLpr_file "(3)" diff --git a/cesm/models/utils/timing/gptl/man/man3/GPTLstart_handle.3 b/cesm/models/utils/timing/gptl/man/man3/GPTLstart_handle.3 deleted file mode 100644 index 8e3f2cf..0000000 --- a/cesm/models/utils/timing/gptl/man/man3/GPTLstart_handle.3 +++ /dev/null @@ -1 +0,0 @@ -.so man3/GPTLstart.3 diff --git a/cesm/models/utils/timing/gptl/man/man3/GPTLstop.3 b/cesm/models/utils/timing/gptl/man/man3/GPTLstop.3 deleted file mode 100644 index 8e3f2cf..0000000 --- a/cesm/models/utils/timing/gptl/man/man3/GPTLstop.3 +++ /dev/null @@ -1 +0,0 @@ -.so man3/GPTLstart.3 diff --git a/cesm/models/utils/timing/gptl/man/man3/GPTLstop_handle.3 b/cesm/models/utils/timing/gptl/man/man3/GPTLstop_handle.3 deleted file mode 100644 index 8e3f2cf..0000000 --- a/cesm/models/utils/timing/gptl/man/man3/GPTLstop_handle.3 +++ /dev/null @@ -1 +0,0 @@ -.so man3/GPTLstart.3 diff --git a/cesm/models/utils/timing/gptl/memstats.c b/cesm/models/utils/timing/gptl/memstats.c deleted file mode 100644 index a8c0443..0000000 --- a/cesm/models/utils/timing/gptl/memstats.c +++ /dev/null @@ -1,77 +0,0 @@ -#include "private.h" - -static void print_threadmapping (FILE *, int); /* print mapping of thread ids */ - -void GPTLprint_memstats (FILE *fp, Timer **timers, int nthreads, int tablesize, int maxthreads) -{ - Timer *ptr; /* walk through linked list */ - float pchmem = 0.; /* parent/child array memory usage */ - float regionmem = 0.; /* timer memory usage */ - float papimem = 0.; /* PAPI stats memory usage */ - float hashmem; /* hash table memory usage */ - float callstackmem; /* callstack memory usage */ - float totmem; /* total GPTL memory usage */ - int numtimers; /* number of timers */ - int t; - - hashmem = (float) sizeof (Hashentry) * tablesize * maxthreads; /* fixed size of table */ - callstackmem = (float) sizeof (Timer *) * MAX_STACK * maxthreads; - for (t = 0; t < nthreads; t++) { - numtimers = 0; - for (ptr = timers[t]->next; ptr; ptr = ptr->next) { - ++numtimers; - pchmem += (float) sizeof (Timer *) * (ptr->nchildren + ptr->nparent); - } - hashmem += (float) numtimers * sizeof (Timer *); - regionmem += (float) numtimers * sizeof (Timer); -#ifdef HAVE_PAPI - papimem += (float) numtimers * sizeof (Papistats); -#endif - } - - totmem = hashmem + regionmem + pchmem + callstackmem; - fprintf (fp, "\n"); - fprintf (fp, "Total GPTL memory usage = %g KB\n", totmem*.001); - fprintf (fp, "Components:\n"); - fprintf (fp, "Hashmem = %g KB\n" - "Regionmem = %g KB (papimem portion = %g KB)\n" - "Parent/child arrays = %g KB\n" - "Callstackmem = %g KB\n", - hashmem*.001, regionmem*.001, papimem*.001, pchmem*.001, callstackmem*.001); - - print_threadmapping (fp, nthreads); -} - -#if ( defined THREADED_OMP ) - -static void print_threadmapping (FILE *fp, int nthreads) -{ - int t; - - fprintf (fp, "\n"); - fprintf (fp, "Thread mapping:\n"); - for (t = 0; t < nthreads; ++t) - fprintf (fp, "GPTLthreadid_omp[%d] = %d\n", t, GPTLthreadid_omp[t]); -} - -#elif ( defined THREADED_PTHREADS ) - -static void print_threadmapping (FILE *fp, int nthreads) -{ - int t; - - fprintf (fp, "\n"); - fprintf (fp, "Thread mapping:\n"); - for (t = 0; t < nthreads; ++t) - fprintf (fp, "GPTLthreadid[%d] = %lu\n", t, (unsigned long) GPTLthreadid[t]); -} - -#else - -static void print_threadmapping (FILE *fp, int nthreads) -{ - fprintf (fp, "\n"); - fprintf (fp, "GPTLthreadid[0] = 0\n"); -} - -#endif diff --git a/cesm/models/utils/timing/gptl/mkheaders.csh b/cesm/models/utils/timing/gptl/mkheaders.csh deleted file mode 100755 index c4580cf..0000000 --- a/cesm/models/utils/timing/gptl/mkheaders.csh +++ /dev/null @@ -1,111 +0,0 @@ -#!/bin/csh -f - -# This script creates C header file gptl.h, Fortran header file gptl.inc, and -# Fortran module file gptlf.F90. DRY programming: define the header values -# in one place (this script) - -# Set shell variables which will be substituted in the header files: - -set GPTLsync_mpi = 0 -set GPTLwall = 1 -set GPTLcpu = 2 -set GPTLabort_on_error = 3 -set GPTLoverhead = 4 -set GPTLdepthlimit = 5 -set GPTLverbose = 6 -set GPTLnarrowprint = 7 -set GPTLpercent = 9 -set GPTLpersec = 10 -set GPTLmultiplex = 11 -set GPTLdopr_preamble = 12 -set GPTLdopr_threadsort = 13 -set GPTLdopr_multparent = 14 -set GPTLdopr_collision = 15 -set GPTLprint_method = 16 -set GPTLdopr_memusage = 27 -set GPTLtablesize = 50 -set GPTLmaxthreads = 51 - -set GPTL_IPC = 17 -set GPTL_CI = 18 -set GPTL_FPC = 19 -set GPTL_FPI = 20 -set GPTL_LSTPI = 21 -set GPTL_DCMRT = 22 -set GPTL_LSTPDCM = 23 -set GPTL_L2MRT = 24 -set GPTL_LSTPL2M = 25 -set GPTL_L3MRT = 26 - -set GPTLgettimeofday = 1 -set GPTLnanotime = 2 -set GPTLread_real_time = 3 -set GPTLmpiwtime = 4 -set GPTLclockgettime = 5 -set GPTLpapitime = 6 -set GPTLplacebo = 7 - -set GPTLfirst_parent = 1 -set GPTLlast_parent = 2 -set GPTLmost_frequent = 3 -set GPTLfull_tree = 4 - -# Create the sed script which will replace variables in the 3 header files -# with the above-defined values - -cat >! sedscript <! gptl.h || (echo bad attempt to write to gptl.h && exit 1) -sed -f sedscript gptl.inc.template >! gptl.inc || (echo bad attempt to write to gptl.inc && exit 1) -sed -f sedscript gptlf.F90.template >! gptlf.F90 || (echo bad attempt to write to gptlf.F90 && exit 1) - -# Ensure that all variables got substituted by looking for "#" in the output files - -grep -v '^#' gptl.h | grep '#' && (echo "found unsubstituted variables in gptl.h" && exit 1) -grep -v '^!' gptl.inc | grep '#' && (echo "found unsubstituted variables in gptl.inc" && exit 1) -grep -v '^!' gptlf.F90 | grep -v '^#' | grep '#' && (echo "found unsubstituted variables in gptlf.F90" && exit 1) - -exit 0 diff --git a/cesm/models/utils/timing/gptl/parsegptlout.pl b/cesm/models/utils/timing/gptl/parsegptlout.pl deleted file mode 100755 index 1aecb0f..0000000 --- a/cesm/models/utils/timing/gptl/parsegptlout.pl +++ /dev/null @@ -1,159 +0,0 @@ -#!/usr/bin/perl - -use strict; - -our ($verbose) = 0; # output verbosity -our ($maxval); # max value across all processes/threads -our ($minval); # min value across all processes/threads -our ($sum); # total -our ($nval); # number of entries found across all processes/threads -our ($totcalls); # number of calls found across all processes/threads -our ($numthreads); # number of threads - -my ($fn); # file name -my ($fnroot) = "timing"; -my ($target); # region to search for -my ($arg); # element of @ARGV -my ($started); # flag indicates initial "Stats for thread" found -my ($thread); # thread number -my ($threadmax); # thread number for max value -my ($threadmin); # thread number for min value -my ($task); # MPI task index (= ntask at loop completion) -my ($taskmax); # task index for max value -my ($taskmin); # task index for min value -my ($line); # input line read in from file -my ($idx); # index -my ($hidx); # heading index -my ($mean); # mean value -my ($found); # flag indicates region name found -my ($totposs); # number of threads * number of tasks -my ($heading) = "Wallclock"; # heading (column) to search for - -my (@vals); # values for region -my (@headinglist); # list of headings in input files - -# Parse arg list - -while ($arg = shift (@ARGV)) { - if ($arg eq "-f") { - $fnroot = shift (@ARGV); # change root of file name - } elsif ($arg eq "-h") { - $heading = shift (@ARGV); # change heading to search for - } elsif ($arg eq "-v") { - $verbose = 1; - } else { - if ( ! defined $target ) { - $target = "$arg"; # region name - chomp ($target); - } else { - die_usemsg ("Unknown argument $arg\n"); - } - } -} - -die_usemsg ("Target region name not defined\n") if ( ! defined $target ); -&initstats(); # Initialize stats -$found = 0; # false - -# Loop through output files - -for ($task = 0; -e "${fnroot}.$task"; $task++) { - $fn = "${fnroot}.$task"; - open (FILE, "<$fn") || die ("Can't open $fn for reading\n"); - $started = 0; - -# Read all the lines in the file, looking for "Stats for thread", followed by -# thre region name - - while ($line = ) { - chomp ($line); - if ($line =~ /^Stats for thread (\d*):/) { - $started = 1; - $thread = $1; - $numthreads = $thread if ($thread > $numthreads); - -# Next line contains the headings. Parse for later printing -# Chop off leading whitespace--in can foul up later parsing - - $line = ; - chomp ($line); - if ($line =~ /^\s+(.*)$/) { - $line = $1; - } - @headinglist = split (/\s+/, $line); - for ($hidx = 0; $hidx <= $#headinglist; $hidx++) { - last if ($headinglist[$hidx] eq $heading); - } - if ($hidx > $#headinglist) { - die ("Heading $heading not found in $fn. Giving up\n"); - } - } elsif ($started && ($line =~ /^[* ]\s*${target}\s+(.*)$/)) { - $found = 1; - @vals = split (/\s+/, $1); - ($#vals >= $hidx) || die ("$heading not found in input:\n$1\n"); - $totcalls += $vals[0]; - $sum += $vals[$hidx]; - $nval++; - - if ($vals[$hidx] > $maxval) { - $maxval = $vals[$hidx]; - $taskmax = $task; - $threadmax = $thread; - } - if ($vals[$hidx] < $minval) { - $minval = $vals[$hidx]; - $taskmin = $task; - $threadmin = $thread; - } - $started = 0; - next; # Look for next "Stats for thread" - } - } -} - -die ("Found no occurrences of $target in any of $task files\n") if ( ! $found ); - -print (STDOUT "Searched for region $target\n"); -$numthreads++; # convert from 0-based to 1-based -print (STDOUT "Found $totcalls calls across $task tasks and $numthreads threads per task\n"); -$totposs = $numthreads * $task; -print (STDOUT "$nval of a possible $totposs tasks and threads had entries for $target\n"); -print (STDOUT "Heading is $heading\n"); -printf (STDOUT "Max = %.3g on thread %d task %d\n", $maxval, $threadmax, $taskmax); -printf (STDOUT "Min = %.3g on thread %d task %d\n", $minval, $threadmin, $taskmin); -$mean = $sum / $nval; -printf (STDOUT "Mean = %.3g\n", $mean); -printf (STDOUT "Total = %.3g\n", $sum); - -exit 0; - -sub initstats { - our ($verbose); - our ($maxval); - our ($minval); - our ($sum); - our ($nval); - our ($totcalls); - our ($numthreads); - - $totcalls = 0; - $numthreads = 0; - $minval = 9.99e19; - $maxval = -9.99e19; - $nval = 0; - $sum = 0.; - $taskmax = -1; - $taskmin = -1; - $threadmax = -1; - $threadmin = -1; -} - -sub die_usemsg { - defined $_[0] && print (STDOUT "$_[0]"); - print (STDOUT "Usage: $0 [-v] [-f file-root] [-h heading] region\n", - " -f file-root => look for files named . (default file-root is 'timing')\n", - " -h heading => use as the default search target (default is Wallclock)\n", - " -v => verbose\n", - " region => region name to search for\n"); - exit 1; -} diff --git a/cesm/models/utils/timing/gptl/pmpi.c b/cesm/models/utils/timing/gptl/pmpi.c deleted file mode 100644 index 2dc426e..0000000 --- a/cesm/models/utils/timing/gptl/pmpi.c +++ /dev/null @@ -1,661 +0,0 @@ -/* -** pmpi.c -** -** Author: Jim Rosinski -** -** Wrappers to MPI routines -*/ - -#include "private.h" -#include "gptl.h" - -#ifdef ENABLE_PMPI -#include - -static bool sync_mpi = false; - -int GPTLpmpi_setoption (const int option, - const int val) -{ - int retval; - - switch (option) { - case GPTLsync_mpi: - sync_mpi = (bool) val; - retval = 0; - break; - default: - retval = 1; - } - return retval; -} - -/* -** Additions to MPI_Init: Initialize GPTL if this hasn't already been done. -** Start a timer which will be stopped in MPI_Finalize. -*/ -int MPI_Init (int *argc, char ***argv) -{ - int ret; - int ignoreret; - - ret = PMPI_Init (argc, argv); - if ( ! GPTLis_initialized ()) - ignoreret = GPTLinitialize (); - - ignoreret = GPTLstart ("MPI_Init_thru_Finalize"); - - return ret; -} - -int MPI_Init_thread (int *argc, char ***argv, int required, int *provided) -{ - int ret; - int ignoreret; - - ret = PMPI_Init_thread (argc, argv, required, provided); - if ( ! GPTLis_initialized ()) - ignoreret = GPTLinitialize (); - - ignoreret = GPTLstart ("MPI_Init_thru_Finalize"); - - return ret; -} - -int MPI_Send (CONST void *buf, int count, MPI_Datatype datatype, int dest, int tag, - MPI_Comm comm) -{ - int ret; - int size; - int ignoreret; - Timer *timer; - - ignoreret = GPTLstart ("MPI_Send"); - ret = PMPI_Send (buf, count, datatype, dest, tag, comm); - ignoreret = GPTLstop ("MPI_Send"); - if ((timer = GPTLgetentry ("MPI_Send"))) { - ignoreret = PMPI_Type_size (datatype, &size); - timer->nbytes += ((double) count) * size; - } - return ret; -} - -int MPI_Recv (void *buf, int count, MPI_Datatype datatype, int source, int tag, - MPI_Comm comm, MPI_Status *status) -{ - int ret; - int ignoreret; - int size; - Timer *timer; - - if (sync_mpi) { - ignoreret = GPTLstart ("sync_Recv"); - /* Ignore status */ - ignoreret = PMPI_Probe (source, tag, comm, status); - ignoreret = GPTLstop ("sync_Recv"); - } - - ignoreret = GPTLstart ("MPI_Recv"); - ret = PMPI_Recv (buf, count, datatype, source, tag, comm, status); - ignoreret = GPTLstop ("MPI_Recv"); - if ((timer = GPTLgetentry ("MPI_Recv"))) { - ignoreret = PMPI_Type_size (datatype, &size); - timer->nbytes += ((double) count) * size; - } - return ret; -} - -int MPI_Sendrecv (CONST void *sendbuf, int sendcount, MPI_Datatype sendtype, int dest, int sendtag, - void *recvbuf, int recvcount, MPI_Datatype recvtype, int source, int recvtag, - MPI_Comm comm, MPI_Status *status ) -{ - int ret; - int ignoreret; - int sendsize, recvsize; - Timer *timer; - - ignoreret = GPTLstart ("MPI_Sendrecv"); - ret = PMPI_Sendrecv (sendbuf, sendcount, sendtype, dest, sendtag, - recvbuf, recvcount, recvtype, source, recvtag, comm, status); - ignoreret = GPTLstop ("MPI_Sendrecv"); - if ((timer = GPTLgetentry ("MPI_Sendrecv"))) { - ignoreret = PMPI_Type_size (sendtype, &sendsize); - ignoreret = PMPI_Type_size (recvtype, &recvsize); - - timer->nbytes += ((double) recvcount * recvsize) + ((double) sendcount * sendsize); - } - return ret; -} - -int MPI_Isend (CONST void *buf, int count, MPI_Datatype datatype, int dest, int tag, - MPI_Comm comm, MPI_Request *request) -{ - int ret; - int ignoreret; - int size; - Timer *timer; - - ignoreret = GPTLstart ("MPI_Isend"); - ret = PMPI_Isend (buf, count, datatype, dest, tag, comm, request); - ignoreret = GPTLstop ("MPI_Isend"); - if ((timer = GPTLgetentry ("MPI_Isend"))) { - ignoreret = PMPI_Type_size (datatype, &size); - timer->nbytes += ((double) count) * size; - } - return ret; -} - -int MPI_Issend (CONST void *buf, int count, MPI_Datatype datatype, int dest, int tag, - MPI_Comm comm, MPI_Request *request) -{ - int ret; - int ignoreret; - int size; - Timer *timer; - - ignoreret = GPTLstart ("MPI_Issend"); - ret = PMPI_Issend (buf, count, datatype, dest, tag, comm, request); - ignoreret = GPTLstop ("MPI_Issend"); - if ((timer = GPTLgetentry ("MPI_Issend"))) { - ignoreret = PMPI_Type_size (datatype, &size); - timer->nbytes += ((double) count) * size; - } - return ret; -} - -int MPI_Irecv (void *buf, int count, MPI_Datatype datatype, int source, int tag, - MPI_Comm comm, MPI_Request *request) -{ - int ret; - int ignoreret; - int size; - Timer *timer; - - ignoreret = GPTLstart ("MPI_Irecv"); - ret = PMPI_Irecv (buf, count, datatype, source, tag, comm, request); - ignoreret = GPTLstop ("MPI_Irecv"); - if ((timer = GPTLgetentry ("MPI_Irecv"))) { - ignoreret = PMPI_Type_size (datatype, &size); - timer->nbytes += ((double) count) * size; - } - return ret; -} - -int MPI_Wait (MPI_Request *request, MPI_Status *status) -{ - int ret; - int ignoreret; - - ignoreret = GPTLstart ("MPI_Wait"); - ret = PMPI_Wait (request, status); - ignoreret = GPTLstop ("MPI_Wait"); - return ret; -} - -int MPI_Waitall(int count, - MPI_Request array_of_requests[], - MPI_Status array_of_statuses[]) -{ - int ret; - int ignoreret; - - ignoreret = GPTLstart ("MPI_Waitall"); - ret = PMPI_Waitall (count, array_of_requests, array_of_statuses); - ignoreret = GPTLstop ("MPI_Waitall"); - return ret; -} - -int MPI_Barrier (MPI_Comm comm) -{ - int ret; - int ignoreret; - - ignoreret = GPTLstart ("MPI_Barrier"); - ret = PMPI_Barrier (comm); - ignoreret = GPTLstop ("MPI_Barrier"); - return ret; -} - -int MPI_Bcast (void *buffer, int count, MPI_Datatype datatype, int root, - MPI_Comm comm ) -{ - int ret; - int ignoreret; - int size; - Timer *timer; - - if (sync_mpi) { - ignoreret = GPTLstart ("sync_Bcast"); - ignoreret = PMPI_Barrier (comm); - ignoreret = GPTLstop ("sync_Bcast"); - } - - ignoreret = GPTLstart ("MPI_Bcast"); - ret = PMPI_Bcast (buffer, count, datatype, root, comm); - ignoreret = GPTLstop ("MPI_Bcast"); - if ((timer = GPTLgetentry ("MPI_Bcast"))) { - ignoreret = PMPI_Type_size (datatype, &size); - timer->nbytes += ((double) count) * size; - } - return ret; -} - -int MPI_Allreduce (CONST void *sendbuf, void *recvbuf, int count, MPI_Datatype datatype, - MPI_Op op, MPI_Comm comm) -{ - int ret; - int ignoreret; - int size; - Timer *timer; - - if (sync_mpi) { - ignoreret = GPTLstart ("sync_Allreduce"); - ignoreret = PMPI_Barrier (comm); - ignoreret = GPTLstop ("sync_Allreduce"); - } - - ignoreret = GPTLstart ("MPI_Allreduce"); - ret = PMPI_Allreduce (sendbuf, recvbuf, count, datatype, op, comm); - ignoreret = GPTLstop ("MPI_Allreduce"); - if ((timer = GPTLgetentry ("MPI_Allreduce"))) { - ignoreret = PMPI_Type_size (datatype, &size); - /* Estimate size as 1 send plus 1 recv */ - timer->nbytes += 2.*((double) count) * size; - } - return ret; -} - -int MPI_Gather (CONST void *sendbuf, int sendcount, MPI_Datatype sendtype, - void *recvbuf, int recvcount, MPI_Datatype recvtype, - int root, MPI_Comm comm) -{ - int ret; - int iam; - int sendsize, recvsize; - int commsize; - int ignoreret; - Timer *timer; - - if (sync_mpi) { - ignoreret = GPTLstart ("sync_Gather"); - ignoreret = PMPI_Barrier (comm); - ignoreret = GPTLstop ("sync_Gather"); - } - - ignoreret = GPTLstart ("MPI_Gather"); - ret = PMPI_Gather (sendbuf, sendcount, sendtype, - recvbuf, recvcount, recvtype, root, comm); - ignoreret = GPTLstop ("MPI_Gather"); - - if ((timer = GPTLgetentry ("MPI_Gather"))) { - ignoreret = PMPI_Comm_rank (comm, &iam); - ignoreret = PMPI_Comm_size (comm, &commsize); - ignoreret = PMPI_Type_size (sendtype, &sendsize); - ignoreret = PMPI_Type_size (recvtype, &recvsize); - timer->nbytes += (double) sendcount * sendsize; - if (iam == root) { - timer->nbytes += (double) recvcount * recvsize * (commsize-1); - } - } - return ret; -} - -int MPI_Gatherv (CONST void *sendbuf, int sendcount, MPI_Datatype sendtype, - void *recvbuf, CONST int *recvcounts, CONST int *displs, - MPI_Datatype recvtype, int root, MPI_Comm comm ) -{ - int ret; - int iam; - int i; - int sendsize, recvsize; - int commsize; - int ignoreret; - Timer *timer; - - if (sync_mpi) { - ignoreret = GPTLstart ("sync_Gatherv"); - ignoreret = PMPI_Barrier (comm); - ignoreret = GPTLstop ("sync_Gatherv"); - } - - ignoreret = GPTLstart ("MPI_Gatherv"); - ret = PMPI_Gatherv (sendbuf, sendcount, sendtype, - recvbuf, recvcounts, displs, - recvtype, root, comm); - ignoreret = GPTLstop ("MPI_Gatherv"); - - if ((timer = GPTLgetentry ("MPI_Gatherv"))) { - ignoreret = PMPI_Comm_rank (comm, &iam); - ignoreret = PMPI_Comm_size (comm, &commsize); - ignoreret = PMPI_Type_size (sendtype, &sendsize); - ignoreret = PMPI_Type_size (recvtype, &recvsize); - if (iam == root) { - for (i = 0; i < commsize; ++i) - if (i != iam) - timer->nbytes += (double) recvcounts[i] * recvsize; - } else { - timer->nbytes += (double) sendcount * sendsize; - } - } - return ret; -} - -int MPI_Scatter (CONST void *sendbuf, int sendcount, MPI_Datatype sendtype, - void *recvbuf, int recvcount, MPI_Datatype recvtype, - int root, MPI_Comm comm) -{ - int ret; - int iam; - int sendsize, recvsize; - int ignoreret; - Timer *timer; - - if (sync_mpi) { - ignoreret = GPTLstart ("sync_Scatter"); - ignoreret = PMPI_Barrier (comm); - ignoreret = GPTLstop ("sync_Scatter"); - } - - ignoreret = GPTLstart ("MPI_Scatter"); - ret = PMPI_Scatter (sendbuf, sendcount, sendtype, - recvbuf, recvcount, recvtype, root, comm); - ignoreret = GPTLstop ("MPI_Scatter"); - if ((timer = GPTLgetentry ("MPI_Scatter"))) { - ignoreret = PMPI_Comm_rank (comm, &iam); - ignoreret = PMPI_Type_size (recvtype, &recvsize); - timer->nbytes += (double) recvcount * recvsize; - if (iam == root) { - ignoreret = PMPI_Type_size (sendtype, &sendsize); - timer->nbytes += (double) sendcount * sendsize; - } - } - return ret; -} - -int MPI_Alltoall (CONST void *sendbuf, int sendcount, MPI_Datatype sendtype, - void *recvbuf, int recvcount, MPI_Datatype recvtype, - MPI_Comm comm) -{ - int ret; - int sendsize, recvsize; - int commsize; - int ignoreret; - Timer *timer; - - if (sync_mpi) { - ignoreret = GPTLstart ("sync_Alltoall"); - ignoreret = PMPI_Barrier (comm); - ignoreret = GPTLstop ("sync_Alltoall"); - } - - ignoreret = GPTLstart ("MPI_Alltoall"); - ret = PMPI_Alltoall (sendbuf, sendcount, sendtype, - recvbuf, recvcount, recvtype, comm); - ignoreret = GPTLstop ("MPI_Alltoall"); - if ((timer = GPTLgetentry ("MPI_Alltoall"))) { - ignoreret = PMPI_Comm_size (comm, &commsize); - ignoreret = PMPI_Type_size (sendtype, &sendsize); - ignoreret = PMPI_Type_size (recvtype, &recvsize); - - timer->nbytes += ((double) sendcount * sendsize * (commsize-1)) + - ((double) recvcount * recvsize * (commsize-1)); - } - return ret; -} - -int MPI_Reduce (CONST void *sendbuf, void *recvbuf, int count, MPI_Datatype datatype, - MPI_Op op, int root, MPI_Comm comm ) -{ - int ret; - int size; - int ignoreret; - Timer *timer; - - if (sync_mpi) { - ignoreret = GPTLstart ("sync_Reduce"); - ignoreret = PMPI_Barrier (comm); - ignoreret = GPTLstop ("sync_Reduce"); - } - - ignoreret = GPTLstart ("MPI_Reduce"); - ret = PMPI_Reduce (sendbuf, recvbuf, count, datatype, op, root, comm); - ignoreret = GPTLstop ("MPI_Reduce"); - if ((timer = GPTLgetentry ("MPI_Reduce"))) { - ignoreret = PMPI_Type_size (datatype, &size); - /* Estimate byte count as 1 send */ - timer->nbytes += ((double) count) * size; - } - return ret; -} - -/* -** Additions to MPI_Finalize: Stop the timer started in MPI_Init, and -** call GPTLpr() if it hasn't already been called. -*/ -int MPI_Finalize (void) -{ - int ret, ignoreret; - int iam; - - ignoreret = GPTLstop ("MPI_Init_thru_Finalize"); - - if ( ! GPTLpr_has_been_called ()) { - PMPI_Comm_rank (MPI_COMM_WORLD, &iam); - ignoreret = GPTLpr (iam); - } - /* Since we're in MPI_Finalize it's safe to call GPTLpr_summary for MPI_COMM_WORLD */ - ignoreret = GPTLpr_summary (MPI_COMM_WORLD); - - ret = PMPI_Finalize(); - return ret; -} - -int MPI_Allgather (CONST void *sendbuf, int sendcount, MPI_Datatype sendtype, - void *recvbuf, int recvcount, MPI_Datatype recvtype, - MPI_Comm comm) -{ - int ret; - int sendsize, recvsize; - int commsize; - int ignoreret; - Timer *timer; - - if (sync_mpi) { - ignoreret = GPTLstart ("sync_Allgather"); - ignoreret = PMPI_Barrier (comm); - ignoreret = GPTLstop ("sync_Allgather"); - } - - ignoreret = GPTLstart ("MPI_Allgather"); - ret = PMPI_Allgather (sendbuf, sendcount, sendtype, - recvbuf, recvcount, recvtype, comm); - ignoreret = GPTLstop ("MPI_Allgather"); - - if ((timer = GPTLgetentry ("MPI_Allgather"))) { - ignoreret = PMPI_Comm_size (comm, &commsize); - ignoreret = PMPI_Type_size (sendtype, &sendsize); - ignoreret = PMPI_Type_size (recvtype, &recvsize); - timer->nbytes += (double) sendcount * sendsize * (commsize-1)+ - (double) recvcount * recvsize * (commsize-1); - } - return ret; -} - -int MPI_Allgatherv (CONST void *sendbuf, int sendcount, MPI_Datatype sendtype, - void *recvbuf, CONST int *recvcounts, CONST int *displs, - MPI_Datatype recvtype, MPI_Comm comm ) -{ - int ret; - int iam; - int i; - int sendsize, recvsize; - int commsize; - int ignoreret; - Timer *timer; - - if (sync_mpi) { - ignoreret = GPTLstart ("sync_Allgatherv"); - ignoreret = PMPI_Barrier (comm); - ignoreret = GPTLstop ("sync_Allgatherv"); - } - - ignoreret = GPTLstart ("MPI_Allgatherv"); - ret = PMPI_Allgatherv (sendbuf, sendcount, sendtype, - recvbuf, recvcounts, displs, - recvtype, comm); - ignoreret = GPTLstop ("MPI_Allgatherv"); - - if ((timer = GPTLgetentry ("MPI_Allgatherv"))) { - ignoreret = PMPI_Comm_rank (comm, &iam); - ignoreret = PMPI_Comm_size (comm, &commsize); - ignoreret = PMPI_Type_size (sendtype, &sendsize); - ignoreret = PMPI_Type_size (recvtype, &recvsize); - timer->nbytes += (double) sendcount * sendsize * (commsize-1); - for (i = 0; i < commsize; ++i) - if (i != iam) - timer->nbytes += (double) recvcounts[i] * recvsize; - } - return ret; -} - -int MPI_Iprobe (int source, int tag, MPI_Comm comm, int *flag, - MPI_Status *status) -{ - int ret; - int ignoreret; - - ignoreret = GPTLstart ("MPI_Iprobe"); - ret = PMPI_Iprobe (source, tag, comm, flag, status); - ignoreret = GPTLstop ("MPI_Iprobe"); - return ret; -} - -int MPI_Probe (int source, int tag, MPI_Comm comm, MPI_Status *status) -{ - int ret; - int ignoreret; - - ignoreret = GPTLstart ("MPI_Probe"); - ret = PMPI_Probe (source, tag, comm, status); - ignoreret = GPTLstop ("MPI_Probe"); - return ret; -} - -int MPI_Ssend (CONST void *buf, int count, MPI_Datatype datatype, - int dest, int tag, MPI_Comm comm) -{ - int ret; - int ignoreret; - int size; - Timer *timer; - - ignoreret = GPTLstart ("MPI_Ssend"); - ret = PMPI_Ssend (buf, count, datatype, dest, tag, comm); - ignoreret = GPTLstop ("MPI_Ssend"); - if ((timer = GPTLgetentry ("MPI_Ssend"))) { - ignoreret = PMPI_Type_size (datatype, &size); - timer->nbytes += ((double) count) * size; - } - return ret; -} - -int MPI_Alltoallv (CONST void *sendbuf, CONST int *sendcounts, CONST int *sdispls, - MPI_Datatype sendtype, void *recvbuf, CONST int *recvcounts, - CONST int *rdispls, MPI_Datatype recvtype, MPI_Comm comm) -{ - int ret; - int iam; - int i; - int sendsize, recvsize; - int commsize; - int ignoreret; - Timer *timer; - - if (sync_mpi) { - ignoreret = GPTLstart ("sync_Alltoallv"); - ignoreret = PMPI_Barrier (comm); - ignoreret = GPTLstop ("sync_Alltoallv"); - } - - ignoreret = GPTLstart ("MPI_Alltoallv"); - ret = PMPI_Alltoallv (sendbuf, sendcounts, sdispls, - sendtype, recvbuf, recvcounts, - rdispls, recvtype, comm); - - ignoreret = GPTLstop ("MPI_Alltoallv"); - if ((timer = GPTLgetentry ("MPI_Alltoallv"))) { - ignoreret = PMPI_Comm_rank (comm, &iam); - ignoreret = PMPI_Comm_size (comm, &commsize); - ignoreret = PMPI_Type_size (sendtype, &sendsize); - ignoreret = PMPI_Type_size (recvtype, &recvsize); - for (i = 0; i < commsize; ++i) { - if (i != iam) { - timer->nbytes += (double) sendcounts[i] * sendsize; - timer->nbytes += (double) recvcounts[i] * recvsize; - } - } - } - return ret; -} - -int MPI_Scatterv (CONST void *sendbuf, CONST int *sendcounts, CONST int *displs, - MPI_Datatype sendtype, void *recvbuf, int recvcount, - MPI_Datatype recvtype, int root, MPI_Comm comm) -{ - int ret; - int iam; - int i; - int sendsize, recvsize; - int commsize; - int ignoreret; - Timer *timer; - - if (sync_mpi) { - ignoreret = GPTLstart ("sync_Scatterv"); - ignoreret = PMPI_Barrier (comm); - ignoreret = GPTLstop ("sync_Scatterv"); - } - - ignoreret = GPTLstart ("MPI_Scatterv"); - ret = PMPI_Scatterv (sendbuf, sendcounts, displs, - sendtype, recvbuf, recvcount, - recvtype, root, comm); - ignoreret = GPTLstop ("MPI_Scatterv"); - if ((timer = GPTLgetentry ("MPI_Scatterv"))) { - ignoreret = PMPI_Comm_rank (comm, &iam); - ignoreret = PMPI_Comm_size (comm, &commsize); - ignoreret = PMPI_Type_size (sendtype, &sendsize); - ignoreret = PMPI_Type_size (recvtype, &recvsize); - timer->nbytes += (double) recvcount * recvsize; - if (iam == root) { - for (i = 0; i < commsize; ++i) - if (i != iam) - timer->nbytes += (double) sendcounts[i] * sendsize; - } else { - timer->nbytes += (double) recvcount * recvsize; - } - } - return ret; -} - -int MPI_Test (MPI_Request *request, int *flag, MPI_Status *status) -{ - int ret; - int ignoreret; - - ignoreret = GPTLstart ("MPI_Test"); - ret = PMPI_Test (request, flag, status); - ignoreret = GPTLstop ("MPI_Test"); - return ret; -} - -#else /* ENABLE_PMPI not set */ - -int GPTLpmpi_setoption (const int option, - const int val) -{ - return GPTLerror ("GPTLpmpi_setoption: GPTL needs to be built with ENABLE_PMPI=yes " - "to set option %d\n", option); -} - -#endif diff --git a/cesm/models/utils/timing/gptl/pr_summary.c b/cesm/models/utils/timing/gptl/pr_summary.c deleted file mode 100644 index a70e2d9..0000000 --- a/cesm/models/utils/timing/gptl/pr_summary.c +++ /dev/null @@ -1,584 +0,0 @@ -#include -#include -#include -#include /* sqrt */ - -#include "private.h" -#include "gptl.h" - -/* MPI summary stats */ -typedef struct { - unsigned long totcalls; /* number of calls to the region across threads and tasks */ -#ifdef HAVE_PAPI - double papimax[MAX_AUX]; /* max counter value across threads, tasks */ - double papimin[MAX_AUX]; /* max counter value across threads, tasks */ - int papimax_p[MAX_AUX]; /* task producing papimax */ - int papimax_t[MAX_AUX]; /* thread producing papimax */ - int papimin_p[MAX_AUX]; /* task producing papimin */ - int papimin_t[MAX_AUX]; /* thread producing papimin */ -#endif - unsigned int notstopped; /* number of ranks+threads for whom the timer is ON */ - unsigned int tottsk; /* number of tasks which invoked this region */ - float wallmax; /* max time across threads, tasks */ - float wallmin; /* min time across threads, tasks */ - float mean; /* accumulated mean */ - float m2; /* from Chan, et. al. */ - int wallmax_p; /* task producing wallmax */ - int wallmax_t; /* thread producing wallmax */ - int wallmin_p; /* task producing wallmin */ - int wallmin_t; /* thread producing wallmin */ - char name[MAX_CHARS+1]; /* timer name */ -} Global; - -static void get_threadstats (int, char *, Timer **, Global *); -static Timer *getentry_slowway (Timer *, char *); -static int nthreads; /* Used by both GPTLpr_summary() and get_threadstats() */ - -/* -** GPTLpr_summary_file: Subsumes what used to be GPTLpr_summary() into a new routine -** which takes additional argument "outfile". GPTLpr_summary() is -** now simply a wrapper routine which calls GPTLpr_summary_file() -** with outfile="timing.summary", so NO CHANGE TO PREVIOUS API. -** Thanks to Jim Edwards of NCAR for the modification. -** -** When MPI enabled, gather and print summary stats across threads -** and MPI tasks. The communication algorithm is O(log nranks) so -** it easily scales to thousands of ranks. Added local memory usage -** is 2*(number_of_regions)*sizeof(Global) on each rank. -** -** Input arguments: -** comm: communicator (e.g. MPI_COMM_WORLD). If zero, use MPI_COMM_WORLD -** outfile: name of file to be written -*/ - -#ifdef HAVE_MPI -#include -int GPTLpr_summary_file (MPI_Comm comm, const char *outfile) /* communicator */ -{ - int ret; /* return code */ - int iam; /* my rank */ - int nranks; /* number of ranks in communicator */ - int nregions; /* number of regions aggregated across all tasks */ - int nregions_p; /* number of regions for a single task */ - int n, nn; /* region index */ - int i; /* index */ - Timer *ptr; /* linked list pointer */ - Timer **timers; - int incr; /* increment for tree sum */ - int twoincr; /* 2*incr */ - int dosend; /* logical indicating whether to send this iteration */ - int dorecv; /* logical indicating whether to recv this iteration */ - int sendto; /* rank to send to */ - int p; /* rank to recv fm */ - int mnl; /* max name length across all threads and tasks */ - MPI_Status status; /* required by MPI_Recv */ - int extraspace; /* for padding to length of longest name */ - int multithread; /* flag indicates multithreaded or not for any task */ - int multithread_p; /* recvd flag for other processor indicates multithreaded or not */ - Global *global; /* stats to be printed accumulated across tasks */ - Global *global_p; /* stats to be printed for a single task */ - Global *sptr; /* realloc intermediate */ - float delta; /* from Chan, et. al. */ - float sigma; /* st. dev. */ - unsigned int tsksum; /* part of Chan, et. al. equation */ - static const int tag = 98789; /* tag for MPI message */ - static const int nbytes = sizeof (Global); /* number of bytes to be sent/recvd */ - static const char *thisfunc = "GPTLpr_summary_file"; /* this function */ - FILE *fp = 0; /* file handle to write to */ -#ifdef HAVE_PAPI - int e; /* event index */ -#endif - - if ( ! GPTLis_initialized ()) - return GPTLerror ("%s: GPTLinitialize() has not been called\n", thisfunc); - - if (((int) comm) == 0) - comm = MPI_COMM_WORLD; - - if ((ret = MPI_Comm_rank (comm, &iam)) != MPI_SUCCESS) - return GPTLerror ("%s: Bad return from MPI_Comm_rank=%d\n", thisfunc, ret); - - if ((ret = MPI_Comm_size (comm, &nranks)) != MPI_SUCCESS) - return GPTLerror ("%s rank %d: Bad return from MPI_Comm_size=%d\n", thisfunc, iam, ret); - - /* Examine only thread 0 regions */ - ret = GPTLget_nregions (0, &nregions); - if (nregions < 1) - GPTLwarn ("%s rank %d: nregions = 0\n", thisfunc, iam); - global = (Global *) GPTLallocate (nregions * sizeof (Global), thisfunc); - - /* - ** Gather per-thread stats based on thread 0 list. - ** Also discover length of longest region name for formatting - */ - n = 0; - mnl = 0; - timers = GPTLget_timersaddr (); - nthreads = GPTLget_nthreads (); /* get_threadstats() needs to know this value too */ - multithread = (nthreads > 1); - - for (ptr = timers[0]->next; ptr; ptr = ptr->next) { - get_threadstats (iam, ptr->name, timers, &global[n]); - mnl = MAX (strlen (ptr->name), mnl); - - /* Initialize for calculating mean, st. dev. */ - global[n].mean = global[n].wallmax; - global[n].m2 = 0.; - global[n].tottsk = 1; - ++n; - } - if (n != nregions) - GPTLwarn ("%s rank %d: Bad logic caused n=%d and nregions=%d\n", thisfunc, iam, n, nregions); - - /* - ** If all ranks participate in a region, could use MPI_Reduce to get mean and variance. - ** But we can't assume that, so instead code the parallel algorithm by hand. - ** Log(ntask) algorithm to gather results to a single task is Jim Rosinski's concoction. - ** One-pass algorithm for gathering mean and standard deviation comes from Chan et. al. - ** (1979) described in: http://en.wikipedia.org/wiki/Algorithms_for_calculating_variance - ** Discovered by googling for "one pass standard deviation" which found the Wikipedia - ** page pointing to the Chan et. al. work. I'm not enough of a statistical whiz to - ** be able to map the simple 3-line algorithm in the Wikipedia page (see "Parallel - ** algorithm") to anything in the Chan et. al. work, but it does work. - */ - for (incr = 1; incr < nranks; incr = twoincr) { - twoincr = 2*incr; - sendto = iam - incr; - p = iam + incr; /* could rename p as recvfm */ - - /* - ** The && part of the next 2 stmts prevents sending to or receiving from - ** outside communicator bounds when nranks is not a power of 2 - */ - dorecv = ((iam + twoincr) % twoincr == 0) && (p < nranks); - dosend = ((iam + incr) % twoincr == 0) && (sendto > -1); - if (dosend) { - if (dorecv) - printf ("%s: WARNING: iam=%d: dosend and dorecv both true: possible hang?\n", thisfunc, iam); - - if ((ret = MPI_Send (&nregions, 1, MPI_INT, sendto, tag, comm)) != MPI_SUCCESS) - return GPTLerror ("%s rank %d: Bad return from MPI_Send=%d\n", thisfunc, iam, ret); - if ((ret = MPI_Send (&multithread, 1, MPI_INT, sendto, tag, comm)) != MPI_SUCCESS) - return GPTLerror ("%s rank %d: Bad return from MPI_Send=%d\n", thisfunc, iam, ret); - if ((ret = MPI_Send (global, nbytes*nregions, MPI_BYTE, sendto, tag, comm)) != MPI_SUCCESS) - return GPTLerror ("%s rank %d: Bad return from MPI_Send=%d\n", thisfunc, iam, ret); - } - - if (dorecv) { - if (dosend) - printf ("%s: WARNING: iam=%d: dosend and dorecv both true: possible hang?\n", thisfunc, iam); - - if ((ret = MPI_Recv (&nregions_p, 1, MPI_INT, p, tag, comm, &status)) != MPI_SUCCESS) - return GPTLerror ("%s rank %d: Bad return from MPI_Recv=%d\n", thisfunc, iam, ret); - if ((ret = MPI_Recv (&multithread_p, 1, MPI_INT, p, tag, comm, &status)) != MPI_SUCCESS) - return GPTLerror ("%s rank %d: Bad return from MPI_Recv=%d\n", thisfunc, iam, ret); - if (multithread_p) - multithread = true; - - global_p = (Global *) GPTLallocate (nregions_p * sizeof (Global), thisfunc); - ret = MPI_Recv (global_p, nbytes*nregions_p, MPI_BYTE, p, tag, comm, &status); - if (ret != MPI_SUCCESS) - return GPTLerror ("%s rank %d: Bad return from MPI_Recv=%d\n", thisfunc, iam, ret); - - /* Merge stats for task p with our current stats */ - for (n = 0; n < nregions_p; ++n) { - for (nn = 0; nn < nregions; ++nn) { - if (STRMATCH (global_p[n].name, global[nn].name)) { - break; - } - } - - if (nn == nregions) { /* new region: reallocate and copy stats */ - ++nregions; - sptr = realloc (global, nregions * sizeof (Global)); - if ( ! sptr) - return GPTLerror ("%s: realloc error", thisfunc); - global = sptr; - /* IMPORTANT: structure copy only works because it contains NO pointers (only arrays) */ - global[nn] = global_p[n]; - mnl = MAX (strlen (global[nn].name), mnl); - - } else { /* adjust stats for region */ - - /* Won't print this entry if it was on for any rank or thread */ - global[nn].notstopped += global_p[n].notstopped; - global[nn].totcalls += global_p[n].totcalls; /* count is cumulative */ - if (global_p[n].wallmax > global[nn].wallmax) { - global[nn].wallmax = global_p[n].wallmax; - global[nn].wallmax_p = global_p[n].wallmax_p; - global[nn].wallmax_t = global_p[n].wallmax_t; - } - if (global_p[n].wallmin < global[nn].wallmin) { - global[nn].wallmin = global_p[n].wallmin; - global[nn].wallmin_p = global_p[n].wallmin_p; - global[nn].wallmin_t = global_p[n].wallmin_t; - } - - /* Mean, variance calcs. Cast to float avoids possible integer overflow */ - tsksum = global_p[n].tottsk + global[nn].tottsk; - delta = global_p[n].mean - global[nn].mean; - global[nn].mean += (delta * global_p[n].tottsk) / tsksum; - global[nn].m2 += global_p[n].m2 + - delta * delta * ((float) global_p[n].tottsk * global[nn].tottsk) / tsksum; - global[nn].tottsk = tsksum; - -#ifdef HAVE_PAPI - for (e = 0; e < GPTLnevents; ++e) { - if (global_p[n].papimax[e] > global[nn].papimax[e]) { - global[nn].papimax[e] = global_p[n].papimax[e]; - global[nn].papimax_p[e] = p; - global[nn].papimax_t[e] = global_p[n].papimax_t[e]; - } - if (global_p[n].papimin[e] < global[nn].papimin[e]) { - global[nn].papimin[e] = global_p[n].papimin[e]; - global[nn].papimin_p[e] = p; - global[nn].papimin_t[e] = global_p[n].papimin_t[e]; - } - } -#endif - } - } - free (global_p); /* done with received data this iteration */ - } - } - - if (iam == 0) { - if ( ! (fp = fopen (outfile, "w"))) { - fp = stderr; - printf ("%s: WARNING: file=%s cannot be opened for writing. Using stderr instead\n", - thisfunc, outfile); - } - - /* Print a warning if GPTLerror() was ever called */ - if (GPTLnum_errors () > 0) { - fprintf (fp, "WARNING: GPTLerror was called at least once during the run.\n"); - fprintf (fp, "Please examine your output for error messages beginning with GPTL...\n"); - } - - /* Print heading */ - fprintf (fp, "Total ranks in communicator=%d\n", nranks); - fprintf (fp, "nthreads on rank 0=%d\n", nthreads); - fprintf (fp, "'N' used for mean, std. dev. calcs.: 'ncalls'/'nthreads'\n"); - fprintf (fp, "'ncalls': number of times the region was invoked across tasks and threads.\n"); - fprintf (fp, "'nranks': number of ranks which invoked the region.\n"); - fprintf (fp, "mean, std. dev: computed using per-rank max time across all threads on each rank\n"); - fprintf (fp, "wallmax and wallmin: max, min time across tasks and threads.\n"); - - fprintf (fp, "\nname"); - extraspace = mnl - strlen ("name"); - for (n = 0; n < extraspace; ++n) - fprintf (fp, " "); - fprintf (fp, " ncalls nranks mean_time std_dev wallmax (rank "); - if (multithread) - fprintf (fp, "thread"); - fprintf (fp, ") wallmin (rank "); - if (multithread) - fprintf (fp, "thread"); - fprintf (fp, ")"); - -#ifdef HAVE_PAPI - for (e = 0; e < GPTLnevents; ++e) { - fprintf (fp, " %8.8smax (rank ", GPTLeventlist[e].str8); - if (multithread) - fprintf (fp, "thread"); - fprintf (fp, ")"); - - fprintf (fp, " %8.8smin (rank ", GPTLeventlist[e].str8); - if (multithread) - fprintf (fp, "thread"); - fprintf (fp, ")"); - } -#endif - fprintf (fp, "\n"); - - /* Loop over regions and print summarized timing stats */ - for (n = 0; n < nregions; ++n) { - fprintf (fp, "%s", global[n].name); - extraspace = mnl - strlen (global[n].name); - - for (i = 0; i < extraspace; ++i) - fprintf (fp, " "); - - /* - ** Don't print stats if the timer is currently on for any thread or task: too dangerous - ** since the timer needs to be stopped to have currently accurate timings - */ - if (global[n].notstopped > 0) { - fprintf (fp, " NOT PRINTED: timer is currently ON for %d threads\n", - global[n].notstopped); - continue; - } - - if (global[n].tottsk > 1) - sigma = sqrt ((double) global[n].m2 / (global[n].tottsk - 1)); - else - sigma = 0.; - - if (multithread) { /* Threads and tasks */ - if (global[n].totcalls < PRTHRESH) { - fprintf (fp, " %8lu %6u %9.3f %9.3f %9.3f (%6d %5d) %9.3f (%6d %5d)", - global[n].totcalls, global[n].tottsk, global[n].mean, sigma, - global[n].wallmax, global[n].wallmax_p, global[n].wallmax_t, - global[n].wallmin, global[n].wallmin_p, global[n].wallmin_t); - } else { - fprintf (fp, " %8.1e %6u %9.3f %9.3f %9.3f (%6d %5d) %9.3f (%6d %5d)", - (float) global[n].totcalls, global[n].tottsk, global[n].mean, sigma, - global[n].wallmax, global[n].wallmax_p, global[n].wallmax_t, - global[n].wallmin, global[n].wallmin_p, global[n].wallmin_t); - } - } else { /* No threads */ - if (global[n].totcalls < PRTHRESH) { - fprintf (fp, " %8lu %6u %9.3f %9.3f %9.3f (%6d) %9.3f (%6d)", - global[n].totcalls, global[n].tottsk, global[n].mean, sigma, - global[n].wallmax, global[n].wallmax_p, - global[n].wallmin, global[n].wallmin_p); - } else { - fprintf (fp, " %8.1e %6u %9.3f %9.3f %9.3f (%6d) %9.3f (%6d)", - (float) global[n].totcalls, global[n].tottsk, global[n].mean, sigma, - global[n].wallmax, global[n].wallmax_p, - global[n].wallmin, global[n].wallmin_p); - } - } - -#ifdef HAVE_PAPI - for (e = 0; e < GPTLnevents; ++e) { - if (multithread) - fprintf (fp, " %8.2e (%6d %5d)", - global[n].papimax[e], global[n].papimax_p[e], - global[n].papimax_t[e]); - else - fprintf (fp, " %8.2e (%6d)", - global[n].papimax[e], global[n].papimax_p[e]); - - if (multithread) - fprintf (fp, " %8.2e (%6d %5d)", - global[n].papimin[e], global[n].papimin_p[e], - global[n].papimin_t[e]); - else - fprintf (fp, " %8.2e (%6d)", - global[n].papimin[e], global[n].papimin_p[e]); - } -#endif - fprintf (fp, "\n"); - } - if (fp != stderr && fclose (fp) != 0) - fprintf (stderr, "Attempt to close %s failed\n", outfile); - } - free (global); - return 0; -} - -int GPTLpr_summary (MPI_Comm comm) /* communicator */ -{ - static const char *outfile = "timing.summary"; /* file to write to */ - - return GPTLpr_summary_file (comm, outfile); -} - -#else - -/* No MPI. Mimic MPI version but for only one rank */ -int GPTLpr_summary_file (const char *outfile) -{ - FILE *fp = 0; /* file handle */ - Timer **timers; - int multithread; /* flag indicates multithreaded or not */ - int mnl; /* max name length across all threads */ - int extraspace; /* for padding to length of longest name */ - int n; -#ifdef HAVE_PAPI - int e; /* event index */ -#endif - Global global; /* stats to be printed */ - Timer *ptr; - static const char *thisfunc = "GPTLpr_summary_file"; /* this function */ - - if ( ! GPTLis_initialized ()) - return GPTLerror ("%s: GPTLinitialize() has not been called\n", thisfunc); - - nthreads = GPTLget_nthreads (); /* get_threadstats() needs to know this value too */ - multithread = (nthreads > 1); - - if ( ! (fp = fopen (outfile, "w"))) { - fp = stderr; - printf ("%s: WARNING: file=%s cannot be opened for writing. Using stderr instead\n", - thisfunc, outfile); - } - - /* Print heading */ - fprintf (fp, "GPTLpr_summary: GPTL was built W/O MPI\n"); - fprintf (fp, "CAUTION: Calling with multiple MPI tasks will not produce the behavior you want.\n"); - fprintf (fp, "This is because all invoking tasks will write to the same file in a race condition.\n"); - fprintf (fp, "nthreads=%d\n", nthreads); - fprintf (fp, "'ncalls': number of times the region was invoked across threads.\n"); - - fprintf (fp, "\nname"); - - mnl = 0; - timers = GPTLget_timersaddr (); - for (ptr = timers[0]->next; ptr; ptr = ptr->next) - mnl = MAX (strlen (ptr->name), mnl); - - extraspace = mnl - strlen ("name"); - for (n = 0; n < extraspace; ++n) - fprintf (fp, " "); - - if (multithread) - fprintf (fp, " ncalls wallmax (thred) wallmin (thred)"); - else - fprintf (fp, " ncalls walltim"); - -#ifdef HAVE_PAPI - for (e = 0; e < GPTLnevents; ++e) { - if (multithread) - fprintf (fp, " %8.8smax (thred) %8.8smin (thred)", GPTLeventlist[e].str8, GPTLeventlist[e].str8); - else - fprintf (fp, " %8.8s", GPTLeventlist[e].str8); - } -#endif - fprintf (fp, "\n"); - - for (ptr = timers[0]->next; ptr; ptr = ptr->next) { - get_threadstats (0, ptr->name, timers, &global); - extraspace = mnl - strlen (global.name); - - fprintf (fp, "%s", global.name); - for (n = 0; n < extraspace; ++n) - fprintf (fp, " "); - - /* - ** Don't print stats if the timer is currently on for any thread or task: too dangerous - ** since the timer needs to be stopped to have currently accurate timings - */ - if (global.notstopped > 0) { - fprintf (fp, " NOT PRINTED: timer is currently ON for %d threads\n", global.notstopped); - continue; - } - - if (multithread) { - if (global.totcalls < PRTHRESH) { - fprintf (fp, " %8lu %9.3f (%5d) %9.3f (%5d)", - global.totcalls, global.wallmax, global.wallmax_t, global.wallmin, global.wallmin_t); - } else { - fprintf (fp, " %8.1e %9.3f (%5d) %9.3f (%5d)", - (float) global.totcalls, global.wallmax, global.wallmax_t, global.wallmin, global.wallmin_t); - } - } else { /* No threads */ - if (global.totcalls < PRTHRESH) { - fprintf (fp, " %8lu %9.3f", global.totcalls, global.wallmax); - } else { - fprintf (fp, " %8.1e %9.3f", (float) global.totcalls, global.wallmax); - } - } -#ifdef HAVE_PAPI - for (e = 0; e < GPTLnevents; ++e) { - if (multithread) - fprintf (fp, " %8.2e (%5d)", global.papimax[e], global.papimax_t[e]); - else - fprintf (fp, " %8.2e", global.papimax[e]); - - if (multithread) - fprintf (fp, " %8.2e (%5d)", global.papimin[e], global.papimin_t[e]); - } -#endif - fprintf (fp, "\n"); - } - if (fp != stderr && fclose (fp) != 0) - fprintf (stderr, "Attempt to close %s failed\n", outfile); - - return 0; -} - -int GPTLpr_summary () /* communicator */ -{ - static const char *outfile = "timing.summary"; /* file to write to */ - - return GPTLpr_summary_file (outfile); -} - -#endif /* False branch of HAVE_MPI */ - - - -/* -** get_threadstats: gather stats for timer "name" over all threads -** -** Input arguments: -** iam: my rank -** name: timer name -** timers: array of linked lists of timers -** global: pointer to struct containing stats -** Output arguments: -** global: max/min stats over all threads -*/ -static void get_threadstats (int iam, - char *name, - Timer **timers, - Global *global) -{ - int t; /* thread index */ - Timer *ptr; - static const char *thisfunc = "get_threadstats"; - - /* This memset fortuitiously initializes the process values to master (0) */ - memset (global, 0, sizeof (Global)); - strcpy (global->name, name); - - for (t = 0; t < nthreads; ++t) { - if ((ptr = getentry_slowway (timers[t]->next, name))) { - /* Won't print this entry if it was on for any rank or thread */ - if (ptr->onflg) - ++global->notstopped; - - global->totcalls += ptr->count; - - if (ptr->wall.accum > global->wallmax) { - global->wallmax = ptr->wall.accum; - global->wallmax_p = iam; - global->wallmax_t = t; - } - - /* global->wallmin = 0 for first thread */ - if (ptr->wall.accum < global->wallmin || global->wallmin == 0.) { - global->wallmin = ptr->wall.accum; - global->wallmin_p = iam; - global->wallmin_t = t; - } -#ifdef HAVE_PAPI - int e; - for (e = 0; e < GPTLnevents; ++e) { - double value; - if (GPTL_PAPIget_eventvalue (GPTLeventlist[e].namestr, &ptr->aux, &value) != 0) { - fprintf (stderr, "GPTL: %s: Bad return from GPTL_PAPIget_eventvalue\n", thisfunc); - return; - } - if (value > global->papimax[e]) { - global->papimax[e] = value; - global->papimax_p[e] = iam; - global->papimax_t[e] = t; - } - - /* First thread value in global is zero */ - if (value < global->papimin[e] || global->papimin[e] == 0.) { - global->papimin[e] = value; - global->papimin_p[e] = iam; - global->papimin_t[e] = t; - } - } -#endif - } - } -} - -Timer *getentry_slowway (Timer *timer, char *name) -{ - Timer *ptr = 0; - - for (; timer; timer = timer->next) { - if (STRMATCH (name, timer->name)) { - ptr = timer; - break; - } - } - return ptr; -} diff --git a/cesm/models/utils/timing/gptl/print_memusage.c b/cesm/models/utils/timing/gptl/print_memusage.c deleted file mode 100644 index de8c4f6..0000000 --- a/cesm/models/utils/timing/gptl/print_memusage.c +++ /dev/null @@ -1,64 +0,0 @@ -/* -** print_memusage.c -** -** Author: Jim Rosinski -** -** print_memusage: -** -** Prints info about memory usage of this process by calling get_memusage. -** -** Return value: 0 = success -** -1 = failure -*/ - -#include "gptl.h" -#include -#include -#include -#include - -int GPTLprint_memusage (const char *str) -{ - int size; /* process size (returned from OS) */ - int rss; /* resident set size (returned from OS) */ - int share; /* shared data segment size (returned from OS) */ - int text; /* text segment size (returned from OS) */ - int datastack; /* data/stack size (returned from OS) */ - static int pagesize = -1; /* convert to bytes (init to invalid) */ - static double pagestomb = -1; /* convert pages to MB */ - static const char *thisfunc = "GPTLprint_memusage"; - - if (GPTLget_memusage (&size, &rss, &share, &text, &datastack) < 0) - return -1; - -#if (defined HAVE_SLASHPROC || defined __APPLE__) - - if (pagesize == -1) - if ((pagesize = sysconf (_SC_PAGESIZE)) > 0) { - pagestomb = pagesize / (1024.*1024.); - printf ("%s: Using pagesize=%d\n", thisfunc, pagesize); - } - - if (pagestomb > 0) - printf ("%s: %s size=%.1f MB rss=%.1f MB datastack=%.1f MB\n", - thisfunc, str, size*pagestomb, rss*pagestomb, datastack*pagestomb); - else - printf ("%s: %s size=%d rss=%d datastack=%d\n", - thisfunc, str, size, rss, datastack); - -#else - - /* - ** Use max rss as returned by getrusage. If someone knows how to - ** get the process size under AIX please tell me. - */ - pagesize = 1024; - pagestomb = pagesize / (1024.*1024.); - if (1) /* change to 0 if cannot convert to MB */ - printf ("%s: %s max rss=%.1f MB\n", thisfunc, str, rss*pagestomb); - else - printf ("%s: %s max rss=%d\n", thisfunc, str, rss); -#endif - - return 0; -} diff --git a/cesm/models/utils/timing/gptl/print_rusage.c b/cesm/models/utils/timing/gptl/print_rusage.c deleted file mode 100644 index f309f6a..0000000 --- a/cesm/models/utils/timing/gptl/print_rusage.c +++ /dev/null @@ -1,35 +0,0 @@ -/* -** print_rusage.c -** -** Author: Jim Rosinski -** -** print_rusage: -** -** Prints info from getrusage() -** -** Return value: 0 = success -** -1 = failure -*/ - -#include "private.h" -#include -#include -#include - -int GPTLprint_rusage (const char *str) -{ - struct rusage usage; - static const char *thisfunc = "GPTLprint_rusage"; - static const float onek = 1042.; - - if (getrusage (RUSAGE_SELF, &usage) < 0) - return GPTLerror ("%s: failure from getrusage()\n", thisfunc); - - /* ru_maxrss is in KB */ - printf ("%s ru_maxrss=%.1f MB ru_minflt=%.1f K ru_majflt=%.1f K ru_nvcsw=%.1f K\n", str, - usage.ru_maxrss/onek, - usage.ru_minflt/onek, - usage.ru_majflt/onek, - usage.ru_nvcsw/onek); - return 0; -} diff --git a/cesm/models/utils/timing/gptl/printmpistatussize.F90 b/cesm/models/utils/timing/gptl/printmpistatussize.F90 deleted file mode 100644 index 2ab62db..0000000 --- a/cesm/models/utils/timing/gptl/printmpistatussize.F90 +++ /dev/null @@ -1,11 +0,0 @@ -program printmpistatussize -#ifdef HAVE_MPI - use mpi -#endif - implicit none -#ifdef HAVE_MPI - write(6,*) 'MPI_STATUS_SIZE=', MPI_STATUS_SIZE -#else - write(6,*) 'Need set HAVE_MPI=yes to get MPI_STATUS_SIZE' -#endif -end program printmpistatussize diff --git a/cesm/models/utils/timing/gptl/private.h b/cesm/models/utils/timing/gptl/private.h deleted file mode 100644 index 3eaf0f7..0000000 --- a/cesm/models/utils/timing/gptl/private.h +++ /dev/null @@ -1,185 +0,0 @@ -/* -** $Id: private.h,v 1.74 2011-03-28 20:55:19 rosinski Exp $ -** -** Author: Jim Rosinski -** -** Contains definitions private to GPTL and inaccessible to invoking user environment -*/ - -#include -#include - -#ifndef MIN -#define MIN(X,Y) ((X) < (Y) ? (X) : (Y)) -#endif - -#ifndef MAX -#define MAX(X,Y) ((X) > (Y) ? (X) : (Y)) -#endif - -#define STRMATCH(X,Y) (strcmp((X),(Y)) == 0) - -/* Output counts less than PRTHRESH will be printed as integers */ -#define PRTHRESH 1000000L - -/* Maximum allowed callstack depth */ -#define MAX_STACK 128 - -/* longest timer name allowed (probably safe to just change) */ -#define MAX_CHARS 63 - -/* -** max allowable number of PAPI counters, or derived events. For convenience, -** set to max (# derived events, # papi counters required) so "avail" lists -** all available options. -*/ -#define MAX_AUX 9 - -#ifndef __cplusplus -typedef enum {false = 0, true = 1} bool; /* mimic C++ */ -#endif - -typedef struct { - int val; /* depth in calling tree */ - int padding[31]; /* padding is to mitigate false cache sharing */ -} Nofalse; - -typedef struct { - long last_utime; /* saved usr time from "start" */ - long last_stime; /* saved sys time from "start" */ - long accum_utime; /* accumulator for usr time */ - long accum_stime; /* accumulator for sys time */ -} Cpustats; - -typedef struct { - double last; /* timestamp from last call */ - double accum; /* accumulated time */ - float max; /* longest time for start/stop pair */ - float min; /* shortest time for start/stop pair */ -} Wallstats; - -typedef struct { - long long last[MAX_AUX]; /* array of saved counters from "start" */ - long long accum[MAX_AUX]; /* accumulator for counters */ -} Papistats; - -typedef struct { - int counter; /* PAPI or Derived counter */ - char *namestr; /* PAPI or Derived counter as string */ - char *str8; /* print string for output timers (8 chars) */ - char *str16; /* print string for output timers (16 chars) */ - char *longstr; /* long descriptive print string */ -} Entry; - -typedef struct { - Entry event; - int numidx; /* derived event: PAPI counter array index for numerator */ - int denomidx; /* derived event: PAPI counter array index for denominator */ -} Pr_event; - -typedef struct TIMER { -#ifdef ENABLE_PMPI - double nbytes; /* number of bytes for MPI call */ -#endif -#ifdef HAVE_PAPI - Papistats aux; /* PAPI stats */ -#endif - Cpustats cpu; /* cpu stats */ - Wallstats wall; /* wallclock stats */ - unsigned long count; /* number of start/stop calls */ - unsigned long nrecurse; /* number of recursive start/stop calls */ - void *address; /* address of timer: used only by _instr routines */ - struct TIMER *next; /* next timer in linked list */ - struct TIMER **parent; /* array of parents */ - struct TIMER **children; /* array of children */ - int *parent_count; /* array of call counts, one for each parent */ - unsigned int recurselvl; /* recursion level */ - unsigned int nchildren; /* number of children */ - unsigned int nparent; /* number of parents */ - unsigned int norphan; /* number of times this timer was an orphan */ - bool onflg; /* timer currently on or off */ - char name[MAX_CHARS+1]; /* timer name (user input) */ -} Timer; - -typedef struct { - Timer **entries; /* array of timers hashed to the same value */ - unsigned int nument; /* number of entries hashed to the same value */ -} Hashentry; - -/* Require external data items */ -/* array of thread ids */ -#if ( defined THREADED_OMP ) -extern volatile int *GPTLthreadid_omp; -#elif ( defined THREADED_PTHREADS ) -#include -extern volatile pthread_t *GPTLthreadid; -#else -extern int GPTLthreadid; -#endif - -/* Function prototypes */ -extern int GPTLerror (const char *, ...); /* print error msg and return */ -extern void GPTLwarn (const char *, ...); /* print warning msg and return */ -extern void GPTLset_abort_on_error (bool val); /* set flag to abort on error */ -extern void GPTLreset_errors (void); /* num_errors to zero */ -extern void *GPTLallocate (const int, const char *); /* malloc wrapper */ - -extern int GPTLstart_instr (void *); /* auto-instrumented start */ -extern int GPTLstop_instr (void *); /* auto-instrumented stop */ -extern int GPTLis_initialized (void); /* needed by MPI_Init wrapper */ -extern int GPTLget_overhead (FILE *, /* file descriptor */ - double (*)(), /* UTR() */ - Timer *(), /* getentry() */ - unsigned int (const char *), /* genhashidx() */ - int (void), /* get_thread_num() */ - Nofalse *, /* stackidx */ - Timer ***, /* callstack */ - const Hashentry *, /* hashtable */ - const int, /* tablesize */ - bool, /* dousepapi */ - int, /* imperfect_nest */ - double *, /* self_ohd */ - double *); /* parent_ohd */ -extern void GPTLprint_hashstats (FILE *, int, Hashentry **, int); -extern void GPTLprint_memstats (FILE *, Timer **, int, int, int); -extern int GPTLget_nthreads (void); -extern Timer **GPTLget_timersaddr (void); - -#ifdef __cplusplus -extern "C" { -#endif - -extern void __cyg_profile_func_enter (void *, void *); -extern void __cyg_profile_func_exit (void *, void *); - -#ifdef __cplusplus -}; -#endif - -/* These are needed for communication between gptl.c and other files (mainly gptl_papi.c) */ -#ifdef HAVE_PAPI -extern Entry GPTLeventlist[]; /* list of PAPI-based events to be counted */ -extern int GPTLnevents; /* number of PAPI events (init to 0) */ - -extern int GPTL_PAPIsetoption (const int, const int); -extern int GPTL_PAPIinitialize (const int, const bool, int *, Entry *); -extern int GPTL_PAPIstart (const int, Papistats *); -extern int GPTL_PAPIstop (const int, Papistats *); -extern void GPTL_PAPIprstr (FILE *); -extern void GPTL_PAPIpr (FILE *, const Papistats *, const int, const int, const double); -extern void GPTL_PAPIadd (Papistats *, const Papistats *); -extern void GPTL_PAPIfinalize (int); -extern void GPTL_PAPIquery (const Papistats *, long long *, int); -extern int GPTL_PAPIget_eventvalue (const char *, const Papistats *, double *); -extern bool GPTL_PAPIis_multiplexed (void); -extern void GPTL_PAPIprintenabled (FILE *); -extern void read_counters1000 (void); -extern int GPTLget_npapievents (void); -extern int GPTLcreate_and_start_events (const int); -#endif - -#ifdef ENABLE_PMPI -extern Timer *GPTLgetentry (const char *); -extern int GPTLpmpi_setoption (const int, const int); -extern int GPTLpr_has_been_called (void); /* needed by MPI_Finalize wrapper*/ -#endif diff --git a/cesm/models/utils/timing/gptl/process_namelist.F90 b/cesm/models/utils/timing/gptl/process_namelist.F90 deleted file mode 100644 index b4a588a..0000000 --- a/cesm/models/utils/timing/gptl/process_namelist.F90 +++ /dev/null @@ -1,344 +0,0 @@ -subroutine gptlprocess_namelist (filename, unitno, outret) -! -! process_namelist.F90 -! -! Author: Jim Rosinski -! -! Utility subroutine processes namelist group &gptlnl and makes appropriate -! calls to gptlsetoption() and/or gptlsetutr(). -! -! To follow GPTL conventions this should be a function not a subroutine. -! But 'include ./gptl.inc' and then setting function gptlprocess_namelist -! to a return value causes compiler to barf because the function is declared -! 'external' in the header. So set return value in output arg 'outret' instead. -! - implicit none - - character(len=*), intent(in) :: filename ! Input file containing &gptlnl - integer, intent(in) :: unitno ! Fortran unit number to open - integer, intent(out) :: outret ! Output return code - -#include "./gptl.inc" - - integer :: j ! loop index - integer :: ios ! status return from file open - integer :: code ! event code - integer :: ret ! return value - integer, parameter :: maxevents = 99 ! space to hold more than enough events - -! Default values for namelist variables - logical, parameter :: def_sync_mpi = .false. - logical, parameter :: def_wall = .true. - logical, parameter :: def_cpu = .false. - logical, parameter :: def_abort_on_error = .false. - logical, parameter :: def_overhead = .true. - integer, parameter :: def_depthlimit = 99999 ! Effectively unlimited - integer, parameter :: def_maxthreads = -1 - integer, parameter :: def_tablesize = 1023 ! Needs to match DEFAULT_TABLE_SIZE in gptl.c - logical, parameter :: def_verbose = .false. - logical, parameter :: def_narrowprint = .true. - logical, parameter :: def_percent = .false. - logical, parameter :: def_persec = .true. - logical, parameter :: def_multiplex = .false. - logical, parameter :: def_dopr_preamble = .true. - logical, parameter :: def_dopr_threadsort = .true. - logical, parameter :: def_dopr_multparent = .true. - logical, parameter :: def_dopr_collision = .true. - logical, parameter :: def_dopr_memusage = .false. - character(len=16), parameter :: def_print_method = 'full_tree ' - character(len=16), parameter :: def_utr = 'gettimeofday ' - -! Namelist values: initialize to defaults - logical :: sync_mpi = def_sync_mpi - logical :: wall = def_wall - logical :: cpu = def_cpu - logical :: abort_on_error = def_abort_on_error - logical :: overhead = def_overhead - integer :: depthlimit = def_depthlimit - integer :: maxthreads = def_maxthreads - integer :: tablesize = def_tablesize - logical :: verbose = def_verbose - logical :: narrowprint = def_narrowprint - logical :: percent = def_percent - logical :: persec = def_persec - logical :: multiplex = def_multiplex - logical :: dopr_preamble = def_dopr_preamble - logical :: dopr_threadsort = def_dopr_threadsort - logical :: dopr_multparent = def_dopr_multparent - logical :: dopr_collision = def_dopr_collision - logical :: dopr_memusage = def_dopr_memusage - character(len=16) :: print_method = def_print_method - character(len=16) :: utr = def_utr - character(len=64) :: eventlist(maxevents) = & - (/(' ',j=1,maxevents)/) - character(len=20), parameter :: thisfunc = 'gptlprocess_namelist' - - namelist /gptlnl/ sync_mpi, wall, cpu, abort_on_error, overhead, depthlimit, & - maxthreads, tablesize, verbose, narrowprint, percent, persec, multiplex, & - dopr_preamble, dopr_threadsort, dopr_multparent, dopr_collision, & - dopr_memusage, print_method, eventlist, utr - - open (unit=unitno, file=filename, status='old', iostat=ios) - if (ios /= 0) then - write(6,*) thisfunc, ': cannot open namelist file ', filename - outret = -1 - return - end if - - read (unitno, gptlnl, iostat=ios) - if (ios /= 0) then - write(6,*) thisfunc, ': failure reading namelist' - outret = -1 - close (unit=unitno) - return - end if - -! Set options for user-defined values which are not default. -! Do verbose and abort_on_error first because of their immediate effects on behavior. - if (verbose .neqv. def_verbose) then - if (verbose) then - write(6,*) thisfunc, ': setting verbose to ', verbose - ret = gptlsetoption (gptlverbose, 1) - else - ret = gptlsetoption (gptlverbose, 0) - end if - end if - - if (abort_on_error .neqv. def_abort_on_error) then - if (verbose) then - write(6,*) thisfunc,': setting abort_on_error to ', abort_on_error - end if - if (abort_on_error) then - ret = gptlsetoption (gptlabort_on_error, 1) - else - ret = gptlsetoption (gptlabort_on_error, 0) - end if - end if - - if (sync_mpi .neqv. def_sync_mpi) then - if (verbose) then - write(6,*) thisfunc,': setting sync_mpi to ', sync_mpi - end if - if (sync_mpi) then - ret = gptlsetoption (gptlsync_mpi, 1) - else - ret = gptlsetoption (gptlsync_mpi, 0) - end if - end if - - if (wall .neqv. def_wall) then - if (verbose) then - write(6,*) thisfunc,': wall to ', wall - end if - if (wall) then - ret = gptlsetoption (gptlwall, 1) - else - ret = gptlsetoption (gptlwall, 0) - end if - end if - - if (cpu .neqv. def_cpu) then - if (verbose) then - write(6,*) thisfunc,': setting cpu to ', cpu - end if - if (cpu) then - ret = gptlsetoption (gptlcpu, 1) - else - ret = gptlsetoption (gptlcpu, 0) - end if - end if - - if (overhead .neqv. def_overhead) then - if (verbose) then - write(6,*) thisfunc,': setting overhead to ', overhead - end if - if (overhead) then - ret = gptlsetoption (gptloverhead, 1) - else - ret = gptlsetoption (gptloverhead, 0) - end if - end if - - if (depthlimit /= def_depthlimit) then - if (verbose) then - write(6,*) thisfunc, ': setting depthlimit to ', depthlimit - end if - ret = gptlsetoption (gptldepthlimit, depthlimit) - end if - - if (maxthreads /= def_maxthreads) then - if (verbose) then - write(6,*) thisfunc, ': setting maxthreads to ', maxthreads - end if - ret = gptlsetoption (gptlmaxthreads, maxthreads) - end if - - if (tablesize /= def_tablesize) then - if (verbose) then - write(6,*) thisfunc, ': setting tablesize to ', tablesize - end if - ret = gptlsetoption (gptltablesize, tablesize) - end if - - if (narrowprint .neqv. def_narrowprint) then - if (verbose) then - write(6,*) thisfunc, ': setting narrowprint to ', narrowprint - end if - if (narrowprint) then - ret = gptlsetoption (gptlnarrowprint, 1) - else - ret = gptlsetoption (gptlnarrowprint, 0) - end if - end if - - if (percent .neqv. def_percent) then - if (verbose) then - write(6,*) thisfunc, ': setting percent to ', percent - end if - if (percent) then - ret = gptlsetoption (gptlpercent, 1) - else - ret = gptlsetoption (gptlpercent, 0) - end if - end if - - if (persec .neqv. def_persec) then - if (verbose) then - write(6,*) thisfunc, ': setting persec to ', persec - end if - if (persec) then - ret = gptlsetoption (gptlpersec, 1) - else - ret = gptlsetoption (gptlpersec, 0) - end if - end if - - if (multiplex .neqv. def_multiplex) then - if (verbose) then - write(6,*) thisfunc, ': setting multiplex to ', multiplex - end if - if (multiplex) then - ret = gptlsetoption (gptlmultiplex, 1) - else - ret = gptlsetoption (gptlmultiplex, 0) - end if - end if - - if (dopr_preamble .neqv. def_dopr_preamble) then - if (verbose) then - write(6,*) thisfunc, ': setting dopr_preamble to ', dopr_preamble - end if - if (dopr_preamble) then - ret = gptlsetoption (gptldopr_preamble, 1) - else - ret = gptlsetoption (gptldopr_preamble, 0) - end if - end if - - if (dopr_threadsort .neqv. def_dopr_threadsort) then - if (verbose) then - write(6,*) thisfunc, ': setting dopr_threadsort to ', dopr_threadsort - end if - if (dopr_threadsort) then - ret = gptlsetoption (gptldopr_threadsort, 1) - else - ret = gptlsetoption (gptldopr_threadsort, 0) - end if - end if - - if (dopr_multparent .neqv. def_dopr_multparent) then - if (verbose) then - write(6,*) thisfunc, ': setting dopr_multparent to ', dopr_multparent - end if - if (dopr_multparent) then - ret = gptlsetoption (gptldopr_multparent, 1) - else - ret = gptlsetoption (gptldopr_multparent, 0) - end if - end if - - if (dopr_collision .neqv. def_dopr_collision) then - if (verbose) then - write(6,*) thisfunc, ': setting dopr_collision to ', dopr_collision - end if - if (dopr_collision) then - ret = gptlsetoption (gptldopr_collision, 1) - else - ret = gptlsetoption (gptldopr_collision, 0) - end if - end if - - if (dopr_memusage .neqv. def_dopr_memusage) then - if (verbose) then - write(6,*) thisfunc, ': setting dopr_memusage to ', dopr_memusage - end if - if (dopr_memusage) then - ret = gptlsetoption (gptldopr_memusage, 1) - else - ret = gptlsetoption (gptldopr_memusage, 0) - end if - end if - -! Character-based variables - if (utr /= def_utr) then - if (verbose) then - write(6,*) thisfunc, ': setting utr to ', trim(utr) - end if - if (trim(utr) == 'gettimeofday') then - ret = gptlsetutr (gptlgettimeofday) - else if (trim(utr) == 'nanotime') then - ret = gptlsetutr (gptlnanotime) - else if (trim(utr) == 'read_real_time') then - ret = gptlsetutr (gptlread_real_time) - else if (trim(utr) == 'mpiwtime') then - ret = gptlsetutr (gptlmpiwtime) - else if (trim(utr) == 'clockgettime') then - ret = gptlsetutr (gptlclockgettime) - else if (trim(utr) == 'papitime') then - ret = gptlsetutr (gptlpapitime) - else - write(6,*) thisfunc, ': Underlying timing routine not available: ', trim (utr) - end if - end if - -! Print method: use characters for namelist variables to avoid magic numbers in namelist - if (print_method /= def_print_method) then - if (verbose) then - write(6,*) thisfunc, ': setting print_method to ', trim (print_method) - end if - if (trim(print_method) == 'first_parent') then - ret = gptlsetoption (gptlprint_method, gptlfirst_parent) - else if (trim(print_method) == 'last_parent') then - ret = gptlsetoption (gptlprint_method, gptllast_parent) - else if (trim(print_method) == 'most_frequent') then - ret = gptlsetoption (gptlprint_method, gptlmost_frequent) - else if (trim(print_method) == 'full_tree') then - ret = gptlsetoption (gptlprint_method, gptlfull_tree) - else - write(6,*) thisfunc, ': print_method not available: ', print_method - end if - end if - -#ifdef HAVE_PAPI - do j=1,maxevents - if (eventlist(j)(1:16) /= ' ') then - ret = gptlevent_name_to_code (trim (eventlist(j)), code) - if (ret == 0) then - if (verbose) then - write(6,*) thisfunc, ': enabling event ', trim (eventlist(j)) - end if - ret = gptlsetoption (code, 1) - else - write(6,*) thisfunc, ': no code found for event ', trim (eventlist(j)) - end if - end if - end do -#else -! Comment out this print because it can be very annoying when the MPI task count is large -! write(6,*) thisfunc, ': skipping check for PAPI-based events because ', & -! 'GPTL was built without PAPI support' -#endif - close (unit=unitno) - outret = 0 - return -end subroutine gptlprocess_namelist diff --git a/cesm/models/utils/timing/gptl/runalltests.csh b/cesm/models/utils/timing/gptl/runalltests.csh deleted file mode 100755 index ae0f715..0000000 --- a/cesm/models/utils/timing/gptl/runalltests.csh +++ /dev/null @@ -1,67 +0,0 @@ -#!/bin/csh -f - -# Test the GPTL library by permuting the default values of as many user-settable -# parameters as possible. The list defined by the "foreach" loop below will -# need to be culled of all tests which truly can't be changed. For example if -# PAPI is unavailable, delete HAVE_PAPI from the list because this script will -# try to run a PAPI test where HAVE_PAPI is permuted from "no" to "yes", and -# the test will fail. - -set basescript = macros.make.linux # This is the base script to start from -set make = make # Name of gnu make program -echo "$0 Testing $basescript..." -echo "$basescript settings:" -foreach setting (DEBUG OPENMP PTHREADS FORTRAN HAVE_PAPI HAVE_MPI TEST_AUTOPROFILE \ - ENABLE_PMPI HAVE_IARGCGETARG ) - echo `grep "^ *$setting *= " $basescript` -end - -cp -f $basescript ./macros.make || echo "Failure to cp $basescript to macros.make" && exit 1 -$make clean; $make || echo "Failure in $make" && exit 1 -$make test || echo "Failure in $make test" && exit 1 -echo "$0 $basescript worked" >! results - -# Will need to delete from user settable list all items which truly aren't available -#foreach usersettable ( DEBUG OPENMP PTHREADS FORTRAN HAVE_PAPI HAVE_MPI TEST_AUTOPROFILE \ -# ENABLE_PMPI HAVE_IARGCGETARG ) -foreach usersettable ( DEBUG OPENMP PTHREADS FORTRAN HAVE_PAPI HAVE_MPI TEST_AUTOPROFILE \ - ENABLE_PMPI ) -grep "^ *$usersettable *= *yes *" $basescript -set ret = $status - -# Determine whether to toggle from no to yes, or yes to no -if ($ret == 0) then - set oldtest = yes - set newtest = no -else - set oldtest = no - set newtest = yes -endif -echo "$0 Testing $usersettable = $newtest ..." -echo "$0 Testing $usersettable = $newtest ..." >> results - -# For PTHREADS case, ensure OPENMP is no -if ( $usersettable == PTHREADS ) then - sed -e "s/^ *OPENMP *= *yes */OPENMP = no/g" \ - -e "s/^ *$usersettable *= *$oldtest */$usersettable = $newtest/g" $basescript >! macros.make - -# For HAVE_IARGCGETARG case, ensure HAVE_MPI and ENABLE_PMPI are true -else if ( $usersettable == HAVE_IARGCGETARG ) then - sed -e "s/^ *HAVE_MPI *= *no */HAVE_MPI = yes/g" \ - -e "s/^ *ENABLE_PMPI *= *no */ENABLE_PMPI = yes/g" \ - -e "s/^ *$usersettable *= *$oldtest */$usersettable = $newtest/g" $basescript >! macros.make - -# For ENABLE_PMPI case, ensure HAVE_MPI is true -else if ( $usersettable == ENABLE_PMPI ) then - sed -e "s/^ *HAVE_MPI *= *no */HAVE_MPI = yes/g" \ - -e "s/^ *$usersettable *= *$oldtest */$usersettable = $newtest/g" $basescript >! macros.make -else - sed -e "s/^ *$usersettable *= *$oldtest */$usersettable = $newtest/g" $basescript >! macros.make -endif - -$make clean; $make || echo "Failure in $make" && exit 1 -$make test || echo "Failure in $make test" && exit 1 -echo "$usersettable = $newtest worked" >> results -end - -echo "Permuting all user settable tests passed" && exit 0 diff --git a/cesm/models/utils/timing/gptl/runalltests.csh.bluefire b/cesm/models/utils/timing/gptl/runalltests.csh.bluefire deleted file mode 100755 index 9db585b..0000000 --- a/cesm/models/utils/timing/gptl/runalltests.csh.bluefire +++ /dev/null @@ -1,76 +0,0 @@ -#!/bin/csh -f - -# Test the GPTL library by permuting the default values of as many user-settable -# parameters as possible. The list defined by the "foreach" loop below will -# need to be culled of all tests which truly can't be changed. For example if -# PAPI is unavailable, delete HAVE_PAPI from the list because this script will -# try to run a PAPI test where HAVE_PAPI is permuted from "no" to "yes", and -# the test will fail. - -set basescript = jrmacros/macros.make.bluefire # This is the base script to start from -set make = gmake # Name of gnu make program - -# bluefire: set env. vars. for 2 MPI process -hostname >! hostfile -hostname >> hostfile -setenv MP_HOSTFILE `pwd`/hostfile -setenv MP_EUILIB ip -setenv MP_PROCS 2 - -echo "$0 Testing $basescript..." -echo "$basescript settings:" - -foreach setting (DEBUG OPENMP PTHREADS FORTRAN HAVE_PAPI HAVE_MPI TEST_AUTOPROFILE \ - ENABLE_PMPI HAVE_IARGCGETARG ) - echo `grep "^ *$setting *= " $basescript` -end - -cp -f $basescript ./macros.make || echo "Failure to cp $basescript to macros.make" && exit 1 -$make clean; $make || echo "Failure in $make" && exit 1 -$make test || echo "Failure in $make test" && exit 1 -echo "$0 $basescript worked" >! results - -# Will need to delete from user settable list all items which truly aren't available -#foreach usersettable ( DEBUG OPENMP PTHREADS FORTRAN HAVE_PAPI HAVE_MPI TEST_AUTOPROFILE \ -# ENABLE_PMPI HAVE_IARGCGETARG ) -foreach usersettable ( DEBUG OPENMP PTHREADS FORTRAN HAVE_PAPI HAVE_MPI TEST_AUTOPROFILE \ - ENABLE_PMPI ) -grep "^ *$usersettable *= *yes *" $basescript -set ret = $status - -# Determine whether to toggle from no to yes, or yes to no -if ($ret == 0) then - set oldtest = yes - set newtest = no -else - set oldtest = no - set newtest = yes -endif -echo "$0 Testing $usersettable = $newtest ..." -echo "$0 Testing $usersettable = $newtest ..." >> results - -# For PTHREADS case, ensure OPENMP is no -if ( $usersettable == PTHREADS ) then - sed -e "s/^ *OPENMP *= *yes */OPENMP = no/g" \ - -e "s/^ *$usersettable *= *$oldtest */$usersettable = $newtest/g" $basescript >! macros.make - -# For HAVE_IARGCGETARG case, ensure HAVE_MPI and ENABLE_PMPI are true -else if ( $usersettable == HAVE_IARGCGETARG ) then - sed -e "s/^ *HAVE_MPI *= *no */HAVE_MPI = yes/g" \ - -e "s/^ *ENABLE_PMPI *= *no */ENABLE_PMPI = yes/g" \ - -e "s/^ *$usersettable *= *$oldtest */$usersettable = $newtest/g" $basescript >! macros.make - -# For ENABLE_PMPI case, ensure HAVE_MPI is true -else if ( $usersettable == ENABLE_PMPI ) then - sed -e "s/^ *HAVE_MPI *= *no */HAVE_MPI = yes/g" \ - -e "s/^ *$usersettable *= *$oldtest */$usersettable = $newtest/g" $basescript >! macros.make -else - sed -e "s/^ *$usersettable *= *$oldtest */$usersettable = $newtest/g" $basescript >! macros.make -endif - -$make clean; $make || echo "Failure in $make" && exit 1 -$make test || echo "Failure in $make test" && exit 1 -echo "$usersettable = $newtest worked" >> results -end - -echo "Permuting all user settable tests passed" && exit 0 diff --git a/cesm/models/utils/timing/gptl/runalltests.csh.cray b/cesm/models/utils/timing/gptl/runalltests.csh.cray deleted file mode 100755 index f4fd959..0000000 --- a/cesm/models/utils/timing/gptl/runalltests.csh.cray +++ /dev/null @@ -1,74 +0,0 @@ -#!/bin/csh -f - -# Test the GPTL library by permuting the default values of as many user-settable -# parameters as possible. The list defined by the "foreach" loop below will -# need to be culled of all tests which truly can't be changed. For example if -# PAPI is unavailable, delete HAVE_PAPI from the list because this script will -# try to run a PAPI test where HAVE_PAPI is permuted from "no" to "yes", and -# the test will fail. - -set basescript = jrmacros/macros.make.cray # This is the base script to start from -set make = make # Name of gnu make program - -# jaguarpf: Normally would load xt-papi module here, but that doesn'twork -# It must be set in the environment - -if ( ! $?PAPI_INCLUDE_OPTS ) then - echo "$0 Need to have done module load papi from the environment" - exit 1 -endif - -echo "$0 Testing $basescript..." -echo "$basescript settings:" -# ENABLE_PMPI, TEST_AUTOPROFILE HAVE_IARGCGETARG do not work on Cray -foreach setting (DEBUG OPENMP PTHREADS FORTRAN HAVE_PAPI HAVE_MPI ) - echo `grep "^ *$setting *= " $basescript` -end - -cp -f $basescript ./macros.make || echo "Failure to cp $basescript to macros.make" && exit 1 -$make clean; $make || echo "Failure in $make" && exit 1 -$make test || echo "Failure in $make test" && exit 1 -echo "$0 $basescript worked" >! results - -# Will need to delete from user settable list all items which truly aren't available -# ENABLE_PMPI, TEST_AUTOPROFILE HAVE_IARGCGETARG do not work on Cray -foreach usersettable ( DEBUG OPENMP PTHREADS FORTRAN HAVE_PAPI HAVE_MPI ) -grep "^ *$usersettable *= *yes *" $basescript -set ret = $status - -# Determine whether to toggle from no to yes, or yes to no -if ($ret == 0) then - set oldtest = yes - set newtest = no -else - set oldtest = no - set newtest = yes -endif -echo "$0 Testing $usersettable = $newtest ..." -echo "$0 Testing $usersettable = $newtest ..." >> results - -# For PTHREADS case, ensure OPENMP is no -if ( $usersettable == PTHREADS ) then - sed -e "s/^ *OPENMP *= *yes */OPENMP = no/g" \ - -e "s/^ *$usersettable *= *$oldtest */$usersettable = $newtest/g" $basescript >! macros.make - -# For HAVE_IARGCGETARG case, ensure HAVE_MPI and ENABLE_PMPI are true -else if ( $usersettable == HAVE_IARGCGETARG ) then - sed -e "s/^ *HAVE_MPI *= *no */HAVE_MPI = yes/g" \ - -e "s/^ *ENABLE_PMPI *= *no */ENABLE_PMPI = yes/g" \ - -e "s/^ *$usersettable *= *$oldtest */$usersettable = $newtest/g" $basescript >! macros.make - -# For ENABLE_PMPI case, ensure HAVE_MPI is true -else if ( $usersettable == ENABLE_PMPI ) then - sed -e "s/^ *HAVE_MPI *= *no */HAVE_MPI = yes/g" \ - -e "s/^ *$usersettable *= *$oldtest */$usersettable = $newtest/g" $basescript >! macros.make -else - sed -e "s/^ *$usersettable *= *$oldtest */$usersettable = $newtest/g" $basescript >! macros.make -endif - -$make clean; $make || echo "Failure in $make" && exit 1 -$make test || echo "Failure in $make test" && exit 1 -echo "$usersettable = $newtest worked" >> results -end - -echo "Permuting all user settable tests passed" && exit 0 diff --git a/cesm/models/utils/timing/gptl/runalltests.csh.jet b/cesm/models/utils/timing/gptl/runalltests.csh.jet deleted file mode 100755 index 23a22c3..0000000 --- a/cesm/models/utils/timing/gptl/runalltests.csh.jet +++ /dev/null @@ -1,67 +0,0 @@ -#!/bin/csh -f - -# Test the GPTL library by permuting the default values of as many user-settable -# parameters as possible. The list defined by the "foreach" loop below will -# need to be culled of all tests which truly can't be changed. For example if -# PAPI is unavailable, delete HAVE_PAPI from the list because this script will -# try to run a PAPI test where HAVE_PAPI is permuted from "no" to "yes", and -# the test will fail. - -set basescript = jrmacros/macros.make.jet # This is the base script to start from -set make = make # Name of gnu make program -echo "$0 Testing $basescript..." -echo "$basescript settings:" -foreach setting (DEBUG OPENMP PTHREADS FORTRAN HAVE_PAPI HAVE_MPI TEST_AUTOPROFILE \ - ENABLE_PMPI HAVE_IARGCGETARG ) - echo `grep "^ *$setting *= " $basescript` -end - -cp -f $basescript ./macros.make || echo "Failure to cp $basescript to macros.make" && exit 1 -$make clean; $make || echo "Failure in $make" && exit 1 -$make test || echo "Failure in $make test" && exit 1 -echo "$0 $basescript worked" >! results - -# Will need to delete from user settable list all items which truly aren't available -#foreach usersettable ( DEBUG OPENMP PTHREADS FORTRAN HAVE_PAPI HAVE_MPI TEST_AUTOPROFILE \ -# ENABLE_PMPI HAVE_IARGCGETARG ) -foreach usersettable ( DEBUG OPENMP PTHREADS FORTRAN HAVE_PAPI HAVE_MPI TEST_AUTOPROFILE \ - ENABLE_PMPI ) -grep "^ *$usersettable *= *yes *" $basescript -set ret = $status - -# Determine whether to toggle from no to yes, or yes to no -if ($ret == 0) then - set oldtest = yes - set newtest = no -else - set oldtest = no - set newtest = yes -endif -echo "$0 Testing $usersettable = $newtest ..." -echo "$0 Testing $usersettable = $newtest ..." >> results - -# For PTHREADS case, ensure OPENMP is no -if ( $usersettable == PTHREADS ) then - sed -e "s/^ *OPENMP *= *yes */OPENMP = no/g" \ - -e "s/^ *$usersettable *= *$oldtest */$usersettable = $newtest/g" $basescript >! macros.make - -# For HAVE_IARGCGETARG case, ensure HAVE_MPI and ENABLE_PMPI are true -else if ( $usersettable == HAVE_IARGCGETARG ) then - sed -e "s/^ *HAVE_MPI *= *no */HAVE_MPI = yes/g" \ - -e "s/^ *ENABLE_PMPI *= *no */ENABLE_PMPI = yes/g" \ - -e "s/^ *$usersettable *= *$oldtest */$usersettable = $newtest/g" $basescript >! macros.make - -# For ENABLE_PMPI case, ensure HAVE_MPI is true -else if ( $usersettable == ENABLE_PMPI ) then - sed -e "s/^ *HAVE_MPI *= *no */HAVE_MPI = yes/g" \ - -e "s/^ *$usersettable *= *$oldtest */$usersettable = $newtest/g" $basescript >! macros.make -else - sed -e "s/^ *$usersettable *= *$oldtest */$usersettable = $newtest/g" $basescript >! macros.make -endif - -$make clean; $make || echo "Failure in $make" && exit 1 -$make test || echo "Failure in $make test" && exit 1 -echo "$usersettable = $newtest worked" >> results -end - -echo "Permuting all user settable tests passed" && exit 0 diff --git a/cesm/models/utils/timing/gptl/runalltests.csh.xt5.pgi b/cesm/models/utils/timing/gptl/runalltests.csh.xt5.pgi deleted file mode 100755 index dbc163c..0000000 --- a/cesm/models/utils/timing/gptl/runalltests.csh.xt5.pgi +++ /dev/null @@ -1,76 +0,0 @@ -#!/bin/csh -f - -# Test the GPTL library by permuting the default values of as many user-settable -# parameters as possible. The list defined by the "foreach" loop below will -# need to be culled of all tests which truly can't be changed. For example if -# PAPI is unavailable, delete HAVE_PAPI from the list because this script will -# try to run a PAPI test where HAVE_PAPI is permuted from "no" to "yes", and -# the test will fail. - -set basescript = jrmacros/macros.make.xt5.pgi # This is the base script to start from -set make = make # Name of gnu make program - -# jaguarpf: Normally would load xt-papi module here, but that doesn'twork -# It must be set in the environment - -if ( ! $?PAPI_INCLUDE_OPTS ) then - echo "$0 Need to have done module load xt-papi from the environment" - exit 1 -endif - -echo "$0 Testing $basescript..." -echo "$basescript settings:" -foreach setting (DEBUG OPENMP PTHREADS FORTRAN HAVE_PAPI HAVE_MPI TEST_AUTOPROFILE \ - ENABLE_PMPI HAVE_IARGCGETARG ) - echo `grep "^ *$setting *= " $basescript` -end - -cp -f $basescript ./macros.make || echo "Failure to cp $basescript to macros.make" && exit 1 -$make clean; $make || echo "Failure in $make" && exit 1 -$make test || echo "Failure in $make test" && exit 1 -echo "$0 $basescript worked" >! results - -# Will need to delete from user settable list all items which truly aren't available -#foreach usersettable ( DEBUG OPENMP PTHREADS FORTRAN HAVE_PAPI HAVE_MPI TEST_AUTOPROFILE \ -# ENABLE_PMPI HAVE_IARGCGETARG ) -foreach usersettable ( DEBUG OPENMP PTHREADS FORTRAN HAVE_PAPI HAVE_MPI TEST_AUTOPROFILE \ - ENABLE_PMPI ) -grep "^ *$usersettable *= *yes *" $basescript -set ret = $status - -# Determine whether to toggle from no to yes, or yes to no -if ($ret == 0) then - set oldtest = yes - set newtest = no -else - set oldtest = no - set newtest = yes -endif -echo "$0 Testing $usersettable = $newtest ..." -echo "$0 Testing $usersettable = $newtest ..." >> results - -# For PTHREADS case, ensure OPENMP is no -if ( $usersettable == PTHREADS ) then - sed -e "s/^ *OPENMP *= *yes */OPENMP = no/g" \ - -e "s/^ *$usersettable *= *$oldtest */$usersettable = $newtest/g" $basescript >! macros.make - -# For HAVE_IARGCGETARG case, ensure HAVE_MPI and ENABLE_PMPI are true -else if ( $usersettable == HAVE_IARGCGETARG ) then - sed -e "s/^ *HAVE_MPI *= *no */HAVE_MPI = yes/g" \ - -e "s/^ *ENABLE_PMPI *= *no */ENABLE_PMPI = yes/g" \ - -e "s/^ *$usersettable *= *$oldtest */$usersettable = $newtest/g" $basescript >! macros.make - -# For ENABLE_PMPI case, ensure HAVE_MPI is true -else if ( $usersettable == ENABLE_PMPI ) then - sed -e "s/^ *HAVE_MPI *= *no */HAVE_MPI = yes/g" \ - -e "s/^ *$usersettable *= *$oldtest */$usersettable = $newtest/g" $basescript >! macros.make -else - sed -e "s/^ *$usersettable *= *$oldtest */$usersettable = $newtest/g" $basescript >! macros.make -endif - -$make clean; $make || echo "Failure in $make" && exit 1 -$make test || echo "Failure in $make test" && exit 1 -echo "$usersettable = $newtest worked" >> results -end - -echo "Permuting all user settable tests passed" && exit 0 diff --git a/cesm/models/utils/timing/gptl/suggestions b/cesm/models/utils/timing/gptl/suggestions deleted file mode 100755 index 010e5c2..0000000 --- a/cesm/models/utils/timing/gptl/suggestions +++ /dev/null @@ -1,4729 +0,0 @@ -#! /bin/sh -# Guess values for system-dependent variables and create Makefiles. -# Generated by GNU Autoconf 2.68. -# -# -# Copyright (C) 1992, 1993, 1994, 1995, 1996, 1998, 1999, 2000, 2001, -# 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010 Free Software -# Foundation, Inc. -# -# -# This configure script is free software; the Free Software Foundation -# gives unlimited permission to copy, distribute and modify it. -## -------------------- ## -## M4sh Initialization. ## -## -------------------- ## - -# Be more Bourne compatible -DUALCASE=1; export DUALCASE # for MKS sh -if test -n "${ZSH_VERSION+set}" && (emulate sh) >/dev/null 2>&1; then : - emulate sh - NULLCMD=: - # Pre-4.2 versions of Zsh do word splitting on ${1+"$@"}, which - # is contrary to our usage. Disable this feature. - alias -g '${1+"$@"}'='"$@"' - setopt NO_GLOB_SUBST -else - case `(set -o) 2>/dev/null` in #( - *posix*) : - set -o posix ;; #( - *) : - ;; -esac -fi - - -as_nl=' -' -export as_nl -# Printing a long string crashes Solaris 7 /usr/bin/printf. -as_echo='\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\' -as_echo=$as_echo$as_echo$as_echo$as_echo$as_echo -as_echo=$as_echo$as_echo$as_echo$as_echo$as_echo$as_echo -# Prefer a ksh shell builtin over an external printf program on Solaris, -# but without wasting forks for bash or zsh. -if test -z "$BASH_VERSION$ZSH_VERSION" \ - && (test "X`print -r -- $as_echo`" = "X$as_echo") 2>/dev/null; then - as_echo='print -r --' - as_echo_n='print -rn --' -elif (test "X`printf %s $as_echo`" = "X$as_echo") 2>/dev/null; then - as_echo='printf %s\n' - as_echo_n='printf %s' -else - if test "X`(/usr/ucb/echo -n -n $as_echo) 2>/dev/null`" = "X-n $as_echo"; then - as_echo_body='eval /usr/ucb/echo -n "$1$as_nl"' - as_echo_n='/usr/ucb/echo -n' - else - as_echo_body='eval expr "X$1" : "X\\(.*\\)"' - as_echo_n_body='eval - arg=$1; - case $arg in #( - *"$as_nl"*) - expr "X$arg" : "X\\(.*\\)$as_nl"; - arg=`expr "X$arg" : ".*$as_nl\\(.*\\)"`;; - esac; - expr "X$arg" : "X\\(.*\\)" | tr -d "$as_nl" - ' - export as_echo_n_body - as_echo_n='sh -c $as_echo_n_body as_echo' - fi - export as_echo_body - as_echo='sh -c $as_echo_body as_echo' -fi - -# The user is always right. -if test "${PATH_SEPARATOR+set}" != set; then - PATH_SEPARATOR=: - (PATH='/bin;/bin'; FPATH=$PATH; sh -c :) >/dev/null 2>&1 && { - (PATH='/bin:/bin'; FPATH=$PATH; sh -c :) >/dev/null 2>&1 || - PATH_SEPARATOR=';' - } -fi - - -# IFS -# We need space, tab and new line, in precisely that order. Quoting is -# there to prevent editors from complaining about space-tab. -# (If _AS_PATH_WALK were called with IFS unset, it would disable word -# splitting by setting IFS to empty value.) -IFS=" "" $as_nl" - -# Find who we are. Look in the path if we contain no directory separator. -as_myself= -case $0 in #(( - *[\\/]* ) as_myself=$0 ;; - *) as_save_IFS=$IFS; IFS=$PATH_SEPARATOR -for as_dir in $PATH -do - IFS=$as_save_IFS - test -z "$as_dir" && as_dir=. - test -r "$as_dir/$0" && as_myself=$as_dir/$0 && break - done -IFS=$as_save_IFS - - ;; -esac -# We did not find ourselves, most probably we were run as `sh COMMAND' -# in which case we are not to be found in the path. -if test "x$as_myself" = x; then - as_myself=$0 -fi -if test ! -f "$as_myself"; then - $as_echo "$as_myself: error: cannot find myself; rerun with an absolute file name" >&2 - exit 1 -fi - -# Unset variables that we do not need and which cause bugs (e.g. in -# pre-3.0 UWIN ksh). But do not cause bugs in bash 2.01; the "|| exit 1" -# suppresses any "Segmentation fault" message there. '((' could -# trigger a bug in pdksh 5.2.14. -for as_var in BASH_ENV ENV MAIL MAILPATH -do eval test x\${$as_var+set} = xset \ - && ( (unset $as_var) || exit 1) >/dev/null 2>&1 && unset $as_var || : -done -PS1='$ ' -PS2='> ' -PS4='+ ' - -# NLS nuisances. -LC_ALL=C -export LC_ALL -LANGUAGE=C -export LANGUAGE - -# CDPATH. -(unset CDPATH) >/dev/null 2>&1 && unset CDPATH - -if test "x$CONFIG_SHELL" = x; then - as_bourne_compatible="if test -n \"\${ZSH_VERSION+set}\" && (emulate sh) >/dev/null 2>&1; then : - emulate sh - NULLCMD=: - # Pre-4.2 versions of Zsh do word splitting on \${1+\"\$@\"}, which - # is contrary to our usage. Disable this feature. - alias -g '\${1+\"\$@\"}'='\"\$@\"' - setopt NO_GLOB_SUBST -else - case \`(set -o) 2>/dev/null\` in #( - *posix*) : - set -o posix ;; #( - *) : - ;; -esac -fi -" - as_required="as_fn_return () { (exit \$1); } -as_fn_success () { as_fn_return 0; } -as_fn_failure () { as_fn_return 1; } -as_fn_ret_success () { return 0; } -as_fn_ret_failure () { return 1; } - -exitcode=0 -as_fn_success || { exitcode=1; echo as_fn_success failed.; } -as_fn_failure && { exitcode=1; echo as_fn_failure succeeded.; } -as_fn_ret_success || { exitcode=1; echo as_fn_ret_success failed.; } -as_fn_ret_failure && { exitcode=1; echo as_fn_ret_failure succeeded.; } -if ( set x; as_fn_ret_success y && test x = \"\$1\" ); then : - -else - exitcode=1; echo positional parameters were not saved. -fi -test x\$exitcode = x0 || exit 1" - as_suggested=" as_lineno_1=";as_suggested=$as_suggested$LINENO;as_suggested=$as_suggested" as_lineno_1a=\$LINENO - as_lineno_2=";as_suggested=$as_suggested$LINENO;as_suggested=$as_suggested" as_lineno_2a=\$LINENO - eval 'test \"x\$as_lineno_1'\$as_run'\" != \"x\$as_lineno_2'\$as_run'\" && - test \"x\`expr \$as_lineno_1'\$as_run' + 1\`\" = \"x\$as_lineno_2'\$as_run'\"' || exit 1 -test \$(( 1 + 1 )) = 2 || exit 1" - if (eval "$as_required") 2>/dev/null; then : - as_have_required=yes -else - as_have_required=no -fi - if test x$as_have_required = xyes && (eval "$as_suggested") 2>/dev/null; then : - -else - as_save_IFS=$IFS; IFS=$PATH_SEPARATOR -as_found=false -for as_dir in /bin$PATH_SEPARATOR/usr/bin$PATH_SEPARATOR$PATH -do - IFS=$as_save_IFS - test -z "$as_dir" && as_dir=. - as_found=: - case $as_dir in #( - /*) - for as_base in sh bash ksh sh5; do - # Try only shells that exist, to save several forks. - as_shell=$as_dir/$as_base - if { test -f "$as_shell" || test -f "$as_shell.exe"; } && - { $as_echo "$as_bourne_compatible""$as_required" | as_run=a "$as_shell"; } 2>/dev/null; then : - CONFIG_SHELL=$as_shell as_have_required=yes - if { $as_echo "$as_bourne_compatible""$as_suggested" | as_run=a "$as_shell"; } 2>/dev/null; then : - break 2 -fi -fi - done;; - esac - as_found=false -done -$as_found || { if { test -f "$SHELL" || test -f "$SHELL.exe"; } && - { $as_echo "$as_bourne_compatible""$as_required" | as_run=a "$SHELL"; } 2>/dev/null; then : - CONFIG_SHELL=$SHELL as_have_required=yes -fi; } -IFS=$as_save_IFS - - - if test "x$CONFIG_SHELL" != x; then : - # We cannot yet assume a decent shell, so we have to provide a - # neutralization value for shells without unset; and this also - # works around shells that cannot unset nonexistent variables. - # Preserve -v and -x to the replacement shell. - BASH_ENV=/dev/null - ENV=/dev/null - (unset BASH_ENV) >/dev/null 2>&1 && unset BASH_ENV ENV - export CONFIG_SHELL - case $- in # (((( - *v*x* | *x*v* ) as_opts=-vx ;; - *v* ) as_opts=-v ;; - *x* ) as_opts=-x ;; - * ) as_opts= ;; - esac - exec "$CONFIG_SHELL" $as_opts "$as_myself" ${1+"$@"} -fi - - if test x$as_have_required = xno; then : - $as_echo "$0: This script requires a shell more modern than all" - $as_echo "$0: the shells that I found on your system." - if test x${ZSH_VERSION+set} = xset ; then - $as_echo "$0: In particular, zsh $ZSH_VERSION has bugs and should" - $as_echo "$0: be upgraded to zsh 4.3.4 or later." - else - $as_echo "$0: Please tell bug-autoconf@gnu.org about your system, -$0: including any error possibly output before this -$0: message. Then install a modern shell, or manually run -$0: the script under such a shell if you do have one." - fi - exit 1 -fi -fi -fi -SHELL=${CONFIG_SHELL-/bin/sh} -export SHELL -# Unset more variables known to interfere with behavior of common tools. -CLICOLOR_FORCE= GREP_OPTIONS= -unset CLICOLOR_FORCE GREP_OPTIONS - -## --------------------- ## -## M4sh Shell Functions. ## -## --------------------- ## -# as_fn_unset VAR -# --------------- -# Portably unset VAR. -as_fn_unset () -{ - { eval $1=; unset $1;} -} -as_unset=as_fn_unset - -# as_fn_set_status STATUS -# ----------------------- -# Set $? to STATUS, without forking. -as_fn_set_status () -{ - return $1 -} # as_fn_set_status - -# as_fn_exit STATUS -# ----------------- -# Exit the shell with STATUS, even in a "trap 0" or "set -e" context. -as_fn_exit () -{ - set +e - as_fn_set_status $1 - exit $1 -} # as_fn_exit - -# as_fn_mkdir_p -# ------------- -# Create "$as_dir" as a directory, including parents if necessary. -as_fn_mkdir_p () -{ - - case $as_dir in #( - -*) as_dir=./$as_dir;; - esac - test -d "$as_dir" || eval $as_mkdir_p || { - as_dirs= - while :; do - case $as_dir in #( - *\'*) as_qdir=`$as_echo "$as_dir" | sed "s/'/'\\\\\\\\''/g"`;; #'( - *) as_qdir=$as_dir;; - esac - as_dirs="'$as_qdir' $as_dirs" - as_dir=`$as_dirname -- "$as_dir" || -$as_expr X"$as_dir" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ - X"$as_dir" : 'X\(//\)[^/]' \| \ - X"$as_dir" : 'X\(//\)$' \| \ - X"$as_dir" : 'X\(/\)' \| . 2>/dev/null || -$as_echo X"$as_dir" | - sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ - s//\1/ - q - } - /^X\(\/\/\)[^/].*/{ - s//\1/ - q - } - /^X\(\/\/\)$/{ - s//\1/ - q - } - /^X\(\/\).*/{ - s//\1/ - q - } - s/.*/./; q'` - test -d "$as_dir" && break - done - test -z "$as_dirs" || eval "mkdir $as_dirs" - } || test -d "$as_dir" || as_fn_error $? "cannot create directory $as_dir" - - -} # as_fn_mkdir_p -# as_fn_append VAR VALUE -# ---------------------- -# Append the text in VALUE to the end of the definition contained in VAR. Take -# advantage of any shell optimizations that allow amortized linear growth over -# repeated appends, instead of the typical quadratic growth present in naive -# implementations. -if (eval "as_var=1; as_var+=2; test x\$as_var = x12") 2>/dev/null; then : - eval 'as_fn_append () - { - eval $1+=\$2 - }' -else - as_fn_append () - { - eval $1=\$$1\$2 - } -fi # as_fn_append - -# as_fn_arith ARG... -# ------------------ -# Perform arithmetic evaluation on the ARGs, and store the result in the -# global $as_val. Take advantage of shells that can avoid forks. The arguments -# must be portable across $(()) and expr. -if (eval "test \$(( 1 + 1 )) = 2") 2>/dev/null; then : - eval 'as_fn_arith () - { - as_val=$(( $* )) - }' -else - as_fn_arith () - { - as_val=`expr "$@" || test $? -eq 1` - } -fi # as_fn_arith - - -# as_fn_error STATUS ERROR [LINENO LOG_FD] -# ---------------------------------------- -# Output "`basename $0`: error: ERROR" to stderr. If LINENO and LOG_FD are -# provided, also output the error to LOG_FD, referencing LINENO. Then exit the -# script with STATUS, using 1 if that was 0. -as_fn_error () -{ - as_status=$1; test $as_status -eq 0 && as_status=1 - if test "$4"; then - as_lineno=${as_lineno-"$3"} as_lineno_stack=as_lineno_stack=$as_lineno_stack - $as_echo "$as_me:${as_lineno-$LINENO}: error: $2" >&$4 - fi - $as_echo "$as_me: error: $2" >&2 - as_fn_exit $as_status -} # as_fn_error - -if expr a : '\(a\)' >/dev/null 2>&1 && - test "X`expr 00001 : '.*\(...\)'`" = X001; then - as_expr=expr -else - as_expr=false -fi - -if (basename -- /) >/dev/null 2>&1 && test "X`basename -- / 2>&1`" = "X/"; then - as_basename=basename -else - as_basename=false -fi - -if (as_dir=`dirname -- /` && test "X$as_dir" = X/) >/dev/null 2>&1; then - as_dirname=dirname -else - as_dirname=false -fi - -as_me=`$as_basename -- "$0" || -$as_expr X/"$0" : '.*/\([^/][^/]*\)/*$' \| \ - X"$0" : 'X\(//\)$' \| \ - X"$0" : 'X\(/\)' \| . 2>/dev/null || -$as_echo X/"$0" | - sed '/^.*\/\([^/][^/]*\)\/*$/{ - s//\1/ - q - } - /^X\/\(\/\/\)$/{ - s//\1/ - q - } - /^X\/\(\/\).*/{ - s//\1/ - q - } - s/.*/./; q'` - -# Avoid depending upon Character Ranges. -as_cr_letters='abcdefghijklmnopqrstuvwxyz' -as_cr_LETTERS='ABCDEFGHIJKLMNOPQRSTUVWXYZ' -as_cr_Letters=$as_cr_letters$as_cr_LETTERS -as_cr_digits='0123456789' -as_cr_alnum=$as_cr_Letters$as_cr_digits - - - as_lineno_1=$LINENO as_lineno_1a=$LINENO - as_lineno_2=$LINENO as_lineno_2a=$LINENO - eval 'test "x$as_lineno_1'$as_run'" != "x$as_lineno_2'$as_run'" && - test "x`expr $as_lineno_1'$as_run' + 1`" = "x$as_lineno_2'$as_run'"' || { - # Blame Lee E. McMahon (1931-1989) for sed's syntax. :-) - sed -n ' - p - /[$]LINENO/= - ' <$as_myself | - sed ' - s/[$]LINENO.*/&-/ - t lineno - b - :lineno - N - :loop - s/[$]LINENO\([^'$as_cr_alnum'_].*\n\)\(.*\)/\2\1\2/ - t loop - s/-\n.*// - ' >$as_me.lineno && - chmod +x "$as_me.lineno" || - { $as_echo "$as_me: error: cannot create $as_me.lineno; rerun with a POSIX shell" >&2; as_fn_exit 1; } - - # Don't try to exec as it changes $[0], causing all sort of problems - # (the dirname of $[0] is not the place where we might find the - # original and so on. Autoconf is especially sensitive to this). - . "./$as_me.lineno" - # Exit status is that of the last command. - exit -} - -ECHO_C= ECHO_N= ECHO_T= -case `echo -n x` in #((((( --n*) - case `echo 'xy\c'` in - *c*) ECHO_T=' ';; # ECHO_T is single tab character. - xy) ECHO_C='\c';; - *) echo `echo ksh88 bug on AIX 6.1` > /dev/null - ECHO_T=' ';; - esac;; -*) - ECHO_N='-n';; -esac - -rm -f conf$$ conf$$.exe conf$$.file -if test -d conf$$.dir; then - rm -f conf$$.dir/conf$$.file -else - rm -f conf$$.dir - mkdir conf$$.dir 2>/dev/null -fi -if (echo >conf$$.file) 2>/dev/null; then - if ln -s conf$$.file conf$$ 2>/dev/null; then - as_ln_s='ln -s' - # ... but there are two gotchas: - # 1) On MSYS, both `ln -s file dir' and `ln file dir' fail. - # 2) DJGPP < 2.04 has no symlinks; `ln -s' creates a wrapper executable. - # In both cases, we have to default to `cp -p'. - ln -s conf$$.file conf$$.dir 2>/dev/null && test ! -f conf$$.exe || - as_ln_s='cp -p' - elif ln conf$$.file conf$$ 2>/dev/null; then - as_ln_s=ln - else - as_ln_s='cp -p' - fi -else - as_ln_s='cp -p' -fi -rm -f conf$$ conf$$.exe conf$$.dir/conf$$.file conf$$.file -rmdir conf$$.dir 2>/dev/null - -if mkdir -p . 2>/dev/null; then - as_mkdir_p='mkdir -p "$as_dir"' -else - test -d ./-p && rmdir ./-p - as_mkdir_p=false -fi - -if test -x / >/dev/null 2>&1; then - as_test_x='test -x' -else - if ls -dL / >/dev/null 2>&1; then - as_ls_L_option=L - else - as_ls_L_option= - fi - as_test_x=' - eval sh -c '\'' - if test -d "$1"; then - test -d "$1/."; - else - case $1 in #( - -*)set "./$1";; - esac; - case `ls -ld'$as_ls_L_option' "$1" 2>/dev/null` in #(( - ???[sx]*):;;*)false;;esac;fi - '\'' sh - ' -fi -as_executable_p=$as_test_x - -# Sed expression to map a string onto a valid CPP name. -as_tr_cpp="eval sed 'y%*$as_cr_letters%P$as_cr_LETTERS%;s%[^_$as_cr_alnum]%_%g'" - -# Sed expression to map a string onto a valid variable name. -as_tr_sh="eval sed 'y%*+%pp%;s%[^_$as_cr_alnum]%_%g'" - - -test -n "$DJDIR" || exec 7<&0 &1 - -# Name of the host. -# hostname on some systems (SVR3.2, old GNU/Linux) returns a bogus exit status, -# so uname gets run too. -ac_hostname=`(hostname || uname -n) 2>/dev/null | sed 1q` - -# -# Initializations. -# -ac_default_prefix=/usr/local -ac_clean_files= -ac_config_libobj_dir=. -LIBOBJS= -cross_compiling=no -subdirs= -MFLAGS= -MAKEFLAGS= - -# Identity of this package. -PACKAGE_NAME= -PACKAGE_TARNAME= -PACKAGE_VERSION= -PACKAGE_STRING= -PACKAGE_BUGREPORT= -PACKAGE_URL= - -ac_unique_file="private.h" -# Factoring default headers for most tests. -ac_includes_default="\ -#include -#ifdef HAVE_SYS_TYPES_H -# include -#endif -#ifdef HAVE_SYS_STAT_H -# include -#endif -#ifdef STDC_HEADERS -# include -# include -#else -# ifdef HAVE_STDLIB_H -# include -# endif -#endif -#ifdef HAVE_STRING_H -# if !defined STDC_HEADERS && defined HAVE_MEMORY_H -# include -# endif -# include -#endif -#ifdef HAVE_STRINGS_H -# include -#endif -#ifdef HAVE_INTTYPES_H -# include -#endif -#ifdef HAVE_STDINT_H -# include -#endif -#ifdef HAVE_UNISTD_H -# include -#endif" - -ac_subst_vars='EGREP -GREP -CPP -FCLIBS -ac_ct_FC -FCFLAGS -FC -OBJEXT -EXEEXT -ac_ct_CC -CPPFLAGS -LDFLAGS -CFLAGS -CC -SET_MAKE -target_alias -host_alias -build_alias -LIBS -ECHO_T -ECHO_N -ECHO_C -DEFS -mandir -localedir -libdir -psdir -pdfdir -dvidir -htmldir -infodir -docdir -oldincludedir -includedir -localstatedir -sharedstatedir -sysconfdir -datadir -datarootdir -libexecdir -sbindir -bindir -program_transform_name -prefix -exec_prefix -PACKAGE_URL -PACKAGE_BUGREPORT -PACKAGE_STRING -PACKAGE_VERSION -PACKAGE_TARNAME -PACKAGE_NAME -PATH_SEPARATOR -SHELL' -ac_subst_files='' -ac_user_opts=' -enable_option_checking -' - ac_precious_vars='build_alias -host_alias -target_alias -CC -CFLAGS -LDFLAGS -LIBS -CPPFLAGS -FC -FCFLAGS -CPP' - - -# Initialize some variables set by options. -ac_init_help= -ac_init_version=false -ac_unrecognized_opts= -ac_unrecognized_sep= -# The variables have the same names as the options, with -# dashes changed to underlines. -cache_file=/dev/null -exec_prefix=NONE -no_create= -no_recursion= -prefix=NONE -program_prefix=NONE -program_suffix=NONE -program_transform_name=s,x,x, -silent= -site= -srcdir= -verbose= -x_includes=NONE -x_libraries=NONE - -# Installation directory options. -# These are left unexpanded so users can "make install exec_prefix=/foo" -# and all the variables that are supposed to be based on exec_prefix -# by default will actually change. -# Use braces instead of parens because sh, perl, etc. also accept them. -# (The list follows the same order as the GNU Coding Standards.) -bindir='${exec_prefix}/bin' -sbindir='${exec_prefix}/sbin' -libexecdir='${exec_prefix}/libexec' -datarootdir='${prefix}/share' -datadir='${datarootdir}' -sysconfdir='${prefix}/etc' -sharedstatedir='${prefix}/com' -localstatedir='${prefix}/var' -includedir='${prefix}/include' -oldincludedir='/usr/include' -docdir='${datarootdir}/doc/${PACKAGE}' -infodir='${datarootdir}/info' -htmldir='${docdir}' -dvidir='${docdir}' -pdfdir='${docdir}' -psdir='${docdir}' -libdir='${exec_prefix}/lib' -localedir='${datarootdir}/locale' -mandir='${datarootdir}/man' - -ac_prev= -ac_dashdash= -for ac_option -do - # If the previous option needs an argument, assign it. - if test -n "$ac_prev"; then - eval $ac_prev=\$ac_option - ac_prev= - continue - fi - - case $ac_option in - *=?*) ac_optarg=`expr "X$ac_option" : '[^=]*=\(.*\)'` ;; - *=) ac_optarg= ;; - *) ac_optarg=yes ;; - esac - - # Accept the important Cygnus configure options, so we can diagnose typos. - - case $ac_dashdash$ac_option in - --) - ac_dashdash=yes ;; - - -bindir | --bindir | --bindi | --bind | --bin | --bi) - ac_prev=bindir ;; - -bindir=* | --bindir=* | --bindi=* | --bind=* | --bin=* | --bi=*) - bindir=$ac_optarg ;; - - -build | --build | --buil | --bui | --bu) - ac_prev=build_alias ;; - -build=* | --build=* | --buil=* | --bui=* | --bu=*) - build_alias=$ac_optarg ;; - - -cache-file | --cache-file | --cache-fil | --cache-fi \ - | --cache-f | --cache- | --cache | --cach | --cac | --ca | --c) - ac_prev=cache_file ;; - -cache-file=* | --cache-file=* | --cache-fil=* | --cache-fi=* \ - | --cache-f=* | --cache-=* | --cache=* | --cach=* | --cac=* | --ca=* | --c=*) - cache_file=$ac_optarg ;; - - --config-cache | -C) - cache_file=config.cache ;; - - -datadir | --datadir | --datadi | --datad) - ac_prev=datadir ;; - -datadir=* | --datadir=* | --datadi=* | --datad=*) - datadir=$ac_optarg ;; - - -datarootdir | --datarootdir | --datarootdi | --datarootd | --dataroot \ - | --dataroo | --dataro | --datar) - ac_prev=datarootdir ;; - -datarootdir=* | --datarootdir=* | --datarootdi=* | --datarootd=* \ - | --dataroot=* | --dataroo=* | --dataro=* | --datar=*) - datarootdir=$ac_optarg ;; - - -disable-* | --disable-*) - ac_useropt=`expr "x$ac_option" : 'x-*disable-\(.*\)'` - # Reject names that are not valid shell variable names. - expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null && - as_fn_error $? "invalid feature name: $ac_useropt" - ac_useropt_orig=$ac_useropt - ac_useropt=`$as_echo "$ac_useropt" | sed 's/[-+.]/_/g'` - case $ac_user_opts in - *" -"enable_$ac_useropt" -"*) ;; - *) ac_unrecognized_opts="$ac_unrecognized_opts$ac_unrecognized_sep--disable-$ac_useropt_orig" - ac_unrecognized_sep=', ';; - esac - eval enable_$ac_useropt=no ;; - - -docdir | --docdir | --docdi | --doc | --do) - ac_prev=docdir ;; - -docdir=* | --docdir=* | --docdi=* | --doc=* | --do=*) - docdir=$ac_optarg ;; - - -dvidir | --dvidir | --dvidi | --dvid | --dvi | --dv) - ac_prev=dvidir ;; - -dvidir=* | --dvidir=* | --dvidi=* | --dvid=* | --dvi=* | --dv=*) - dvidir=$ac_optarg ;; - - -enable-* | --enable-*) - ac_useropt=`expr "x$ac_option" : 'x-*enable-\([^=]*\)'` - # Reject names that are not valid shell variable names. - expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null && - as_fn_error $? "invalid feature name: $ac_useropt" - ac_useropt_orig=$ac_useropt - ac_useropt=`$as_echo "$ac_useropt" | sed 's/[-+.]/_/g'` - case $ac_user_opts in - *" -"enable_$ac_useropt" -"*) ;; - *) ac_unrecognized_opts="$ac_unrecognized_opts$ac_unrecognized_sep--enable-$ac_useropt_orig" - ac_unrecognized_sep=', ';; - esac - eval enable_$ac_useropt=\$ac_optarg ;; - - -exec-prefix | --exec_prefix | --exec-prefix | --exec-prefi \ - | --exec-pref | --exec-pre | --exec-pr | --exec-p | --exec- \ - | --exec | --exe | --ex) - ac_prev=exec_prefix ;; - -exec-prefix=* | --exec_prefix=* | --exec-prefix=* | --exec-prefi=* \ - | --exec-pref=* | --exec-pre=* | --exec-pr=* | --exec-p=* | --exec-=* \ - | --exec=* | --exe=* | --ex=*) - exec_prefix=$ac_optarg ;; - - -gas | --gas | --ga | --g) - # Obsolete; use --with-gas. - with_gas=yes ;; - - -help | --help | --hel | --he | -h) - ac_init_help=long ;; - -help=r* | --help=r* | --hel=r* | --he=r* | -hr*) - ac_init_help=recursive ;; - -help=s* | --help=s* | --hel=s* | --he=s* | -hs*) - ac_init_help=short ;; - - -host | --host | --hos | --ho) - ac_prev=host_alias ;; - -host=* | --host=* | --hos=* | --ho=*) - host_alias=$ac_optarg ;; - - -htmldir | --htmldir | --htmldi | --htmld | --html | --htm | --ht) - ac_prev=htmldir ;; - -htmldir=* | --htmldir=* | --htmldi=* | --htmld=* | --html=* | --htm=* \ - | --ht=*) - htmldir=$ac_optarg ;; - - -includedir | --includedir | --includedi | --included | --include \ - | --includ | --inclu | --incl | --inc) - ac_prev=includedir ;; - -includedir=* | --includedir=* | --includedi=* | --included=* | --include=* \ - | --includ=* | --inclu=* | --incl=* | --inc=*) - includedir=$ac_optarg ;; - - -infodir | --infodir | --infodi | --infod | --info | --inf) - ac_prev=infodir ;; - -infodir=* | --infodir=* | --infodi=* | --infod=* | --info=* | --inf=*) - infodir=$ac_optarg ;; - - -libdir | --libdir | --libdi | --libd) - ac_prev=libdir ;; - -libdir=* | --libdir=* | --libdi=* | --libd=*) - libdir=$ac_optarg ;; - - -libexecdir | --libexecdir | --libexecdi | --libexecd | --libexec \ - | --libexe | --libex | --libe) - ac_prev=libexecdir ;; - -libexecdir=* | --libexecdir=* | --libexecdi=* | --libexecd=* | --libexec=* \ - | --libexe=* | --libex=* | --libe=*) - libexecdir=$ac_optarg ;; - - -localedir | --localedir | --localedi | --localed | --locale) - ac_prev=localedir ;; - -localedir=* | --localedir=* | --localedi=* | --localed=* | --locale=*) - localedir=$ac_optarg ;; - - -localstatedir | --localstatedir | --localstatedi | --localstated \ - | --localstate | --localstat | --localsta | --localst | --locals) - ac_prev=localstatedir ;; - -localstatedir=* | --localstatedir=* | --localstatedi=* | --localstated=* \ - | --localstate=* | --localstat=* | --localsta=* | --localst=* | --locals=*) - localstatedir=$ac_optarg ;; - - -mandir | --mandir | --mandi | --mand | --man | --ma | --m) - ac_prev=mandir ;; - -mandir=* | --mandir=* | --mandi=* | --mand=* | --man=* | --ma=* | --m=*) - mandir=$ac_optarg ;; - - -nfp | --nfp | --nf) - # Obsolete; use --without-fp. - with_fp=no ;; - - -no-create | --no-create | --no-creat | --no-crea | --no-cre \ - | --no-cr | --no-c | -n) - no_create=yes ;; - - -no-recursion | --no-recursion | --no-recursio | --no-recursi \ - | --no-recurs | --no-recur | --no-recu | --no-rec | --no-re | --no-r) - no_recursion=yes ;; - - -oldincludedir | --oldincludedir | --oldincludedi | --oldincluded \ - | --oldinclude | --oldinclud | --oldinclu | --oldincl | --oldinc \ - | --oldin | --oldi | --old | --ol | --o) - ac_prev=oldincludedir ;; - -oldincludedir=* | --oldincludedir=* | --oldincludedi=* | --oldincluded=* \ - | --oldinclude=* | --oldinclud=* | --oldinclu=* | --oldincl=* | --oldinc=* \ - | --oldin=* | --oldi=* | --old=* | --ol=* | --o=*) - oldincludedir=$ac_optarg ;; - - -prefix | --prefix | --prefi | --pref | --pre | --pr | --p) - ac_prev=prefix ;; - -prefix=* | --prefix=* | --prefi=* | --pref=* | --pre=* | --pr=* | --p=*) - prefix=$ac_optarg ;; - - -program-prefix | --program-prefix | --program-prefi | --program-pref \ - | --program-pre | --program-pr | --program-p) - ac_prev=program_prefix ;; - -program-prefix=* | --program-prefix=* | --program-prefi=* \ - | --program-pref=* | --program-pre=* | --program-pr=* | --program-p=*) - program_prefix=$ac_optarg ;; - - -program-suffix | --program-suffix | --program-suffi | --program-suff \ - | --program-suf | --program-su | --program-s) - ac_prev=program_suffix ;; - -program-suffix=* | --program-suffix=* | --program-suffi=* \ - | --program-suff=* | --program-suf=* | --program-su=* | --program-s=*) - program_suffix=$ac_optarg ;; - - -program-transform-name | --program-transform-name \ - | --program-transform-nam | --program-transform-na \ - | --program-transform-n | --program-transform- \ - | --program-transform | --program-transfor \ - | --program-transfo | --program-transf \ - | --program-trans | --program-tran \ - | --progr-tra | --program-tr | --program-t) - ac_prev=program_transform_name ;; - -program-transform-name=* | --program-transform-name=* \ - | --program-transform-nam=* | --program-transform-na=* \ - | --program-transform-n=* | --program-transform-=* \ - | --program-transform=* | --program-transfor=* \ - | --program-transfo=* | --program-transf=* \ - | --program-trans=* | --program-tran=* \ - | --progr-tra=* | --program-tr=* | --program-t=*) - program_transform_name=$ac_optarg ;; - - -pdfdir | --pdfdir | --pdfdi | --pdfd | --pdf | --pd) - ac_prev=pdfdir ;; - -pdfdir=* | --pdfdir=* | --pdfdi=* | --pdfd=* | --pdf=* | --pd=*) - pdfdir=$ac_optarg ;; - - -psdir | --psdir | --psdi | --psd | --ps) - ac_prev=psdir ;; - -psdir=* | --psdir=* | --psdi=* | --psd=* | --ps=*) - psdir=$ac_optarg ;; - - -q | -quiet | --quiet | --quie | --qui | --qu | --q \ - | -silent | --silent | --silen | --sile | --sil) - silent=yes ;; - - -sbindir | --sbindir | --sbindi | --sbind | --sbin | --sbi | --sb) - ac_prev=sbindir ;; - -sbindir=* | --sbindir=* | --sbindi=* | --sbind=* | --sbin=* \ - | --sbi=* | --sb=*) - sbindir=$ac_optarg ;; - - -sharedstatedir | --sharedstatedir | --sharedstatedi \ - | --sharedstated | --sharedstate | --sharedstat | --sharedsta \ - | --sharedst | --shareds | --shared | --share | --shar \ - | --sha | --sh) - ac_prev=sharedstatedir ;; - -sharedstatedir=* | --sharedstatedir=* | --sharedstatedi=* \ - | --sharedstated=* | --sharedstate=* | --sharedstat=* | --sharedsta=* \ - | --sharedst=* | --shareds=* | --shared=* | --share=* | --shar=* \ - | --sha=* | --sh=*) - sharedstatedir=$ac_optarg ;; - - -site | --site | --sit) - ac_prev=site ;; - -site=* | --site=* | --sit=*) - site=$ac_optarg ;; - - -srcdir | --srcdir | --srcdi | --srcd | --src | --sr) - ac_prev=srcdir ;; - -srcdir=* | --srcdir=* | --srcdi=* | --srcd=* | --src=* | --sr=*) - srcdir=$ac_optarg ;; - - -sysconfdir | --sysconfdir | --sysconfdi | --sysconfd | --sysconf \ - | --syscon | --sysco | --sysc | --sys | --sy) - ac_prev=sysconfdir ;; - -sysconfdir=* | --sysconfdir=* | --sysconfdi=* | --sysconfd=* | --sysconf=* \ - | --syscon=* | --sysco=* | --sysc=* | --sys=* | --sy=*) - sysconfdir=$ac_optarg ;; - - -target | --target | --targe | --targ | --tar | --ta | --t) - ac_prev=target_alias ;; - -target=* | --target=* | --targe=* | --targ=* | --tar=* | --ta=* | --t=*) - target_alias=$ac_optarg ;; - - -v | -verbose | --verbose | --verbos | --verbo | --verb) - verbose=yes ;; - - -version | --version | --versio | --versi | --vers | -V) - ac_init_version=: ;; - - -with-* | --with-*) - ac_useropt=`expr "x$ac_option" : 'x-*with-\([^=]*\)'` - # Reject names that are not valid shell variable names. - expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null && - as_fn_error $? "invalid package name: $ac_useropt" - ac_useropt_orig=$ac_useropt - ac_useropt=`$as_echo "$ac_useropt" | sed 's/[-+.]/_/g'` - case $ac_user_opts in - *" -"with_$ac_useropt" -"*) ;; - *) ac_unrecognized_opts="$ac_unrecognized_opts$ac_unrecognized_sep--with-$ac_useropt_orig" - ac_unrecognized_sep=', ';; - esac - eval with_$ac_useropt=\$ac_optarg ;; - - -without-* | --without-*) - ac_useropt=`expr "x$ac_option" : 'x-*without-\(.*\)'` - # Reject names that are not valid shell variable names. - expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null && - as_fn_error $? "invalid package name: $ac_useropt" - ac_useropt_orig=$ac_useropt - ac_useropt=`$as_echo "$ac_useropt" | sed 's/[-+.]/_/g'` - case $ac_user_opts in - *" -"with_$ac_useropt" -"*) ;; - *) ac_unrecognized_opts="$ac_unrecognized_opts$ac_unrecognized_sep--without-$ac_useropt_orig" - ac_unrecognized_sep=', ';; - esac - eval with_$ac_useropt=no ;; - - --x) - # Obsolete; use --with-x. - with_x=yes ;; - - -x-includes | --x-includes | --x-include | --x-includ | --x-inclu \ - | --x-incl | --x-inc | --x-in | --x-i) - ac_prev=x_includes ;; - -x-includes=* | --x-includes=* | --x-include=* | --x-includ=* | --x-inclu=* \ - | --x-incl=* | --x-inc=* | --x-in=* | --x-i=*) - x_includes=$ac_optarg ;; - - -x-libraries | --x-libraries | --x-librarie | --x-librari \ - | --x-librar | --x-libra | --x-libr | --x-lib | --x-li | --x-l) - ac_prev=x_libraries ;; - -x-libraries=* | --x-libraries=* | --x-librarie=* | --x-librari=* \ - | --x-librar=* | --x-libra=* | --x-libr=* | --x-lib=* | --x-li=* | --x-l=*) - x_libraries=$ac_optarg ;; - - -*) as_fn_error $? "unrecognized option: \`$ac_option' -Try \`$0 --help' for more information" - ;; - - *=*) - ac_envvar=`expr "x$ac_option" : 'x\([^=]*\)='` - # Reject names that are not valid shell variable names. - case $ac_envvar in #( - '' | [0-9]* | *[!_$as_cr_alnum]* ) - as_fn_error $? "invalid variable name: \`$ac_envvar'" ;; - esac - eval $ac_envvar=\$ac_optarg - export $ac_envvar ;; - - *) - # FIXME: should be removed in autoconf 3.0. - $as_echo "$as_me: WARNING: you should use --build, --host, --target" >&2 - expr "x$ac_option" : ".*[^-._$as_cr_alnum]" >/dev/null && - $as_echo "$as_me: WARNING: invalid host type: $ac_option" >&2 - : "${build_alias=$ac_option} ${host_alias=$ac_option} ${target_alias=$ac_option}" - ;; - - esac -done - -if test -n "$ac_prev"; then - ac_option=--`echo $ac_prev | sed 's/_/-/g'` - as_fn_error $? "missing argument to $ac_option" -fi - -if test -n "$ac_unrecognized_opts"; then - case $enable_option_checking in - no) ;; - fatal) as_fn_error $? "unrecognized options: $ac_unrecognized_opts" ;; - *) $as_echo "$as_me: WARNING: unrecognized options: $ac_unrecognized_opts" >&2 ;; - esac -fi - -# Check all directory arguments for consistency. -for ac_var in exec_prefix prefix bindir sbindir libexecdir datarootdir \ - datadir sysconfdir sharedstatedir localstatedir includedir \ - oldincludedir docdir infodir htmldir dvidir pdfdir psdir \ - libdir localedir mandir -do - eval ac_val=\$$ac_var - # Remove trailing slashes. - case $ac_val in - */ ) - ac_val=`expr "X$ac_val" : 'X\(.*[^/]\)' \| "X$ac_val" : 'X\(.*\)'` - eval $ac_var=\$ac_val;; - esac - # Be sure to have absolute directory names. - case $ac_val in - [\\/$]* | ?:[\\/]* ) continue;; - NONE | '' ) case $ac_var in *prefix ) continue;; esac;; - esac - as_fn_error $? "expected an absolute directory name for --$ac_var: $ac_val" -done - -# There might be people who depend on the old broken behavior: `$host' -# used to hold the argument of --host etc. -# FIXME: To remove some day. -build=$build_alias -host=$host_alias -target=$target_alias - -# FIXME: To remove some day. -if test "x$host_alias" != x; then - if test "x$build_alias" = x; then - cross_compiling=maybe - $as_echo "$as_me: WARNING: if you wanted to set the --build type, don't use --host. - If a cross compiler is detected then cross compile mode will be used" >&2 - elif test "x$build_alias" != "x$host_alias"; then - cross_compiling=yes - fi -fi - -ac_tool_prefix= -test -n "$host_alias" && ac_tool_prefix=$host_alias- - -test "$silent" = yes && exec 6>/dev/null - - -ac_pwd=`pwd` && test -n "$ac_pwd" && -ac_ls_di=`ls -di .` && -ac_pwd_ls_di=`cd "$ac_pwd" && ls -di .` || - as_fn_error $? "working directory cannot be determined" -test "X$ac_ls_di" = "X$ac_pwd_ls_di" || - as_fn_error $? "pwd does not report name of working directory" - - -# Find the source files, if location was not specified. -if test -z "$srcdir"; then - ac_srcdir_defaulted=yes - # Try the directory containing this script, then the parent directory. - ac_confdir=`$as_dirname -- "$as_myself" || -$as_expr X"$as_myself" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ - X"$as_myself" : 'X\(//\)[^/]' \| \ - X"$as_myself" : 'X\(//\)$' \| \ - X"$as_myself" : 'X\(/\)' \| . 2>/dev/null || -$as_echo X"$as_myself" | - sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ - s//\1/ - q - } - /^X\(\/\/\)[^/].*/{ - s//\1/ - q - } - /^X\(\/\/\)$/{ - s//\1/ - q - } - /^X\(\/\).*/{ - s//\1/ - q - } - s/.*/./; q'` - srcdir=$ac_confdir - if test ! -r "$srcdir/$ac_unique_file"; then - srcdir=.. - fi -else - ac_srcdir_defaulted=no -fi -if test ! -r "$srcdir/$ac_unique_file"; then - test "$ac_srcdir_defaulted" = yes && srcdir="$ac_confdir or .." - as_fn_error $? "cannot find sources ($ac_unique_file) in $srcdir" -fi -ac_msg="sources are in $srcdir, but \`cd $srcdir' does not work" -ac_abs_confdir=`( - cd "$srcdir" && test -r "./$ac_unique_file" || as_fn_error $? "$ac_msg" - pwd)` -# When building in place, set srcdir=. -if test "$ac_abs_confdir" = "$ac_pwd"; then - srcdir=. -fi -# Remove unnecessary trailing slashes from srcdir. -# Double slashes in file names in object file debugging info -# mess up M-x gdb in Emacs. -case $srcdir in -*/) srcdir=`expr "X$srcdir" : 'X\(.*[^/]\)' \| "X$srcdir" : 'X\(.*\)'`;; -esac -for ac_var in $ac_precious_vars; do - eval ac_env_${ac_var}_set=\${${ac_var}+set} - eval ac_env_${ac_var}_value=\$${ac_var} - eval ac_cv_env_${ac_var}_set=\${${ac_var}+set} - eval ac_cv_env_${ac_var}_value=\$${ac_var} -done - -# -# Report the --help message. -# -if test "$ac_init_help" = "long"; then - # Omit some internal or obsolete options to make the list less imposing. - # This message is too long to be a string in the A/UX 3.1 sh. - cat <<_ACEOF -\`configure' configures this package to adapt to many kinds of systems. - -Usage: $0 [OPTION]... [VAR=VALUE]... - -To assign environment variables (e.g., CC, CFLAGS...), specify them as -VAR=VALUE. See below for descriptions of some of the useful variables. - -Defaults for the options are specified in brackets. - -Configuration: - -h, --help display this help and exit - --help=short display options specific to this package - --help=recursive display the short help of all the included packages - -V, --version display version information and exit - -q, --quiet, --silent do not print \`checking ...' messages - --cache-file=FILE cache test results in FILE [disabled] - -C, --config-cache alias for \`--cache-file=config.cache' - -n, --no-create do not create output files - --srcdir=DIR find the sources in DIR [configure dir or \`..'] - -Installation directories: - --prefix=PREFIX install architecture-independent files in PREFIX - [$ac_default_prefix] - --exec-prefix=EPREFIX install architecture-dependent files in EPREFIX - [PREFIX] - -By default, \`make install' will install all the files in -\`$ac_default_prefix/bin', \`$ac_default_prefix/lib' etc. You can specify -an installation prefix other than \`$ac_default_prefix' using \`--prefix', -for instance \`--prefix=\$HOME'. - -For better control, use the options below. - -Fine tuning of the installation directories: - --bindir=DIR user executables [EPREFIX/bin] - --sbindir=DIR system admin executables [EPREFIX/sbin] - --libexecdir=DIR program executables [EPREFIX/libexec] - --sysconfdir=DIR read-only single-machine data [PREFIX/etc] - --sharedstatedir=DIR modifiable architecture-independent data [PREFIX/com] - --localstatedir=DIR modifiable single-machine data [PREFIX/var] - --libdir=DIR object code libraries [EPREFIX/lib] - --includedir=DIR C header files [PREFIX/include] - --oldincludedir=DIR C header files for non-gcc [/usr/include] - --datarootdir=DIR read-only arch.-independent data root [PREFIX/share] - --datadir=DIR read-only architecture-independent data [DATAROOTDIR] - --infodir=DIR info documentation [DATAROOTDIR/info] - --localedir=DIR locale-dependent data [DATAROOTDIR/locale] - --mandir=DIR man documentation [DATAROOTDIR/man] - --docdir=DIR documentation root [DATAROOTDIR/doc/PACKAGE] - --htmldir=DIR html documentation [DOCDIR] - --dvidir=DIR dvi documentation [DOCDIR] - --pdfdir=DIR pdf documentation [DOCDIR] - --psdir=DIR ps documentation [DOCDIR] -_ACEOF - - cat <<\_ACEOF -_ACEOF -fi - -if test -n "$ac_init_help"; then - - cat <<\_ACEOF - -Some influential environment variables: - CC C compiler command - CFLAGS C compiler flags - LDFLAGS linker flags, e.g. -L if you have libraries in a - nonstandard directory - LIBS libraries to pass to the linker, e.g. -l - CPPFLAGS (Objective) C/C++ preprocessor flags, e.g. -I if - you have headers in a nonstandard directory - FC Fortran compiler command - FCFLAGS Fortran compiler flags - CPP C preprocessor - -Use these variables to override the choices made by `configure' or to help -it to find libraries and programs with nonstandard names/locations. - -Report bugs to the package provider. -_ACEOF -ac_status=$? -fi - -if test "$ac_init_help" = "recursive"; then - # If there are subdirs, report their specific --help. - for ac_dir in : $ac_subdirs_all; do test "x$ac_dir" = x: && continue - test -d "$ac_dir" || - { cd "$srcdir" && ac_pwd=`pwd` && srcdir=. && test -d "$ac_dir"; } || - continue - ac_builddir=. - -case "$ac_dir" in -.) ac_dir_suffix= ac_top_builddir_sub=. ac_top_build_prefix= ;; -*) - ac_dir_suffix=/`$as_echo "$ac_dir" | sed 's|^\.[\\/]||'` - # A ".." for each directory in $ac_dir_suffix. - ac_top_builddir_sub=`$as_echo "$ac_dir_suffix" | sed 's|/[^\\/]*|/..|g;s|/||'` - case $ac_top_builddir_sub in - "") ac_top_builddir_sub=. ac_top_build_prefix= ;; - *) ac_top_build_prefix=$ac_top_builddir_sub/ ;; - esac ;; -esac -ac_abs_top_builddir=$ac_pwd -ac_abs_builddir=$ac_pwd$ac_dir_suffix -# for backward compatibility: -ac_top_builddir=$ac_top_build_prefix - -case $srcdir in - .) # We are building in place. - ac_srcdir=. - ac_top_srcdir=$ac_top_builddir_sub - ac_abs_top_srcdir=$ac_pwd ;; - [\\/]* | ?:[\\/]* ) # Absolute name. - ac_srcdir=$srcdir$ac_dir_suffix; - ac_top_srcdir=$srcdir - ac_abs_top_srcdir=$srcdir ;; - *) # Relative name. - ac_srcdir=$ac_top_build_prefix$srcdir$ac_dir_suffix - ac_top_srcdir=$ac_top_build_prefix$srcdir - ac_abs_top_srcdir=$ac_pwd/$srcdir ;; -esac -ac_abs_srcdir=$ac_abs_top_srcdir$ac_dir_suffix - - cd "$ac_dir" || { ac_status=$?; continue; } - # Check for guested configure. - if test -f "$ac_srcdir/configure.gnu"; then - echo && - $SHELL "$ac_srcdir/configure.gnu" --help=recursive - elif test -f "$ac_srcdir/configure"; then - echo && - $SHELL "$ac_srcdir/configure" --help=recursive - else - $as_echo "$as_me: WARNING: no configuration information is in $ac_dir" >&2 - fi || ac_status=$? - cd "$ac_pwd" || { ac_status=$?; break; } - done -fi - -test -n "$ac_init_help" && exit $ac_status -if $ac_init_version; then - cat <<\_ACEOF -configure -generated by GNU Autoconf 2.68 - -Copyright (C) 2010 Free Software Foundation, Inc. -This configure script is free software; the Free Software Foundation -gives unlimited permission to copy, distribute and modify it. -_ACEOF - exit -fi - -## ------------------------ ## -## Autoconf initialization. ## -## ------------------------ ## - -# ac_fn_c_try_compile LINENO -# -------------------------- -# Try to compile conftest.$ac_ext, and return whether this succeeded. -ac_fn_c_try_compile () -{ - as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack - rm -f conftest.$ac_objext - if { { ac_try="$ac_compile" -case "(($ac_try" in - *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; - *) ac_try_echo=$ac_try;; -esac -eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" -$as_echo "$ac_try_echo"; } >&5 - (eval "$ac_compile") 2>conftest.err - ac_status=$? - if test -s conftest.err; then - grep -v '^ *+' conftest.err >conftest.er1 - cat conftest.er1 >&5 - mv -f conftest.er1 conftest.err - fi - $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 - test $ac_status = 0; } && { - test -z "$ac_c_werror_flag" || - test ! -s conftest.err - } && test -s conftest.$ac_objext; then : - ac_retval=0 -else - $as_echo "$as_me: failed program was:" >&5 -sed 's/^/| /' conftest.$ac_ext >&5 - - ac_retval=1 -fi - eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno - as_fn_set_status $ac_retval - -} # ac_fn_c_try_compile - -# ac_fn_fc_try_compile LINENO -# --------------------------- -# Try to compile conftest.$ac_ext, and return whether this succeeded. -ac_fn_fc_try_compile () -{ - as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack - rm -f conftest.$ac_objext - if { { ac_try="$ac_compile" -case "(($ac_try" in - *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; - *) ac_try_echo=$ac_try;; -esac -eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" -$as_echo "$ac_try_echo"; } >&5 - (eval "$ac_compile") 2>conftest.err - ac_status=$? - if test -s conftest.err; then - grep -v '^ *+' conftest.err >conftest.er1 - cat conftest.er1 >&5 - mv -f conftest.er1 conftest.err - fi - $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 - test $ac_status = 0; } && { - test -z "$ac_fc_werror_flag" || - test ! -s conftest.err - } && test -s conftest.$ac_objext; then : - ac_retval=0 -else - $as_echo "$as_me: failed program was:" >&5 -sed 's/^/| /' conftest.$ac_ext >&5 - - ac_retval=1 -fi - eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno - as_fn_set_status $ac_retval - -} # ac_fn_fc_try_compile - -# ac_fn_c_try_link LINENO -# ----------------------- -# Try to link conftest.$ac_ext, and return whether this succeeded. -ac_fn_c_try_link () -{ - as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack - rm -f conftest.$ac_objext conftest$ac_exeext - if { { ac_try="$ac_link" -case "(($ac_try" in - *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; - *) ac_try_echo=$ac_try;; -esac -eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" -$as_echo "$ac_try_echo"; } >&5 - (eval "$ac_link") 2>conftest.err - ac_status=$? - if test -s conftest.err; then - grep -v '^ *+' conftest.err >conftest.er1 - cat conftest.er1 >&5 - mv -f conftest.er1 conftest.err - fi - $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 - test $ac_status = 0; } && { - test -z "$ac_c_werror_flag" || - test ! -s conftest.err - } && test -s conftest$ac_exeext && { - test "$cross_compiling" = yes || - $as_test_x conftest$ac_exeext - }; then : - ac_retval=0 -else - $as_echo "$as_me: failed program was:" >&5 -sed 's/^/| /' conftest.$ac_ext >&5 - - ac_retval=1 -fi - # Delete the IPA/IPO (Inter Procedural Analysis/Optimization) information - # created by the PGI compiler (conftest_ipa8_conftest.oo), as it would - # interfere with the next link command; also delete a directory that is - # left behind by Apple's compiler. We do this before executing the actions. - rm -rf conftest.dSYM conftest_ipa8_conftest.oo - eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno - as_fn_set_status $ac_retval - -} # ac_fn_c_try_link - -# ac_fn_c_check_func LINENO FUNC VAR -# ---------------------------------- -# Tests whether FUNC exists, setting the cache variable VAR accordingly -ac_fn_c_check_func () -{ - as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack - { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $2" >&5 -$as_echo_n "checking for $2... " >&6; } -if eval \${$3+:} false; then : - $as_echo_n "(cached) " >&6 -else - cat confdefs.h - <<_ACEOF >conftest.$ac_ext -/* end confdefs.h. */ -/* Define $2 to an innocuous variant, in case declares $2. - For example, HP-UX 11i declares gettimeofday. */ -#define $2 innocuous_$2 - -/* System header to define __stub macros and hopefully few prototypes, - which can conflict with char $2 (); below. - Prefer to if __STDC__ is defined, since - exists even on freestanding compilers. */ - -#ifdef __STDC__ -# include -#else -# include -#endif - -#undef $2 - -/* Override any GCC internal prototype to avoid an error. - Use char because int might match the return type of a GCC - builtin and then its argument prototype would still apply. */ -#ifdef __cplusplus -extern "C" -#endif -char $2 (); -/* The GNU C library defines this for functions which it implements - to always fail with ENOSYS. Some functions are actually named - something starting with __ and the normal name is an alias. */ -#if defined __stub_$2 || defined __stub___$2 -choke me -#endif - -#ifdef FC_DUMMY_MAIN -#ifndef FC_DUMMY_MAIN_EQ_F77 -# ifdef __cplusplus - extern "C" -# endif - int FC_DUMMY_MAIN() { return 1; } -#endif -#endif -int -main () -{ -return $2 (); - ; - return 0; -} -_ACEOF -if ac_fn_c_try_link "$LINENO"; then : - eval "$3=yes" -else - eval "$3=no" -fi -rm -f core conftest.err conftest.$ac_objext \ - conftest$ac_exeext conftest.$ac_ext -fi -eval ac_res=\$$3 - { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_res" >&5 -$as_echo "$ac_res" >&6; } - eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno - -} # ac_fn_c_check_func - -# ac_fn_c_try_run LINENO -# ---------------------- -# Try to link conftest.$ac_ext, and return whether this succeeded. Assumes -# that executables *can* be run. -ac_fn_c_try_run () -{ - as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack - if { { ac_try="$ac_link" -case "(($ac_try" in - *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; - *) ac_try_echo=$ac_try;; -esac -eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" -$as_echo "$ac_try_echo"; } >&5 - (eval "$ac_link") 2>&5 - ac_status=$? - $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 - test $ac_status = 0; } && { ac_try='./conftest$ac_exeext' - { { case "(($ac_try" in - *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; - *) ac_try_echo=$ac_try;; -esac -eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" -$as_echo "$ac_try_echo"; } >&5 - (eval "$ac_try") 2>&5 - ac_status=$? - $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 - test $ac_status = 0; }; }; then : - ac_retval=0 -else - $as_echo "$as_me: program exited with status $ac_status" >&5 - $as_echo "$as_me: failed program was:" >&5 -sed 's/^/| /' conftest.$ac_ext >&5 - - ac_retval=$ac_status -fi - rm -rf conftest.dSYM conftest_ipa8_conftest.oo - eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno - as_fn_set_status $ac_retval - -} # ac_fn_c_try_run - -# ac_fn_c_compute_int LINENO EXPR VAR INCLUDES -# -------------------------------------------- -# Tries to find the compile-time value of EXPR in a program that includes -# INCLUDES, setting VAR accordingly. Returns whether the value could be -# computed -ac_fn_c_compute_int () -{ - as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack - if test "$cross_compiling" = yes; then - # Depending upon the size, compute the lo and hi bounds. -cat confdefs.h - <<_ACEOF >conftest.$ac_ext -/* end confdefs.h. */ -$4 -#ifdef FC_DUMMY_MAIN -#ifndef FC_DUMMY_MAIN_EQ_F77 -# ifdef __cplusplus - extern "C" -# endif - int FC_DUMMY_MAIN() { return 1; } -#endif -#endif -int -main () -{ -static int test_array [1 - 2 * !(($2) >= 0)]; -test_array [0] = 0 - - ; - return 0; -} -_ACEOF -if ac_fn_c_try_compile "$LINENO"; then : - ac_lo=0 ac_mid=0 - while :; do - cat confdefs.h - <<_ACEOF >conftest.$ac_ext -/* end confdefs.h. */ -$4 -#ifdef FC_DUMMY_MAIN -#ifndef FC_DUMMY_MAIN_EQ_F77 -# ifdef __cplusplus - extern "C" -# endif - int FC_DUMMY_MAIN() { return 1; } -#endif -#endif -int -main () -{ -static int test_array [1 - 2 * !(($2) <= $ac_mid)]; -test_array [0] = 0 - - ; - return 0; -} -_ACEOF -if ac_fn_c_try_compile "$LINENO"; then : - ac_hi=$ac_mid; break -else - as_fn_arith $ac_mid + 1 && ac_lo=$as_val - if test $ac_lo -le $ac_mid; then - ac_lo= ac_hi= - break - fi - as_fn_arith 2 '*' $ac_mid + 1 && ac_mid=$as_val -fi -rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext - done -else - cat confdefs.h - <<_ACEOF >conftest.$ac_ext -/* end confdefs.h. */ -$4 -#ifdef FC_DUMMY_MAIN -#ifndef FC_DUMMY_MAIN_EQ_F77 -# ifdef __cplusplus - extern "C" -# endif - int FC_DUMMY_MAIN() { return 1; } -#endif -#endif -int -main () -{ -static int test_array [1 - 2 * !(($2) < 0)]; -test_array [0] = 0 - - ; - return 0; -} -_ACEOF -if ac_fn_c_try_compile "$LINENO"; then : - ac_hi=-1 ac_mid=-1 - while :; do - cat confdefs.h - <<_ACEOF >conftest.$ac_ext -/* end confdefs.h. */ -$4 -#ifdef FC_DUMMY_MAIN -#ifndef FC_DUMMY_MAIN_EQ_F77 -# ifdef __cplusplus - extern "C" -# endif - int FC_DUMMY_MAIN() { return 1; } -#endif -#endif -int -main () -{ -static int test_array [1 - 2 * !(($2) >= $ac_mid)]; -test_array [0] = 0 - - ; - return 0; -} -_ACEOF -if ac_fn_c_try_compile "$LINENO"; then : - ac_lo=$ac_mid; break -else - as_fn_arith '(' $ac_mid ')' - 1 && ac_hi=$as_val - if test $ac_mid -le $ac_hi; then - ac_lo= ac_hi= - break - fi - as_fn_arith 2 '*' $ac_mid && ac_mid=$as_val -fi -rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext - done -else - ac_lo= ac_hi= -fi -rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext -fi -rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext -# Binary search between lo and hi bounds. -while test "x$ac_lo" != "x$ac_hi"; do - as_fn_arith '(' $ac_hi - $ac_lo ')' / 2 + $ac_lo && ac_mid=$as_val - cat confdefs.h - <<_ACEOF >conftest.$ac_ext -/* end confdefs.h. */ -$4 -#ifdef FC_DUMMY_MAIN -#ifndef FC_DUMMY_MAIN_EQ_F77 -# ifdef __cplusplus - extern "C" -# endif - int FC_DUMMY_MAIN() { return 1; } -#endif -#endif -int -main () -{ -static int test_array [1 - 2 * !(($2) <= $ac_mid)]; -test_array [0] = 0 - - ; - return 0; -} -_ACEOF -if ac_fn_c_try_compile "$LINENO"; then : - ac_hi=$ac_mid -else - as_fn_arith '(' $ac_mid ')' + 1 && ac_lo=$as_val -fi -rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext -done -case $ac_lo in #(( -?*) eval "$3=\$ac_lo"; ac_retval=0 ;; -'') ac_retval=1 ;; -esac - else - cat confdefs.h - <<_ACEOF >conftest.$ac_ext -/* end confdefs.h. */ -$4 -static long int longval () { return $2; } -static unsigned long int ulongval () { return $2; } -#include -#include -#ifdef FC_DUMMY_MAIN -#ifndef FC_DUMMY_MAIN_EQ_F77 -# ifdef __cplusplus - extern "C" -# endif - int FC_DUMMY_MAIN() { return 1; } -#endif -#endif -int -main () -{ - - FILE *f = fopen ("conftest.val", "w"); - if (! f) - return 1; - if (($2) < 0) - { - long int i = longval (); - if (i != ($2)) - return 1; - fprintf (f, "%ld", i); - } - else - { - unsigned long int i = ulongval (); - if (i != ($2)) - return 1; - fprintf (f, "%lu", i); - } - /* Do not output a trailing newline, as this causes \r\n confusion - on some platforms. */ - return ferror (f) || fclose (f) != 0; - - ; - return 0; -} -_ACEOF -if ac_fn_c_try_run "$LINENO"; then : - echo >>conftest.val; read $3 &5 - (eval "$ac_cpp conftest.$ac_ext") 2>conftest.err - ac_status=$? - if test -s conftest.err; then - grep -v '^ *+' conftest.err >conftest.er1 - cat conftest.er1 >&5 - mv -f conftest.er1 conftest.err - fi - $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 - test $ac_status = 0; } > conftest.i && { - test -z "$ac_c_preproc_warn_flag$ac_c_werror_flag" || - test ! -s conftest.err - }; then : - ac_retval=0 -else - $as_echo "$as_me: failed program was:" >&5 -sed 's/^/| /' conftest.$ac_ext >&5 - - ac_retval=1 -fi - eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno - as_fn_set_status $ac_retval - -} # ac_fn_c_try_cpp - -# ac_fn_c_check_header_compile LINENO HEADER VAR INCLUDES -# ------------------------------------------------------- -# Tests whether HEADER exists and can be compiled using the include files in -# INCLUDES, setting the cache variable VAR accordingly. -ac_fn_c_check_header_compile () -{ - as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack - { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $2" >&5 -$as_echo_n "checking for $2... " >&6; } -if eval \${$3+:} false; then : - $as_echo_n "(cached) " >&6 -else - cat confdefs.h - <<_ACEOF >conftest.$ac_ext -/* end confdefs.h. */ -$4 -#include <$2> -_ACEOF -if ac_fn_c_try_compile "$LINENO"; then : - eval "$3=yes" -else - eval "$3=no" -fi -rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext -fi -eval ac_res=\$$3 - { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_res" >&5 -$as_echo "$ac_res" >&6; } - eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno - -} # ac_fn_c_check_header_compile -cat >config.log <<_ACEOF -This file contains any messages produced by compilers while -running configure, to aid debugging if configure makes a mistake. - -It was created by $as_me, which was -generated by GNU Autoconf 2.68. Invocation command line was - - $ $0 $@ - -_ACEOF -exec 5>>config.log -{ -cat <<_ASUNAME -## --------- ## -## Platform. ## -## --------- ## - -hostname = `(hostname || uname -n) 2>/dev/null | sed 1q` -uname -m = `(uname -m) 2>/dev/null || echo unknown` -uname -r = `(uname -r) 2>/dev/null || echo unknown` -uname -s = `(uname -s) 2>/dev/null || echo unknown` -uname -v = `(uname -v) 2>/dev/null || echo unknown` - -/usr/bin/uname -p = `(/usr/bin/uname -p) 2>/dev/null || echo unknown` -/bin/uname -X = `(/bin/uname -X) 2>/dev/null || echo unknown` - -/bin/arch = `(/bin/arch) 2>/dev/null || echo unknown` -/usr/bin/arch -k = `(/usr/bin/arch -k) 2>/dev/null || echo unknown` -/usr/convex/getsysinfo = `(/usr/convex/getsysinfo) 2>/dev/null || echo unknown` -/usr/bin/hostinfo = `(/usr/bin/hostinfo) 2>/dev/null || echo unknown` -/bin/machine = `(/bin/machine) 2>/dev/null || echo unknown` -/usr/bin/oslevel = `(/usr/bin/oslevel) 2>/dev/null || echo unknown` -/bin/universe = `(/bin/universe) 2>/dev/null || echo unknown` - -_ASUNAME - -as_save_IFS=$IFS; IFS=$PATH_SEPARATOR -for as_dir in $PATH -do - IFS=$as_save_IFS - test -z "$as_dir" && as_dir=. - $as_echo "PATH: $as_dir" - done -IFS=$as_save_IFS - -} >&5 - -cat >&5 <<_ACEOF - - -## ----------- ## -## Core tests. ## -## ----------- ## - -_ACEOF - - -# Keep a trace of the command line. -# Strip out --no-create and --no-recursion so they do not pile up. -# Strip out --silent because we don't want to record it for future runs. -# Also quote any args containing shell meta-characters. -# Make two passes to allow for proper duplicate-argument suppression. -ac_configure_args= -ac_configure_args0= -ac_configure_args1= -ac_must_keep_next=false -for ac_pass in 1 2 -do - for ac_arg - do - case $ac_arg in - -no-create | --no-c* | -n | -no-recursion | --no-r*) continue ;; - -q | -quiet | --quiet | --quie | --qui | --qu | --q \ - | -silent | --silent | --silen | --sile | --sil) - continue ;; - *\'*) - ac_arg=`$as_echo "$ac_arg" | sed "s/'/'\\\\\\\\''/g"` ;; - esac - case $ac_pass in - 1) as_fn_append ac_configure_args0 " '$ac_arg'" ;; - 2) - as_fn_append ac_configure_args1 " '$ac_arg'" - if test $ac_must_keep_next = true; then - ac_must_keep_next=false # Got value, back to normal. - else - case $ac_arg in - *=* | --config-cache | -C | -disable-* | --disable-* \ - | -enable-* | --enable-* | -gas | --g* | -nfp | --nf* \ - | -q | -quiet | --q* | -silent | --sil* | -v | -verb* \ - | -with-* | --with-* | -without-* | --without-* | --x) - case "$ac_configure_args0 " in - "$ac_configure_args1"*" '$ac_arg' "* ) continue ;; - esac - ;; - -* ) ac_must_keep_next=true ;; - esac - fi - as_fn_append ac_configure_args " '$ac_arg'" - ;; - esac - done -done -{ ac_configure_args0=; unset ac_configure_args0;} -{ ac_configure_args1=; unset ac_configure_args1;} - -# When interrupted or exit'd, cleanup temporary files, and complete -# config.log. We remove comments because anyway the quotes in there -# would cause problems or look ugly. -# WARNING: Use '\'' to represent an apostrophe within the trap. -# WARNING: Do not start the trap code with a newline, due to a FreeBSD 4.0 bug. -trap 'exit_status=$? - # Save into config.log some information that might help in debugging. - { - echo - - $as_echo "## ---------------- ## -## Cache variables. ## -## ---------------- ##" - echo - # The following way of writing the cache mishandles newlines in values, -( - for ac_var in `(set) 2>&1 | sed -n '\''s/^\([a-zA-Z_][a-zA-Z0-9_]*\)=.*/\1/p'\''`; do - eval ac_val=\$$ac_var - case $ac_val in #( - *${as_nl}*) - case $ac_var in #( - *_cv_*) { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: cache variable $ac_var contains a newline" >&5 -$as_echo "$as_me: WARNING: cache variable $ac_var contains a newline" >&2;} ;; - esac - case $ac_var in #( - _ | IFS | as_nl) ;; #( - BASH_ARGV | BASH_SOURCE) eval $ac_var= ;; #( - *) { eval $ac_var=; unset $ac_var;} ;; - esac ;; - esac - done - (set) 2>&1 | - case $as_nl`(ac_space='\'' '\''; set) 2>&1` in #( - *${as_nl}ac_space=\ *) - sed -n \ - "s/'\''/'\''\\\\'\'''\''/g; - s/^\\([_$as_cr_alnum]*_cv_[_$as_cr_alnum]*\\)=\\(.*\\)/\\1='\''\\2'\''/p" - ;; #( - *) - sed -n "/^[_$as_cr_alnum]*_cv_[_$as_cr_alnum]*=/p" - ;; - esac | - sort -) - echo - - $as_echo "## ----------------- ## -## Output variables. ## -## ----------------- ##" - echo - for ac_var in $ac_subst_vars - do - eval ac_val=\$$ac_var - case $ac_val in - *\'\''*) ac_val=`$as_echo "$ac_val" | sed "s/'\''/'\''\\\\\\\\'\'''\''/g"`;; - esac - $as_echo "$ac_var='\''$ac_val'\''" - done | sort - echo - - if test -n "$ac_subst_files"; then - $as_echo "## ------------------- ## -## File substitutions. ## -## ------------------- ##" - echo - for ac_var in $ac_subst_files - do - eval ac_val=\$$ac_var - case $ac_val in - *\'\''*) ac_val=`$as_echo "$ac_val" | sed "s/'\''/'\''\\\\\\\\'\'''\''/g"`;; - esac - $as_echo "$ac_var='\''$ac_val'\''" - done | sort - echo - fi - - if test -s confdefs.h; then - $as_echo "## ----------- ## -## confdefs.h. ## -## ----------- ##" - echo - cat confdefs.h - echo - fi - test "$ac_signal" != 0 && - $as_echo "$as_me: caught signal $ac_signal" - $as_echo "$as_me: exit $exit_status" - } >&5 - rm -f core *.core core.conftest.* && - rm -f -r conftest* confdefs* conf$$* $ac_clean_files && - exit $exit_status -' 0 -for ac_signal in 1 2 13 15; do - trap 'ac_signal='$ac_signal'; as_fn_exit 1' $ac_signal -done -ac_signal=0 - -# confdefs.h avoids OS command line length limits that DEFS can exceed. -rm -f -r conftest* confdefs.h - -$as_echo "/* confdefs.h */" > confdefs.h - -# Predefined preprocessor variables. - -cat >>confdefs.h <<_ACEOF -#define PACKAGE_NAME "$PACKAGE_NAME" -_ACEOF - -cat >>confdefs.h <<_ACEOF -#define PACKAGE_TARNAME "$PACKAGE_TARNAME" -_ACEOF - -cat >>confdefs.h <<_ACEOF -#define PACKAGE_VERSION "$PACKAGE_VERSION" -_ACEOF - -cat >>confdefs.h <<_ACEOF -#define PACKAGE_STRING "$PACKAGE_STRING" -_ACEOF - -cat >>confdefs.h <<_ACEOF -#define PACKAGE_BUGREPORT "$PACKAGE_BUGREPORT" -_ACEOF - -cat >>confdefs.h <<_ACEOF -#define PACKAGE_URL "$PACKAGE_URL" -_ACEOF - - -# Let the site file select an alternate cache file if it wants to. -# Prefer an explicitly selected file to automatically selected ones. -ac_site_file1=NONE -ac_site_file2=NONE -if test -n "$CONFIG_SITE"; then - # We do not want a PATH search for config.site. - case $CONFIG_SITE in #(( - -*) ac_site_file1=./$CONFIG_SITE;; - */*) ac_site_file1=$CONFIG_SITE;; - *) ac_site_file1=./$CONFIG_SITE;; - esac -elif test "x$prefix" != xNONE; then - ac_site_file1=$prefix/share/config.site - ac_site_file2=$prefix/etc/config.site -else - ac_site_file1=$ac_default_prefix/share/config.site - ac_site_file2=$ac_default_prefix/etc/config.site -fi -for ac_site_file in "$ac_site_file1" "$ac_site_file2" -do - test "x$ac_site_file" = xNONE && continue - if test /dev/null != "$ac_site_file" && test -r "$ac_site_file"; then - { $as_echo "$as_me:${as_lineno-$LINENO}: loading site script $ac_site_file" >&5 -$as_echo "$as_me: loading site script $ac_site_file" >&6;} - sed 's/^/| /' "$ac_site_file" >&5 - . "$ac_site_file" \ - || { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 -$as_echo "$as_me: error: in \`$ac_pwd':" >&2;} -as_fn_error $? "failed to load site script $ac_site_file -See \`config.log' for more details" "$LINENO" 5; } - fi -done - -if test -r "$cache_file"; then - # Some versions of bash will fail to source /dev/null (special files - # actually), so we avoid doing that. DJGPP emulates it as a regular file. - if test /dev/null != "$cache_file" && test -f "$cache_file"; then - { $as_echo "$as_me:${as_lineno-$LINENO}: loading cache $cache_file" >&5 -$as_echo "$as_me: loading cache $cache_file" >&6;} - case $cache_file in - [\\/]* | ?:[\\/]* ) . "$cache_file";; - *) . "./$cache_file";; - esac - fi -else - { $as_echo "$as_me:${as_lineno-$LINENO}: creating cache $cache_file" >&5 -$as_echo "$as_me: creating cache $cache_file" >&6;} - >$cache_file -fi - -# Check that the precious variables saved in the cache have kept the same -# value. -ac_cache_corrupted=false -for ac_var in $ac_precious_vars; do - eval ac_old_set=\$ac_cv_env_${ac_var}_set - eval ac_new_set=\$ac_env_${ac_var}_set - eval ac_old_val=\$ac_cv_env_${ac_var}_value - eval ac_new_val=\$ac_env_${ac_var}_value - case $ac_old_set,$ac_new_set in - set,) - { $as_echo "$as_me:${as_lineno-$LINENO}: error: \`$ac_var' was set to \`$ac_old_val' in the previous run" >&5 -$as_echo "$as_me: error: \`$ac_var' was set to \`$ac_old_val' in the previous run" >&2;} - ac_cache_corrupted=: ;; - ,set) - { $as_echo "$as_me:${as_lineno-$LINENO}: error: \`$ac_var' was not set in the previous run" >&5 -$as_echo "$as_me: error: \`$ac_var' was not set in the previous run" >&2;} - ac_cache_corrupted=: ;; - ,);; - *) - if test "x$ac_old_val" != "x$ac_new_val"; then - # differences in whitespace do not lead to failure. - ac_old_val_w=`echo x $ac_old_val` - ac_new_val_w=`echo x $ac_new_val` - if test "$ac_old_val_w" != "$ac_new_val_w"; then - { $as_echo "$as_me:${as_lineno-$LINENO}: error: \`$ac_var' has changed since the previous run:" >&5 -$as_echo "$as_me: error: \`$ac_var' has changed since the previous run:" >&2;} - ac_cache_corrupted=: - else - { $as_echo "$as_me:${as_lineno-$LINENO}: warning: ignoring whitespace changes in \`$ac_var' since the previous run:" >&5 -$as_echo "$as_me: warning: ignoring whitespace changes in \`$ac_var' since the previous run:" >&2;} - eval $ac_var=\$ac_old_val - fi - { $as_echo "$as_me:${as_lineno-$LINENO}: former value: \`$ac_old_val'" >&5 -$as_echo "$as_me: former value: \`$ac_old_val'" >&2;} - { $as_echo "$as_me:${as_lineno-$LINENO}: current value: \`$ac_new_val'" >&5 -$as_echo "$as_me: current value: \`$ac_new_val'" >&2;} - fi;; - esac - # Pass precious variables to config.status. - if test "$ac_new_set" = set; then - case $ac_new_val in - *\'*) ac_arg=$ac_var=`$as_echo "$ac_new_val" | sed "s/'/'\\\\\\\\''/g"` ;; - *) ac_arg=$ac_var=$ac_new_val ;; - esac - case " $ac_configure_args " in - *" '$ac_arg' "*) ;; # Avoid dups. Use of quotes ensures accuracy. - *) as_fn_append ac_configure_args " '$ac_arg'" ;; - esac - fi -done -if $ac_cache_corrupted; then - { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 -$as_echo "$as_me: error: in \`$ac_pwd':" >&2;} - { $as_echo "$as_me:${as_lineno-$LINENO}: error: changes in the environment can compromise the build" >&5 -$as_echo "$as_me: error: changes in the environment can compromise the build" >&2;} - as_fn_error $? "run \`make distclean' and/or \`rm $cache_file' and start over" "$LINENO" 5 -fi -## -------------------- ## -## Main body of script. ## -## -------------------- ## - -ac_ext=c -ac_cpp='$CPP $CPPFLAGS' -ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' -ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' -ac_compiler_gnu=$ac_cv_c_compiler_gnu - - -ac_ext=c -ac_cpp='$CPP $CPPFLAGS' -ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' -ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' -ac_compiler_gnu=$ac_cv_c_compiler_gnu - -echo "This script provides suggestions for settings to apply in macros.make" -echo "You can pass things like FC=gfortran or CC=pathcc to it to override defaults." -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking whether ${MAKE-make} sets \$(MAKE)" >&5 -$as_echo_n "checking whether ${MAKE-make} sets \$(MAKE)... " >&6; } -set x ${MAKE-make} -ac_make=`$as_echo "$2" | sed 's/+/p/g; s/[^a-zA-Z0-9_]/_/g'` -if eval \${ac_cv_prog_make_${ac_make}_set+:} false; then : - $as_echo_n "(cached) " >&6 -else - cat >conftest.make <<\_ACEOF -SHELL = /bin/sh -all: - @echo '@@@%%%=$(MAKE)=@@@%%%' -_ACEOF -# GNU make sometimes prints "make[1]: Entering ...", which would confuse us. -case `${MAKE-make} -f conftest.make 2>/dev/null` in - *@@@%%%=?*=@@@%%%*) - eval ac_cv_prog_make_${ac_make}_set=yes;; - *) - eval ac_cv_prog_make_${ac_make}_set=no;; -esac -rm -f conftest.make -fi -if eval test \$ac_cv_prog_make_${ac_make}_set = yes; then - { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5 -$as_echo "yes" >&6; } - SET_MAKE= -else - { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 -$as_echo "no" >&6; } - SET_MAKE="MAKE=${MAKE-make}" -fi - -ac_ext=c -ac_cpp='$CPP $CPPFLAGS' -ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' -ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' -ac_compiler_gnu=$ac_cv_c_compiler_gnu -if test -n "$ac_tool_prefix"; then - # Extract the first word of "${ac_tool_prefix}gcc", so it can be a program name with args. -set dummy ${ac_tool_prefix}gcc; ac_word=$2 -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 -$as_echo_n "checking for $ac_word... " >&6; } -if ${ac_cv_prog_CC+:} false; then : - $as_echo_n "(cached) " >&6 -else - if test -n "$CC"; then - ac_cv_prog_CC="$CC" # Let the user override the test. -else -as_save_IFS=$IFS; IFS=$PATH_SEPARATOR -for as_dir in $PATH -do - IFS=$as_save_IFS - test -z "$as_dir" && as_dir=. - for ac_exec_ext in '' $ac_executable_extensions; do - if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then - ac_cv_prog_CC="${ac_tool_prefix}gcc" - $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 - break 2 - fi -done - done -IFS=$as_save_IFS - -fi -fi -CC=$ac_cv_prog_CC -if test -n "$CC"; then - { $as_echo "$as_me:${as_lineno-$LINENO}: result: $CC" >&5 -$as_echo "$CC" >&6; } -else - { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 -$as_echo "no" >&6; } -fi - - -fi -if test -z "$ac_cv_prog_CC"; then - ac_ct_CC=$CC - # Extract the first word of "gcc", so it can be a program name with args. -set dummy gcc; ac_word=$2 -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 -$as_echo_n "checking for $ac_word... " >&6; } -if ${ac_cv_prog_ac_ct_CC+:} false; then : - $as_echo_n "(cached) " >&6 -else - if test -n "$ac_ct_CC"; then - ac_cv_prog_ac_ct_CC="$ac_ct_CC" # Let the user override the test. -else -as_save_IFS=$IFS; IFS=$PATH_SEPARATOR -for as_dir in $PATH -do - IFS=$as_save_IFS - test -z "$as_dir" && as_dir=. - for ac_exec_ext in '' $ac_executable_extensions; do - if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then - ac_cv_prog_ac_ct_CC="gcc" - $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 - break 2 - fi -done - done -IFS=$as_save_IFS - -fi -fi -ac_ct_CC=$ac_cv_prog_ac_ct_CC -if test -n "$ac_ct_CC"; then - { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_ct_CC" >&5 -$as_echo "$ac_ct_CC" >&6; } -else - { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 -$as_echo "no" >&6; } -fi - - if test "x$ac_ct_CC" = x; then - CC="" - else - case $cross_compiling:$ac_tool_warned in -yes:) -{ $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5 -$as_echo "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;} -ac_tool_warned=yes ;; -esac - CC=$ac_ct_CC - fi -else - CC="$ac_cv_prog_CC" -fi - -if test -z "$CC"; then - if test -n "$ac_tool_prefix"; then - # Extract the first word of "${ac_tool_prefix}cc", so it can be a program name with args. -set dummy ${ac_tool_prefix}cc; ac_word=$2 -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 -$as_echo_n "checking for $ac_word... " >&6; } -if ${ac_cv_prog_CC+:} false; then : - $as_echo_n "(cached) " >&6 -else - if test -n "$CC"; then - ac_cv_prog_CC="$CC" # Let the user override the test. -else -as_save_IFS=$IFS; IFS=$PATH_SEPARATOR -for as_dir in $PATH -do - IFS=$as_save_IFS - test -z "$as_dir" && as_dir=. - for ac_exec_ext in '' $ac_executable_extensions; do - if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then - ac_cv_prog_CC="${ac_tool_prefix}cc" - $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 - break 2 - fi -done - done -IFS=$as_save_IFS - -fi -fi -CC=$ac_cv_prog_CC -if test -n "$CC"; then - { $as_echo "$as_me:${as_lineno-$LINENO}: result: $CC" >&5 -$as_echo "$CC" >&6; } -else - { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 -$as_echo "no" >&6; } -fi - - - fi -fi -if test -z "$CC"; then - # Extract the first word of "cc", so it can be a program name with args. -set dummy cc; ac_word=$2 -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 -$as_echo_n "checking for $ac_word... " >&6; } -if ${ac_cv_prog_CC+:} false; then : - $as_echo_n "(cached) " >&6 -else - if test -n "$CC"; then - ac_cv_prog_CC="$CC" # Let the user override the test. -else - ac_prog_rejected=no -as_save_IFS=$IFS; IFS=$PATH_SEPARATOR -for as_dir in $PATH -do - IFS=$as_save_IFS - test -z "$as_dir" && as_dir=. - for ac_exec_ext in '' $ac_executable_extensions; do - if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then - if test "$as_dir/$ac_word$ac_exec_ext" = "/usr/ucb/cc"; then - ac_prog_rejected=yes - continue - fi - ac_cv_prog_CC="cc" - $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 - break 2 - fi -done - done -IFS=$as_save_IFS - -if test $ac_prog_rejected = yes; then - # We found a bogon in the path, so make sure we never use it. - set dummy $ac_cv_prog_CC - shift - if test $# != 0; then - # We chose a different compiler from the bogus one. - # However, it has the same basename, so the bogon will be chosen - # first if we set CC to just the basename; use the full file name. - shift - ac_cv_prog_CC="$as_dir/$ac_word${1+' '}$@" - fi -fi -fi -fi -CC=$ac_cv_prog_CC -if test -n "$CC"; then - { $as_echo "$as_me:${as_lineno-$LINENO}: result: $CC" >&5 -$as_echo "$CC" >&6; } -else - { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 -$as_echo "no" >&6; } -fi - - -fi -if test -z "$CC"; then - if test -n "$ac_tool_prefix"; then - for ac_prog in cl.exe - do - # Extract the first word of "$ac_tool_prefix$ac_prog", so it can be a program name with args. -set dummy $ac_tool_prefix$ac_prog; ac_word=$2 -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 -$as_echo_n "checking for $ac_word... " >&6; } -if ${ac_cv_prog_CC+:} false; then : - $as_echo_n "(cached) " >&6 -else - if test -n "$CC"; then - ac_cv_prog_CC="$CC" # Let the user override the test. -else -as_save_IFS=$IFS; IFS=$PATH_SEPARATOR -for as_dir in $PATH -do - IFS=$as_save_IFS - test -z "$as_dir" && as_dir=. - for ac_exec_ext in '' $ac_executable_extensions; do - if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then - ac_cv_prog_CC="$ac_tool_prefix$ac_prog" - $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 - break 2 - fi -done - done -IFS=$as_save_IFS - -fi -fi -CC=$ac_cv_prog_CC -if test -n "$CC"; then - { $as_echo "$as_me:${as_lineno-$LINENO}: result: $CC" >&5 -$as_echo "$CC" >&6; } -else - { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 -$as_echo "no" >&6; } -fi - - - test -n "$CC" && break - done -fi -if test -z "$CC"; then - ac_ct_CC=$CC - for ac_prog in cl.exe -do - # Extract the first word of "$ac_prog", so it can be a program name with args. -set dummy $ac_prog; ac_word=$2 -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 -$as_echo_n "checking for $ac_word... " >&6; } -if ${ac_cv_prog_ac_ct_CC+:} false; then : - $as_echo_n "(cached) " >&6 -else - if test -n "$ac_ct_CC"; then - ac_cv_prog_ac_ct_CC="$ac_ct_CC" # Let the user override the test. -else -as_save_IFS=$IFS; IFS=$PATH_SEPARATOR -for as_dir in $PATH -do - IFS=$as_save_IFS - test -z "$as_dir" && as_dir=. - for ac_exec_ext in '' $ac_executable_extensions; do - if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then - ac_cv_prog_ac_ct_CC="$ac_prog" - $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 - break 2 - fi -done - done -IFS=$as_save_IFS - -fi -fi -ac_ct_CC=$ac_cv_prog_ac_ct_CC -if test -n "$ac_ct_CC"; then - { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_ct_CC" >&5 -$as_echo "$ac_ct_CC" >&6; } -else - { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 -$as_echo "no" >&6; } -fi - - - test -n "$ac_ct_CC" && break -done - - if test "x$ac_ct_CC" = x; then - CC="" - else - case $cross_compiling:$ac_tool_warned in -yes:) -{ $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5 -$as_echo "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;} -ac_tool_warned=yes ;; -esac - CC=$ac_ct_CC - fi -fi - -fi - - -test -z "$CC" && { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 -$as_echo "$as_me: error: in \`$ac_pwd':" >&2;} -as_fn_error $? "no acceptable C compiler found in \$PATH -See \`config.log' for more details" "$LINENO" 5; } - -# Provide some information about the compiler. -$as_echo "$as_me:${as_lineno-$LINENO}: checking for C compiler version" >&5 -set X $ac_compile -ac_compiler=$2 -for ac_option in --version -v -V -qversion; do - { { ac_try="$ac_compiler $ac_option >&5" -case "(($ac_try" in - *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; - *) ac_try_echo=$ac_try;; -esac -eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" -$as_echo "$ac_try_echo"; } >&5 - (eval "$ac_compiler $ac_option >&5") 2>conftest.err - ac_status=$? - if test -s conftest.err; then - sed '10a\ -... rest of stderr output deleted ... - 10q' conftest.err >conftest.er1 - cat conftest.er1 >&5 - fi - rm -f conftest.er1 conftest.err - $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 - test $ac_status = 0; } -done - -cat confdefs.h - <<_ACEOF >conftest.$ac_ext -/* end confdefs.h. */ - -int -main () -{ - - ; - return 0; -} -_ACEOF -ac_clean_files_save=$ac_clean_files -ac_clean_files="$ac_clean_files a.out a.out.dSYM a.exe b.out" -# Try to create an executable without -o first, disregard a.out. -# It will help us diagnose broken compilers, and finding out an intuition -# of exeext. -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking whether the C compiler works" >&5 -$as_echo_n "checking whether the C compiler works... " >&6; } -ac_link_default=`$as_echo "$ac_link" | sed 's/ -o *conftest[^ ]*//'` - -# The possible output files: -ac_files="a.out conftest.exe conftest a.exe a_out.exe b.out conftest.*" - -ac_rmfiles= -for ac_file in $ac_files -do - case $ac_file in - *.$ac_ext | *.xcoff | *.tds | *.d | *.pdb | *.xSYM | *.bb | *.bbg | *.map | *.inf | *.dSYM | *.o | *.obj ) ;; - * ) ac_rmfiles="$ac_rmfiles $ac_file";; - esac -done -rm -f $ac_rmfiles - -if { { ac_try="$ac_link_default" -case "(($ac_try" in - *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; - *) ac_try_echo=$ac_try;; -esac -eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" -$as_echo "$ac_try_echo"; } >&5 - (eval "$ac_link_default") 2>&5 - ac_status=$? - $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 - test $ac_status = 0; }; then : - # Autoconf-2.13 could set the ac_cv_exeext variable to `no'. -# So ignore a value of `no', otherwise this would lead to `EXEEXT = no' -# in a Makefile. We should not override ac_cv_exeext if it was cached, -# so that the user can short-circuit this test for compilers unknown to -# Autoconf. -for ac_file in $ac_files '' -do - test -f "$ac_file" || continue - case $ac_file in - *.$ac_ext | *.xcoff | *.tds | *.d | *.pdb | *.xSYM | *.bb | *.bbg | *.map | *.inf | *.dSYM | *.o | *.obj ) - ;; - [ab].out ) - # We found the default executable, but exeext='' is most - # certainly right. - break;; - *.* ) - if test "${ac_cv_exeext+set}" = set && test "$ac_cv_exeext" != no; - then :; else - ac_cv_exeext=`expr "$ac_file" : '[^.]*\(\..*\)'` - fi - # We set ac_cv_exeext here because the later test for it is not - # safe: cross compilers may not add the suffix if given an `-o' - # argument, so we may need to know it at that point already. - # Even if this section looks crufty: it has the advantage of - # actually working. - break;; - * ) - break;; - esac -done -test "$ac_cv_exeext" = no && ac_cv_exeext= - -else - ac_file='' -fi -if test -z "$ac_file"; then : - { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 -$as_echo "no" >&6; } -$as_echo "$as_me: failed program was:" >&5 -sed 's/^/| /' conftest.$ac_ext >&5 - -{ { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 -$as_echo "$as_me: error: in \`$ac_pwd':" >&2;} -as_fn_error 77 "C compiler cannot create executables -See \`config.log' for more details" "$LINENO" 5; } -else - { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5 -$as_echo "yes" >&6; } -fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for C compiler default output file name" >&5 -$as_echo_n "checking for C compiler default output file name... " >&6; } -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_file" >&5 -$as_echo "$ac_file" >&6; } -ac_exeext=$ac_cv_exeext - -rm -f -r a.out a.out.dSYM a.exe conftest$ac_cv_exeext b.out -ac_clean_files=$ac_clean_files_save -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for suffix of executables" >&5 -$as_echo_n "checking for suffix of executables... " >&6; } -if { { ac_try="$ac_link" -case "(($ac_try" in - *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; - *) ac_try_echo=$ac_try;; -esac -eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" -$as_echo "$ac_try_echo"; } >&5 - (eval "$ac_link") 2>&5 - ac_status=$? - $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 - test $ac_status = 0; }; then : - # If both `conftest.exe' and `conftest' are `present' (well, observable) -# catch `conftest.exe'. For instance with Cygwin, `ls conftest' will -# work properly (i.e., refer to `conftest.exe'), while it won't with -# `rm'. -for ac_file in conftest.exe conftest conftest.*; do - test -f "$ac_file" || continue - case $ac_file in - *.$ac_ext | *.xcoff | *.tds | *.d | *.pdb | *.xSYM | *.bb | *.bbg | *.map | *.inf | *.dSYM | *.o | *.obj ) ;; - *.* ) ac_cv_exeext=`expr "$ac_file" : '[^.]*\(\..*\)'` - break;; - * ) break;; - esac -done -else - { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 -$as_echo "$as_me: error: in \`$ac_pwd':" >&2;} -as_fn_error $? "cannot compute suffix of executables: cannot compile and link -See \`config.log' for more details" "$LINENO" 5; } -fi -rm -f conftest conftest$ac_cv_exeext -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_exeext" >&5 -$as_echo "$ac_cv_exeext" >&6; } - -rm -f conftest.$ac_ext -EXEEXT=$ac_cv_exeext -ac_exeext=$EXEEXT -cat confdefs.h - <<_ACEOF >conftest.$ac_ext -/* end confdefs.h. */ -#include -int -main () -{ -FILE *f = fopen ("conftest.out", "w"); - return ferror (f) || fclose (f) != 0; - - ; - return 0; -} -_ACEOF -ac_clean_files="$ac_clean_files conftest.out" -# Check that the compiler produces executables we can run. If not, either -# the compiler is broken, or we cross compile. -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking whether we are cross compiling" >&5 -$as_echo_n "checking whether we are cross compiling... " >&6; } -if test "$cross_compiling" != yes; then - { { ac_try="$ac_link" -case "(($ac_try" in - *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; - *) ac_try_echo=$ac_try;; -esac -eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" -$as_echo "$ac_try_echo"; } >&5 - (eval "$ac_link") 2>&5 - ac_status=$? - $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 - test $ac_status = 0; } - if { ac_try='./conftest$ac_cv_exeext' - { { case "(($ac_try" in - *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; - *) ac_try_echo=$ac_try;; -esac -eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" -$as_echo "$ac_try_echo"; } >&5 - (eval "$ac_try") 2>&5 - ac_status=$? - $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 - test $ac_status = 0; }; }; then - cross_compiling=no - else - if test "$cross_compiling" = maybe; then - cross_compiling=yes - else - { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 -$as_echo "$as_me: error: in \`$ac_pwd':" >&2;} -as_fn_error $? "cannot run C compiled programs. -If you meant to cross compile, use \`--host'. -See \`config.log' for more details" "$LINENO" 5; } - fi - fi -fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $cross_compiling" >&5 -$as_echo "$cross_compiling" >&6; } - -rm -f conftest.$ac_ext conftest$ac_cv_exeext conftest.out -ac_clean_files=$ac_clean_files_save -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for suffix of object files" >&5 -$as_echo_n "checking for suffix of object files... " >&6; } -if ${ac_cv_objext+:} false; then : - $as_echo_n "(cached) " >&6 -else - cat confdefs.h - <<_ACEOF >conftest.$ac_ext -/* end confdefs.h. */ - -int -main () -{ - - ; - return 0; -} -_ACEOF -rm -f conftest.o conftest.obj -if { { ac_try="$ac_compile" -case "(($ac_try" in - *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; - *) ac_try_echo=$ac_try;; -esac -eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" -$as_echo "$ac_try_echo"; } >&5 - (eval "$ac_compile") 2>&5 - ac_status=$? - $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 - test $ac_status = 0; }; then : - for ac_file in conftest.o conftest.obj conftest.*; do - test -f "$ac_file" || continue; - case $ac_file in - *.$ac_ext | *.xcoff | *.tds | *.d | *.pdb | *.xSYM | *.bb | *.bbg | *.map | *.inf | *.dSYM ) ;; - *) ac_cv_objext=`expr "$ac_file" : '.*\.\(.*\)'` - break;; - esac -done -else - $as_echo "$as_me: failed program was:" >&5 -sed 's/^/| /' conftest.$ac_ext >&5 - -{ { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 -$as_echo "$as_me: error: in \`$ac_pwd':" >&2;} -as_fn_error $? "cannot compute suffix of object files: cannot compile -See \`config.log' for more details" "$LINENO" 5; } -fi -rm -f conftest.$ac_cv_objext conftest.$ac_ext -fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_objext" >&5 -$as_echo "$ac_cv_objext" >&6; } -OBJEXT=$ac_cv_objext -ac_objext=$OBJEXT -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking whether we are using the GNU C compiler" >&5 -$as_echo_n "checking whether we are using the GNU C compiler... " >&6; } -if ${ac_cv_c_compiler_gnu+:} false; then : - $as_echo_n "(cached) " >&6 -else - cat confdefs.h - <<_ACEOF >conftest.$ac_ext -/* end confdefs.h. */ - -int -main () -{ -#ifndef __GNUC__ - choke me -#endif - - ; - return 0; -} -_ACEOF -if ac_fn_c_try_compile "$LINENO"; then : - ac_compiler_gnu=yes -else - ac_compiler_gnu=no -fi -rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext -ac_cv_c_compiler_gnu=$ac_compiler_gnu - -fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_c_compiler_gnu" >&5 -$as_echo "$ac_cv_c_compiler_gnu" >&6; } -if test $ac_compiler_gnu = yes; then - GCC=yes -else - GCC= -fi -ac_test_CFLAGS=${CFLAGS+set} -ac_save_CFLAGS=$CFLAGS -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking whether $CC accepts -g" >&5 -$as_echo_n "checking whether $CC accepts -g... " >&6; } -if ${ac_cv_prog_cc_g+:} false; then : - $as_echo_n "(cached) " >&6 -else - ac_save_c_werror_flag=$ac_c_werror_flag - ac_c_werror_flag=yes - ac_cv_prog_cc_g=no - CFLAGS="-g" - cat confdefs.h - <<_ACEOF >conftest.$ac_ext -/* end confdefs.h. */ - -int -main () -{ - - ; - return 0; -} -_ACEOF -if ac_fn_c_try_compile "$LINENO"; then : - ac_cv_prog_cc_g=yes -else - CFLAGS="" - cat confdefs.h - <<_ACEOF >conftest.$ac_ext -/* end confdefs.h. */ - -int -main () -{ - - ; - return 0; -} -_ACEOF -if ac_fn_c_try_compile "$LINENO"; then : - -else - ac_c_werror_flag=$ac_save_c_werror_flag - CFLAGS="-g" - cat confdefs.h - <<_ACEOF >conftest.$ac_ext -/* end confdefs.h. */ - -int -main () -{ - - ; - return 0; -} -_ACEOF -if ac_fn_c_try_compile "$LINENO"; then : - ac_cv_prog_cc_g=yes -fi -rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext -fi -rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext -fi -rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext - ac_c_werror_flag=$ac_save_c_werror_flag -fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_prog_cc_g" >&5 -$as_echo "$ac_cv_prog_cc_g" >&6; } -if test "$ac_test_CFLAGS" = set; then - CFLAGS=$ac_save_CFLAGS -elif test $ac_cv_prog_cc_g = yes; then - if test "$GCC" = yes; then - CFLAGS="-g -O2" - else - CFLAGS="-g" - fi -else - if test "$GCC" = yes; then - CFLAGS="-O2" - else - CFLAGS= - fi -fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $CC option to accept ISO C89" >&5 -$as_echo_n "checking for $CC option to accept ISO C89... " >&6; } -if ${ac_cv_prog_cc_c89+:} false; then : - $as_echo_n "(cached) " >&6 -else - ac_cv_prog_cc_c89=no -ac_save_CC=$CC -cat confdefs.h - <<_ACEOF >conftest.$ac_ext -/* end confdefs.h. */ -#include -#include -#include -#include -/* Most of the following tests are stolen from RCS 5.7's src/conf.sh. */ -struct buf { int x; }; -FILE * (*rcsopen) (struct buf *, struct stat *, int); -static char *e (p, i) - char **p; - int i; -{ - return p[i]; -} -static char *f (char * (*g) (char **, int), char **p, ...) -{ - char *s; - va_list v; - va_start (v,p); - s = g (p, va_arg (v,int)); - va_end (v); - return s; -} - -/* OSF 4.0 Compaq cc is some sort of almost-ANSI by default. It has - function prototypes and stuff, but not '\xHH' hex character constants. - These don't provoke an error unfortunately, instead are silently treated - as 'x'. The following induces an error, until -std is added to get - proper ANSI mode. Curiously '\x00'!='x' always comes out true, for an - array size at least. It's necessary to write '\x00'==0 to get something - that's true only with -std. */ -int osf4_cc_array ['\x00' == 0 ? 1 : -1]; - -/* IBM C 6 for AIX is almost-ANSI by default, but it replaces macro parameters - inside strings and character constants. */ -#define FOO(x) 'x' -int xlc6_cc_array[FOO(a) == 'x' ? 1 : -1]; - -int test (int i, double x); -struct s1 {int (*f) (int a);}; -struct s2 {int (*f) (double a);}; -int pairnames (int, char **, FILE *(*)(struct buf *, struct stat *, int), int, int); -int argc; -char **argv; -int -main () -{ -return f (e, argv, 0) != argv[0] || f (e, argv, 1) != argv[1]; - ; - return 0; -} -_ACEOF -for ac_arg in '' -qlanglvl=extc89 -qlanglvl=ansi -std \ - -Ae "-Aa -D_HPUX_SOURCE" "-Xc -D__EXTENSIONS__" -do - CC="$ac_save_CC $ac_arg" - if ac_fn_c_try_compile "$LINENO"; then : - ac_cv_prog_cc_c89=$ac_arg -fi -rm -f core conftest.err conftest.$ac_objext - test "x$ac_cv_prog_cc_c89" != "xno" && break -done -rm -f conftest.$ac_ext -CC=$ac_save_CC - -fi -# AC_CACHE_VAL -case "x$ac_cv_prog_cc_c89" in - x) - { $as_echo "$as_me:${as_lineno-$LINENO}: result: none needed" >&5 -$as_echo "none needed" >&6; } ;; - xno) - { $as_echo "$as_me:${as_lineno-$LINENO}: result: unsupported" >&5 -$as_echo "unsupported" >&6; } ;; - *) - CC="$CC $ac_cv_prog_cc_c89" - { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_prog_cc_c89" >&5 -$as_echo "$ac_cv_prog_cc_c89" >&6; } ;; -esac -if test "x$ac_cv_prog_cc_c89" != xno; then : - -fi - -ac_ext=c -ac_cpp='$CPP $CPPFLAGS' -ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' -ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' -ac_compiler_gnu=$ac_cv_c_compiler_gnu - -echo "Assuming C compiler is $CC" -ac_ext=${ac_fc_srcext-f} -ac_compile='$FC -c $FCFLAGS $ac_fcflags_srcext conftest.$ac_ext >&5' -ac_link='$FC -o conftest$ac_exeext $FCFLAGS $LDFLAGS $ac_fcflags_srcext conftest.$ac_ext $LIBS >&5' -ac_compiler_gnu=$ac_cv_fc_compiler_gnu -if test -n "$ac_tool_prefix"; then - for ac_prog in gfortran g95 xlf95 f95 fort ifort ifc efc pgfortran pgf95 lf95 ftn xlf90 f90 pgf90 pghpf epcf90 g77 xlf f77 frt pgf77 cf77 fort77 fl32 af77 - do - # Extract the first word of "$ac_tool_prefix$ac_prog", so it can be a program name with args. -set dummy $ac_tool_prefix$ac_prog; ac_word=$2 -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 -$as_echo_n "checking for $ac_word... " >&6; } -if ${ac_cv_prog_FC+:} false; then : - $as_echo_n "(cached) " >&6 -else - if test -n "$FC"; then - ac_cv_prog_FC="$FC" # Let the user override the test. -else -as_save_IFS=$IFS; IFS=$PATH_SEPARATOR -for as_dir in $PATH -do - IFS=$as_save_IFS - test -z "$as_dir" && as_dir=. - for ac_exec_ext in '' $ac_executable_extensions; do - if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then - ac_cv_prog_FC="$ac_tool_prefix$ac_prog" - $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 - break 2 - fi -done - done -IFS=$as_save_IFS - -fi -fi -FC=$ac_cv_prog_FC -if test -n "$FC"; then - { $as_echo "$as_me:${as_lineno-$LINENO}: result: $FC" >&5 -$as_echo "$FC" >&6; } -else - { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 -$as_echo "no" >&6; } -fi - - - test -n "$FC" && break - done -fi -if test -z "$FC"; then - ac_ct_FC=$FC - for ac_prog in gfortran g95 xlf95 f95 fort ifort ifc efc pgfortran pgf95 lf95 ftn xlf90 f90 pgf90 pghpf epcf90 g77 xlf f77 frt pgf77 cf77 fort77 fl32 af77 -do - # Extract the first word of "$ac_prog", so it can be a program name with args. -set dummy $ac_prog; ac_word=$2 -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 -$as_echo_n "checking for $ac_word... " >&6; } -if ${ac_cv_prog_ac_ct_FC+:} false; then : - $as_echo_n "(cached) " >&6 -else - if test -n "$ac_ct_FC"; then - ac_cv_prog_ac_ct_FC="$ac_ct_FC" # Let the user override the test. -else -as_save_IFS=$IFS; IFS=$PATH_SEPARATOR -for as_dir in $PATH -do - IFS=$as_save_IFS - test -z "$as_dir" && as_dir=. - for ac_exec_ext in '' $ac_executable_extensions; do - if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then - ac_cv_prog_ac_ct_FC="$ac_prog" - $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 - break 2 - fi -done - done -IFS=$as_save_IFS - -fi -fi -ac_ct_FC=$ac_cv_prog_ac_ct_FC -if test -n "$ac_ct_FC"; then - { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_ct_FC" >&5 -$as_echo "$ac_ct_FC" >&6; } -else - { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 -$as_echo "no" >&6; } -fi - - - test -n "$ac_ct_FC" && break -done - - if test "x$ac_ct_FC" = x; then - FC="" - else - case $cross_compiling:$ac_tool_warned in -yes:) -{ $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5 -$as_echo "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;} -ac_tool_warned=yes ;; -esac - FC=$ac_ct_FC - fi -fi - - -# Provide some information about the compiler. -$as_echo "$as_me:${as_lineno-$LINENO}: checking for Fortran compiler version" >&5 -set X $ac_compile -ac_compiler=$2 -for ac_option in --version -v -V -qversion; do - { { ac_try="$ac_compiler $ac_option >&5" -case "(($ac_try" in - *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; - *) ac_try_echo=$ac_try;; -esac -eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" -$as_echo "$ac_try_echo"; } >&5 - (eval "$ac_compiler $ac_option >&5") 2>conftest.err - ac_status=$? - if test -s conftest.err; then - sed '10a\ -... rest of stderr output deleted ... - 10q' conftest.err >conftest.er1 - cat conftest.er1 >&5 - fi - rm -f conftest.er1 conftest.err - $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 - test $ac_status = 0; } -done -rm -f a.out - -# If we don't use `.F' as extension, the preprocessor is not run on the -# input file. (Note that this only needs to work for GNU compilers.) -ac_save_ext=$ac_ext -ac_ext=F -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking whether we are using the GNU Fortran compiler" >&5 -$as_echo_n "checking whether we are using the GNU Fortran compiler... " >&6; } -if ${ac_cv_fc_compiler_gnu+:} false; then : - $as_echo_n "(cached) " >&6 -else - cat > conftest.$ac_ext <<_ACEOF - program main -#ifndef __GNUC__ - choke me -#endif - - end -_ACEOF -if ac_fn_fc_try_compile "$LINENO"; then : - ac_compiler_gnu=yes -else - ac_compiler_gnu=no -fi -rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext -ac_cv_fc_compiler_gnu=$ac_compiler_gnu - -fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_fc_compiler_gnu" >&5 -$as_echo "$ac_cv_fc_compiler_gnu" >&6; } -ac_ext=$ac_save_ext -ac_test_FCFLAGS=${FCFLAGS+set} -ac_save_FCFLAGS=$FCFLAGS -FCFLAGS= -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking whether $FC accepts -g" >&5 -$as_echo_n "checking whether $FC accepts -g... " >&6; } -if ${ac_cv_prog_fc_g+:} false; then : - $as_echo_n "(cached) " >&6 -else - FCFLAGS=-g -cat > conftest.$ac_ext <<_ACEOF - program main - - end -_ACEOF -if ac_fn_fc_try_compile "$LINENO"; then : - ac_cv_prog_fc_g=yes -else - ac_cv_prog_fc_g=no -fi -rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext - -fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_prog_fc_g" >&5 -$as_echo "$ac_cv_prog_fc_g" >&6; } -if test "$ac_test_FCFLAGS" = set; then - FCFLAGS=$ac_save_FCFLAGS -elif test $ac_cv_prog_fc_g = yes; then - if test "x$ac_cv_fc_compiler_gnu" = xyes; then - FCFLAGS="-g -O2" - else - FCFLAGS="-g" - fi -else - if test "x$ac_cv_fc_compiler_gnu" = xyes; then - FCFLAGS="-O2" - else - FCFLAGS= - fi -fi - -ac_ext=c -ac_cpp='$CPP $CPPFLAGS' -ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' -ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' -ac_compiler_gnu=$ac_cv_c_compiler_gnu - -echo "Assuming Fortran compiler is $FC" - -ac_ext=${ac_fc_srcext-f} -ac_compile='$FC -c $FCFLAGS $ac_fcflags_srcext conftest.$ac_ext >&5' -ac_link='$FC -o conftest$ac_exeext $FCFLAGS $LDFLAGS $ac_fcflags_srcext conftest.$ac_ext $LIBS >&5' -ac_compiler_gnu=$ac_cv_fc_compiler_gnu -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking how to get verbose linking output from $FC" >&5 -$as_echo_n "checking how to get verbose linking output from $FC... " >&6; } -if ${ac_cv_prog_fc_v+:} false; then : - $as_echo_n "(cached) " >&6 -else - cat > conftest.$ac_ext <<_ACEOF - program main - - end -_ACEOF -if ac_fn_fc_try_compile "$LINENO"; then : - ac_cv_prog_fc_v= -# Try some options frequently used verbose output -for ac_verb in -v -verbose --verbose -V -\#\#\#; do - cat > conftest.$ac_ext <<_ACEOF - program main - - end -_ACEOF - -# Compile and link our simple test program by passing a flag (argument -# 1 to this macro) to the Fortran compiler in order to get -# "verbose" output that we can then parse for the Fortran linker -# flags. -ac_save_FCFLAGS=$FCFLAGS -FCFLAGS="$FCFLAGS $ac_verb" -eval "set x $ac_link" -shift -$as_echo "$as_me:${as_lineno-$LINENO}: $*" >&5 -# gfortran 4.3 outputs lines setting COLLECT_GCC_OPTIONS, COMPILER_PATH, -# LIBRARY_PATH; skip all such settings. -ac_fc_v_output=`eval $ac_link 5>&1 2>&1 | - sed '/^Driving:/d; /^Configured with:/d; - '"/^[_$as_cr_Letters][_$as_cr_alnum]*=/d"` -$as_echo "$ac_fc_v_output" >&5 -FCFLAGS=$ac_save_FCFLAGS - -rm -rf conftest* - -# On HP/UX there is a line like: "LPATH is: /foo:/bar:/baz" where -# /foo, /bar, and /baz are search directories for the Fortran linker. -# Here, we change these into -L/foo -L/bar -L/baz (and put it first): -ac_fc_v_output="`echo $ac_fc_v_output | - grep 'LPATH is:' | - sed 's|.*LPATH is\(: *[^ ]*\).*|\1|;s|: */| -L/|g'` $ac_fc_v_output" - -# FIXME: we keep getting bitten by quoted arguments; a more general fix -# that detects unbalanced quotes in FLIBS should be implemented -# and (ugh) tested at some point. -case $ac_fc_v_output in - # If we are using xlf then replace all the commas with spaces. - *xlfentry*) - ac_fc_v_output=`echo $ac_fc_v_output | sed 's/,/ /g'` ;; - - # With Intel ifc, ignore the quoted -mGLOB_options_string stuff (quoted - # $LIBS confuse us, and the libraries appear later in the output anyway). - *mGLOB_options_string*) - ac_fc_v_output=`echo $ac_fc_v_output | sed 's/"-mGLOB[^"]*"/ /g'` ;; - - # Portland Group compiler has singly- or doubly-quoted -cmdline argument - # Singly-quoted arguments were reported for versions 5.2-4 and 6.0-4. - # Doubly-quoted arguments were reported for "PGF90/x86 Linux/x86 5.0-2". - *-cmdline\ * | *-ignore\ * | *-def\ *) - ac_fc_v_output=`echo $ac_fc_v_output | sed "\ - s/-cmdline *'[^']*'/ /g; s/-cmdline *\"[^\"]*\"/ /g - s/-ignore *'[^']*'/ /g; s/-ignore *\"[^\"]*\"/ /g - s/-def *'[^']*'/ /g; s/-def *\"[^\"]*\"/ /g"` ;; - - # If we are using Cray Fortran then delete quotes. - *cft90*) - ac_fc_v_output=`echo $ac_fc_v_output | sed 's/"//g'` ;; -esac - - - # look for -l* and *.a constructs in the output - for ac_arg in $ac_fc_v_output; do - case $ac_arg in - [\\/]*.a | ?:[\\/]*.a | -[lLRu]*) - ac_cv_prog_fc_v=$ac_verb - break 2 ;; - esac - done -done -if test -z "$ac_cv_prog_fc_v"; then - { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: cannot determine how to obtain linking information from $FC" >&5 -$as_echo "$as_me: WARNING: cannot determine how to obtain linking information from $FC" >&2;} -fi -else - { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: compilation failed" >&5 -$as_echo "$as_me: WARNING: compilation failed" >&2;} -fi -rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext - -fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_prog_fc_v" >&5 -$as_echo "$ac_cv_prog_fc_v" >&6; } -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for Fortran libraries of $FC" >&5 -$as_echo_n "checking for Fortran libraries of $FC... " >&6; } -if ${ac_cv_fc_libs+:} false; then : - $as_echo_n "(cached) " >&6 -else - if test "x$FCLIBS" != "x"; then - ac_cv_fc_libs="$FCLIBS" # Let the user override the test. -else - -cat > conftest.$ac_ext <<_ACEOF - program main - - end -_ACEOF - -# Compile and link our simple test program by passing a flag (argument -# 1 to this macro) to the Fortran compiler in order to get -# "verbose" output that we can then parse for the Fortran linker -# flags. -ac_save_FCFLAGS=$FCFLAGS -FCFLAGS="$FCFLAGS $ac_cv_prog_fc_v" -eval "set x $ac_link" -shift -$as_echo "$as_me:${as_lineno-$LINENO}: $*" >&5 -# gfortran 4.3 outputs lines setting COLLECT_GCC_OPTIONS, COMPILER_PATH, -# LIBRARY_PATH; skip all such settings. -ac_fc_v_output=`eval $ac_link 5>&1 2>&1 | - sed '/^Driving:/d; /^Configured with:/d; - '"/^[_$as_cr_Letters][_$as_cr_alnum]*=/d"` -$as_echo "$ac_fc_v_output" >&5 -FCFLAGS=$ac_save_FCFLAGS - -rm -rf conftest* - -# On HP/UX there is a line like: "LPATH is: /foo:/bar:/baz" where -# /foo, /bar, and /baz are search directories for the Fortran linker. -# Here, we change these into -L/foo -L/bar -L/baz (and put it first): -ac_fc_v_output="`echo $ac_fc_v_output | - grep 'LPATH is:' | - sed 's|.*LPATH is\(: *[^ ]*\).*|\1|;s|: */| -L/|g'` $ac_fc_v_output" - -# FIXME: we keep getting bitten by quoted arguments; a more general fix -# that detects unbalanced quotes in FLIBS should be implemented -# and (ugh) tested at some point. -case $ac_fc_v_output in - # If we are using xlf then replace all the commas with spaces. - *xlfentry*) - ac_fc_v_output=`echo $ac_fc_v_output | sed 's/,/ /g'` ;; - - # With Intel ifc, ignore the quoted -mGLOB_options_string stuff (quoted - # $LIBS confuse us, and the libraries appear later in the output anyway). - *mGLOB_options_string*) - ac_fc_v_output=`echo $ac_fc_v_output | sed 's/"-mGLOB[^"]*"/ /g'` ;; - - # Portland Group compiler has singly- or doubly-quoted -cmdline argument - # Singly-quoted arguments were reported for versions 5.2-4 and 6.0-4. - # Doubly-quoted arguments were reported for "PGF90/x86 Linux/x86 5.0-2". - *-cmdline\ * | *-ignore\ * | *-def\ *) - ac_fc_v_output=`echo $ac_fc_v_output | sed "\ - s/-cmdline *'[^']*'/ /g; s/-cmdline *\"[^\"]*\"/ /g - s/-ignore *'[^']*'/ /g; s/-ignore *\"[^\"]*\"/ /g - s/-def *'[^']*'/ /g; s/-def *\"[^\"]*\"/ /g"` ;; - - # If we are using Cray Fortran then delete quotes. - *cft90*) - ac_fc_v_output=`echo $ac_fc_v_output | sed 's/"//g'` ;; -esac - - - -ac_cv_fc_libs= - -# Save positional arguments (if any) -ac_save_positional="$@" - -set X $ac_fc_v_output -while test $# != 1; do - shift - ac_arg=$1 - case $ac_arg in - [\\/]*.a | ?:[\\/]*.a) - ac_exists=false - for ac_i in $ac_cv_fc_libs; do - if test x"$ac_arg" = x"$ac_i"; then - ac_exists=true - break - fi - done - - if test x"$ac_exists" = xtrue; then : - -else - ac_cv_fc_libs="$ac_cv_fc_libs $ac_arg" -fi - ;; - -bI:*) - ac_exists=false - for ac_i in $ac_cv_fc_libs; do - if test x"$ac_arg" = x"$ac_i"; then - ac_exists=true - break - fi - done - - if test x"$ac_exists" = xtrue; then : - -else - if test "$ac_compiler_gnu" = yes; then - for ac_link_opt in $ac_arg; do - ac_cv_fc_libs="$ac_cv_fc_libs -Xlinker $ac_link_opt" - done -else - ac_cv_fc_libs="$ac_cv_fc_libs $ac_arg" -fi -fi - ;; - # Ignore these flags. - -lang* | -lcrt*.o | -lc | -lgcc* | -lSystem | -libmil | -little \ - |-LANG:=* | -LIST:* | -LNO:* | -link) - ;; - -lkernel32) - test x"$CYGWIN" != xyes && ac_cv_fc_libs="$ac_cv_fc_libs $ac_arg" - ;; - -[LRuYz]) - # These flags, when seen by themselves, take an argument. - # We remove the space between option and argument and re-iterate - # unless we find an empty arg or a new option (starting with -) - case $2 in - "" | -*);; - *) - ac_arg="$ac_arg$2" - shift; shift - set X $ac_arg "$@" - ;; - esac - ;; - -YP,*) - for ac_j in `$as_echo "$ac_arg" | sed -e 's/-YP,/-L/;s/:/ -L/g'`; do - ac_exists=false - for ac_i in $ac_cv_fc_libs; do - if test x"$ac_j" = x"$ac_i"; then - ac_exists=true - break - fi - done - - if test x"$ac_exists" = xtrue; then : - -else - ac_arg="$ac_arg $ac_j" - ac_cv_fc_libs="$ac_cv_fc_libs $ac_j" -fi - done - ;; - -[lLR]*) - ac_exists=false - for ac_i in $ac_cv_fc_libs; do - if test x"$ac_arg" = x"$ac_i"; then - ac_exists=true - break - fi - done - - if test x"$ac_exists" = xtrue; then : - -else - ac_cv_fc_libs="$ac_cv_fc_libs $ac_arg" -fi - ;; - -zallextract*| -zdefaultextract) - ac_cv_fc_libs="$ac_cv_fc_libs $ac_arg" - ;; - # Ignore everything else. - esac -done -# restore positional arguments -set X $ac_save_positional; shift - -# We only consider "LD_RUN_PATH" on Solaris systems. If this is seen, -# then we insist that the "run path" must be an absolute path (i.e. it -# must begin with a "/"). -case `(uname -sr) 2>/dev/null` in - "SunOS 5"*) - ac_ld_run_path=`$as_echo "$ac_fc_v_output" | - sed -n 's,^.*LD_RUN_PATH *= *\(/[^ ]*\).*$,-R\1,p'` - test "x$ac_ld_run_path" != x && - if test "$ac_compiler_gnu" = yes; then - for ac_link_opt in $ac_ld_run_path; do - ac_cv_fc_libs="$ac_cv_fc_libs -Xlinker $ac_link_opt" - done -else - ac_cv_fc_libs="$ac_cv_fc_libs $ac_ld_run_path" -fi - ;; -esac -fi # test "x$[]_AC_LANG_PREFIX[]LIBS" = "x" - -fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_fc_libs" >&5 -$as_echo "$ac_cv_fc_libs" >&6; } -FCLIBS="$ac_cv_fc_libs" - - -ac_ext=c -ac_cpp='$CPP $CPPFLAGS' -ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' -ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' -ac_compiler_gnu=$ac_cv_c_compiler_gnu - - -ac_ext=${ac_fc_srcext-f} -ac_compile='$FC -c $FCFLAGS $ac_fcflags_srcext conftest.$ac_ext >&5' -ac_link='$FC -o conftest$ac_exeext $FCFLAGS $LDFLAGS $ac_fcflags_srcext conftest.$ac_ext $LIBS >&5' -ac_compiler_gnu=$ac_cv_fc_compiler_gnu - -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for dummy main to link with Fortran libraries" >&5 -$as_echo_n "checking for dummy main to link with Fortran libraries... " >&6; } -if ${ac_cv_fc_dummy_main+:} false; then : - $as_echo_n "(cached) " >&6 -else - ac_fc_dm_save_LIBS=$LIBS - LIBS="$LIBS $FCLIBS" - ac_fortran_dm_var=FC_DUMMY_MAIN - ac_ext=c -ac_cpp='$CPP $CPPFLAGS' -ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' -ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' -ac_compiler_gnu=$ac_cv_c_compiler_gnu - - # First, try linking without a dummy main: - cat confdefs.h - <<_ACEOF >conftest.$ac_ext -/* end confdefs.h. */ - -#ifdef FC_DUMMY_MAIN -#ifndef FC_DUMMY_MAIN_EQ_F77 -# ifdef __cplusplus - extern "C" -# endif - int FC_DUMMY_MAIN() { return 1; } -#endif -#endif -int -main () -{ - - ; - return 0; -} -_ACEOF -if ac_fn_c_try_link "$LINENO"; then : - ac_cv_fortran_dummy_main=none -else - ac_cv_fortran_dummy_main=unknown -fi -rm -f core conftest.err conftest.$ac_objext \ - conftest$ac_exeext conftest.$ac_ext - - if test $ac_cv_fortran_dummy_main = unknown; then - for ac_func in MAIN__ MAIN_ __main MAIN _MAIN __MAIN main_ main__ _main; do - cat confdefs.h - <<_ACEOF >conftest.$ac_ext -/* end confdefs.h. */ -#define $ac_fortran_dm_var $ac_func -#ifdef FC_DUMMY_MAIN -#ifndef FC_DUMMY_MAIN_EQ_F77 -# ifdef __cplusplus - extern "C" -# endif - int FC_DUMMY_MAIN() { return 1; } -#endif -#endif -int -main () -{ - - ; - return 0; -} -_ACEOF -if ac_fn_c_try_link "$LINENO"; then : - ac_cv_fortran_dummy_main=$ac_func; break -fi -rm -f core conftest.err conftest.$ac_objext \ - conftest$ac_exeext conftest.$ac_ext - done - fi - ac_ext=${ac_fc_srcext-f} -ac_compile='$FC -c $FCFLAGS $ac_fcflags_srcext conftest.$ac_ext >&5' -ac_link='$FC -o conftest$ac_exeext $FCFLAGS $LDFLAGS $ac_fcflags_srcext conftest.$ac_ext $LIBS >&5' -ac_compiler_gnu=$ac_cv_fc_compiler_gnu - ac_cv_fc_dummy_main=$ac_cv_fortran_dummy_main - rm -rf conftest* - LIBS=$ac_fc_dm_save_LIBS - -fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_fc_dummy_main" >&5 -$as_echo "$ac_cv_fc_dummy_main" >&6; } -FC_DUMMY_MAIN=$ac_cv_fc_dummy_main -if test "$FC_DUMMY_MAIN" != unknown; then : - if test $FC_DUMMY_MAIN != none; then - -cat >>confdefs.h <<_ACEOF -#define FC_DUMMY_MAIN $FC_DUMMY_MAIN -_ACEOF - - if test "x$ac_cv_fc_dummy_main" = "x$ac_cv_f77_dummy_main"; then - -$as_echo "#define FC_DUMMY_MAIN_EQ_F77 1" >>confdefs.h - - fi -fi -else - { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 -$as_echo "$as_me: error: in \`$ac_pwd':" >&2;} -as_fn_error $? "linking to Fortran libraries from C fails -See \`config.log' for more details" "$LINENO" 5; } -fi - -ac_ext=c -ac_cpp='$CPP $CPPFLAGS' -ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' -ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' -ac_compiler_gnu=$ac_cv_c_compiler_gnu - -ac_ext=${ac_fc_srcext-f} -ac_compile='$FC -c $FCFLAGS $ac_fcflags_srcext conftest.$ac_ext >&5' -ac_link='$FC -o conftest$ac_exeext $FCFLAGS $LDFLAGS $ac_fcflags_srcext conftest.$ac_ext $LIBS >&5' -ac_compiler_gnu=$ac_cv_fc_compiler_gnu -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for Fortran name-mangling scheme" >&5 -$as_echo_n "checking for Fortran name-mangling scheme... " >&6; } -if ${ac_cv_fc_mangling+:} false; then : - $as_echo_n "(cached) " >&6 -else - cat > conftest.$ac_ext <<_ACEOF - subroutine foobar() - return - end - subroutine foo_bar() - return - end -_ACEOF -if ac_fn_fc_try_compile "$LINENO"; then : - mv conftest.$ac_objext cfortran_test.$ac_objext - - ac_save_LIBS=$LIBS - LIBS="cfortran_test.$ac_objext $LIBS $FCLIBS" - - ac_ext=c -ac_cpp='$CPP $CPPFLAGS' -ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' -ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' -ac_compiler_gnu=$ac_cv_c_compiler_gnu - ac_success=no - for ac_foobar in foobar FOOBAR; do - for ac_underscore in "" "_"; do - ac_func="$ac_foobar$ac_underscore" - cat confdefs.h - <<_ACEOF >conftest.$ac_ext -/* end confdefs.h. */ - -/* Override any GCC internal prototype to avoid an error. - Use char because int might match the return type of a GCC - builtin and then its argument prototype would still apply. */ -#ifdef __cplusplus -extern "C" -#endif -char $ac_func (); -#ifdef FC_DUMMY_MAIN -#ifndef FC_DUMMY_MAIN_EQ_F77 -# ifdef __cplusplus - extern "C" -# endif - int FC_DUMMY_MAIN() { return 1; } -#endif -#endif -int -main () -{ -return $ac_func (); - ; - return 0; -} -_ACEOF -if ac_fn_c_try_link "$LINENO"; then : - ac_success=yes; break 2 -fi -rm -f core conftest.err conftest.$ac_objext \ - conftest$ac_exeext conftest.$ac_ext - done - done - ac_ext=${ac_fc_srcext-f} -ac_compile='$FC -c $FCFLAGS $ac_fcflags_srcext conftest.$ac_ext >&5' -ac_link='$FC -o conftest$ac_exeext $FCFLAGS $LDFLAGS $ac_fcflags_srcext conftest.$ac_ext $LIBS >&5' -ac_compiler_gnu=$ac_cv_fc_compiler_gnu - - if test "$ac_success" = "yes"; then - case $ac_foobar in - foobar) - ac_case=lower - ac_foo_bar=foo_bar - ;; - FOOBAR) - ac_case=upper - ac_foo_bar=FOO_BAR - ;; - esac - - ac_ext=c -ac_cpp='$CPP $CPPFLAGS' -ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' -ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' -ac_compiler_gnu=$ac_cv_c_compiler_gnu - ac_success_extra=no - for ac_extra in "" "_"; do - ac_func="$ac_foo_bar$ac_underscore$ac_extra" - cat confdefs.h - <<_ACEOF >conftest.$ac_ext -/* end confdefs.h. */ - -/* Override any GCC internal prototype to avoid an error. - Use char because int might match the return type of a GCC - builtin and then its argument prototype would still apply. */ -#ifdef __cplusplus -extern "C" -#endif -char $ac_func (); -#ifdef FC_DUMMY_MAIN -#ifndef FC_DUMMY_MAIN_EQ_F77 -# ifdef __cplusplus - extern "C" -# endif - int FC_DUMMY_MAIN() { return 1; } -#endif -#endif -int -main () -{ -return $ac_func (); - ; - return 0; -} -_ACEOF -if ac_fn_c_try_link "$LINENO"; then : - ac_success_extra=yes; break -fi -rm -f core conftest.err conftest.$ac_objext \ - conftest$ac_exeext conftest.$ac_ext - done - ac_ext=${ac_fc_srcext-f} -ac_compile='$FC -c $FCFLAGS $ac_fcflags_srcext conftest.$ac_ext >&5' -ac_link='$FC -o conftest$ac_exeext $FCFLAGS $LDFLAGS $ac_fcflags_srcext conftest.$ac_ext $LIBS >&5' -ac_compiler_gnu=$ac_cv_fc_compiler_gnu - - if test "$ac_success_extra" = "yes"; then - ac_cv_fc_mangling="$ac_case case" - if test -z "$ac_underscore"; then - ac_cv_fc_mangling="$ac_cv_fc_mangling, no underscore" - else - ac_cv_fc_mangling="$ac_cv_fc_mangling, underscore" - fi - if test -z "$ac_extra"; then - ac_cv_fc_mangling="$ac_cv_fc_mangling, no extra underscore" - else - ac_cv_fc_mangling="$ac_cv_fc_mangling, extra underscore" - fi - else - ac_cv_fc_mangling="unknown" - fi - else - ac_cv_fc_mangling="unknown" - fi - - LIBS=$ac_save_LIBS - rm -rf conftest* - rm -f cfortran_test* -else - { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 -$as_echo "$as_me: error: in \`$ac_pwd':" >&2;} -as_fn_error $? "cannot compile a simple Fortran program -See \`config.log' for more details" "$LINENO" 5; } -fi -rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext - -fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_fc_mangling" >&5 -$as_echo "$ac_cv_fc_mangling" >&6; } - -ac_ext=c -ac_cpp='$CPP $CPPFLAGS' -ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' -ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' -ac_compiler_gnu=$ac_cv_c_compiler_gnu - -ac_ext=${ac_fc_srcext-f} -ac_compile='$FC -c $FCFLAGS $ac_fcflags_srcext conftest.$ac_ext >&5' -ac_link='$FC -o conftest$ac_exeext $FCFLAGS $LDFLAGS $ac_fcflags_srcext conftest.$ac_ext $LIBS >&5' -ac_compiler_gnu=$ac_cv_fc_compiler_gnu -case $ac_cv_fc_mangling in - upper*) ac_val="Z_ZZ" ;; - lower*) ac_val="z_zz" ;; - *) ac_val="unknown" ;; -esac -case $ac_cv_fc_mangling in *," underscore"*) ac_val="$ac_val"_ ;; esac -case $ac_cv_fc_mangling in *," extra underscore"*) ac_val="$ac_val"_ ;; esac - -z_zz="$ac_val" - -ac_ext=c -ac_cpp='$CPP $CPPFLAGS' -ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' -ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' -ac_compiler_gnu=$ac_cv_c_compiler_gnu - -case $z_zz in - z_zz__) echo "Fortran name mangling: UNDERSCORING=-DFORTRANDOUBLEUNDERSCORE" ;; - z_zz_) echo "Fortran name mangling: UNDERSCORING=-DFORTRANUNDERSCORE" ;; - Z_ZZ) echo "Fortran name mangling: UNDERSCORING=-DFORTRANCAPS" ;; - *) echo "Fortran name mangling: UNDERSCORING=" ;; -esac - -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for inline" >&5 -$as_echo_n "checking for inline... " >&6; } -if ${ac_cv_c_inline+:} false; then : - $as_echo_n "(cached) " >&6 -else - ac_cv_c_inline=no -for ac_kw in inline __inline__ __inline; do - cat confdefs.h - <<_ACEOF >conftest.$ac_ext -/* end confdefs.h. */ -#ifndef __cplusplus -typedef int foo_t; -static $ac_kw foo_t static_foo () {return 0; } -$ac_kw foo_t foo () {return 0; } -#endif - -_ACEOF -if ac_fn_c_try_compile "$LINENO"; then : - ac_cv_c_inline=$ac_kw -fi -rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext - test "$ac_cv_c_inline" != no && break -done - -fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_c_inline" >&5 -$as_echo "$ac_cv_c_inline" >&6; } - -case $ac_cv_c_inline in - inline | yes) ;; - *) - case $ac_cv_c_inline in - no) ac_val=;; - *) ac_val=$ac_cv_c_inline;; - esac - cat >>confdefs.h <<_ACEOF -#ifndef __cplusplus -#define inline $ac_val -#endif -_ACEOF - ;; -esac - -echo "Inlining: -Dinline=$ac_cv_c_inline" -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for PAPI_library_init in -lpapi" >&5 -$as_echo_n "checking for PAPI_library_init in -lpapi... " >&6; } -if ${ac_cv_lib_papi_PAPI_library_init+:} false; then : - $as_echo_n "(cached) " >&6 -else - ac_check_lib_save_LIBS=$LIBS -LIBS="-lpapi $LIBS" -cat confdefs.h - <<_ACEOF >conftest.$ac_ext -/* end confdefs.h. */ - -/* Override any GCC internal prototype to avoid an error. - Use char because int might match the return type of a GCC - builtin and then its argument prototype would still apply. */ -#ifdef __cplusplus -extern "C" -#endif -char PAPI_library_init (); -#ifdef FC_DUMMY_MAIN -#ifndef FC_DUMMY_MAIN_EQ_F77 -# ifdef __cplusplus - extern "C" -# endif - int FC_DUMMY_MAIN() { return 1; } -#endif -#endif -int -main () -{ -return PAPI_library_init (); - ; - return 0; -} -_ACEOF -if ac_fn_c_try_link "$LINENO"; then : - ac_cv_lib_papi_PAPI_library_init=yes -else - ac_cv_lib_papi_PAPI_library_init=no -fi -rm -f core conftest.err conftest.$ac_objext \ - conftest$ac_exeext conftest.$ac_ext -LIBS=$ac_check_lib_save_LIBS -fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_papi_PAPI_library_init" >&5 -$as_echo "$ac_cv_lib_papi_PAPI_library_init" >&6; } -if test "x$ac_cv_lib_papi_PAPI_library_init" = xyes; then : - echo "PAPI library found: OK to set HAVE_PAPI=yes" -else - echo "PAPI library not found: HAVE_PAPI=no" -fi - - -ac_fn_c_check_func "$LINENO" "backtrace_symbols" "ac_cv_func_backtrace_symbols" -if test "x$ac_cv_func_backtrace_symbols" = xyes; then : - echo "backtrace_symbols found: OK to set HAVE_BACKTRACE=yes" -else - echo "backtrace_symbols NOT found: HAVE_BACKTRACE=no" -fi - - -unset usempich; -unset usempi; -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for MPI_Init in -lmpich" >&5 -$as_echo_n "checking for MPI_Init in -lmpich... " >&6; } -if ${ac_cv_lib_mpich_MPI_Init+:} false; then : - $as_echo_n "(cached) " >&6 -else - ac_check_lib_save_LIBS=$LIBS -LIBS="-lmpich $LIBS" -cat confdefs.h - <<_ACEOF >conftest.$ac_ext -/* end confdefs.h. */ - -/* Override any GCC internal prototype to avoid an error. - Use char because int might match the return type of a GCC - builtin and then its argument prototype would still apply. */ -#ifdef __cplusplus -extern "C" -#endif -char MPI_Init (); -#ifdef FC_DUMMY_MAIN -#ifndef FC_DUMMY_MAIN_EQ_F77 -# ifdef __cplusplus - extern "C" -# endif - int FC_DUMMY_MAIN() { return 1; } -#endif -#endif -int -main () -{ -return MPI_Init (); - ; - return 0; -} -_ACEOF -if ac_fn_c_try_link "$LINENO"; then : - ac_cv_lib_mpich_MPI_Init=yes -else - ac_cv_lib_mpich_MPI_Init=no -fi -rm -f core conftest.err conftest.$ac_objext \ - conftest$ac_exeext conftest.$ac_ext -LIBS=$ac_check_lib_save_LIBS -fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_mpich_MPI_Init" >&5 -$as_echo "$ac_cv_lib_mpich_MPI_Init" >&6; } -if test "x$ac_cv_lib_mpich_MPI_Init" = xyes; then : - echo "libmpich.a found: OK to set HAVE_MPI=yes";usempich=yes -else - { $as_echo "$as_me:${as_lineno-$LINENO}: checking for MPI_Init in -lmpi" >&5 -$as_echo_n "checking for MPI_Init in -lmpi... " >&6; } -if ${ac_cv_lib_mpi_MPI_Init+:} false; then : - $as_echo_n "(cached) " >&6 -else - ac_check_lib_save_LIBS=$LIBS -LIBS="-lmpi $LIBS" -cat confdefs.h - <<_ACEOF >conftest.$ac_ext -/* end confdefs.h. */ - -/* Override any GCC internal prototype to avoid an error. - Use char because int might match the return type of a GCC - builtin and then its argument prototype would still apply. */ -#ifdef __cplusplus -extern "C" -#endif -char MPI_Init (); -#ifdef FC_DUMMY_MAIN -#ifndef FC_DUMMY_MAIN_EQ_F77 -# ifdef __cplusplus - extern "C" -# endif - int FC_DUMMY_MAIN() { return 1; } -#endif -#endif -int -main () -{ -return MPI_Init (); - ; - return 0; -} -_ACEOF -if ac_fn_c_try_link "$LINENO"; then : - ac_cv_lib_mpi_MPI_Init=yes -else - ac_cv_lib_mpi_MPI_Init=no -fi -rm -f core conftest.err conftest.$ac_objext \ - conftest$ac_exeext conftest.$ac_ext -LIBS=$ac_check_lib_save_LIBS -fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_mpi_MPI_Init" >&5 -$as_echo "$ac_cv_lib_mpi_MPI_Init" >&6; } -if test "x$ac_cv_lib_mpi_MPI_Init" = xyes; then : - echo "libmpi.a found: OK to set HAVE_MPI=yes OK";usempi=yes -else - echo "MPI library not found: HAVE_MPI=no" -fi - -fi - -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for /proc" >&5 -$as_echo_n "checking for /proc... " >&6; } -if ${ac_cv_file__proc+:} false; then : - $as_echo_n "(cached) " >&6 -else - test "$cross_compiling" = yes && - as_fn_error $? "cannot check for file existence when cross compiling" "$LINENO" 5 -if test -r "/proc"; then - ac_cv_file__proc=yes -else - ac_cv_file__proc=no -fi -fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_file__proc" >&5 -$as_echo "$ac_cv_file__proc" >&6; } -if test "x$ac_cv_file__proc" = xyes; then : - echo "/proc found: HAVE_SLASHPROC=yes" -else - echo "/proc not found: HAVE_SLASHPROC=no" -fi - -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for pthread_mutex_init in -lpthread" >&5 -$as_echo_n "checking for pthread_mutex_init in -lpthread... " >&6; } -if ${ac_cv_lib_pthread_pthread_mutex_init+:} false; then : - $as_echo_n "(cached) " >&6 -else - ac_check_lib_save_LIBS=$LIBS -LIBS="-lpthread $LIBS" -cat confdefs.h - <<_ACEOF >conftest.$ac_ext -/* end confdefs.h. */ - -/* Override any GCC internal prototype to avoid an error. - Use char because int might match the return type of a GCC - builtin and then its argument prototype would still apply. */ -#ifdef __cplusplus -extern "C" -#endif -char pthread_mutex_init (); -#ifdef FC_DUMMY_MAIN -#ifndef FC_DUMMY_MAIN_EQ_F77 -# ifdef __cplusplus - extern "C" -# endif - int FC_DUMMY_MAIN() { return 1; } -#endif -#endif -int -main () -{ -return pthread_mutex_init (); - ; - return 0; -} -_ACEOF -if ac_fn_c_try_link "$LINENO"; then : - ac_cv_lib_pthread_pthread_mutex_init=yes -else - ac_cv_lib_pthread_pthread_mutex_init=no -fi -rm -f core conftest.err conftest.$ac_objext \ - conftest$ac_exeext conftest.$ac_ext -LIBS=$ac_check_lib_save_LIBS -fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_pthread_pthread_mutex_init" >&5 -$as_echo "$ac_cv_lib_pthread_pthread_mutex_init" >&6; } -if test "x$ac_cv_lib_pthread_pthread_mutex_init" = xyes; then : - echo "pthreads library found: OK to set PTHREADS=yes" -else - echo "pthreads library not found: PTHREADS=no" -fi - - -if test -n "${usempich}" ; then -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for iargc in -lmpich" >&5 -$as_echo_n "checking for iargc in -lmpich... " >&6; } -if ${ac_cv_lib_mpich_iargc+:} false; then : - $as_echo_n "(cached) " >&6 -else - ac_check_lib_save_LIBS=$LIBS -LIBS="-lmpich $LIBS" -cat confdefs.h - <<_ACEOF >conftest.$ac_ext -/* end confdefs.h. */ - -/* Override any GCC internal prototype to avoid an error. - Use char because int might match the return type of a GCC - builtin and then its argument prototype would still apply. */ -#ifdef __cplusplus -extern "C" -#endif -char iargc (); -#ifdef FC_DUMMY_MAIN -#ifndef FC_DUMMY_MAIN_EQ_F77 -# ifdef __cplusplus - extern "C" -# endif - int FC_DUMMY_MAIN() { return 1; } -#endif -#endif -int -main () -{ -return iargc (); - ; - return 0; -} -_ACEOF -if ac_fn_c_try_link "$LINENO"; then : - ac_cv_lib_mpich_iargc=yes -else - ac_cv_lib_mpich_iargc=no -fi -rm -f core conftest.err conftest.$ac_objext \ - conftest$ac_exeext conftest.$ac_ext -LIBS=$ac_check_lib_save_LIBS -fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_mpich_iargc" >&5 -$as_echo "$ac_cv_lib_mpich_iargc" >&6; } -if test "x$ac_cv_lib_mpich_iargc" = xyes; then : - echo "iargc found in libmpich.a: OK to set HAVE_IARGCGETARG=yes" -else - echo "iargc not found in libmpich.a: HAVE_IARGCGETARG=no" -fi - -fi - -if test -n "${usempi}" ; then -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for iargc in -lmpi" >&5 -$as_echo_n "checking for iargc in -lmpi... " >&6; } -if ${ac_cv_lib_mpi_iargc+:} false; then : - $as_echo_n "(cached) " >&6 -else - ac_check_lib_save_LIBS=$LIBS -LIBS="-lmpi $LIBS" -cat confdefs.h - <<_ACEOF >conftest.$ac_ext -/* end confdefs.h. */ - -/* Override any GCC internal prototype to avoid an error. - Use char because int might match the return type of a GCC - builtin and then its argument prototype would still apply. */ -#ifdef __cplusplus -extern "C" -#endif -char iargc (); -#ifdef FC_DUMMY_MAIN -#ifndef FC_DUMMY_MAIN_EQ_F77 -# ifdef __cplusplus - extern "C" -# endif - int FC_DUMMY_MAIN() { return 1; } -#endif -#endif -int -main () -{ -return iargc (); - ; - return 0; -} -_ACEOF -if ac_fn_c_try_link "$LINENO"; then : - ac_cv_lib_mpi_iargc=yes -else - ac_cv_lib_mpi_iargc=no -fi -rm -f core conftest.err conftest.$ac_objext \ - conftest$ac_exeext conftest.$ac_ext -LIBS=$ac_check_lib_save_LIBS -fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_mpi_iargc" >&5 -$as_echo "$ac_cv_lib_mpi_iargc" >&6; } -if test "x$ac_cv_lib_mpi_iargc" = xyes; then : - echo "iargc found in libmpi.a: OK to set HAVE_IARGCGETARG=yes" -else - echo "iargc not found in libmpi.a: HAVE_IARGCGETARG=no" -fi - -fi - -ac_ext=c -ac_cpp='$CPP $CPPFLAGS' -ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' -ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' -ac_compiler_gnu=$ac_cv_c_compiler_gnu -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking how to run the C preprocessor" >&5 -$as_echo_n "checking how to run the C preprocessor... " >&6; } -# On Suns, sometimes $CPP names a directory. -if test -n "$CPP" && test -d "$CPP"; then - CPP= -fi -if test -z "$CPP"; then - if ${ac_cv_prog_CPP+:} false; then : - $as_echo_n "(cached) " >&6 -else - # Double quotes because CPP needs to be expanded - for CPP in "$CC -E" "$CC -E -traditional-cpp" "/lib/cpp" - do - ac_preproc_ok=false -for ac_c_preproc_warn_flag in '' yes -do - # Use a header file that comes with gcc, so configuring glibc - # with a fresh cross-compiler works. - # Prefer to if __STDC__ is defined, since - # exists even on freestanding compilers. - # On the NeXT, cc -E runs the code through the compiler's parser, - # not just through cpp. "Syntax error" is here to catch this case. - cat confdefs.h - <<_ACEOF >conftest.$ac_ext -/* end confdefs.h. */ -#ifdef __STDC__ -# include -#else -# include -#endif - Syntax error -_ACEOF -if ac_fn_c_try_cpp "$LINENO"; then : - -else - # Broken: fails on valid input. -continue -fi -rm -f conftest.err conftest.i conftest.$ac_ext - - # OK, works on sane cases. Now check whether nonexistent headers - # can be detected and how. - cat confdefs.h - <<_ACEOF >conftest.$ac_ext -/* end confdefs.h. */ -#include -_ACEOF -if ac_fn_c_try_cpp "$LINENO"; then : - # Broken: success on invalid input. -continue -else - # Passes both tests. -ac_preproc_ok=: -break -fi -rm -f conftest.err conftest.i conftest.$ac_ext - -done -# Because of `break', _AC_PREPROC_IFELSE's cleaning code was skipped. -rm -f conftest.i conftest.err conftest.$ac_ext -if $ac_preproc_ok; then : - break -fi - - done - ac_cv_prog_CPP=$CPP - -fi - CPP=$ac_cv_prog_CPP -else - ac_cv_prog_CPP=$CPP -fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $CPP" >&5 -$as_echo "$CPP" >&6; } -ac_preproc_ok=false -for ac_c_preproc_warn_flag in '' yes -do - # Use a header file that comes with gcc, so configuring glibc - # with a fresh cross-compiler works. - # Prefer to if __STDC__ is defined, since - # exists even on freestanding compilers. - # On the NeXT, cc -E runs the code through the compiler's parser, - # not just through cpp. "Syntax error" is here to catch this case. - cat confdefs.h - <<_ACEOF >conftest.$ac_ext -/* end confdefs.h. */ -#ifdef __STDC__ -# include -#else -# include -#endif - Syntax error -_ACEOF -if ac_fn_c_try_cpp "$LINENO"; then : - -else - # Broken: fails on valid input. -continue -fi -rm -f conftest.err conftest.i conftest.$ac_ext - - # OK, works on sane cases. Now check whether nonexistent headers - # can be detected and how. - cat confdefs.h - <<_ACEOF >conftest.$ac_ext -/* end confdefs.h. */ -#include -_ACEOF -if ac_fn_c_try_cpp "$LINENO"; then : - # Broken: success on invalid input. -continue -else - # Passes both tests. -ac_preproc_ok=: -break -fi -rm -f conftest.err conftest.i conftest.$ac_ext - -done -# Because of `break', _AC_PREPROC_IFELSE's cleaning code was skipped. -rm -f conftest.i conftest.err conftest.$ac_ext -if $ac_preproc_ok; then : - -else - { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 -$as_echo "$as_me: error: in \`$ac_pwd':" >&2;} -as_fn_error $? "C preprocessor \"$CPP\" fails sanity check -See \`config.log' for more details" "$LINENO" 5; } -fi - -ac_ext=c -ac_cpp='$CPP $CPPFLAGS' -ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' -ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' -ac_compiler_gnu=$ac_cv_c_compiler_gnu - - -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for grep that handles long lines and -e" >&5 -$as_echo_n "checking for grep that handles long lines and -e... " >&6; } -if ${ac_cv_path_GREP+:} false; then : - $as_echo_n "(cached) " >&6 -else - if test -z "$GREP"; then - ac_path_GREP_found=false - # Loop through the user's path and test for each of PROGNAME-LIST - as_save_IFS=$IFS; IFS=$PATH_SEPARATOR -for as_dir in $PATH$PATH_SEPARATOR/usr/xpg4/bin -do - IFS=$as_save_IFS - test -z "$as_dir" && as_dir=. - for ac_prog in grep ggrep; do - for ac_exec_ext in '' $ac_executable_extensions; do - ac_path_GREP="$as_dir/$ac_prog$ac_exec_ext" - { test -f "$ac_path_GREP" && $as_test_x "$ac_path_GREP"; } || continue -# Check for GNU ac_path_GREP and select it if it is found. - # Check for GNU $ac_path_GREP -case `"$ac_path_GREP" --version 2>&1` in -*GNU*) - ac_cv_path_GREP="$ac_path_GREP" ac_path_GREP_found=:;; -*) - ac_count=0 - $as_echo_n 0123456789 >"conftest.in" - while : - do - cat "conftest.in" "conftest.in" >"conftest.tmp" - mv "conftest.tmp" "conftest.in" - cp "conftest.in" "conftest.nl" - $as_echo 'GREP' >> "conftest.nl" - "$ac_path_GREP" -e 'GREP$' -e '-(cannot match)-' < "conftest.nl" >"conftest.out" 2>/dev/null || break - diff "conftest.out" "conftest.nl" >/dev/null 2>&1 || break - as_fn_arith $ac_count + 1 && ac_count=$as_val - if test $ac_count -gt ${ac_path_GREP_max-0}; then - # Best one so far, save it but keep looking for a better one - ac_cv_path_GREP="$ac_path_GREP" - ac_path_GREP_max=$ac_count - fi - # 10*(2^10) chars as input seems more than enough - test $ac_count -gt 10 && break - done - rm -f conftest.in conftest.tmp conftest.nl conftest.out;; -esac - - $ac_path_GREP_found && break 3 - done - done - done -IFS=$as_save_IFS - if test -z "$ac_cv_path_GREP"; then - as_fn_error $? "no acceptable grep could be found in $PATH$PATH_SEPARATOR/usr/xpg4/bin" "$LINENO" 5 - fi -else - ac_cv_path_GREP=$GREP -fi - -fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_path_GREP" >&5 -$as_echo "$ac_cv_path_GREP" >&6; } - GREP="$ac_cv_path_GREP" - - -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for egrep" >&5 -$as_echo_n "checking for egrep... " >&6; } -if ${ac_cv_path_EGREP+:} false; then : - $as_echo_n "(cached) " >&6 -else - if echo a | $GREP -E '(a|b)' >/dev/null 2>&1 - then ac_cv_path_EGREP="$GREP -E" - else - if test -z "$EGREP"; then - ac_path_EGREP_found=false - # Loop through the user's path and test for each of PROGNAME-LIST - as_save_IFS=$IFS; IFS=$PATH_SEPARATOR -for as_dir in $PATH$PATH_SEPARATOR/usr/xpg4/bin -do - IFS=$as_save_IFS - test -z "$as_dir" && as_dir=. - for ac_prog in egrep; do - for ac_exec_ext in '' $ac_executable_extensions; do - ac_path_EGREP="$as_dir/$ac_prog$ac_exec_ext" - { test -f "$ac_path_EGREP" && $as_test_x "$ac_path_EGREP"; } || continue -# Check for GNU ac_path_EGREP and select it if it is found. - # Check for GNU $ac_path_EGREP -case `"$ac_path_EGREP" --version 2>&1` in -*GNU*) - ac_cv_path_EGREP="$ac_path_EGREP" ac_path_EGREP_found=:;; -*) - ac_count=0 - $as_echo_n 0123456789 >"conftest.in" - while : - do - cat "conftest.in" "conftest.in" >"conftest.tmp" - mv "conftest.tmp" "conftest.in" - cp "conftest.in" "conftest.nl" - $as_echo 'EGREP' >> "conftest.nl" - "$ac_path_EGREP" 'EGREP$' < "conftest.nl" >"conftest.out" 2>/dev/null || break - diff "conftest.out" "conftest.nl" >/dev/null 2>&1 || break - as_fn_arith $ac_count + 1 && ac_count=$as_val - if test $ac_count -gt ${ac_path_EGREP_max-0}; then - # Best one so far, save it but keep looking for a better one - ac_cv_path_EGREP="$ac_path_EGREP" - ac_path_EGREP_max=$ac_count - fi - # 10*(2^10) chars as input seems more than enough - test $ac_count -gt 10 && break - done - rm -f conftest.in conftest.tmp conftest.nl conftest.out;; -esac - - $ac_path_EGREP_found && break 3 - done - done - done -IFS=$as_save_IFS - if test -z "$ac_cv_path_EGREP"; then - as_fn_error $? "no acceptable egrep could be found in $PATH$PATH_SEPARATOR/usr/xpg4/bin" "$LINENO" 5 - fi -else - ac_cv_path_EGREP=$EGREP -fi - - fi -fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_path_EGREP" >&5 -$as_echo "$ac_cv_path_EGREP" >&6; } - EGREP="$ac_cv_path_EGREP" - - -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for ANSI C header files" >&5 -$as_echo_n "checking for ANSI C header files... " >&6; } -if ${ac_cv_header_stdc+:} false; then : - $as_echo_n "(cached) " >&6 -else - cat confdefs.h - <<_ACEOF >conftest.$ac_ext -/* end confdefs.h. */ -#include -#include -#include -#include - -#ifdef FC_DUMMY_MAIN -#ifndef FC_DUMMY_MAIN_EQ_F77 -# ifdef __cplusplus - extern "C" -# endif - int FC_DUMMY_MAIN() { return 1; } -#endif -#endif -int -main () -{ - - ; - return 0; -} -_ACEOF -if ac_fn_c_try_compile "$LINENO"; then : - ac_cv_header_stdc=yes -else - ac_cv_header_stdc=no -fi -rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext - -if test $ac_cv_header_stdc = yes; then - # SunOS 4.x string.h does not declare mem*, contrary to ANSI. - cat confdefs.h - <<_ACEOF >conftest.$ac_ext -/* end confdefs.h. */ -#include - -_ACEOF -if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | - $EGREP "memchr" >/dev/null 2>&1; then : - -else - ac_cv_header_stdc=no -fi -rm -f conftest* - -fi - -if test $ac_cv_header_stdc = yes; then - # ISC 2.0.2 stdlib.h does not declare free, contrary to ANSI. - cat confdefs.h - <<_ACEOF >conftest.$ac_ext -/* end confdefs.h. */ -#include - -_ACEOF -if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | - $EGREP "free" >/dev/null 2>&1; then : - -else - ac_cv_header_stdc=no -fi -rm -f conftest* - -fi - -if test $ac_cv_header_stdc = yes; then - # /bin/cc in Irix-4.0.5 gets non-ANSI ctype macros unless using -ansi. - if test "$cross_compiling" = yes; then : - : -else - cat confdefs.h - <<_ACEOF >conftest.$ac_ext -/* end confdefs.h. */ -#include -#include -#if ((' ' & 0x0FF) == 0x020) -# define ISLOWER(c) ('a' <= (c) && (c) <= 'z') -# define TOUPPER(c) (ISLOWER(c) ? 'A' + ((c) - 'a') : (c)) -#else -# define ISLOWER(c) \ - (('a' <= (c) && (c) <= 'i') \ - || ('j' <= (c) && (c) <= 'r') \ - || ('s' <= (c) && (c) <= 'z')) -# define TOUPPER(c) (ISLOWER(c) ? ((c) | 0x40) : (c)) -#endif - -#define XOR(e, f) (((e) && !(f)) || (!(e) && (f))) -int -main () -{ - int i; - for (i = 0; i < 256; i++) - if (XOR (islower (i), ISLOWER (i)) - || toupper (i) != TOUPPER (i)) - return 2; - return 0; -} -_ACEOF -if ac_fn_c_try_run "$LINENO"; then : - -else - ac_cv_header_stdc=no -fi -rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ - conftest.$ac_objext conftest.beam conftest.$ac_ext -fi - -fi -fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_header_stdc" >&5 -$as_echo "$ac_cv_header_stdc" >&6; } -if test $ac_cv_header_stdc = yes; then - -$as_echo "#define STDC_HEADERS 1" >>confdefs.h - -fi - -# On IRIX 5.3, sys/types and inttypes.h are conflicting. -for ac_header in sys/types.h sys/stat.h stdlib.h string.h memory.h strings.h \ - inttypes.h stdint.h unistd.h -do : - as_ac_Header=`$as_echo "ac_cv_header_$ac_header" | $as_tr_sh` -ac_fn_c_check_header_compile "$LINENO" "$ac_header" "$as_ac_Header" "$ac_includes_default -" -if eval test \"x\$"$as_ac_Header"\" = x"yes"; then : - cat >>confdefs.h <<_ACEOF -#define `$as_echo "HAVE_$ac_header" | $as_tr_cpp` 1 -_ACEOF - -fi - -done - - -# The cast to long int works around a bug in the HP C Compiler -# version HP92453-01 B.11.11.23709.GP, which incorrectly rejects -# declarations like `int a3[[(sizeof (unsigned char)) >= 0]];'. -# This bug is HP SR number 8606223364. -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking size of void *" >&5 -$as_echo_n "checking size of void *... " >&6; } -if ${ac_cv_sizeof_void_p+:} false; then : - $as_echo_n "(cached) " >&6 -else - if ac_fn_c_compute_int "$LINENO" "(long int) (sizeof (void *))" "ac_cv_sizeof_void_p" "$ac_includes_default"; then : - -else - if test "$ac_cv_type_void_p" = yes; then - { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 -$as_echo "$as_me: error: in \`$ac_pwd':" >&2;} -as_fn_error 77 "cannot compute sizeof (void *) -See \`config.log' for more details" "$LINENO" 5; } - else - ac_cv_sizeof_void_p=0 - fi -fi - -fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_sizeof_void_p" >&5 -$as_echo "$ac_cv_sizeof_void_p" >&6; } - - - -cat >>confdefs.h <<_ACEOF -#define SIZEOF_VOID_P $ac_cv_sizeof_void_p -_ACEOF - - -if test "$ac_cv_sizeof_void_p" = 8; then - echo "Pointer size = 8 so BIT64=yes"; -elif test "$ac_cv_sizeof_void_p" = 4; then - echo "Pointer size = 4 so BIT64=no"; -fi diff --git a/cesm/models/utils/timing/gptl/timingModule.F90 b/cesm/models/utils/timing/gptl/timingModule.F90 deleted file mode 100644 index 88233a9..0000000 --- a/cesm/models/utils/timing/gptl/timingModule.F90 +++ /dev/null @@ -1,429 +0,0 @@ -module timingModule - -!----------------------------------------------------------------------- -! timing module -!----------------------------------------------------------------------- - -implicit none - -include 'gptl.inc' - -#if defined(HAVE_PAPI) -include 'f77papi.h' -#endif - -!----------------------------------------------------------------------- -! public interfaces -!----------------------------------------------------------------------- - -private -public timing_init, timing_on, timing_off, timing_clear, timing_prt - -integer :: iret -integer :: nregion -integer :: nevent - -character(len=64), allocatable, dimension(:) :: regions -integer (kind=8), allocatable, dimension(:) :: papicounters - -#if defined( use_EFFICIENCY_COUNTERS ) - - real :: CPU_CYCLES - real :: IA64_INST_RETIRED_THIS - real :: NOPS_RETIRED - real :: BACK_END_BUBBLE_ALL - real :: FP_OPS_RETIRED - real :: BUS_MEMORY_EQ_128BYTE_SELF - real :: BUS_MEMORY_LT_128BYTE_SELF - -#endif - - -#if defined( use_STALL_COUNTERS ) - - real :: BACK_END_BUBBLE_ALL - real :: BE_EXE_BUBBLE_GRALL - real :: BE_EXE_BUBBLE_GRGR - real :: BE_L1D_FPU_BUBBLE_L1D - real :: BE_EXE_BUBBLE_FRALL - real :: BE_L1D_FPU_BUBBLE_FPU - real :: BE_FLUSH_BUBBLE_BRU - real :: FE_BUBBLE_BUBBLE - real :: FE_BUBBLE_BRANCH - real :: FE_BUBBLE_IMISS - real :: BACK_END_BUBBLE_FE - real :: FE_BUBBLE_ALLBUT_IBFULL - real :: BE_RSE_BUBBLE_ALL - -#endif - -#if defined( use_D_CACHE_STALLS_COUNTERS ) - - real :: BACK_END_BUBBLE_ALL - real :: BE_L1D_FPU_BUBBLE_L1D_L2BPRESS - real :: BE_EXE_BUBBLE_GRALL - real :: BE_EXE_BUBBLE_GRGR - real :: BE_L1D_FPU_BUBBLE_L1D_DCURECIR - real :: BE_L1D_FPU_BUBBLE_L1D_STBUFRECIR - real :: BE_L1D_FPU_BUBBLE_L1D_FULLSTBUF - real :: BE_L1D_FPU_BUBBLE_L1D_FILLCONF - real :: BE_L1D_FPU_BUBBLE_L1D_TLB - real :: BE_L1D_FPU_BUBBLE_L1D_HPW - -#endif - -contains - -!####################################################################### - -subroutine timing_init () - -!----------------------------------------------------------------------- -! initialization -!----------------------------------------------------------------------- - - character(len=32), allocatable, dimension(:) :: eventname - - integer :: n, ncount, event - -#if defined(HAVE_PAPI) - - iret = PAPI_VER_CURRENT - call papif_library_init (iret) - if (iret .ne. PAPI_VER_CURRENT) call error_handler(' PAPI_VER_CURRENT ') - -#if defined( use_EFFICIENCY_COUNTERS ) - - nevent = 7 - ncount = 0 - allocate (eventname(nevent)) - -!----------------------------------------------------------------------- -! cycles -!----------------------------------------------------------------------- - ncount = ncount + 1; eventname(ncount) = 'CPU_CYCLES' - -!----------------------------------------------------------------------- -! instruction counts -!----------------------------------------------------------------------- - ncount = ncount + 1; eventname(ncount) = 'IA64_INST_RETIRED_THIS' - ncount = ncount + 1; eventname(ncount) = 'NOPS_RETIRED' - -!----------------------------------------------------------------------- -! total stalls -!----------------------------------------------------------------------- - ncount = ncount + 1; eventname(ncount) = 'BACK_END_BUBBLE_ALL' - -!----------------------------------------------------------------------- -! fp ops counts -!----------------------------------------------------------------------- - ncount = ncount + 1; eventname(ncount) = 'FP_OPS_RETIRED' - -!----------------------------------------------------------------------- -! main memory bandwidth -!----------------------------------------------------------------------- - ncount = ncount + 1; eventname(ncount) = 'BUS_MEMORY_EQ_128BYTE_SELF' - ncount = ncount + 1; eventname(ncount) = 'BUS_MEMORY_LT_128BYTE_SELF' - -#endif - - -#if defined( use_STALL_COUNTERS ) - - nevent = 13 - ncount = 0 - allocate (eventname(nevent)) - -!----------------------------------------------------------------------- -! total stalls -!----------------------------------------------------------------------- - ncount = ncount + 1; eventname(ncount) = 'BACK_END_BUBBLE_ALL' - -!----------------------------------------------------------------------- -! d-cache stalls -!----------------------------------------------------------------------- - ncount = ncount + 1; eventname(ncount) = 'BE_EXE_BUBBLE_GRALL' - ncount = ncount + 1; eventname(ncount) = 'BE_EXE_BUBBLE_GRGR' - ncount = ncount + 1; eventname(ncount) = 'BE_L1D_FPU_BUBBLE_L1D' - -!----------------------------------------------------------------------- -! fpu stalls -!----------------------------------------------------------------------- - ncount = ncount + 1; eventname(ncount) = 'BE_EXE_BUBBLE_FRALL' - ncount = ncount + 1; eventname(ncount) = 'BE_L1D_FPU_BUBBLE_FPU' - -!----------------------------------------------------------------------- -! branch mispredict stalls -!----------------------------------------------------------------------- - ncount = ncount + 1; eventname(ncount) = 'BE_FLUSH_BUBBLE_BRU' - ncount = ncount + 1; eventname(ncount) = 'FE_BUBBLE_BUBBLE' - ncount = ncount + 1; eventname(ncount) = 'FE_BUBBLE_BRANCH' - -!----------------------------------------------------------------------- -! i-cache stalls -!----------------------------------------------------------------------- - ncount = ncount + 1; eventname(ncount) = 'FE_BUBBLE_IMISS' - ncount = ncount + 1; eventname(ncount) = 'BACK_END_BUBBLE_FE' - ncount = ncount + 1; eventname(ncount) = 'FE_BUBBLE_ALLBUT_IBFULL' - -!----------------------------------------------------------------------- -! rse stalls -!----------------------------------------------------------------------- -! ncount = ncount + 1; eventname(ncount) = 'BACK_END_BUBBLE_FE' - ncount = ncount + 1; eventname(ncount) = 'BE_RSE_BUBBLE_ALL' - -!----------------------------------------------------------------------- -! support register dependency stalls -!----------------------------------------------------------------------- -! ncount = ncount + 1; eventname(ncount) = 'BE_EXE_BUBBLE_ARCR_PR_CANCEL_BANK' - -!----------------------------------------------------------------------- -! integer register dependency stalls -!----------------------------------------------------------------------- -! ncount = ncount + 1; eventname(ncount) = 'BE_EXE_BUBBLE_GRGR' - -#endif - -#if defined( use_D_CACHE_STALLS_COUNTERS ) - - nevent = 10 - ncount = 0 - allocate (eventname(nevent)) - -!----------------------------------------------------------------------- -! total stalls -!----------------------------------------------------------------------- - - ncount = ncount + 1; eventname(ncount) = 'BACK_END_BUBBLE_ALL' - -!----------------------------------------------------------------------- -! l2 Capacity Stalls -!----------------------------------------------------------------------- - ncount = ncount + 1; eventname(ncount) = 'BE_L1D_FPU_BUBBLE_L1D_L2BPRESS' - -!----------------------------------------------------------------------- -! integer load latency stalls -!----------------------------------------------------------------------- - ncount = ncount + 1; eventname(ncount) = 'BE_EXE_BUBBLE_GRALL' - ncount = ncount + 1; eventname(ncount) = 'BE_EXE_BUBBLE_GRGR' - -!----------------------------------------------------------------------- -! l2 recirculation stalls -!----------------------------------------------------------------------- - ncount = ncount + 1; eventname(ncount) = 'BE_L1D_FPU_BUBBLE_L1D_DCURECIR' - ncount = ncount + 1; eventname(ncount) = 'BE_L1D_FPU_BUBBLE_L1D_STBUFRECIR' - -!----------------------------------------------------------------------- -! store related stalls -!----------------------------------------------------------------------- - ncount = ncount + 1; eventname(ncount) = 'BE_L1D_FPU_BUBBLE_L1D_FULLSTBUF' - ncount = ncount + 1; eventname(ncount) = 'BE_L1D_FPU_BUBBLE_L1D_FILLCONF' - -!----------------------------------------------------------------------- -! virtual memory stalls -!----------------------------------------------------------------------- - ncount = ncount + 1; eventname(ncount) = 'BE_L1D_FPU_BUBBLE_L1D_TLB' - ncount = ncount + 1; eventname(ncount) = 'BE_L1D_FPU_BUBBLE_L1D_HPW' - -#endif - - do n=1,nevent - call PAPIf_event_name_to_code(eventname(n), event, iret) - if (iret .ne. 0) call error_handler ( ' PAPIf_event_name_to_code ' ) - if (gptlsetoption (event, 1) .lt. 0) call error_handler ( ' gptlsetoption ' ) - enddo - - if (gptlsetoption (gptloverhead , 0) < 0) call error_handler ( ' gptloverhead ' ) - if (gptlsetoption (gptlnarrowprint, 1) < 0) call error_handler ( ' gptlsetoption ' ) - if (gptlinitialize () < 0) call error_handler ( ' gptlinitialize ' ) - -#endif - -end subroutine timing_init - -!####################################################################### - -subroutine timing_on ( blk_name ) - -!----------------------------------------------------------------------- -! timing on -!----------------------------------------------------------------------- - - character*(*), intent(in) :: blk_name - - iret = gptlstart( blk_name ) - -end subroutine timing_on - -!####################################################################### - -subroutine timing_off ( blk_name ) - -!----------------------------------------------------------------------- -! timing off -!----------------------------------------------------------------------- - - character*(*), intent(in) :: blk_name - - iret = gptlstop ( blk_name ) - -end subroutine timing_off - -!####################################################################### - -subroutine timing_clear () - -!----------------------------------------------------------------------- -! timing clear -!----------------------------------------------------------------------- - - iret = gptlreset() - -end subroutine timing_clear - -!####################################################################### - -subroutine timing_prt - -!----------------------------------------------------------------------- -! timing print -!----------------------------------------------------------------------- - - integer n - - iret = gptlpr ( 0 ) - - nregion = 1 - allocate (regions(nregion)) - - regions(1) = 'FYPPM4' - - allocate (papicounters(nevent)) - - do n=1,nregion - iret = gptlquerycounters (TRIM(regions(n)), -1, papicounters) - - write(6,*) - write(6,"(' REGION NAME = ', a32)") regions(n) - -#if defined( use_EFFICIENCY_COUNTERS ) - - CPU_CYCLES = papicounters(1) - IA64_INST_RETIRED_THIS = papicounters(2) - NOPS_RETIRED = papicounters(3) - BACK_END_BUBBLE_ALL = papicounters(4) - FP_OPS_RETIRED = papicounters(5) - BUS_MEMORY_EQ_128BYTE_SELF = papicounters(6) - BUS_MEMORY_LT_128BYTE_SELF = papicounters(7) - - write(6,*) - write(6,"(' CPU_CYCLES...........................= ', e12.6)") CPU_CYCLES - write(6,"(' IA64_INST_RETIRED_THIS...............= ', e12.6)") IA64_INST_RETIRED_THIS - write(6,"(' NOPS_RETIRED.........................= ', e12.6)") NOPS_RETIRED - write(6,"(' BACK_END_BUBBLE_ALL..................= ', e12.6)") BACK_END_BUBBLE_ALL - write(6,"(' FP_OPS_RETIRED.......................= ', e12.6)") FP_OPS_RETIRED - write(6,"(' BUS_MEMORY_EQ_128BYTE_SELF...........= ', e12.6)") BUS_MEMORY_EQ_128BYTE_SELF - write(6,"(' BUS_MEMORY_LT_128BYTE_SELF...........= ', e12.6)") BUS_MEMORY_LT_128BYTE_SELF - write(6,*) - write(6,"(' Useful Ops/Cycle.........................= ', e9.3)") ( IA64_INST_RETIRED_THIS - NOPS_RETIRED )/CPU_CYCLES - write(6,"(' NOPS/Cycle ..............................= ', e9.3)") NOPS_RETIRED /CPU_CYCLES - write(6,"(' Total Stalls/Cycle.......................= ', e9.3)") BACK_END_BUBBLE_ALL / CPU_CYCLES - write(6,"(' FLOPS/Cycle..............................= ', e9.3)") FP_OPS_RETIRED / CPU_CYCLES - write(6,"(' Main Memory Bandwidth Used...............= ', e9.3)") ( BUS_MEMORY_EQ_128BYTE_SELF*128 +BUS_MEMORY_LT_128BYTE_SELF*128)/CPU_CYCLES -#endif - -#if defined( use_STALL_COUNTERS ) - - BACK_END_BUBBLE_ALL = papicounters(1) - BE_EXE_BUBBLE_GRALL = papicounters(2) - BE_EXE_BUBBLE_GRGR = papicounters(3) - BE_L1D_FPU_BUBBLE_L1D = papicounters(4) - BE_EXE_BUBBLE_FRALL = papicounters(5) - BE_L1D_FPU_BUBBLE_FPU = papicounters(6) - BE_FLUSH_BUBBLE_BRU = papicounters(7) - FE_BUBBLE_BUBBLE = papicounters(8) - FE_BUBBLE_BRANCH = papicounters(9) - FE_BUBBLE_IMISS = papicounters(10) - BACK_END_BUBBLE_FE = papicounters(11) - FE_BUBBLE_ALLBUT_IBFULL = papicounters(12) - BE_RSE_BUBBLE_ALL = papicounters(13) - - write(6,"(' BACK_END_BUBBLE_ALL..................= ', e12.6)") BACK_END_BUBBLE_ALL - write(6,"(' BE_EXE_BUBBLE_GRALL..................= ', e12.6)") BE_EXE_BUBBLE_GRALL - write(6,"(' BE_EXE_BUBBLE_GRGR...................= ', e12.6)") BE_EXE_BUBBLE_GRGR - write(6,"(' BE_L1D_FPU_BUBBLE_L1D................= ', e12.6)") BE_L1D_FPU_BUBBLE_L1D - write(6,"(' BE_EXE_BUBBLE_FRALL..................= ', e12.6)") BE_EXE_BUBBLE_FRALL - write(6,"(' BE_L1D_FPU_BUBBLE_FPU................= ', e12.6)") BE_L1D_FPU_BUBBLE_FPU - write(6,"(' BE_FLUSH_BUBBLE_BRU..................= ', e12.6)") BE_FLUSH_BUBBLE_BRU - write(6,"(' FE_BUBBLE_BUBBLE.....................= ', e12.6)") FE_BUBBLE_BUBBLE - write(6,"(' FE_BUBBLE_BRANCH.....................= ', e12.6)") FE_BUBBLE_BUBBLE - write(6,"(' FE_BUBBLE_IMISS......................= ', e12.6)") FE_BUBBLE_IMISS - write(6,"(' BACK_END_BUBBLE_FE...................= ', e12.6)") BACK_END_BUBBLE_FE - write(6,"(' FE_BUBBLE_ALLBUT_IBFULL..............= ', e12.6)") FE_BUBBLE_ALLBUT_IBFULL - write(6,"(' BE_RSE_BUBBLE_ALL....................= ', e12.6)") BE_RSE_BUBBLE_ALL - - write(6,*) - write(6,"(' D-Cache Stalls...........................= ', e9.3)") ( BE_EXE_BUBBLE_GRALL - BE_EXE_BUBBLE_GRGR + BE_L1D_FPU_BUBBLE_L1D ) / BACK_END_BUBBLE_ALL - write(6,"(' Branch Misprediction Stalls..............= ', e9.3)") ( BE_FLUSH_BUBBLE_BRU + ( FE_BUBBLE_BUBBLE + FE_BUBBLE_BRANCH ) * & - ( BACK_END_BUBBLE_FE / FE_BUBBLE_ALLBUT_IBFULL ) ) / BACK_END_BUBBLE_ALL - write(6,"(' I-Cache Stalls...........................= ', e9.3)") ( FE_BUBBLE_IMISS ) * ( BACK_END_BUBBLE_FE / FE_BUBBLE_ALLBUT_IBFULL ) / BACK_END_BUBBLE_ALL - write(6,"(' FPU Stalls...............................= ', e9.3)") ( BE_EXE_BUBBLE_FRALL + BE_L1D_FPU_BUBBLE_FPU ) / BACK_END_BUBBLE_ALL - write(6,"(' RSE Stalls...............................= ', e9.3)") BE_RSE_BUBBLE_ALL / BACK_END_BUBBLE_ALL - write(6,"(' Integer Register Dependency Stalls.......= ', e9.3)") BE_EXE_BUBBLE_GRGR / BACK_END_BUBBLE_ALL - write(6,"(' Support Register Dependency Stalls.......= ', a2 )") 'na' -#endif - -#if defined( use_D_CACHE_STALLS_COUNTERS ) - - BACK_END_BUBBLE_ALL = papicounters(1) - BE_L1D_FPU_BUBBLE_L1D_L2BPRESS = papicounters(2) - BE_EXE_BUBBLE_GRALL = papicounters(3) - BE_EXE_BUBBLE_GRGR = papicounters(4) - BE_L1D_FPU_BUBBLE_L1D_DCURECIR = papicounters(5) - BE_L1D_FPU_BUBBLE_L1D_STBUFRECIR = papicounters(6) - BE_L1D_FPU_BUBBLE_L1D_FULLSTBUF = papicounters(7) - BE_L1D_FPU_BUBBLE_L1D_FILLCONF = papicounters(8) - BE_L1D_FPU_BUBBLE_L1D_TLB = papicounters(9) - BE_L1D_FPU_BUBBLE_L1D_HPW = papicounters(10) - - write(6,"(' BACK_END_BUBBLE_ALL..................= ', e12.6)") BACK_END_BUBBLE_ALL - write(6,"(' BE_L1D_FPU_BUBBLE_L1D_L2BPRESS.......= ', e12.6)") BE_L1D_FPU_BUBBLE_L1D_L2BPRESS - write(6,"(' BE_EXE_BUBBLE_GRALL..................= ', e12.6)") BE_EXE_BUBBLE_GRALL - write(6,"(' BE_EXE_BUBBLE_GRGR...................= ', e12.6)") BE_EXE_BUBBLE_GRGR - write(6,"(' BE_L1D_FPU_BUBBLE_L1D_DCURECIR.......= ', e12.6)") BE_L1D_FPU_BUBBLE_L1D_DCURECIR - write(6,"(' BE_L1D_FPU_BUBBLE_L1D_STBUFRECIR.....= ', e12.6)") BE_L1D_FPU_BUBBLE_L1D_STBUFRECIR - write(6,"(' BE_L1D_FPU_BUBBLE_L1D_FULLSTBUF......= ', e12.6)") BE_L1D_FPU_BUBBLE_L1D_FULLSTBUF - write(6,"(' BE_L1D_FPU_BUBBLE_L1D_FILLCONF.......= ', e12.6)") BE_L1D_FPU_BUBBLE_L1D_FILLCONF - write(6,"(' BE_L1D_FPU_BUBBLE_L1D_TLB............= ', e12.6)") BE_L1D_FPU_BUBBLE_L1D_TLB - write(6,"(' BE_L1D_FPU_BUBBLE_L1D_HPW............= ', e12.6)") BE_L1D_FPU_BUBBLE_L1D_HPW - - write(6,*) - write(6,"(' L2 Capacity Stalls.......................= ', e9.3)") BE_L1D_FPU_BUBBLE_L1D_L2BPRESS / BACK_END_BUBBLE_ALL - write(6,"(' Integer Load Latency Stalls..............= ', e9.3)") ( BE_EXE_BUBBLE_GRALL - BE_EXE_BUBBLE_GRGR ) / BACK_END_BUBBLE_ALL - write(6,"(' L2 Recirculation Stalls..................= ', e9.3)") ( BE_L1D_FPU_BUBBLE_L1D_DCURECIR + BE_L1D_FPU_BUBBLE_L1D_STBUFRECIR ) / BACK_END_BUBBLE_ALL - write(6,"(' Store Related Stalls.....................= ', e9.3)") ( BE_L1D_FPU_BUBBLE_L1D_FULLSTBUF + BE_L1D_FPU_BUBBLE_L1D_FILLCONF ) / BACK_END_BUBBLE_ALL - write(6,"(' Virtual Memory Stalls....................= ', e9.3)") ( BE_L1D_FPU_BUBBLE_L1D_TLB + BE_L1D_FPU_BUBBLE_L1D_HPW ) / BACK_END_BUBBLE_ALL -#endif - - enddo - - iret = gptlfinalize () - - return - -end subroutine timing_prt - -!####################################################################### - -subroutine error_handler ( message ) -character(len=*), intent(in) :: message - - print *, message - stop - - return -end subroutine error_handler - -!####################################################################### - -end module TimingModule diff --git a/cesm/models/utils/timing/gptl/util.c b/cesm/models/utils/timing/gptl/util.c deleted file mode 100644 index da28ee4..0000000 --- a/cesm/models/utils/timing/gptl/util.c +++ /dev/null @@ -1,140 +0,0 @@ -/* -** $Id: util.c,v 1.13 2010-01-01 01:34:07 rosinski Exp $ -*/ - -#include -#include -#include - -#include "private.h" - -static bool abort_on_error = false; /* flag says to abort on any error */ -static int max_errors = 10; /* max number of error print msgs */ -static int num_errors = 0; /* number of times GPTLerror was called */ -static int max_warn = 10; /* max number of warning messages */ -static int num_warn = 0; /* number of times GPTLwarn was called */ - -/* -** GPTLerror: error return routine to print a message and return a failure -** value. -** -** Input arguments: -** fmt: format string -** variable list of additional arguments for vfprintf -** -** Return value: -1 (failure) -*/ -int GPTLerror (const char *fmt, ...) -{ - va_list args; - - va_start (args, fmt); - - if (fmt != NULL && num_errors < max_errors) { -#ifdef HAVE_VPRINTF - (void) fprintf (stderr, "GPTL error:"); - (void) vfprintf (stderr, fmt, args); -#else - (void) fprintf (stderr, "GPTLerror: no vfprintf: fmt is %s\n", fmt); -#endif - if (num_errors == max_errors) - (void) fprintf (stderr, "Truncating further error print now after %d msgs", - num_errors); - } - - va_end (args); - - if (abort_on_error) - exit (-1); - - ++num_errors; - return (-1); -} - -/* -** GPTLwarn: print a warning message -** value. -** -** Input arguments: -** fmt: format string -** variable list of additional arguments for vfprintf -*/ -void GPTLwarn (const char *fmt, ...) -{ - va_list args; - - va_start (args, fmt); - - if (fmt != NULL && num_warn < max_warn) { -#ifdef HAVE_VPRINTF - (void) fprintf (stderr, "GPTL warning:"); - (void) vfprintf (stderr, fmt, args); -#else - (void) fprintf (stderr, "GPTLwarning: no vfprintf: fmt is %s\n", fmt); -#endif - if (num_warn == max_warn) - (void) fprintf (stderr, "Truncating further warning print now after %d msgs", - num_warn); - } - - va_end (args); - - ++num_warn; - return; -} - -/* -** GPTLset_abort_on_error: User-visible routine to set abort_on_error flag -** -** Input arguments: -** val: true (abort on error) or false (don't) -*/ -void GPTLset_abort_on_error (bool val) -{ - abort_on_error = val; -} - -/* -** GPTLreset_errors: reset error state to no errors -** -*/ -void GPTLreset_errors (void) -{ - num_errors = 0; -} - -/* -** GPTLnum_errors: User-visible routine returns number of times GPTLerror() called -** -*/ -int GPTLnum_errors (void) -{ - return num_errors; -} - -/* -** GPTLnum_errors: User-visible routine returns number of times GPTLerror() called -** -*/ -int GPTLnum_warn (void) -{ - return num_warn; -} - -/* -** GPTLallocate: wrapper utility for malloc -** -** Input arguments: -** nbytes: size to allocate -** -** Return value: pointer to the new space (or NULL) -*/ -void *GPTLallocate (const int nbytes, const char *caller) -{ - void *ptr; - - if ( nbytes <= 0 || ! (ptr = malloc (nbytes))) - (void) GPTLerror ("GPTLallocate from %s: malloc failed for %d bytes\n", nbytes, caller); - - return ptr; -} diff --git a/cesm/scripts/ccsm_utils/CMake/.gitignore b/cesm/scripts/ccsm_utils/CMake/.gitignore deleted file mode 100644 index 52540e7..0000000 --- a/cesm/scripts/ccsm_utils/CMake/.gitignore +++ /dev/null @@ -1,5 +0,0 @@ -CMakeCache.txt -CMakeFiles -Makefile -cmake_install.cmake -install_manifest.txt diff --git a/cesm/scripts/ccsm_utils/CMake/CESM_utils.cmake b/cesm/scripts/ccsm_utils/CMake/CESM_utils.cmake deleted file mode 100644 index 99f2f1a..0000000 --- a/cesm/scripts/ccsm_utils/CMake/CESM_utils.cmake +++ /dev/null @@ -1,69 +0,0 @@ -# Module used for CESM testing. -# -# This module contains statements that would otherwise be boilerplate in -# most CESM tests. It enables CTest testing, handles the USE_COLOR and -# ENABLE_GENF90 arguments, and includes several other modules. - -#========================================================================== -# Copyright (c) 2013-2014, University Corporation for Atmospheric Research -# -# This software is distributed under a two-clause BSD license, with no -# warranties, express or implied. See the accompanying LICENSE file for -# details. -#========================================================================== - -#================================================= -# Enable CTest tests. -#================================================= - -enable_testing() - -#================================================= -# Color output -#================================================= - -option(USE_COLOR "Allow color from the build output." ON) - -set(CMAKE_COLOR_MAKEFILE "${USE_COLOR}") - -#================================================= -# Compiler info -#================================================= - -include(Compilers) - -#================================================= -# GenF90 -#================================================= - -option(ENABLE_GENF90 - "Use genf90.pl to regenerate out-of-date Fortran files from .in files." - OFF) - -if(ENABLE_GENF90) - find_program(GENF90 genf90.pl) - - if(NOT GENF90) - message(FATAL_ERROR "ENABLE_GENF90 enabled, but genf90.pl not found!") - endif() - -endif() - -# Preprocessing utility functions. -include(genf90_utils) - -#================================================= -# pFUnit -#================================================= - -# pFUnit and its preprocessor -find_package(pFUnit) - -# Preprocessor and driver handling. -include(pFUnit_utils) - -#================================================= -# Source list and path utilities. -#================================================= - -include(Sourcelist_utils) diff --git a/cesm/scripts/ccsm_utils/CMake/ChangeLog b/cesm/scripts/ccsm_utils/CMake/ChangeLog deleted file mode 100644 index 0fc506a..0000000 --- a/cesm/scripts/ccsm_utils/CMake/ChangeLog +++ /dev/null @@ -1,8 +0,0 @@ -This repository tracks changes using the Git log. - -For small changes, e.g. fixing typos, use a one line, 50 character summary. - -For larger changes, this summary should be followed by a blank line and a -longer description. The following link gives good advice: - -http://justinhileman.info/article/changing-history/#make-the-most-of-your-commit-message diff --git a/cesm/scripts/ccsm_utils/CMake/Compilers.cmake b/cesm/scripts/ccsm_utils/CMake/Compilers.cmake deleted file mode 100644 index d1a092e..0000000 --- a/cesm/scripts/ccsm_utils/CMake/Compilers.cmake +++ /dev/null @@ -1,176 +0,0 @@ -# Flags for builds with different machines/compilers. -# -# This module is currently a catch-all for compiler-specific functionality -# needed by CESM. It defines OS and compiler CPP macros and CESM build -# types, as well as including the file containing CESM compiler flags, if -# necessary. -# -# There is also one function intended for CTest test writers, described -# below. -# -#========================================================================== -# -# define_Fortran_stop_failure -# -# Arguments: -# test_name - Name of a CTest test. -# -# Ensures that if the named test uses "STOP 1" to signal failure, that this -# is detected by CTest. Currently this is only necessary for NAG, which -# prints the stop code rather than using it as an error code. -# -#========================================================================== - -#========================================================================== -# Copyright (c) 2013-2014, University Corporation for Atmospheric Research -# -# This software is distributed under a two-clause BSD license, with no -# warranties, express or implied. See the accompanying LICENSE file for -# details. -#========================================================================== - -#================================================= -# Add new build types. -#================================================= - -# Add CESM build types. -set(CMAKE_Fortran_FLAGS_CESM "" CACHE STRING - "Flags used by the Fortran compiler during CESM builds." - FORCE) -set(CMAKE_C_FLAGS_CESM "" CACHE STRING - "Flags used by the C compiler during CESM builds." - FORCE) -mark_as_advanced(CMAKE_Fortran_FLAGS_CESM CMAKE_C_FLAGS_CESM) - -set(CMAKE_Fortran_FLAGS_CESM_DEBUG "" CACHE STRING - "Flags used by the Fortran compiler during CESM DEBUG builds." - FORCE) -set(CMAKE_C_FLAGS_CESM_DEBUG "" CACHE STRING - "Flags used by the C compiler during CESM DEBUG builds." - FORCE) -mark_as_advanced(CMAKE_Fortran_FLAGS_CESM_DEBUG CMAKE_C_FLAGS_CESM_DEBUG) - -set(all_build_types - "None Debug Release RelWithDebInfo MinSizeRel CESM CESM_DEBUG") -set(CMAKE_BUILD_TYPE "${CMAKE_BUILD_TYPE}" CACHE STRING - "Choose the type of build, options are: ${all_build_types}." - FORCE) - -#================================================= -# Define OS and compiler macros. -#================================================= - -# Define OS. -string(TOUPPER ${CMAKE_SYSTEM_NAME} os) -add_definitions(-D${os}) - -# Define CESM-compatible compiler names. -if(${CMAKE_Fortran_COMPILER_ID} STREQUAL NAG) - set(compiler_name nag) -elseif(${CMAKE_Fortran_COMPILER_ID} STREQUAL GNU) - set(compiler_name gnu) -elseif(${CMAKE_Fortran_COMPILER_ID} STREQUAL XL) - set(compiler_name ibm) -elseif(${CMAKE_Fortran_COMPILER_ID} STREQUAL Intel) - set(compiler_name intel) -elseif(${CMAKE_Fortran_COMPILER_ID} STREQUAL PGI) - set(compiler_name pgi) -endif() - -# Define CPP macro for the compiler. -string(TOUPPER -DCPR${compiler_name} compiler_cppdef) -add_definitions(${compiler_cppdef}) - -#================================================= -# Utility functions. -#================================================= - -# Add flags to space-separated list rather than normal CMake list. -function(add_flags list) - string(REPLACE ";" " " flags "${ARGN}") - set(${list} "${${list}} ${flags}" PARENT_SCOPE) -endfunction() - -# Add configuration-specific preprocessor definitions. -function(add_config_definitions configuration) - get_directory_property(cppdefs COMPILE_DEFINITIONS_${configuration}) - foreach(flag IN LISTS ARGN) - string(REPLACE "-D" "" def "${flag}") - list(APPEND cppdefs ${def}) - endforeach() - set_directory_properties(PROPERTIES COMPILE_DEFINITIONS_${configuration} - "${cppdefs}") -endfunction() - -#================================================= -# Use CESM Macros file. -#================================================= - -if("${CMAKE_BUILD_TYPE}" MATCHES CESM) - include(${CMAKE_BINARY_DIR}/CESM_Macros.cmake) -endif() - -#================================================= -# Build flags required to use pFUnit. -#================================================= - -if(${CMAKE_Fortran_COMPILER_ID} STREQUAL Intel) - add_flags(CMAKE_Fortran_FLAGS -assume realloc_lhs) -endif() - -#================================================= -# Add flags for debugging output. -#================================================= - -# Define Fortran compiler flags. - -# Add pretty output and extra warnings regardless of build type. However, -# don't set any options in the generic flags that would affect the -# generated binary, because we want to be able to get binaries that -# resemble what you get from the CESM flags. - -if(${CMAKE_Fortran_COMPILER_ID} STREQUAL NAG) - add_flags(CMAKE_Fortran_FLAGS -strict95) - if(USE_COLOR) - add_flags(CMAKE_Fortran_FLAGS -colour) - endif() - - # Add -kind=byte if it isn't anywhere else. - if(NOT "${CMAKE_Fortran_FLAGS_${CMAKE_BUILD_TYPE}}" MATCHES -kind=byte) - add_flags(CMAKE_Fortran_FLAGS -kind=byte) - endif() - -elseif(${CMAKE_Fortran_COMPILER_ID} STREQUAL GNU) - # Turn on warnings, but leave out uninitialized check as it was producing - # a lot of false positives. - add_flags(CMAKE_Fortran_FLAGS -Wall -Wextra -Wno-uninitialized) - -elseif(${CMAKE_Fortran_COMPILER_ID} STREQUAL XL) -elseif(${CMAKE_Fortran_COMPILER_ID} STREQUAL Intel) -elseif(${CMAKE_Fortran_COMPILER_ID} STREQUAL PGI) -endif() - -# Define C flags, analogous to the above Fortran block. -if(CMAKE_C_COMPILER_LOADED) - if(${CMAKE_C_COMPILER_ID} STREQUAL GNU) - add_flags(CMAKE_C_FLAGS -Wall -Wextra -pedantic) - endif() -endif() - -#================================================= -# Help CTest tests recognize when "stop X" is called with non-zero X. -#================================================= - -# Detect "STOP" for CTest. -if(${CMAKE_Fortran_COMPILER_ID} STREQUAL NAG) - # NAG prints the stop code instead of yielding a non-zero return, so we - # have to use a regex to catch that. - function(define_Fortran_stop_failure test_name) - set_tests_properties(${test_name} PROPERTIES - FAIL_REGULAR_EXPRESSION "STOP: [1-9]") - endfunction(define_Fortran_stop_failure) -else() - # Usually, stop /= 0 is already detected with the return code. - function(define_Fortran_stop_failure test_name) - endfunction(define_Fortran_stop_failure) -endif() diff --git a/cesm/scripts/ccsm_utils/CMake/FindNETCDF.cmake b/cesm/scripts/ccsm_utils/CMake/FindNETCDF.cmake deleted file mode 100644 index 936efce..0000000 --- a/cesm/scripts/ccsm_utils/CMake/FindNETCDF.cmake +++ /dev/null @@ -1,62 +0,0 @@ -# - Try to find Netcdf -# Once done this will define -# NETCDF_FOUND - System has Netcdf -# NETCDF_INCLUDE_DIRS - The Netcdf include directories -# NETCDF_C_LIBRARIES - The C libraries needed to use Netcdf -# NETCDF_Fortran_LIBRARIES - The Fortran libraries needed to use Netcdf -# NETCDF_LIBRARIES - All the libraries needed to use Netcdf -# NETCDF_DEFINITIONS - Compiler switches required for using Netcdf - -find_path(NETCDF_INCLUDE_DIR netcdf.h - HINTS ${NETCDF_DIR}/include ) - -find_path(NETCDF_LIB_DIR NAMES libnetcdf.a libnetcdf.so - HINTS ${NETCDF_DIR}/lib ${NETCDF_DIR}/lib64 ) - -find_path(NETCDF_FORTRAN_LIB_DIR libnetcdff.a libnetcdff.so - HINTS ${NETCDF_DIR}/lib ${NETCDF_DIR}/lib64 ) - -find_file(NETCDF4_PAR_H netcdf_par.h - HINTS ${NETCDF_INCLUDE_DIR} - NO_DEFAULT_PATH ) - -#MESSAGE("PAR_H: ${NETCDF4_PAR_H}") -find_library(NETCDF_C_LIBRARY NAMES libnetcdf.a netcdf HINTS ${NETCDF_LIB_DIR}) - -if(NOT NETCDF_FORTRAN_LIB_DIR) - MESSAGE("WARNING: did not find netcdf fortran library") -else() - find_library(NETCDF_Fortran_LIBRARY NAMES libnetcdff.a netcdff HINTS ${NETCDF_FORTRAN_LIB_DIR}) -endif() -set(NETCDF_LIBRARIES ${NETCDF_Fortran_LIBRARY} ${NETCDF_C_LIBRARY}) -if(NOT NETCDF4_PAR_H) - set(NETCDF4_PARALLEL "no") - MESSAGE("NETCDF built without MPIIO") -else() - set(NETCDF4_PARALLEL "yes") - MESSAGE("NETCDF built with hdf5 MPIIO support") -endif() - -set(NETCDF_INCLUDE_DIRS ${NETCDF_INCLUDE_DIR} ) - -FIND_PACKAGE(HDF5 COMPONENTS C HL) - -if(${HDF5_FOUND}) - MESSAGE(STATUS "Adding hdf5 libraries ") - set(NETCDF_C_LIBRARY ${NETCDF_C_LIBRARY} ${HDF5_LIBRARIES}) -endif() - -# Export variables so other projects can use them as well -# ie. if pio is added with add_subdirectory -SET(NETCDF_INCLUDE_DIR ${NETCDF_INCLUDE_DIR} CACHE STRING "Location of NetCDF include files.") -SET(NETCDF_LIBRARIES ${NETCDF_LIBRARIES} CACHE STRING "Link line for NetCDF.") - -include(FindPackageHandleStandardArgs) -# handle the QUIETLY and REQUIRED arguments and set NETCDF_FOUND to TRUE -# if all listed variables are TRUE -# (Note that the Fortran interface is not always a separate library, so -# don't require it to be found.) -find_package_handle_standard_args(NETCDF DEFAULT_MSG NETCDF_LIBRARIES - NETCDF_C_LIBRARY NETCDF_INCLUDE_DIR) - -mark_as_advanced(NETCDF_INCLUDE_DIR NETCDF_LIBRARIES NETCDF_C_LIBRARY NETCDF_Fortran_LIBRARY NETCDF4_PARALLEL ) diff --git a/cesm/scripts/ccsm_utils/CMake/FindPnetcdf.cmake b/cesm/scripts/ccsm_utils/CMake/FindPnetcdf.cmake deleted file mode 100644 index aee86a1..0000000 --- a/cesm/scripts/ccsm_utils/CMake/FindPnetcdf.cmake +++ /dev/null @@ -1,45 +0,0 @@ -include(FindPackageHandleStandardArgs) - -FIND_PATH(PNETCDF_INCLUDE_DIR - pnetcdf.h - HINTS ${PNETCDF_DIR}/include) - - -IF (${PREFER_SHARED}) - FIND_LIBRARY(PNETCDF_LIBRARY - NAMES pnetcdf - HINTS ${PNETCDF_DIR}/lib) - -ELSE () - FIND_LIBRARY(PNETCDF_LIBRARY - NAMES libpnetcdf.a pnetcdf - HINTS ${PNETCDF_DIR}/lib) -ENDIF () - -find_file( PNETCDFTEST NAMES TryPnetcdf_mod.f90 PATHS ${CMAKE_MODULE_PATH} NO_DEFAULT_PATH) -get_filename_component( CMAKE_TEST_PATH ${PNETCDFTEST} PATH) - -TRY_COMPILE(PNETCDF_MOD ${CMAKE_CURRENT_BINARY_DIR}/tryPnetcdf_mod - ${CMAKE_TEST_PATH}/TryPnetcdf_mod.f90 - COMPILE_DEFINITIONS -I${PNETCDF_INCLUDE_DIR} - CMAKE_FLAGS "-DLINK_LIBRARIES:STRING=${PNETCDF_LIBRARIES}" - OUTPUT_VARIABLE Pnet_OUT) - -if(NOT PNETCDF_MOD) - TRY_COMPILE(PNETCDF_INC ${CMAKE_CURRENT_BINARY_DIR}/tryPnetcdf_inc - ${CMAKE_TEST_PATH}/TryPnetcdf_inc.f90 - COMPILE_DEFINITIONS -I${PNETCDF_INCLUDE_DIR} - CMAKE_FLAGS "-DLINK_LIBRARIES:STRING=${PNETCDF_LIBRARIES}" - OUTPUT_VARIABLE Pnet_OUT) -endif() - - - -SET(PNETCDF_LIBRARIES ${PNETCDF_LIBRARY} ) -SET(PNETCDF_INCLUDE_DIRS ${PNETCDF_INCLUDE_DIR} ) - -# Handle QUIETLY and REQUIRED. -find_package_handle_standard_args(pnetcdf DEFAULT_MSG - PNETCDF_LIBRARY PNETCDF_INCLUDE_DIR ) - -mark_as_advanced(PNETCDF_INCLUDE_DIR PNETCDF_LIBRARY PNETCDF_INC PNETCDF_MOD) \ No newline at end of file diff --git a/cesm/scripts/ccsm_utils/CMake/FindpFUnit.cmake b/cesm/scripts/ccsm_utils/CMake/FindpFUnit.cmake deleted file mode 100644 index 4455cdc..0000000 --- a/cesm/scripts/ccsm_utils/CMake/FindpFUnit.cmake +++ /dev/null @@ -1,52 +0,0 @@ -# Find module for pFUnit -# -# For this module to work, either the pFUnit parser must be discoverable -# (e.g. in the user's PATH), or else the environment variable "PFUNIT" must -# be defined, and point to the root directory for the PFUNIT installation. -# -# This module sets some typical variables: -# PFUNIT_FOUND -# PFUNIT_LIBRARY(/LIBRARIES) -# PFUNIT_INCLUDE_DIR(/DIRS) -# -# The module also sets: -# PFUNIT_DRIVER - Path to the pFUnit driver source. -# PFUNIT_MODULE_DIR - Directory containing pFUnit's module files. -# PFUNIT_PARSER - Path to pFUnitParser.py (the preprocessor). - -#========================================================================== -# Copyright (c) 2013-2014, University Corporation for Atmospheric Research -# -# This software is distributed under a two-clause BSD license, with no -# warranties, express or implied. See the accompanying LICENSE file for -# details. -#========================================================================== - -include(FindPackageHandleStandardArgs) - -find_program(PFUNIT_PARSER pFUnitParser.py - HINTS $ENV{PFUNIT}/bin) - -string(REGEX REPLACE "bin/pFUnitParser\\.py\$" "" - pfunit_directory ${PFUNIT_PARSER}) - -find_library(PFUNIT_LIBRARY pfunit - HINTS ${pfunit_directory}/lib) - -find_path(PFUNIT_INCLUDE_DIR driver.F90 - HINTS ${pfunit_directory}/include) - -set(PFUNIT_DRIVER ${PFUNIT_INCLUDE_DIR}/driver.F90) - -find_path(PFUNIT_MODULE_DIR NAMES pfunit.mod PFUNIT.MOD - HINTS ${pfunit_directory}/include ${pfunit_directory}/mod) - -set(PFUNIT_LIBRARIES ${PFUNIT_LIBRARY}) -set(PFUNIT_INCLUDE_DIRS ${PFUNIT_INCLUDE_DIR} ${PFUNIT_MODULE_DIR}) - -# Handle QUIETLY and REQUIRED. -find_package_handle_standard_args(pFUnit DEFAULT_MSG - PFUNIT_LIBRARY PFUNIT_INCLUDE_DIR PFUNIT_MODULE_DIR PFUNIT_PARSER) - -mark_as_advanced(PFUNIT_INCLUDE_DIR PFUNIT_LIBRARY PFUNIT_MODULE_DIR - PFUNIT_PARSER) diff --git a/cesm/scripts/ccsm_utils/CMake/LICENSE b/cesm/scripts/ccsm_utils/CMake/LICENSE deleted file mode 100644 index 8c37c93..0000000 --- a/cesm/scripts/ccsm_utils/CMake/LICENSE +++ /dev/null @@ -1,23 +0,0 @@ -Copyright (c) 2013-2014, University Corporation for Atmospheric Research -All rights reserved. - -Redistribution and use in source and binary forms, with or without modification, -are permitted provided that the following conditions are met: - -1. Redistributions of source code must retain the above copyright notice, this -list of conditions and the following disclaimer. - -2. Redistributions in binary form must reproduce the above copyright notice, -this list of conditions and the following disclaimer in the documentation and/or -other materials provided with the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR -ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES -(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; -LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON -ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT -(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS -SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/cesm/scripts/ccsm_utils/CMake/README.md b/cesm/scripts/ccsm_utils/CMake/README.md deleted file mode 100644 index 9d7a2a2..0000000 --- a/cesm/scripts/ccsm_utils/CMake/README.md +++ /dev/null @@ -1,33 +0,0 @@ -CMake_Fortran_utils -=================== - -CMake modules dealing with Fortran-specific issues and Fortran libraries - -Currently, these modules should work with CMake version 2.8.8 and later -versions. Earlier CMake versions may work but are untested. - -Below is a brief listing of modules. More detailed information on the -purpose and use of these modules can be found in comments at the top of -each file. - -Find modules for specific libraries: - -FindNETCDF - -FindpFUnit - -FindPnetcdf - -Utility modules: - -genf90_utils - Generate Fortran code from genf90.pl templates. - -pFUnit_utils - Create executables using the pFUnit parser and driver. - -Sourcelist_utils - Use source file lists defined over multiple directories. - -Modules that are CESM-specific and/or incomplete: - -CESM_utils - Handles a few options, and includes several other modules. - -Compilers - Specify compiler-specific behavior, add build types for CESM. diff --git a/cesm/scripts/ccsm_utils/CMake/Sourcelist_utils.cmake b/cesm/scripts/ccsm_utils/CMake/Sourcelist_utils.cmake deleted file mode 100644 index 6f65edf..0000000 --- a/cesm/scripts/ccsm_utils/CMake/Sourcelist_utils.cmake +++ /dev/null @@ -1,134 +0,0 @@ -# Utility functions to work with accumulated lists of sources. -# -#========================================================================== -# -# sourcelist_to_parent -# -# Arguments: -# source_list_name - Name of list to send. -# -# Expands relative paths to absolute locations in the source list, then -# copies the value of the list to the list with the same name in the parent -# scope. -# -#========================================================================== -# -# extract_sources -# -# Arguments: -# sources_needed - Base names of sources required for a target. -# all_sources - Absolute locations of available source files. -# source_list_name - Absolute locations of sources to build the target. -# -# Scans through a list of all source files, selects files with the -# requested names, and *appends* them to an output list. If there is more -# than one file with the same name, the *last* match is selected. -# -# This allows you to simulate Makefile idioms that choose from multiple -# versions of a file, based on the order in which they are encountered. -# -#========================================================================== -# -# declare_generated_dependencies. -# -# Arguments: -# target - The target that needs to depend on generated files. -# generated_list - The generated source code files the target requires. -# -# Ensures that generated sources in a different directory are produced -# before compiling and linking the target. This is done by assuming that -# each generated source file corresponds to an existing target. For -# instance, a file called "foo.F90" would be generated by a target called -# "generate_foo". The input target can then be made to depend on each of -# the "generate" targets. -# -# This is unnecessary when source code generation occurs in the directory -# where the target was added. However, CMake does not propagate information -# about source code generation to parent directories, so the intermediate -# "generate" targets must be created to enforce generation in the correct -# order. -# -#========================================================================== - -#========================================================================== -# Copyright (c) 2013-2014, University Corporation for Atmospheric Research -# -# This software is distributed under a two-clause BSD license, with no -# warranties, express or implied. See the accompanying LICENSE file for -# details. -#========================================================================== - -# For each relative path in ${file_list}, prepend ${base_directory} to make -# an absolute path, and put result in list named by ${new_list_name}. -function(expand_relative_paths file_list base_directory new_list_name) - - unset(${new_list_name}) - foreach(file IN LISTS file_list) - if(IS_ABSOLUTE "${file}") - set(new_file "${file}") - else() - set(new_file "${base_directory}/${file}") - endif() - list(APPEND ${new_list_name} "${new_file}") - endforeach() - - set(${new_list_name} "${${new_list_name}}" PARENT_SCOPE) - -endfunction(expand_relative_paths) - -# Expand relative paths in a named source list, and export to parent scope. -# The idea here is to communicate the list between a directory added with -# add_subdirectory, and the directory above it. -macro(sourcelist_to_parent source_list_name) - expand_relative_paths("${${source_list_name}}" - ${CMAKE_CURRENT_SOURCE_DIR} ${source_list_name}) - set(${source_list_name} "${${source_list_name}}" PARENT_SCOPE) -endmacro(sourcelist_to_parent) - -# Find an absolute file path in ${all_sources} for each base name in -# ${sources_needed}, and append found paths to the list named by -# ${source_list_name}. -function(extract_sources sources_needed all_sources source_list_name) - - foreach(needed_source IN LISTS sources_needed) - - set(source_match source-NOTFOUND) - - foreach(source IN LISTS all_sources) - get_filename_component(basename ${source} NAME) - if(${basename} STREQUAL ${needed_source}) - set(source_match ${source}) - endif() - endforeach() - - if(NOT source_match) - message(FATAL_ERROR - "Source file not found: ${needed_source} -After searching in list: ${${all_sources}}") - endif() - - list(APPEND ${source_list_name} ${source_match}) - - endforeach() - - set(${source_list_name} "${${source_list_name}}" PARENT_SCOPE) - -endfunction(extract_sources) - -# Handles dependencies between files generated in one directory and a -# target in another. -# Given a target and a list of files, sets the GENERATED property for each -# file, and makes the target depend on a custom target generated from the -# extensionless base file name. (E.g. for /path/to/foo.F90, it will assume -# that it is generated by a custom target called generate_foo). -function(declare_generated_dependencies target generated_list) - foreach(file IN LISTS generated_list) - - set_source_files_properties(${file} PROPERTIES GENERATED 1) - - get_filename_component(stripped_name ${file} NAME_WE) - - add_dependencies(${target} generate_${stripped_name}) - - endforeach() -endfunction(declare_generated_dependencies) diff --git a/cesm/scripts/ccsm_utils/CMake/TryCSizeOf.f90 b/cesm/scripts/ccsm_utils/CMake/TryCSizeOf.f90 deleted file mode 100644 index 272ed27..0000000 --- a/cesm/scripts/ccsm_utils/CMake/TryCSizeOf.f90 +++ /dev/null @@ -1,6 +0,0 @@ - program trycsizeof - use iso_c_binding, only : c_sizeof - integer :: b - integer :: a(5) - b = c_sizeof(a(1)) - end program trycsizeof diff --git a/cesm/scripts/ccsm_utils/CMake/TryMPIIO.f90 b/cesm/scripts/ccsm_utils/CMake/TryMPIIO.f90 deleted file mode 100644 index 33fadfe..0000000 --- a/cesm/scripts/ccsm_utils/CMake/TryMPIIO.f90 +++ /dev/null @@ -1,6 +0,0 @@ -program mpicheck - include "mpif.h" - integer :: fh, ierr - - call mpi_file_open(mpi_comm_world, 'stupid.file',MPI_MODE_RDWR,MPI_INFO_NULL,fh,ierr) -end program diff --git a/cesm/scripts/ccsm_utils/CMake/TryMPIMod.f90 b/cesm/scripts/ccsm_utils/CMake/TryMPIMod.f90 deleted file mode 100644 index 5fcd146..0000000 --- a/cesm/scripts/ccsm_utils/CMake/TryMPIMod.f90 +++ /dev/null @@ -1,4 +0,0 @@ -program mpimodcheck - use mpi, only : MPI_ROOT, MPI_OFFSET - integer,parameter:: a = MPI_ROOT -end program mpimodcheck diff --git a/cesm/scripts/ccsm_utils/CMake/TryMPISERIAL.f90 b/cesm/scripts/ccsm_utils/CMake/TryMPISERIAL.f90 deleted file mode 100644 index 83908f7..0000000 --- a/cesm/scripts/ccsm_utils/CMake/TryMPISERIAL.f90 +++ /dev/null @@ -1,14 +0,0 @@ -! Test for the mct mpiserial stubs library -! in which mpi_integer == mpi_real4 and the select will -! fail to compile. (PGI doesnt complain so add something -! it will complain about -! -program mpiserial_test - implicit none - include 'mpif.h' - integer :: i - select case(i) - case(mpi_integer) - case(mpi_real4) - end select -end program mpiserial_test diff --git a/cesm/scripts/ccsm_utils/CMake/TryPnetcdf_inc.f90 b/cesm/scripts/ccsm_utils/CMake/TryPnetcdf_inc.f90 deleted file mode 100644 index f24869e..0000000 --- a/cesm/scripts/ccsm_utils/CMake/TryPnetcdf_inc.f90 +++ /dev/null @@ -1,3 +0,0 @@ -program freeform - include "pnetcdf.inc" -end program diff --git a/cesm/scripts/ccsm_utils/CMake/TryPnetcdf_mod.f90 b/cesm/scripts/ccsm_utils/CMake/TryPnetcdf_mod.f90 deleted file mode 100644 index fd9b0c2..0000000 --- a/cesm/scripts/ccsm_utils/CMake/TryPnetcdf_mod.f90 +++ /dev/null @@ -1,5 +0,0 @@ -program freeform - use pnetcdf - integer ierr - ierr = nfmpi_put_att(4, 1, 'fred', 7) -end program diff --git a/cesm/scripts/ccsm_utils/CMake/genf90_utils.cmake b/cesm/scripts/ccsm_utils/CMake/genf90_utils.cmake deleted file mode 100644 index 2ecc81f..0000000 --- a/cesm/scripts/ccsm_utils/CMake/genf90_utils.cmake +++ /dev/null @@ -1,90 +0,0 @@ -# Utility for invoking genf90 on a template file. -# -# If ENABLE_GENF90 is set to a true value, the functions here will behave -# as described below. In this case, the variable GENF90 must be defined and -# contain the genf90.pl command. -# -# If ENABLE_GENF90 is not true, no source code generation or other side -# effects will occur, but output variables will be set as if the generation -# had occurred. -# -#========================================================================== -# -# process_genf90_source_list -# -# Arguments: -# genf90_file_list - A list of template files to process. -# output_directory - Directory where generated sources will be placed. -# fortran_list_name - The name of a list used as output. -# -# Produces generated sources for each of the input templates. Then -# this function *appends* the location of each generated file to the output -# list. -# -# As a side effect, this function will add a target for each generated -# file. For a generated file named "foo.F90", the target will be named -# "generate_foo". -# -# Limitations: -# This function adds targets to work around a deficiency in CMake (see -# "declare_generated_dependencies" in Sourcelist_utils). Unfortunately, -# this means that you cannot use this function to generate two files -# with the same name in a single project. -# -#========================================================================== - -#========================================================================== -# Copyright (c) 2013-2014, University Corporation for Atmospheric Research -# -# This software is distributed under a two-clause BSD license, with no -# warranties, express or implied. See the accompanying LICENSE file for -# details. -#========================================================================== - -if(ENABLE_GENF90) - - # Notify CMake that a Fortran file can be generated from a genf90 - # template. - function(preprocess_genf90_template genf90_file fortran_file) - - add_custom_command(OUTPUT ${fortran_file} - COMMAND ${GENF90} ${genf90_file} >${fortran_file} - MAIN_DEPENDENCY ${genf90_file}) - - get_filename_component(stripped_name ${fortran_file} NAME_WE) - - add_custom_target(generate_${stripped_name} DEPENDS ${fortran_file}) - - endfunction(preprocess_genf90_template) - -else() - - # Stub if genf90 is off. - function(preprocess_genf90_template) - endfunction() - -endif() - -# Auto-generate source names. -function(process_genf90_source_list genf90_file_list output_directory - fortran_list_name) - - foreach(genf90_file IN LISTS genf90_file_list) - - # If a file is a relative path, expand it (relative to current source - # directory. - get_filename_component(genf90_file "${genf90_file}" ABSOLUTE) - - # Get extensionless base name from input. - get_filename_component(genf90_file_stripped "${genf90_file}" NAME_WE) - - # Add generated file to the test list. - set(fortran_file ${output_directory}/${genf90_file_stripped}.F90) - preprocess_genf90_template(${genf90_file} ${fortran_file}) - list(APPEND ${fortran_list_name} ${fortran_file}) - endforeach() - - # Export ${fortran_list_name} to the caller. - set(${fortran_list_name} "${${fortran_list_name}}" PARENT_SCOPE) - -endfunction(process_genf90_source_list) diff --git a/cesm/scripts/ccsm_utils/CMake/pFUnit_utils.cmake b/cesm/scripts/ccsm_utils/CMake/pFUnit_utils.cmake deleted file mode 100644 index 7a13506..0000000 --- a/cesm/scripts/ccsm_utils/CMake/pFUnit_utils.cmake +++ /dev/null @@ -1,212 +0,0 @@ -# Utilities for using pFUnit's preprocessor and provided driver file. -# -# This module relies upon the variables defined by the FindpFUnit module. -# -#========================================================================== -# -# add_pFUnit_executable -# -# Arguments: -# name - Name of the executable to add. -# pf_file_list - List of .pf files to process. -# output_directory - Directory where generated sources will be placed. -# fortran_source_list - List of Fortran files to include. -# -# Preprocesses the input .pf files to create test suites, then creates an -# executable that drives those suites with the pFUnit driver. -# -# Limitations: -# add_pFUnit_executable cannot currently handle cases where the user -# choses to do certain things "manually", such as: -# -# - Test suites written in normal Fortran (not .pf) files. -# - User-specified testSuites.inc -# - User-specified driver file in fortran_source_list. -# -#========================================================================== -# -# define_pFUnit_failure -# -# Arguments: -# test_name - Name of a CTest test. -# -# Defines FAIL_REGULAR_EXPRESSION and PASS_REGULAR_EXPRESSION for the given -# test, so that pFUnit's overall pass/fail status can be detected. -# -#========================================================================== -# -# create_pFUnit_test -# -# Required arguments: -# test_name - Name of a CTest test. -# executable_name - Name of the executable associated with this test. -# pf_file_list - List of .pf files to process. -# fortran_source_list - List of Fortran files to include. -# -# Optional arguments, specified via keyword: -# GEN_OUTPUT_DIRECTORY - directory for generated source files, relative to CMAKE_CURRENT_BINARY_DIR -# - Defaults to CMAKE_CURRENT_BINARY_DIR -# - Needs to be given if you have multiple separate pFUnit tests defined in the same directory -# COMMAND - Command to run the pFUnit test -# - Defaults to executable_name -# - Needs to be given if you need more on the command line than just the executable -# name, such as an aprun command, or setting the number of threads -# - A multi-part command should NOT be enclosed in quotes (see example below) -# -# Does everything needed to create a pFUnit-based test, wrapping -# add_pFUnit_executable, add_test, and define_pFUnit_failure. -# -# Example, using defaults for the optional arguments: -# create_pFUnit_test(mytest mytest_exe "${pfunit_sources}" "${test_sources}") -# -# Example, specifying values for the optional arguments: -# create_pFUnit_test(mytest mytest_exe "${pfunit_sources}" "${test_sources}" -# GEN_OUTPUT_DIRECTORY mytest_dir -# COMMAND env OMP_NUM_THREADS=3 mytest_exe) -# -#========================================================================== - -#========================================================================== -# Copyright (c) 2013-2014, University Corporation for Atmospheric Research -# -# This software is distributed under a two-clause BSD license, with no -# warranties, express or implied. See the accompanying LICENSE file for -# details. -#========================================================================== - -include(CMakeParseArguments) - -# Notify CMake that a given Fortran file can be produced by preprocessing a -# pFUnit file. -function(preprocess_pf_suite pf_file fortran_file) - - add_custom_command(OUTPUT ${fortran_file} - COMMAND python ${PFUNIT_PARSER} ${pf_file} ${fortran_file} - MAIN_DEPENDENCY ${pf_file}) - -endfunction(preprocess_pf_suite) - -# This function manages most of the work involved in preprocessing pFUnit -# files. You provide every *.pf file for a given executable, an output -# directory where generated sources should be output, and a list name. It -# will generate the sources, and append them and the pFUnit driver to the -# named list. -function(process_pFUnit_source_list pf_file_list output_directory - fortran_list_name) - - foreach(pf_file IN LISTS pf_file_list) - - # If a file is a relative path, expand it (relative to current source - # directory. - get_filename_component(pf_file "${pf_file}" ABSOLUTE) - - # Get extensionless base name from input. - get_filename_component(pf_file_stripped "${pf_file}" NAME_WE) - - # Add the generated Fortran files to the source list. - set(fortran_file ${output_directory}/${pf_file_stripped}.F90) - preprocess_pf_suite(${pf_file} ${fortran_file}) - list(APPEND ${fortran_list_name} ${fortran_file}) - - # Add the file to testSuites.inc - set(testSuites_contents - "${testSuites_contents}ADD_TEST_SUITE(${pf_file_stripped}_suite)\n") - endforeach() - - # Regenerate testSuites.inc if and only if necessary. - if(EXISTS ${output_directory}/testSuites.inc) - file(READ ${output_directory}/testSuites.inc old_testSuites_contents) - endif() - - if(NOT testSuites_contents STREQUAL old_testSuites_contents) - file(WRITE ${output_directory}/testSuites.inc ${testSuites_contents}) - endif() - - # Export ${fortran_list_name} to the caller, and add ${PFUNIT_DRIVER} - # to it. - set(${fortran_list_name} "${${fortran_list_name}}" "${PFUNIT_DRIVER}" - PARENT_SCOPE) - -endfunction(process_pFUnit_source_list) - -# Creates an executable of the given name using the pFUnit driver. Input -# variables are the executable name, a list of .pf files, the output -# directory for generated sources, and a list of regular Fortran files. -function(add_pFUnit_executable name pf_file_list output_directory - fortran_source_list) - - # Handle source code generation, add to list of sources. - process_pFUnit_source_list("${pf_file_list}" ${output_directory} - fortran_source_list) - - # Create the executable itself. - add_executable(${name} ${fortran_source_list}) - - # Handle pFUnit linking. - target_link_libraries(${name} "${PFUNIT_LIBRARIES}") - - # Necessary to include testSuites.inc - get_target_property(includes ${name} INCLUDE_DIRECTORIES) - if(NOT includes) - unset(includes) - endif() - list(APPEND includes ${output_directory} "${PFUNIT_INCLUDE_DIRS}") - set_target_properties(${name} PROPERTIES - INCLUDE_DIRECTORIES "${includes}") - - # The above lines are equivalent to: - # target_include_directories(${name} PRIVATE ${output_directory}) - # However, target_include_directories was not added until 2.8.11, and at - # the time of this writing, we can't depend on having such a recent - # version of CMake available on HPC systems. - -endfunction(add_pFUnit_executable) - -# Tells CTest what regular expressions are used to signal pass/fail from -# pFUnit output. -function(define_pFUnit_failure test_name) - # Set both pass and fail regular expressions to minimize the chance that - # the system under test will interfere with output and cause a false - # negative. - set_tests_properties(${test_name} PROPERTIES - FAIL_REGULAR_EXPRESSION "FAILURES!!!") - set_tests_properties(${test_name} PROPERTIES - PASS_REGULAR_EXPRESSION "OK") -endfunction(define_pFUnit_failure) - -# Does everything needed to create a pFUnit-based test, wrapping add_pFUnit_executable, -# add_test, and define_pFUnit_failure. -# -# Required input variables are the test name, the executable name, a list of .pf files, -# and a list of regular Fortran files. -# -# Optional input variables are GEN_OUTPUT_DIRECTORY and COMMAND (see usage notes at the -# top of this file for details). -function(create_pFUnit_test test_name executable_name pf_file_list fortran_source_list) - - # Parse optional arguments - set(options "") - set(oneValueArgs GEN_OUTPUT_DIRECTORY) - set(multiValueArgs COMMAND) - cmake_parse_arguments(MY "${options}" "${oneValueArgs}" "${multiValueArgs}" ${ARGN}) - if (MY_UNPARSED_ARGUMENTS) - message(FATAL_ERROR "Unknown keywords given to create_pFUnit_test(): \"${MY_UNPARSED_ARGUMENTS}\"") - endif() - - # Change GEN_OUTPUT_DIRECTORY to an absolute path, relative to CMAKE_CURRENT_BINARY_DIR - # Note that, if GEN_OUTPUT_DIRECTORY isn't given, this logic will make the output - # directory default to CMAKE_CURRENT_BINARY_DIR - set(MY_GEN_OUTPUT_DIRECTORY ${CMAKE_CURRENT_BINARY_DIR}/${MY_GEN_OUTPUT_DIRECTORY}) - - # Give default values to optional arguments that aren't present - if (NOT MY_COMMAND) - set(MY_COMMAND ${executable_name}) - endif() - - # Do the work - add_pFUnit_executable(${executable_name} "${pf_file_list}" - ${MY_GEN_OUTPUT_DIRECTORY} "${fortran_source_list}") - add_test(NAME ${test_name} COMMAND ${MY_COMMAND}) - define_pFUnit_failure(${test_name}) - -endfunction(create_pFUnit_test)