From 86ac66d0280b52438c851606914edf8bf18304d0 Mon Sep 17 00:00:00 2001 From: Robert Jacob Date: Tue, 25 Apr 2017 10:49:09 -0500 Subject: [PATCH 1/4] Removing cime/src/externals/mct for subtree update Had to remove and re-add because mct dir was moved. --- cime/src/externals/mct/.gitignore | 9 - cime/src/externals/mct/COPYRIGHT | 51 - cime/src/externals/mct/Makefile | 33 - cime/src/externals/mct/Makefile.conf.in | 89 - cime/src/externals/mct/README | 198 - cime/src/externals/mct/aclocal.m4 | 16 - cime/src/externals/mct/benchmarks/.gitignore | 4 - cime/src/externals/mct/benchmarks/Makefile | 58 - .../mct/benchmarks/RouterTestDis.F90 | 200 - .../mct/benchmarks/RouterTestOvr.F90 | 195 - cime/src/externals/mct/benchmarks/T42.8pC | 516 -- cime/src/externals/mct/benchmarks/T42.8pR | 12 - cime/src/externals/mct/benchmarks/gx1.8pC | 3076 ------- cime/src/externals/mct/benchmarks/gx1.8pR | 12 - .../externals/mct/benchmarks/importBench.F90 | 215 - cime/src/externals/mct/config.h.in | 81 - cime/src/externals/mct/configure | 6849 -------------- cime/src/externals/mct/configure.ac | 611 -- cime/src/externals/mct/doc/.gitignore | 7 - cime/src/externals/mct/doc/Makefile | 27 - cime/src/externals/mct/doc/README | 20 - cime/src/externals/mct/doc/coupler.bib | 254 - cime/src/externals/mct/doc/mct_APIs.tex | 338 - cime/src/externals/mct/doc/texsrc/.gitignore | 2 - cime/src/externals/mct/doc/texsrc/Makefile | 29 - cime/src/externals/mct/doc/texsrc/SRCS_tex.mk | 31 - cime/src/externals/mct/examples/Makefile | 20 - cime/src/externals/mct/examples/README | 22 - .../mct/examples/climate_concur1/.gitignore | 5 - .../mct/examples/climate_concur1/Makefile | 52 - .../mct/examples/climate_concur1/README | 38 - .../mct/examples/climate_concur1/coupler.F90 | 315 - .../mct/examples/climate_concur1/master.F90 | 89 - .../mct/examples/climate_concur1/model.F90 | 198 - .../mct/examples/climate_sequen1/.gitignore | 5 - .../mct/examples/climate_sequen1/Makefile | 51 - .../mct/examples/climate_sequen1/README | 42 - .../mct/examples/climate_sequen1/TS1.dat | 8193 ----------------- .../mct/examples/climate_sequen1/coupler.F90 | 214 - .../mct/examples/climate_sequen1/dst.rc | 6 - .../mct/examples/climate_sequen1/dstmodel.F90 | 231 - .../mct/examples/climate_sequen1/master.F90 | 103 - .../mct/examples/climate_sequen1/mutils.F90 | 139 - .../mct/examples/climate_sequen1/src.rc | 6 - .../mct/examples/climate_sequen1/srcmodel.F90 | 248 - .../externals/mct/examples/simple/.gitignore | 4 - .../externals/mct/examples/simple/Makefile | 53 - cime/src/externals/mct/examples/simple/README | 51 - .../mct/examples/simple/script.babyblue | 29 - .../mct/examples/simple/twocmp.con.F90 | 222 - .../mct/examples/simple/twocmp.seq.F90 | 204 - .../mct/examples/simple/twocmp.seqNB.F90 | 283 - .../mct/examples/simple/twocmp.seqUnvn.F90 | 242 - cime/src/externals/mct/install-sh | 276 - cime/src/externals/mct/m4/README | 5 - cime/src/externals/mct/m4/acx_mpi.m4 | 146 - cime/src/externals/mct/m4/ax_fc_version.m4 | 51 - cime/src/externals/mct/m4/fortran.m4 | 855 -- cime/src/externals/mct/mct/Makefile | 108 - cime/src/externals/mct/mct/README | 39 - cime/src/externals/mct/mct/m_Accumulator.F90 | 2471 ----- .../externals/mct/mct/m_AccumulatorComms.F90 | 803 -- cime/src/externals/mct/mct/m_AttrVect.F90 | 4161 --------- .../src/externals/mct/mct/m_AttrVectComms.F90 | 1683 ---- .../externals/mct/mct/m_AttrVectReduce.F90 | 1108 --- cime/src/externals/mct/mct/m_ConvertMaps.F90 | 438 - cime/src/externals/mct/mct/m_ExchangeMaps.F90 | 613 -- cime/src/externals/mct/mct/m_GeneralGrid.F90 | 3315 ------- .../externals/mct/mct/m_GeneralGridComms.F90 | 1536 --- cime/src/externals/mct/mct/m_GlobalMap.F90 | 672 -- cime/src/externals/mct/mct/m_GlobalSegMap.F90 | 2527 ----- .../externals/mct/mct/m_GlobalSegMapComms.F90 | 555 -- .../src/externals/mct/mct/m_GlobalToLocal.F90 | 719 -- cime/src/externals/mct/mct/m_MCTWorld.F90 | 883 -- .../externals/mct/mct/m_MatAttrVectMul.F90 | 632 -- cime/src/externals/mct/mct/m_Merge.F90 | 2912 ------ cime/src/externals/mct/mct/m_Navigator.F90 | 666 -- cime/src/externals/mct/mct/m_Rearranger.F90 | 1343 --- cime/src/externals/mct/mct/m_Router.F90 | 808 -- cime/src/externals/mct/mct/m_SparseMatrix.F90 | 2767 ------ .../externals/mct/mct/m_SparseMatrixComms.F90 | 699 -- .../mct/mct/m_SparseMatrixDecomp.F90 | 756 -- .../externals/mct/mct/m_SparseMatrixPlus.F90 | 872 -- .../mct/mct/m_SparseMatrixToMaps.F90 | 456 - .../externals/mct/mct/m_SpatialIntegral.F90 | 2034 ---- .../externals/mct/mct/m_SpatialIntegralV.F90 | 2017 ---- cime/src/externals/mct/mct/m_Transfer.F90 | 818 -- cime/src/externals/mct/mkinstalldirs | 111 - cime/src/externals/mct/mpeu/Makefile | 126 - cime/src/externals/mct/mpeu/README | 59 - cime/src/externals/mct/mpeu/assertmpeu.H | 55 - cime/src/externals/mct/mpeu/get_zeits.c | 76 - cime/src/externals/mct/mpeu/m_FcComms.F90 | 685 -- cime/src/externals/mct/mpeu/m_FileResolv.F90 | 273 - cime/src/externals/mct/mpeu/m_Filename.F90 | 106 - .../externals/mct/mpeu/m_IndexBin_char.F90 | 257 - .../externals/mct/mpeu/m_IndexBin_integer.F90 | 257 - .../externals/mct/mpeu/m_IndexBin_logical.F90 | 105 - cime/src/externals/mct/mpeu/m_List.F90 | 2112 ----- cime/src/externals/mct/mpeu/m_MergeSorts.F90 | 1469 --- cime/src/externals/mct/mpeu/m_Permuter.F90 | 1284 --- .../src/externals/mct/mpeu/m_SortingTools.F90 | 96 - cime/src/externals/mct/mpeu/m_StrTemplate.F90 | 454 - cime/src/externals/mct/mpeu/m_String.F90 | 831 -- .../externals/mct/mpeu/m_StringLinkedList.F90 | 553 -- cime/src/externals/mct/mpeu/m_TraceBack.F90 | 240 - cime/src/externals/mct/mpeu/m_chars.F90 | 107 - cime/src/externals/mct/mpeu/m_die.F90 | 404 - cime/src/externals/mct/mpeu/m_dropdead.F90 | 191 - cime/src/externals/mct/mpeu/m_flow.F90 | 196 - cime/src/externals/mct/mpeu/m_inpak90.F90 | 2049 ----- cime/src/externals/mct/mpeu/m_ioutil.F90 | 439 - cime/src/externals/mct/mpeu/m_mall.F90 | 1669 ---- cime/src/externals/mct/mpeu/m_mpif.F90 | 69 - cime/src/externals/mct/mpeu/m_mpif90.F90 | 719 -- cime/src/externals/mct/mpeu/m_mpout.F90 | 353 - cime/src/externals/mct/mpeu/m_rankMerge.F90 | 620 -- cime/src/externals/mct/mpeu/m_realkinds.F90 | 52 - cime/src/externals/mct/mpeu/m_stdio.F90 | 53 - cime/src/externals/mct/mpeu/m_zeit.F90 | 1008 -- cime/src/externals/mct/mpi-serial/.gitignore | 1 - cime/src/externals/mct/mpi-serial/Makefile | 91 - .../externals/mct/mpi-serial/Makefile.conf.in | 16 - cime/src/externals/mct/mpi-serial/NOTES | 46 - cime/src/externals/mct/mpi-serial/README | 102 - cime/src/externals/mct/mpi-serial/aclocal.m4 | 15 - cime/src/externals/mct/mpi-serial/cart.c | 128 - .../src/externals/mct/mpi-serial/collective.c | 527 -- cime/src/externals/mct/mpi-serial/comm.c | 247 - cime/src/externals/mct/mpi-serial/config.h.in | 84 - cime/src/externals/mct/mpi-serial/configure | 5833 ------------ .../src/externals/mct/mpi-serial/configure.in | 91 - cime/src/externals/mct/mpi-serial/copy.c | 91 - cime/src/externals/mct/mpi-serial/fort.F90 | 62 - cime/src/externals/mct/mpi-serial/getcount.c | 40 - cime/src/externals/mct/mpi-serial/group.c | 264 - cime/src/externals/mct/mpi-serial/handles.c | 309 - cime/src/externals/mct/mpi-serial/info.c | 53 - cime/src/externals/mct/mpi-serial/list.c | 705 -- cime/src/externals/mct/mpi-serial/list.h | 45 - cime/src/externals/mct/mpi-serial/listP.h | 33 - cime/src/externals/mct/mpi-serial/listops.h | 23 - cime/src/externals/mct/mpi-serial/m4/README | 5 - .../mct/mpi-serial/m4/ax_fc_version.m4 | 51 - cime/src/externals/mct/mpi-serial/mpi.c | 364 - cime/src/externals/mct/mpi-serial/mpi.h | 423 - cime/src/externals/mct/mpi-serial/mpiP.h | 128 - cime/src/externals/mct/mpi-serial/mpif.F90 | 12 - cime/src/externals/mct/mpi-serial/mpif.h | 334 - cime/src/externals/mct/mpi-serial/op.c | 28 - cime/src/externals/mct/mpi-serial/pack.c | 145 - cime/src/externals/mct/mpi-serial/probe.c | 88 - cime/src/externals/mct/mpi-serial/protify.awk | 46 - cime/src/externals/mct/mpi-serial/recv.c | 164 - cime/src/externals/mct/mpi-serial/req.c | 301 - cime/src/externals/mct/mpi-serial/send.c | 251 - .../externals/mct/mpi-serial/tests/.gitignore | 4 - .../externals/mct/mpi-serial/tests/Makefile | 41 - .../externals/mct/mpi-serial/tests/ctest.c | 967 -- .../mct/mpi-serial/tests/ctest_old.c | 181 - .../externals/mct/mpi-serial/tests/ftest.F90 | 680 -- .../mct/mpi-serial/tests/ftest_internal.F90 | 328 - .../mct/mpi-serial/tests/ftest_old.F90 | 165 - cime/src/externals/mct/mpi-serial/time.c | 35 - cime/src/externals/mct/mpi-serial/type.c | 829 -- cime/src/externals/mct/mpi-serial/type.h | 124 - .../src/externals/mct/mpi-serial/type_const.c | 189 - cime/src/externals/mct/protex/protex | 879 -- cime/src/externals/mct/testsystem/Makefile | 20 - .../mct/testsystem/testall/.gitignore | 6 - .../externals/mct/testsystem/testall/Makefile | 60 - .../testall/ReadSparseMatrixAsc.F90 | 242 - .../externals/mct/testsystem/testall/UNTESTED | 13 - .../externals/mct/testsystem/testall/ccm.F90 | 835 -- .../mct/testsystem/testall/convertPOPT.F90 | 454 - .../mct/testsystem/testall/convertgauss.F90 | 516 -- .../externals/mct/testsystem/testall/cpl.F90 | 1270 --- .../mct/testsystem/testall/job.ut-all.jaguar | 23 - .../mct/testsystem/testall/m_ACTEST.F90 | 633 -- .../mct/testsystem/testall/m_AVTEST.F90 | 857 -- .../mct/testsystem/testall/m_GGRIDTEST.F90 | 636 -- .../mct/testsystem/testall/m_GMAPTEST.F90 | 160 - .../mct/testsystem/testall/m_GSMAPTEST.F90 | 377 - .../mct/testsystem/testall/m_MCTWORLDTEST.F90 | 121 - .../mct/testsystem/testall/m_ROUTERTEST.F90 | 120 - .../mct/testsystem/testall/m_SMATTEST.F90 | 627 -- .../mct/testsystem/testall/master.F90 | 39 - .../externals/mct/testsystem/testall/mph.F90 | 1068 --- .../externals/mct/testsystem/testall/pop.F90 | 650 -- .../mct/testsystem/testall/processors_map.in | 12 - .../mct/testsystem/testall/script.jag | 18 - .../mct/testsystem/testall/ut_SparseMatrix.rc | 29 - cime/src/externals/mct/testunit/.gitignore | 4 - .../externals/mct/testunit/AttrVect_Test.F90 | 1907 ---- cime/src/externals/mct/testunit/Makefile | 41 - cime/src/externals/mct/testunit/master.F90 | 101 - 196 files changed, 107227 deletions(-) delete mode 100644 cime/src/externals/mct/.gitignore delete mode 100644 cime/src/externals/mct/COPYRIGHT delete mode 100644 cime/src/externals/mct/Makefile delete mode 100644 cime/src/externals/mct/Makefile.conf.in delete mode 100644 cime/src/externals/mct/README delete mode 100644 cime/src/externals/mct/aclocal.m4 delete mode 100644 cime/src/externals/mct/benchmarks/.gitignore delete mode 100644 cime/src/externals/mct/benchmarks/Makefile delete mode 100644 cime/src/externals/mct/benchmarks/RouterTestDis.F90 delete mode 100644 cime/src/externals/mct/benchmarks/RouterTestOvr.F90 delete mode 100644 cime/src/externals/mct/benchmarks/T42.8pC delete mode 100644 cime/src/externals/mct/benchmarks/T42.8pR delete mode 100644 cime/src/externals/mct/benchmarks/gx1.8pC delete mode 100644 cime/src/externals/mct/benchmarks/gx1.8pR delete mode 100644 cime/src/externals/mct/benchmarks/importBench.F90 delete mode 100644 cime/src/externals/mct/config.h.in delete mode 100755 cime/src/externals/mct/configure delete mode 100644 cime/src/externals/mct/configure.ac delete mode 100644 cime/src/externals/mct/doc/.gitignore delete mode 100644 cime/src/externals/mct/doc/Makefile delete mode 100644 cime/src/externals/mct/doc/README delete mode 100644 cime/src/externals/mct/doc/coupler.bib delete mode 100755 cime/src/externals/mct/doc/mct_APIs.tex delete mode 100644 cime/src/externals/mct/doc/texsrc/.gitignore delete mode 100644 cime/src/externals/mct/doc/texsrc/Makefile delete mode 100644 cime/src/externals/mct/doc/texsrc/SRCS_tex.mk delete mode 100644 cime/src/externals/mct/examples/Makefile delete mode 100644 cime/src/externals/mct/examples/README delete mode 100644 cime/src/externals/mct/examples/climate_concur1/.gitignore delete mode 100644 cime/src/externals/mct/examples/climate_concur1/Makefile delete mode 100644 cime/src/externals/mct/examples/climate_concur1/README delete mode 100644 cime/src/externals/mct/examples/climate_concur1/coupler.F90 delete mode 100644 cime/src/externals/mct/examples/climate_concur1/master.F90 delete mode 100644 cime/src/externals/mct/examples/climate_concur1/model.F90 delete mode 100644 cime/src/externals/mct/examples/climate_sequen1/.gitignore delete mode 100644 cime/src/externals/mct/examples/climate_sequen1/Makefile delete mode 100644 cime/src/externals/mct/examples/climate_sequen1/README delete mode 100644 cime/src/externals/mct/examples/climate_sequen1/TS1.dat delete mode 100644 cime/src/externals/mct/examples/climate_sequen1/coupler.F90 delete mode 100644 cime/src/externals/mct/examples/climate_sequen1/dst.rc delete mode 100644 cime/src/externals/mct/examples/climate_sequen1/dstmodel.F90 delete mode 100644 cime/src/externals/mct/examples/climate_sequen1/master.F90 delete mode 100644 cime/src/externals/mct/examples/climate_sequen1/mutils.F90 delete mode 100644 cime/src/externals/mct/examples/climate_sequen1/src.rc delete mode 100644 cime/src/externals/mct/examples/climate_sequen1/srcmodel.F90 delete mode 100644 cime/src/externals/mct/examples/simple/.gitignore delete mode 100644 cime/src/externals/mct/examples/simple/Makefile delete mode 100644 cime/src/externals/mct/examples/simple/README delete mode 100644 cime/src/externals/mct/examples/simple/script.babyblue delete mode 100644 cime/src/externals/mct/examples/simple/twocmp.con.F90 delete mode 100644 cime/src/externals/mct/examples/simple/twocmp.seq.F90 delete mode 100644 cime/src/externals/mct/examples/simple/twocmp.seqNB.F90 delete mode 100644 cime/src/externals/mct/examples/simple/twocmp.seqUnvn.F90 delete mode 100755 cime/src/externals/mct/install-sh delete mode 100644 cime/src/externals/mct/m4/README delete mode 100644 cime/src/externals/mct/m4/acx_mpi.m4 delete mode 100644 cime/src/externals/mct/m4/ax_fc_version.m4 delete mode 100644 cime/src/externals/mct/m4/fortran.m4 delete mode 100644 cime/src/externals/mct/mct/Makefile delete mode 100644 cime/src/externals/mct/mct/README delete mode 100644 cime/src/externals/mct/mct/m_Accumulator.F90 delete mode 100644 cime/src/externals/mct/mct/m_AccumulatorComms.F90 delete mode 100644 cime/src/externals/mct/mct/m_AttrVect.F90 delete mode 100644 cime/src/externals/mct/mct/m_AttrVectComms.F90 delete mode 100644 cime/src/externals/mct/mct/m_AttrVectReduce.F90 delete mode 100644 cime/src/externals/mct/mct/m_ConvertMaps.F90 delete mode 100644 cime/src/externals/mct/mct/m_ExchangeMaps.F90 delete mode 100644 cime/src/externals/mct/mct/m_GeneralGrid.F90 delete mode 100644 cime/src/externals/mct/mct/m_GeneralGridComms.F90 delete mode 100644 cime/src/externals/mct/mct/m_GlobalMap.F90 delete mode 100644 cime/src/externals/mct/mct/m_GlobalSegMap.F90 delete mode 100644 cime/src/externals/mct/mct/m_GlobalSegMapComms.F90 delete mode 100644 cime/src/externals/mct/mct/m_GlobalToLocal.F90 delete mode 100644 cime/src/externals/mct/mct/m_MCTWorld.F90 delete mode 100644 cime/src/externals/mct/mct/m_MatAttrVectMul.F90 delete mode 100644 cime/src/externals/mct/mct/m_Merge.F90 delete mode 100644 cime/src/externals/mct/mct/m_Navigator.F90 delete mode 100644 cime/src/externals/mct/mct/m_Rearranger.F90 delete mode 100644 cime/src/externals/mct/mct/m_Router.F90 delete mode 100644 cime/src/externals/mct/mct/m_SparseMatrix.F90 delete mode 100644 cime/src/externals/mct/mct/m_SparseMatrixComms.F90 delete mode 100644 cime/src/externals/mct/mct/m_SparseMatrixDecomp.F90 delete mode 100644 cime/src/externals/mct/mct/m_SparseMatrixPlus.F90 delete mode 100644 cime/src/externals/mct/mct/m_SparseMatrixToMaps.F90 delete mode 100644 cime/src/externals/mct/mct/m_SpatialIntegral.F90 delete mode 100644 cime/src/externals/mct/mct/m_SpatialIntegralV.F90 delete mode 100644 cime/src/externals/mct/mct/m_Transfer.F90 delete mode 100755 cime/src/externals/mct/mkinstalldirs delete mode 100644 cime/src/externals/mct/mpeu/Makefile delete mode 100644 cime/src/externals/mct/mpeu/README delete mode 100644 cime/src/externals/mct/mpeu/assertmpeu.H delete mode 100644 cime/src/externals/mct/mpeu/get_zeits.c delete mode 100644 cime/src/externals/mct/mpeu/m_FcComms.F90 delete mode 100644 cime/src/externals/mct/mpeu/m_FileResolv.F90 delete mode 100644 cime/src/externals/mct/mpeu/m_Filename.F90 delete mode 100644 cime/src/externals/mct/mpeu/m_IndexBin_char.F90 delete mode 100644 cime/src/externals/mct/mpeu/m_IndexBin_integer.F90 delete mode 100644 cime/src/externals/mct/mpeu/m_IndexBin_logical.F90 delete mode 100644 cime/src/externals/mct/mpeu/m_List.F90 delete mode 100644 cime/src/externals/mct/mpeu/m_MergeSorts.F90 delete mode 100644 cime/src/externals/mct/mpeu/m_Permuter.F90 delete mode 100644 cime/src/externals/mct/mpeu/m_SortingTools.F90 delete mode 100644 cime/src/externals/mct/mpeu/m_StrTemplate.F90 delete mode 100644 cime/src/externals/mct/mpeu/m_String.F90 delete mode 100644 cime/src/externals/mct/mpeu/m_StringLinkedList.F90 delete mode 100644 cime/src/externals/mct/mpeu/m_TraceBack.F90 delete mode 100644 cime/src/externals/mct/mpeu/m_chars.F90 delete mode 100644 cime/src/externals/mct/mpeu/m_die.F90 delete mode 100644 cime/src/externals/mct/mpeu/m_dropdead.F90 delete mode 100644 cime/src/externals/mct/mpeu/m_flow.F90 delete mode 100644 cime/src/externals/mct/mpeu/m_inpak90.F90 delete mode 100644 cime/src/externals/mct/mpeu/m_ioutil.F90 delete mode 100644 cime/src/externals/mct/mpeu/m_mall.F90 delete mode 100644 cime/src/externals/mct/mpeu/m_mpif.F90 delete mode 100644 cime/src/externals/mct/mpeu/m_mpif90.F90 delete mode 100644 cime/src/externals/mct/mpeu/m_mpout.F90 delete mode 100644 cime/src/externals/mct/mpeu/m_rankMerge.F90 delete mode 100644 cime/src/externals/mct/mpeu/m_realkinds.F90 delete mode 100644 cime/src/externals/mct/mpeu/m_stdio.F90 delete mode 100644 cime/src/externals/mct/mpeu/m_zeit.F90 delete mode 100644 cime/src/externals/mct/mpi-serial/.gitignore delete mode 100644 cime/src/externals/mct/mpi-serial/Makefile delete mode 100644 cime/src/externals/mct/mpi-serial/Makefile.conf.in delete mode 100644 cime/src/externals/mct/mpi-serial/NOTES delete mode 100644 cime/src/externals/mct/mpi-serial/README delete mode 100644 cime/src/externals/mct/mpi-serial/aclocal.m4 delete mode 100644 cime/src/externals/mct/mpi-serial/cart.c delete mode 100644 cime/src/externals/mct/mpi-serial/collective.c delete mode 100644 cime/src/externals/mct/mpi-serial/comm.c delete mode 100644 cime/src/externals/mct/mpi-serial/config.h.in delete mode 100755 cime/src/externals/mct/mpi-serial/configure delete mode 100644 cime/src/externals/mct/mpi-serial/configure.in delete mode 100644 cime/src/externals/mct/mpi-serial/copy.c delete mode 100644 cime/src/externals/mct/mpi-serial/fort.F90 delete mode 100644 cime/src/externals/mct/mpi-serial/getcount.c delete mode 100644 cime/src/externals/mct/mpi-serial/group.c delete mode 100644 cime/src/externals/mct/mpi-serial/handles.c delete mode 100644 cime/src/externals/mct/mpi-serial/info.c delete mode 100644 cime/src/externals/mct/mpi-serial/list.c delete mode 100644 cime/src/externals/mct/mpi-serial/list.h delete mode 100644 cime/src/externals/mct/mpi-serial/listP.h delete mode 100644 cime/src/externals/mct/mpi-serial/listops.h delete mode 100644 cime/src/externals/mct/mpi-serial/m4/README delete mode 100644 cime/src/externals/mct/mpi-serial/m4/ax_fc_version.m4 delete mode 100644 cime/src/externals/mct/mpi-serial/mpi.c delete mode 100644 cime/src/externals/mct/mpi-serial/mpi.h delete mode 100644 cime/src/externals/mct/mpi-serial/mpiP.h delete mode 100644 cime/src/externals/mct/mpi-serial/mpif.F90 delete mode 100644 cime/src/externals/mct/mpi-serial/mpif.h delete mode 100644 cime/src/externals/mct/mpi-serial/op.c delete mode 100644 cime/src/externals/mct/mpi-serial/pack.c delete mode 100644 cime/src/externals/mct/mpi-serial/probe.c delete mode 100755 cime/src/externals/mct/mpi-serial/protify.awk delete mode 100644 cime/src/externals/mct/mpi-serial/recv.c delete mode 100644 cime/src/externals/mct/mpi-serial/req.c delete mode 100644 cime/src/externals/mct/mpi-serial/send.c delete mode 100644 cime/src/externals/mct/mpi-serial/tests/.gitignore delete mode 100644 cime/src/externals/mct/mpi-serial/tests/Makefile delete mode 100644 cime/src/externals/mct/mpi-serial/tests/ctest.c delete mode 100644 cime/src/externals/mct/mpi-serial/tests/ctest_old.c delete mode 100644 cime/src/externals/mct/mpi-serial/tests/ftest.F90 delete mode 100644 cime/src/externals/mct/mpi-serial/tests/ftest_internal.F90 delete mode 100644 cime/src/externals/mct/mpi-serial/tests/ftest_old.F90 delete mode 100644 cime/src/externals/mct/mpi-serial/time.c delete mode 100644 cime/src/externals/mct/mpi-serial/type.c delete mode 100644 cime/src/externals/mct/mpi-serial/type.h delete mode 100644 cime/src/externals/mct/mpi-serial/type_const.c delete mode 100755 cime/src/externals/mct/protex/protex delete mode 100644 cime/src/externals/mct/testsystem/Makefile delete mode 100644 cime/src/externals/mct/testsystem/testall/.gitignore delete mode 100644 cime/src/externals/mct/testsystem/testall/Makefile delete mode 100644 cime/src/externals/mct/testsystem/testall/ReadSparseMatrixAsc.F90 delete mode 100644 cime/src/externals/mct/testsystem/testall/UNTESTED delete mode 100644 cime/src/externals/mct/testsystem/testall/ccm.F90 delete mode 100644 cime/src/externals/mct/testsystem/testall/convertPOPT.F90 delete mode 100644 cime/src/externals/mct/testsystem/testall/convertgauss.F90 delete mode 100644 cime/src/externals/mct/testsystem/testall/cpl.F90 delete mode 100644 cime/src/externals/mct/testsystem/testall/job.ut-all.jaguar delete mode 100644 cime/src/externals/mct/testsystem/testall/m_ACTEST.F90 delete mode 100644 cime/src/externals/mct/testsystem/testall/m_AVTEST.F90 delete mode 100644 cime/src/externals/mct/testsystem/testall/m_GGRIDTEST.F90 delete mode 100644 cime/src/externals/mct/testsystem/testall/m_GMAPTEST.F90 delete mode 100644 cime/src/externals/mct/testsystem/testall/m_GSMAPTEST.F90 delete mode 100644 cime/src/externals/mct/testsystem/testall/m_MCTWORLDTEST.F90 delete mode 100644 cime/src/externals/mct/testsystem/testall/m_ROUTERTEST.F90 delete mode 100644 cime/src/externals/mct/testsystem/testall/m_SMATTEST.F90 delete mode 100644 cime/src/externals/mct/testsystem/testall/master.F90 delete mode 100644 cime/src/externals/mct/testsystem/testall/mph.F90 delete mode 100644 cime/src/externals/mct/testsystem/testall/pop.F90 delete mode 100644 cime/src/externals/mct/testsystem/testall/processors_map.in delete mode 100644 cime/src/externals/mct/testsystem/testall/script.jag delete mode 100644 cime/src/externals/mct/testsystem/testall/ut_SparseMatrix.rc delete mode 100644 cime/src/externals/mct/testunit/.gitignore delete mode 100644 cime/src/externals/mct/testunit/AttrVect_Test.F90 delete mode 100644 cime/src/externals/mct/testunit/Makefile delete mode 100644 cime/src/externals/mct/testunit/master.F90 diff --git a/cime/src/externals/mct/.gitignore b/cime/src/externals/mct/.gitignore deleted file mode 100644 index 6e04052969bd..000000000000 --- a/cime/src/externals/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/cime/src/externals/mct/COPYRIGHT b/cime/src/externals/mct/COPYRIGHT deleted file mode 100644 index f4aa22117eb8..000000000000 --- a/cime/src/externals/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/cime/src/externals/mct/Makefile b/cime/src/externals/mct/Makefile deleted file mode 100644 index 6b5bfe7a444b..000000000000 --- a/cime/src/externals/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/cime/src/externals/mct/Makefile.conf.in b/cime/src/externals/mct/Makefile.conf.in deleted file mode 100644 index bc2896d90efe..000000000000 --- a/cime/src/externals/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/cime/src/externals/mct/README b/cime/src/externals/mct/README deleted file mode 100644 index fa38a8e9767f..000000000000 --- a/cime/src/externals/mct/README +++ /dev/null @@ -1,198 +0,0 @@ -###################################################################### - - -- Mathematics + Computer Science Div. / Argonne National Laboratory - - Model Coupling Toolkit (MCT) - - Robert Jacob - Jay Larson - Everest Ong - Ray Loy - - For more information, see http://www.mcs.anl.gov/mct - - See MCT/COPYRIGHT for license. - -###################################################################### - - This is version 2.9 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. - NO LONGER SUPPORTED - -###################################################################### - REQUIREMENTS: - - Building MCT requires a Fortran90 compiler. - - A full 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 full MPI installation with mpirun - 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, use: - > ./configure FC=bgxlf90_r CC=mpixlc_r MPIFC=mpixlf90_r (can also use versions without _r) - -###################################################################### - 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 - included in the MCT source and available from: - http://gmao.gsfc.nasa.gov/software/protex/ - - 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 - 19 Jun, 2015 -- version 2.9.0 diff --git a/cime/src/externals/mct/aclocal.m4 b/cime/src/externals/mct/aclocal.m4 deleted file mode 100644 index ae3d396d8c87..000000000000 --- a/cime/src/externals/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/cime/src/externals/mct/benchmarks/.gitignore b/cime/src/externals/mct/benchmarks/.gitignore deleted file mode 100644 index 1c6273f3704a..000000000000 --- a/cime/src/externals/mct/benchmarks/.gitignore +++ /dev/null @@ -1,4 +0,0 @@ -importBench -RouterTestDis -RouterTestOvr -fort.* diff --git a/cime/src/externals/mct/benchmarks/Makefile b/cime/src/externals/mct/benchmarks/Makefile deleted file mode 100644 index 75d393ff55a7..000000000000 --- a/cime/src/externals/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/cime/src/externals/mct/benchmarks/RouterTestDis.F90 b/cime/src/externals/mct/benchmarks/RouterTestDis.F90 deleted file mode 100644 index 635acca2a646..000000000000 --- a/cime/src/externals/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/cime/src/externals/mct/benchmarks/RouterTestOvr.F90 b/cime/src/externals/mct/benchmarks/RouterTestOvr.F90 deleted file mode 100644 index b9895b0dd9f2..000000000000 --- a/cime/src/externals/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/cime/src/externals/mct/benchmarks/T42.8pC b/cime/src/externals/mct/benchmarks/T42.8pC deleted file mode 100644 index f80c0b8b0b72..000000000000 --- a/cime/src/externals/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/cime/src/externals/mct/benchmarks/T42.8pR b/cime/src/externals/mct/benchmarks/T42.8pR deleted file mode 100644 index 5f3cd204fb5d..000000000000 --- a/cime/src/externals/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/cime/src/externals/mct/benchmarks/gx1.8pC b/cime/src/externals/mct/benchmarks/gx1.8pC deleted file mode 100644 index a183292daf32..000000000000 --- a/cime/src/externals/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/cime/src/externals/mct/benchmarks/gx1.8pR b/cime/src/externals/mct/benchmarks/gx1.8pR deleted file mode 100644 index c90fd783a547..000000000000 --- a/cime/src/externals/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/cime/src/externals/mct/benchmarks/importBench.F90 b/cime/src/externals/mct/benchmarks/importBench.F90 deleted file mode 100644 index ac7603e9d47b..000000000000 --- a/cime/src/externals/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/cime/src/externals/mct/config.h.in b/cime/src/externals/mct/config.h.in deleted file mode 100644 index 5ea9c79519e9..000000000000 --- a/cime/src/externals/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/cime/src/externals/mct/configure b/cime/src/externals/mct/configure deleted file mode 100755 index 83614aa08dbd..000000000000 --- a/cime/src/externals/mct/configure +++ /dev/null @@ -1,6849 +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" - -enable_option_checking=no -ac_subst_vars='LTLIBOBJS -LIBOBJS -subdirs -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' -ac_subdirs_all='mpi-serial' - -# 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:4070: \"$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 - -if test -n "$DONOTCHECKMPI"; then - echo "MPISERIAL ENABLED: CONFIGURING mpi-serial" - ac_aux_dir= -for ac_dir in "$srcdir" "$srcdir/.." "$srcdir/../.."; do - if test -f "$ac_dir/install-sh"; then - ac_aux_dir=$ac_dir - ac_install_sh="$ac_aux_dir/install-sh -c" - break - elif test -f "$ac_dir/install.sh"; then - ac_aux_dir=$ac_dir - ac_install_sh="$ac_aux_dir/install.sh -c" - break - elif test -f "$ac_dir/shtool"; then - ac_aux_dir=$ac_dir - ac_install_sh="$ac_aux_dir/shtool install -c" - break - fi -done -if test -z "$ac_aux_dir"; then - as_fn_error $? "cannot find install-sh, install.sh, or shtool in \"$srcdir\" \"$srcdir/..\" \"$srcdir/../..\"" "$LINENO" 5 -fi - -# These three variables are undocumented and unsupported, -# and are intended to be withdrawn in a future Autoconf release. -# They can cause serious problems if a builder's source tree is in a directory -# whose full name contains unusual characters. -ac_config_guess="$SHELL $ac_aux_dir/config.guess" # Please don't use this var. -ac_config_sub="$SHELL $ac_aux_dir/config.sub" # Please don't use this var. -ac_configure="$SHELL $ac_aux_dir/configure" # Please don't use this var. - - - - -subdirs="$subdirs mpi-serial" - -fi - -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 - -# -# CONFIG_SUBDIRS section. -# -if test "$no_recursion" != yes; then - - # Remove --cache-file, --srcdir, and --disable-option-checking arguments - # so they do not pile up. - ac_sub_configure_args= - ac_prev= - eval "set x $ac_configure_args" - shift - for ac_arg - do - if test -n "$ac_prev"; then - ac_prev= - continue - fi - case $ac_arg in - -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=*) - ;; - --config-cache | -C) - ;; - -srcdir | --srcdir | --srcdi | --srcd | --src | --sr) - ac_prev=srcdir ;; - -srcdir=* | --srcdir=* | --srcdi=* | --srcd=* | --src=* | --sr=*) - ;; - -prefix | --prefix | --prefi | --pref | --pre | --pr | --p) - ac_prev=prefix ;; - -prefix=* | --prefix=* | --prefi=* | --pref=* | --pre=* | --pr=* | --p=*) - ;; - --disable-option-checking) - ;; - *) - case $ac_arg in - *\'*) ac_arg=`$as_echo "$ac_arg" | sed "s/'/'\\\\\\\\''/g"` ;; - esac - as_fn_append ac_sub_configure_args " '$ac_arg'" ;; - esac - done - - # Always prepend --prefix to ensure using the same prefix - # in subdir configurations. - ac_arg="--prefix=$prefix" - case $ac_arg in - *\'*) ac_arg=`$as_echo "$ac_arg" | sed "s/'/'\\\\\\\\''/g"` ;; - esac - ac_sub_configure_args="'$ac_arg' $ac_sub_configure_args" - - # Pass --silent - if test "$silent" = yes; then - ac_sub_configure_args="--silent $ac_sub_configure_args" - fi - - # Always prepend --disable-option-checking to silence warnings, since - # different subdirs can have different --enable and --with options. - ac_sub_configure_args="--disable-option-checking $ac_sub_configure_args" - - ac_popdir=`pwd` - for ac_dir in : $subdirs; do test "x$ac_dir" = x: && continue - - # Do not complain, so a configure script can configure whichever - # parts of a large source tree are present. - test -d "$srcdir/$ac_dir" || continue - - ac_msg="=== configuring in $ac_dir (`pwd`/$ac_dir)" - $as_echo "$as_me:${as_lineno-$LINENO}: $ac_msg" >&5 - $as_echo "$ac_msg" >&6 - 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 - - - cd "$ac_dir" - - # Check for guested configure; otherwise get Cygnus style configure. - if test -f "$ac_srcdir/configure.gnu"; then - ac_sub_configure=$ac_srcdir/configure.gnu - elif test -f "$ac_srcdir/configure"; then - ac_sub_configure=$ac_srcdir/configure - elif test -f "$ac_srcdir/configure.in"; then - # This should be Cygnus configure. - ac_sub_configure=$ac_aux_dir/configure - else - { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: no configuration information is in $ac_dir" >&5 -$as_echo "$as_me: WARNING: no configuration information is in $ac_dir" >&2;} - ac_sub_configure= - fi - - # The recursion is here. - if test -n "$ac_sub_configure"; then - # Make the cache file name correct relative to the subdirectory. - case $cache_file in - [\\/]* | ?:[\\/]* ) ac_sub_cache_file=$cache_file ;; - *) # Relative name. - ac_sub_cache_file=$ac_top_build_prefix$cache_file ;; - esac - - { $as_echo "$as_me:${as_lineno-$LINENO}: running $SHELL $ac_sub_configure $ac_sub_configure_args --cache-file=$ac_sub_cache_file --srcdir=$ac_srcdir" >&5 -$as_echo "$as_me: running $SHELL $ac_sub_configure $ac_sub_configure_args --cache-file=$ac_sub_cache_file --srcdir=$ac_srcdir" >&6;} - # The eval makes quoting arguments work. - eval "\$SHELL \"\$ac_sub_configure\" $ac_sub_configure_args \ - --cache-file=\"\$ac_sub_cache_file\" --srcdir=\"\$ac_srcdir\"" || - as_fn_error $? "$ac_sub_configure failed for $ac_dir" "$LINENO" 5 - fi - - cd "$ac_popdir" - done -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/cime/src/externals/mct/configure.ac b/cime/src/externals/mct/configure.ac deleted file mode 100644 index 248708870237..000000000000 --- a/cime/src/externals/mct/configure.ac +++ /dev/null @@ -1,611 +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 - -if test -n "$DONOTCHECKMPI"; then - echo "MPISERIAL ENABLED: CONFIGURING mpi-serial" - AC_CONFIG_SUBDIRS(mpi-serial) -fi - -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/cime/src/externals/mct/doc/.gitignore b/cime/src/externals/mct/doc/.gitignore deleted file mode 100644 index aadc44c83991..000000000000 --- a/cime/src/externals/mct/doc/.gitignore +++ /dev/null @@ -1,7 +0,0 @@ -*.toc -*.log -*.dvi -*.aux -*.blg -*.bbl -*.pdf diff --git a/cime/src/externals/mct/doc/Makefile b/cime/src/externals/mct/doc/Makefile deleted file mode 100644 index 48d6e1e122cf..000000000000 --- a/cime/src/externals/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/cime/src/externals/mct/doc/README b/cime/src/externals/mct/doc/README deleted file mode 100644 index 9ccfdfe50e3a..000000000000 --- a/cime/src/externals/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/cime/src/externals/mct/doc/coupler.bib b/cime/src/externals/mct/doc/coupler.bib deleted file mode 100644 index 9d583a0326d7..000000000000 --- a/cime/src/externals/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/cime/src/externals/mct/doc/mct_APIs.tex b/cime/src/externals/mct/doc/mct_APIs.tex deleted file mode 100755 index 7a05358dcca1..000000000000 --- a/cime/src/externals/mct/doc/mct_APIs.tex +++ /dev/null @@ -1,338 +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.9 -\\ } %%% 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 -Version 2.9.0 & Jun 19, 2015 & 2.9.0 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/cime/src/externals/mct/doc/texsrc/.gitignore b/cime/src/externals/mct/doc/texsrc/.gitignore deleted file mode 100644 index 89a588f67135..000000000000 --- a/cime/src/externals/mct/doc/texsrc/.gitignore +++ /dev/null @@ -1,2 +0,0 @@ -*.tex -*.F90 diff --git a/cime/src/externals/mct/doc/texsrc/Makefile b/cime/src/externals/mct/doc/texsrc/Makefile deleted file mode 100644 index 7d4049643f32..000000000000 --- a/cime/src/externals/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/cime/src/externals/mct/doc/texsrc/SRCS_tex.mk b/cime/src/externals/mct/doc/texsrc/SRCS_tex.mk deleted file mode 100644 index 556c7218bcca..000000000000 --- a/cime/src/externals/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/cime/src/externals/mct/examples/Makefile b/cime/src/externals/mct/examples/Makefile deleted file mode 100644 index dfd79727493f..000000000000 --- a/cime/src/externals/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/cime/src/externals/mct/examples/README b/cime/src/externals/mct/examples/README deleted file mode 100644 index a7e19528ead1..000000000000 --- a/cime/src/externals/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/cime/src/externals/mct/examples/climate_concur1/.gitignore b/cime/src/externals/mct/examples/climate_concur1/.gitignore deleted file mode 100644 index d4f2ff7e9f34..000000000000 --- a/cime/src/externals/mct/examples/climate_concur1/.gitignore +++ /dev/null @@ -1,5 +0,0 @@ -climate -*.mod -poe.* -*.script -*.o* diff --git a/cime/src/externals/mct/examples/climate_concur1/Makefile b/cime/src/externals/mct/examples/climate_concur1/Makefile deleted file mode 100644 index 3f4f30e1ed47..000000000000 --- a/cime/src/externals/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/cime/src/externals/mct/examples/climate_concur1/README b/cime/src/externals/mct/examples/climate_concur1/README deleted file mode 100644 index b7b61d9c1ea0..000000000000 --- a/cime/src/externals/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/cime/src/externals/mct/examples/climate_concur1/coupler.F90 b/cime/src/externals/mct/examples/climate_concur1/coupler.F90 deleted file mode 100644 index 465781a8b41b..000000000000 --- a/cime/src/externals/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/cime/src/externals/mct/examples/climate_concur1/master.F90 b/cime/src/externals/mct/examples/climate_concur1/master.F90 deleted file mode 100644 index e9252daa9ee5..000000000000 --- a/cime/src/externals/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/cime/src/externals/mct/examples/climate_concur1/model.F90 b/cime/src/externals/mct/examples/climate_concur1/model.F90 deleted file mode 100644 index 60a245a3f321..000000000000 --- a/cime/src/externals/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/cime/src/externals/mct/examples/climate_sequen1/.gitignore b/cime/src/externals/mct/examples/climate_sequen1/.gitignore deleted file mode 100644 index f2d3c73f037b..000000000000 --- a/cime/src/externals/mct/examples/climate_sequen1/.gitignore +++ /dev/null @@ -1,5 +0,0 @@ -*.mod -climate -TS1out.dat -*.script -*.o* diff --git a/cime/src/externals/mct/examples/climate_sequen1/Makefile b/cime/src/externals/mct/examples/climate_sequen1/Makefile deleted file mode 100644 index 7992fa00f9c2..000000000000 --- a/cime/src/externals/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/cime/src/externals/mct/examples/climate_sequen1/README b/cime/src/externals/mct/examples/climate_sequen1/README deleted file mode 100644 index fa7f9afb57dd..000000000000 --- a/cime/src/externals/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/cime/src/externals/mct/examples/climate_sequen1/TS1.dat b/cime/src/externals/mct/examples/climate_sequen1/TS1.dat deleted file mode 100644 index 6e9ce15fbecd..000000000000 --- a/cime/src/externals/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/cime/src/externals/mct/examples/climate_sequen1/coupler.F90 b/cime/src/externals/mct/examples/climate_sequen1/coupler.F90 deleted file mode 100644 index 7ea8bacf4bab..000000000000 --- a/cime/src/externals/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/cime/src/externals/mct/examples/climate_sequen1/dst.rc b/cime/src/externals/mct/examples/climate_sequen1/dst.rc deleted file mode 100644 index cbb9449b80de..000000000000 --- a/cime/src/externals/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/cime/src/externals/mct/examples/climate_sequen1/dstmodel.F90 b/cime/src/externals/mct/examples/climate_sequen1/dstmodel.F90 deleted file mode 100644 index 3344e7604ca0..000000000000 --- a/cime/src/externals/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/cime/src/externals/mct/examples/climate_sequen1/master.F90 b/cime/src/externals/mct/examples/climate_sequen1/master.F90 deleted file mode 100644 index 0f9a4786782b..000000000000 --- a/cime/src/externals/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/cime/src/externals/mct/examples/climate_sequen1/mutils.F90 b/cime/src/externals/mct/examples/climate_sequen1/mutils.F90 deleted file mode 100644 index 0a1829f0a59d..000000000000 --- a/cime/src/externals/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/cime/src/externals/mct/examples/climate_sequen1/src.rc b/cime/src/externals/mct/examples/climate_sequen1/src.rc deleted file mode 100644 index 1dd5275e5386..000000000000 --- a/cime/src/externals/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/cime/src/externals/mct/examples/climate_sequen1/srcmodel.F90 b/cime/src/externals/mct/examples/climate_sequen1/srcmodel.F90 deleted file mode 100644 index b0c8be56db4a..000000000000 --- a/cime/src/externals/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/cime/src/externals/mct/examples/simple/.gitignore b/cime/src/externals/mct/examples/simple/.gitignore deleted file mode 100644 index 40296985e55d..000000000000 --- a/cime/src/externals/mct/examples/simple/.gitignore +++ /dev/null @@ -1,4 +0,0 @@ -twocon -twoseq -twosequn -twoseqNB diff --git a/cime/src/externals/mct/examples/simple/Makefile b/cime/src/externals/mct/examples/simple/Makefile deleted file mode 100644 index 773fb149744e..000000000000 --- a/cime/src/externals/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/cime/src/externals/mct/examples/simple/README b/cime/src/externals/mct/examples/simple/README deleted file mode 100644 index 037bde5bcf4f..000000000000 --- a/cime/src/externals/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/cime/src/externals/mct/examples/simple/script.babyblue b/cime/src/externals/mct/examples/simple/script.babyblue deleted file mode 100644 index a30fea12731b..000000000000 --- a/cime/src/externals/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/cime/src/externals/mct/examples/simple/twocmp.con.F90 b/cime/src/externals/mct/examples/simple/twocmp.con.F90 deleted file mode 100644 index 8bbd1916b3da..000000000000 --- a/cime/src/externals/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/cime/src/externals/mct/examples/simple/twocmp.seq.F90 b/cime/src/externals/mct/examples/simple/twocmp.seq.F90 deleted file mode 100644 index d828d38f4962..000000000000 --- a/cime/src/externals/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/cime/src/externals/mct/examples/simple/twocmp.seqNB.F90 b/cime/src/externals/mct/examples/simple/twocmp.seqNB.F90 deleted file mode 100644 index 82c93610e500..000000000000 --- a/cime/src/externals/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/cime/src/externals/mct/examples/simple/twocmp.seqUnvn.F90 b/cime/src/externals/mct/examples/simple/twocmp.seqUnvn.F90 deleted file mode 100644 index 7e36e5a26a95..000000000000 --- a/cime/src/externals/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/cime/src/externals/mct/install-sh b/cime/src/externals/mct/install-sh deleted file mode 100755 index 36f96f3e033c..000000000000 --- a/cime/src/externals/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/cime/src/externals/mct/m4/README b/cime/src/externals/mct/m4/README deleted file mode 100644 index b748178e2c79..000000000000 --- a/cime/src/externals/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/cime/src/externals/mct/m4/acx_mpi.m4 b/cime/src/externals/mct/m4/acx_mpi.m4 deleted file mode 100644 index 77f433d82170..000000000000 --- a/cime/src/externals/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/cime/src/externals/mct/m4/ax_fc_version.m4 b/cime/src/externals/mct/m4/ax_fc_version.m4 deleted file mode 100644 index c7e2eaec3c70..000000000000 --- a/cime/src/externals/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/cime/src/externals/mct/m4/fortran.m4 b/cime/src/externals/mct/m4/fortran.m4 deleted file mode 100644 index c835ce232aa7..000000000000 --- a/cime/src/externals/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/cime/src/externals/mct/mct/Makefile b/cime/src/externals/mct/mct/Makefile deleted file mode 100644 index edc5d11a8dfe..000000000000 --- a/cime/src/externals/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/cime/src/externals/mct/mct/README b/cime/src/externals/mct/mct/README deleted file mode 100644 index 139553c6c2d3..000000000000 --- a/cime/src/externals/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/cime/src/externals/mct/mct/m_Accumulator.F90 b/cime/src/externals/mct/mct/m_Accumulator.F90 deleted file mode 100644 index c7b1e29054dc..000000000000 --- a/cime/src/externals/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/cime/src/externals/mct/mct/m_AccumulatorComms.F90 b/cime/src/externals/mct/mct/m_AccumulatorComms.F90 deleted file mode 100644 index e790418c30cd..000000000000 --- a/cime/src/externals/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/cime/src/externals/mct/mct/m_AttrVect.F90 b/cime/src/externals/mct/mct/m_AttrVect.F90 deleted file mode 100644 index 93f0f14d1cda..000000000000 --- a/cime/src/externals/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/cime/src/externals/mct/mct/m_AttrVectComms.F90 b/cime/src/externals/mct/mct/m_AttrVectComms.F90 deleted file mode 100644 index 777a1e504adc..000000000000 --- a/cime/src/externals/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/cime/src/externals/mct/mct/m_AttrVectReduce.F90 b/cime/src/externals/mct/mct/m_AttrVectReduce.F90 deleted file mode 100644 index e05eda342e3b..000000000000 --- a/cime/src/externals/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/cime/src/externals/mct/mct/m_ConvertMaps.F90 b/cime/src/externals/mct/mct/m_ConvertMaps.F90 deleted file mode 100644 index 5132a697d7df..000000000000 --- a/cime/src/externals/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/cime/src/externals/mct/mct/m_ExchangeMaps.F90 b/cime/src/externals/mct/mct/m_ExchangeMaps.F90 deleted file mode 100644 index cb6100b23de3..000000000000 --- a/cime/src/externals/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/cime/src/externals/mct/mct/m_GeneralGrid.F90 b/cime/src/externals/mct/mct/m_GeneralGrid.F90 deleted file mode 100644 index 474fbf9089a7..000000000000 --- a/cime/src/externals/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/cime/src/externals/mct/mct/m_GeneralGridComms.F90 b/cime/src/externals/mct/mct/m_GeneralGridComms.F90 deleted file mode 100644 index f5118309694a..000000000000 --- a/cime/src/externals/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/cime/src/externals/mct/mct/m_GlobalMap.F90 b/cime/src/externals/mct/mct/m_GlobalMap.F90 deleted file mode 100644 index b5273e566b7e..000000000000 --- a/cime/src/externals/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/cime/src/externals/mct/mct/m_GlobalSegMap.F90 b/cime/src/externals/mct/mct/m_GlobalSegMap.F90 deleted file mode 100644 index f59901e929c1..000000000000 --- a/cime/src/externals/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/cime/src/externals/mct/mct/m_GlobalSegMapComms.F90 b/cime/src/externals/mct/mct/m_GlobalSegMapComms.F90 deleted file mode 100644 index a5192a3b3e47..000000000000 --- a/cime/src/externals/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/cime/src/externals/mct/mct/m_GlobalToLocal.F90 b/cime/src/externals/mct/mct/m_GlobalToLocal.F90 deleted file mode 100644 index 0b80a8362747..000000000000 --- a/cime/src/externals/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/cime/src/externals/mct/mct/m_MCTWorld.F90 b/cime/src/externals/mct/mct/m_MCTWorld.F90 deleted file mode 100644 index 3ec6498526eb..000000000000 --- a/cime/src/externals/mct/mct/m_MCTWorld.F90 +++ /dev/null @@ -1,883 +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:root_nprocs(i)-1,i) - call MPI_IRECV(apoint, 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_mpif90 - 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) - - call MP_comm_free(ThisMCTWorld%MCT_comm, ier) - if(ier /= 0) call MP_perr_die(myname_,'MP_comm_free()',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/cime/src/externals/mct/mct/m_MatAttrVectMul.F90 b/cime/src/externals/mct/mct/m_MatAttrVectMul.F90 deleted file mode 100644 index f6937c17b26b..000000000000 --- a/cime/src/externals/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/cime/src/externals/mct/mct/m_Merge.F90 b/cime/src/externals/mct/mct/m_Merge.F90 deleted file mode 100644 index 6700c3bc228d..000000000000 --- a/cime/src/externals/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/cime/src/externals/mct/mct/m_Navigator.F90 b/cime/src/externals/mct/mct/m_Navigator.F90 deleted file mode 100644 index 6c43ab36a924..000000000000 --- a/cime/src/externals/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/cime/src/externals/mct/mct/m_Rearranger.F90 b/cime/src/externals/mct/mct/m_Rearranger.F90 deleted file mode 100644 index dc81dde9b5d9..000000000000 --- a/cime/src/externals/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/cime/src/externals/mct/mct/m_Router.F90 b/cime/src/externals/mct/mct/m_Router.F90 deleted file mode 100644 index 305d2d7e389f..000000000000 --- a/cime/src/externals/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/cime/src/externals/mct/mct/m_SparseMatrix.F90 b/cime/src/externals/mct/mct/m_SparseMatrix.F90 deleted file mode 100644 index 29716c5fd412..000000000000 --- a/cime/src/externals/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/cime/src/externals/mct/mct/m_SparseMatrixComms.F90 b/cime/src/externals/mct/mct/m_SparseMatrixComms.F90 deleted file mode 100644 index 761cd81a3198..000000000000 --- a/cime/src/externals/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/cime/src/externals/mct/mct/m_SparseMatrixDecomp.F90 b/cime/src/externals/mct/mct/m_SparseMatrixDecomp.F90 deleted file mode 100644 index eb914e74aa99..000000000000 --- a/cime/src/externals/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/cime/src/externals/mct/mct/m_SparseMatrixPlus.F90 b/cime/src/externals/mct/mct/m_SparseMatrixPlus.F90 deleted file mode 100644 index de6e966b8041..000000000000 --- a/cime/src/externals/mct/mct/m_SparseMatrixPlus.F90 +++ /dev/null @@ -1,872 +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.' - call die(myname_) - 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/cime/src/externals/mct/mct/m_SparseMatrixToMaps.F90 b/cime/src/externals/mct/mct/m_SparseMatrixToMaps.F90 deleted file mode 100644 index b28448a6231c..000000000000 --- a/cime/src/externals/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/cime/src/externals/mct/mct/m_SpatialIntegral.F90 b/cime/src/externals/mct/mct/m_SpatialIntegral.F90 deleted file mode 100644 index 2cf709b93f52..000000000000 --- a/cime/src/externals/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/cime/src/externals/mct/mct/m_SpatialIntegralV.F90 b/cime/src/externals/mct/mct/m_SpatialIntegralV.F90 deleted file mode 100644 index 1c503b776aa2..000000000000 --- a/cime/src/externals/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/cime/src/externals/mct/mct/m_Transfer.F90 b/cime/src/externals/mct/mct/m_Transfer.F90 deleted file mode 100644 index 475898a06dbf..000000000000 --- a/cime/src/externals/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/cime/src/externals/mct/mkinstalldirs b/cime/src/externals/mct/mkinstalldirs deleted file mode 100755 index d2d5f21b6112..000000000000 --- a/cime/src/externals/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/cime/src/externals/mct/mpeu/Makefile b/cime/src/externals/mct/mpeu/Makefile deleted file mode 100644 index dfadaec624ec..000000000000 --- a/cime/src/externals/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/cime/src/externals/mct/mpeu/README b/cime/src/externals/mct/mpeu/README deleted file mode 100644 index 06d3cc4d93e5..000000000000 --- a/cime/src/externals/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/cime/src/externals/mct/mpeu/assertmpeu.H b/cime/src/externals/mct/mpeu/assertmpeu.H deleted file mode 100644 index ef83c6e464e5..000000000000 --- a/cime/src/externals/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/cime/src/externals/mct/mpeu/get_zeits.c b/cime/src/externals/mct/mpeu/get_zeits.c deleted file mode 100644 index b8065c5ebad3..000000000000 --- a/cime/src/externals/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/cime/src/externals/mct/mpeu/m_FcComms.F90 b/cime/src/externals/mct/mpeu/m_FcComms.F90 deleted file mode 100644 index bdd76ea95ec9..000000000000 --- a/cime/src/externals/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/cime/src/externals/mct/mpeu/m_FileResolv.F90 b/cime/src/externals/mct/mpeu/m_FileResolv.F90 deleted file mode 100644 index 8145aeb43a39..000000000000 --- a/cime/src/externals/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/cime/src/externals/mct/mpeu/m_Filename.F90 b/cime/src/externals/mct/mpeu/m_Filename.F90 deleted file mode 100644 index 1032a512c296..000000000000 --- a/cime/src/externals/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/cime/src/externals/mct/mpeu/m_IndexBin_char.F90 b/cime/src/externals/mct/mpeu/m_IndexBin_char.F90 deleted file mode 100644 index db83e996ad89..000000000000 --- a/cime/src/externals/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/cime/src/externals/mct/mpeu/m_IndexBin_integer.F90 b/cime/src/externals/mct/mpeu/m_IndexBin_integer.F90 deleted file mode 100644 index 8eb5abf277c3..000000000000 --- a/cime/src/externals/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/cime/src/externals/mct/mpeu/m_IndexBin_logical.F90 b/cime/src/externals/mct/mpeu/m_IndexBin_logical.F90 deleted file mode 100644 index 710600eb2129..000000000000 --- a/cime/src/externals/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/cime/src/externals/mct/mpeu/m_List.F90 b/cime/src/externals/mct/mpeu/m_List.F90 deleted file mode 100644 index 0e420c4bf26c..000000000000 --- a/cime/src/externals/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/cime/src/externals/mct/mpeu/m_MergeSorts.F90 b/cime/src/externals/mct/mpeu/m_MergeSorts.F90 deleted file mode 100644 index 6dc4cd6db1da..000000000000 --- a/cime/src/externals/mct/mpeu/m_MergeSorts.F90 +++ /dev/null @@ -1,1469 +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 - - integer,parameter :: I8 = selected_int_kind (13) - - interface IndexSet - module procedure setn_ - module procedure set_ - end interface - interface IndexSort - module procedure iSortn_ - module procedure i8Sortn_ - module procedure rSortn_ - module procedure dSortn_ - module procedure cSortn_ - module procedure iSort_ - module procedure i8Sort_ - module procedure rSort_ - module procedure dSort_ - module procedure cSort_ - module procedure iSort1_ - module procedure i8Sort1_ - 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: -! 23Mar15 - Steve Goldhaber (goldy@ucar.edu) -! . Added interface to perform index sort on 8-byte integers -! 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: i8Sortn_ - A stable merge index sorting of 8-byte INTs. -! -! !DESCRIPTION: -! -! !INTERFACE: - - subroutine i8Sortn_(n,indx,keys,descend,stat) - implicit none - - integer,intent(in) :: n - integer, dimension(n), intent(inout) :: indx - integer(i8), dimension(n), intent(in) :: keys - logical, optional, intent(in) :: descend - integer, optional, intent(out) :: stat - -! !REVISION HISTORY: -! 23Mar15 - Steve Goldhaber (goldy@ucar.edu) -! . Added interface to perform index sort on 8-byte integers -! 15Mar00 - Jing Guo -! . initial prototype/prolog/code -! . redefined for the original interface -!EOP ___________________________________________________________________ - - character(len=*),parameter :: myname_=myname//'::i8Sortn_' - - call i8Sort_(indx(1:n),keys(1:n),descend,stat) -end subroutine i8Sortn_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! 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: i8Sort_ - A stable merge index sorting of 8-byte INTs. -! -! !DESCRIPTION: -! -! !INTERFACE: - - subroutine i8Sort_(indx,keys,descend,stat) - use m_stdio, only : stderr - use m_die, only : die - implicit none - - integer, dimension(:), intent(inout) :: indx - integer(i8), dimension(:), intent(in) :: keys - logical, optional, intent(in) :: descend - integer, optional, intent(out) :: stat - -! !REVISION HISTORY: -! 17Dec14 - goldy@ucar.edu - Added 8-byte version -! 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//'::i8Sort_' - - 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 i8Sort_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! 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//'::i8Sort1_' - - 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: i8Sort1_ - A stable merge index sorting of 8-byte INTs. -! -! !DESCRIPTION: -! -! !INTERFACE: - - subroutine i8Sort1_(indx,keys,ikey,descend,stat) - use m_stdio, only : stderr - use m_die, only : die - implicit none - - integer, dimension(:), intent(inout) :: indx - integer(i8), dimension(:,:), intent(in) :: keys - integer,intent(in) :: ikey - logical, optional, intent(in) :: descend - integer, optional, intent(out) :: stat - -! !REVISION HISTORY: -! 17Dec14 - goldy@ucar.edu - Added 8-byte version -! 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//'::i8Sort1_' - - 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 i8Sort1_ - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! 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/cime/src/externals/mct/mpeu/m_Permuter.F90 b/cime/src/externals/mct/mpeu/m_Permuter.F90 deleted file mode 100644 index 202fc1de751c..000000000000 --- a/cime/src/externals/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/cime/src/externals/mct/mpeu/m_SortingTools.F90 b/cime/src/externals/mct/mpeu/m_SortingTools.F90 deleted file mode 100644 index 2f7399a45fa8..000000000000 --- a/cime/src/externals/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/cime/src/externals/mct/mpeu/m_StrTemplate.F90 b/cime/src/externals/mct/mpeu/m_StrTemplate.F90 deleted file mode 100644 index 979e9800ac34..000000000000 --- a/cime/src/externals/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/cime/src/externals/mct/mpeu/m_String.F90 b/cime/src/externals/mct/mpeu/m_String.F90 deleted file mode 100644 index 2b8bc42e7005..000000000000 --- a/cime/src/externals/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/cime/src/externals/mct/mpeu/m_StringLinkedList.F90 b/cime/src/externals/mct/mpeu/m_StringLinkedList.F90 deleted file mode 100644 index 50300a8b0cbd..000000000000 --- a/cime/src/externals/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/cime/src/externals/mct/mpeu/m_TraceBack.F90 b/cime/src/externals/mct/mpeu/m_TraceBack.F90 deleted file mode 100644 index 1afcaf8eb71d..000000000000 --- a/cime/src/externals/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/cime/src/externals/mct/mpeu/m_chars.F90 b/cime/src/externals/mct/mpeu/m_chars.F90 deleted file mode 100644 index 3ff275b138f3..000000000000 --- a/cime/src/externals/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/cime/src/externals/mct/mpeu/m_die.F90 b/cime/src/externals/mct/mpeu/m_die.F90 deleted file mode 100644 index 9e10b443353c..000000000000 --- a/cime/src/externals/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/cime/src/externals/mct/mpeu/m_dropdead.F90 b/cime/src/externals/mct/mpeu/m_dropdead.F90 deleted file mode 100644 index 0869fd904899..000000000000 --- a/cime/src/externals/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/cime/src/externals/mct/mpeu/m_flow.F90 b/cime/src/externals/mct/mpeu/m_flow.F90 deleted file mode 100644 index 35d7b3c5b84b..000000000000 --- a/cime/src/externals/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/cime/src/externals/mct/mpeu/m_inpak90.F90 b/cime/src/externals/mct/mpeu/m_inpak90.F90 deleted file mode 100644 index d1adfe11a1e7..000000000000 --- a/cime/src/externals/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/cime/src/externals/mct/mpeu/m_ioutil.F90 b/cime/src/externals/mct/mpeu/m_ioutil.F90 deleted file mode 100644 index 94cce456a7a6..000000000000 --- a/cime/src/externals/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/cime/src/externals/mct/mpeu/m_mall.F90 b/cime/src/externals/mct/mpeu/m_mall.F90 deleted file mode 100644 index 416538a4ced8..000000000000 --- a/cime/src/externals/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/cime/src/externals/mct/mpeu/m_mpif.F90 b/cime/src/externals/mct/mpeu/m_mpif.F90 deleted file mode 100644 index d8d6318a545c..000000000000 --- a/cime/src/externals/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/cime/src/externals/mct/mpeu/m_mpif90.F90 b/cime/src/externals/mct/mpeu/m_mpif90.F90 deleted file mode 100644 index 42e5d3355795..000000000000 --- a/cime/src/externals/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/cime/src/externals/mct/mpeu/m_rankMerge.F90 b/cime/src/externals/mct/mpeu/m_rankMerge.F90 deleted file mode 100644 index b3f78fb42db8..000000000000 --- a/cime/src/externals/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/cime/src/externals/mct/mpeu/m_realkinds.F90 b/cime/src/externals/mct/mpeu/m_realkinds.F90 deleted file mode 100644 index cb5f9994c0c3..000000000000 --- a/cime/src/externals/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/cime/src/externals/mct/mpeu/m_stdio.F90 b/cime/src/externals/mct/mpeu/m_stdio.F90 deleted file mode 100644 index 9f9fad81fed2..000000000000 --- a/cime/src/externals/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/cime/src/externals/mct/mpeu/m_zeit.F90 b/cime/src/externals/mct/mpeu/m_zeit.F90 deleted file mode 100644 index 207de748c84c..000000000000 --- a/cime/src/externals/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/cime/src/externals/mct/mpi-serial/.gitignore b/cime/src/externals/mct/mpi-serial/.gitignore deleted file mode 100644 index 8b137891791f..000000000000 --- a/cime/src/externals/mct/mpi-serial/.gitignore +++ /dev/null @@ -1 +0,0 @@ - diff --git a/cime/src/externals/mct/mpi-serial/Makefile b/cime/src/externals/mct/mpi-serial/Makefile deleted file mode 100644 index 024d9f862415..000000000000 --- a/cime/src/externals/mct/mpi-serial/Makefile +++ /dev/null @@ -1,91 +0,0 @@ -SHELL = /bin/sh -############################### -include Makefile.conf - -VPATH=$(SRCDIR)/mpi-serial -# SOURCE FILES - -MODULE = mpi-serial - -SRCS_F90 = fort.F90 \ - mpif.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 \ - type.c \ - type_const.c \ - copy.c \ - op.c \ - cart.c \ - getcount.c \ - probe.c \ - info.c - - -OBJS_ALL = $(SRCS_C:.c=.o) \ - $(SRCS_F90:.F90=.o) - - -INCPATH:= -I . - - -############################### - -# TARGETS - -default: lib$(MODULE).a - - -fort.o: mpif.h - - -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) $(DEFS) $(CPPDEFS) $(CFLAGS) $< - -.F90.o: - $(FC) -c $(INCFLAG) . $(INCPATH) $(DEFS) $(FPPDEFS) $(FCFLAGS) $(MPEUFLAGS) $< - -MYF90FLAGS=$(INCPATH) $(DEFS) $(FCFLAGS) $(MPEUFLAGS) - -.PHONY: clean tests install - -clean: - /bin/rm -f *.o ctest ftest $(LIB) mpi.mod config.log config.status - cd tests ; $(MAKE) clean - -tests: - cd tests; make - -install: lib - $(MKINSTALLDIRS) $(libdir) $(includedir) - $(INSTALL) lib$(MODULE).a -m 644 $(libdir) - $(INSTALL) mpi.h -m 644 $(includedir) - $(INSTALL) mpif.h -m 644 $(includedir) - - - diff --git a/cime/src/externals/mct/mpi-serial/Makefile.conf.in b/cime/src/externals/mct/mpi-serial/Makefile.conf.in deleted file mode 100644 index 9f4ec263480e..000000000000 --- a/cime/src/externals/mct/mpi-serial/Makefile.conf.in +++ /dev/null @@ -1,16 +0,0 @@ -CC = @CC@ -FC = @FC@ -FCFLAGS = @FCFLAGS@ -INCLUDE = -I. -INCFLAG = @INCLUDEFLAG@ -DEFS = @DEFS@ -CFLAGS = @CFLAGS@ -AR = @AR@ -RANLIB = @RANLIB@ -LIBS = @LIBS@ -CRULE = .c.o -F90RULE = .F90.o - -SHELL = /bin/sh - -MODULE = mpi-serial diff --git a/cime/src/externals/mct/mpi-serial/NOTES b/cime/src/externals/mct/mpi-serial/NOTES deleted file mode 100644 index 7387f3f8193f..000000000000 --- a/cime/src/externals/mct/mpi-serial/NOTES +++ /dev/null @@ -1,46 +0,0 @@ - -cart.c - new file, cleaned -collective.c - done -comm.c - done -copy.c - new file, cleaned -getcount.c - new file, cleaned -group.c - copied over git updates -handles.c - nothing to merge, svn updates OK -list.c - svn OK -mpi.c - merged git in -mpi.h - merged git but need to fix some types -fort.F90 - merged git in -mpif.master.h -> mpif.h NOTE: need to add types in type.h,c -Makefile - had to uncomment some things to get mpif.h to build -op.c - new file -pack.c - format more like git, has new code -probe.c - new file -recv.c - done -req.c - merged in git -send.c - merged in git - -time.c - no changes -type.c - new file -type_const.c - new file - - - -*** NOTES - -*** need to look at Request struct, add a type - so that send.c and recv.c can use distinct send and recv types - -*** need to add types in mpi.h and mpif.master.h to type.{c,h} - - -*** need to look at config and how it sets _RSIZE_ and _DSIZE_ - - previously: MCT's configure set env FORT_SIZE - choose mpif.h from mpif.$FORT_SIZE.h - - now: FORT_SIZE ignored - configures sets FSIZE_REAL and FSIZE_DPRECISION based on mpi-serial's configure (default 4/8) - does not need mpif.master.h template -> mpif.$FORT_SIZE.h - - so... did i clobber good value of mpif.h ? - diff --git a/cime/src/externals/mct/mpi-serial/README b/cime/src/externals/mct/mpi-serial/README deleted file mode 100644 index 20e377602bc3..000000000000 --- a/cime/src/externals/mct/mpi-serial/README +++ /dev/null @@ -1,102 +0,0 @@ - -###################################################################### - -mpi-serial - - Version 2.0 - Ray Loy (rloy@alcf.anl.gov) - John Yackovich - -###################################################################### - - -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. - -Version 2.0 adds support for user-defined MPI types and MPI_STATUS_IGNORE. - - ---------------- -Quick Start ---------------- -./configure -make -make tests - - ---------------- -Configuration ---------------- - -There is now a dedicated configure for mpi-serial. - -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 an option to the mpi-serial configure, e.g.: - - ./configure --enable-fort-real=16 --enable-fort-double=32 - - - --------------------------------- -Manual make targets --------------------------------- - -'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/cime/src/externals/mct/mpi-serial/aclocal.m4 b/cime/src/externals/mct/mpi-serial/aclocal.m4 deleted file mode 100644 index c5b6de47a45f..000000000000 --- a/cime/src/externals/mct/mpi-serial/aclocal.m4 +++ /dev/null @@ -1,15 +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/ax_fc_version.m4]) diff --git a/cime/src/externals/mct/mpi-serial/cart.c b/cime/src/externals/mct/mpi-serial/cart.c deleted file mode 100644 index a53ef4814c65..000000000000 --- a/cime/src/externals/mct/mpi-serial/cart.c +++ /dev/null @@ -1,128 +0,0 @@ -#include "mpiP.h" - -/* - * MPI_Cart_create - * - * create a new communicator, - */ - - -FC_FUNC( mpi_cart_create , MPI_CART_CREATE ) - ( int *comm_old, int *ndims, int *dims, int *periods, - int *reorder, int *comm_cart, int *ierr) -{ - *ierr = MPI_Cart_create( *comm_old, *ndims, dims, periods, *reorder, - comm_cart); -} - - -int MPI_Cart_create( MPI_Comm comm_old, int ndims, int *dims, int *periods, - int reorder, MPI_Comm *comm_cart) -{ - int i; - for (i = 0; i < ndims; i++) - if (dims[i] > 1) - { - printf("MPI_Cart_create: Greater dimension than no. of procs\n"); - abort(); - } - - MPI_Comm_dup(comm_old, comm_cart); - - return MPI_SUCCESS; -} - - -/* - * MPI_Cart_get - * - * Returns information about the cartesian organization - * of the communicator. - * - * Assuming the user gives right maxdims, the only possible - * dimensions are (1,1,..,1) for however many dimensions - */ - - -FC_FUNC( mpi_cart_get , MPI_CART_GET ) - (int * comm, int * maxdims, int * dims, - int * periods, int * coords, int * ierr) -{ - *ierr = MPI_Cart_get(*comm, *maxdims, dims, periods, coords); -} - - -int MPI_Cart_get(MPI_Comm comm, int maxdims, int *dims, - int *periods, int *coords) -{ - int i; - for (i=0;i 1) - { - printf("MPI_Dims_create: More nodes than procs specified.\n"); - abort(); - } - - for (i=0; isendlist=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); -} - -/* Intercomm_create - * - */ - -FC_FUNC(mpi_intercomm_create, MPI_INTERCOMM_CREATE)( - int * local_comm, int * local_leader, - int * peer_comm, int * remote_leader, - int * tag, int * newintercomm, int* ierr) -{ - *ierr = MPI_Intercomm_create(*local_comm, *local_leader, *peer_comm, - *remote_leader, *tag, newintercomm); -} - -int MPI_Intercomm_create(MPI_Comm local_comm, int local_leader, - MPI_Comm peer_comm, int remote_leader, - int tag, MPI_Comm *newintercomm) -{ - if (local_comm==MPI_COMM_NULL && peer_comm==MPI_COMM_NULL) - *newintercomm = MPI_COMM_NULL; - else - MPI_Comm_dup(MPI_COMM_WORLD, newintercomm); - - 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/cime/src/externals/mct/mpi-serial/config.h.in b/cime/src/externals/mct/mpi-serial/config.h.in deleted file mode 100644 index eed022557ad8..000000000000 --- a/cime/src/externals/mct/mpi-serial/config.h.in +++ /dev/null @@ -1,84 +0,0 @@ -/* config.h.in. Generated from configure.in by autoheader. */ - -/* User-set Fortran double size */ -#undef CONFIG_FORT_DOUBLE - -/* User-set Fortran real size */ -#undef CONFIG_FORT_REAL - -/* 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 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 - -/* Print extra debug info */ -#undef INFO - -/* Name of package */ -#undef PACKAGE - -/* 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 version of this package. */ -#undef PACKAGE_VERSION - -/* The size of `long', as computed by sizeof. */ -#undef SIZEOF_LONG - -/* Define to 1 if you have the ANSI C header files. */ -#undef STDC_HEADERS - -/* Perform tests on data copies internally instead of using MPI_Send */ -#undef TEST_INTERNAL - -/* Perform type checking during communications */ -#undef TYPE_CHECKING - -/* Version number of package */ -#undef VERSION diff --git a/cime/src/externals/mct/mpi-serial/configure b/cime/src/externals/mct/mpi-serial/configure deleted file mode 100755 index 5dd570dc928c..000000000000 --- a/cime/src/externals/mct/mpi-serial/configure +++ /dev/null @@ -1,5833 +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="mpi.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='LTLIBOBJS -LIBOBJS -INCLUDEFLAG -EGREP -GREP -CPP -FCLIBS -RANLIB -AR -ac_ct_FC -FCFLAGS -FC -OBJEXT -EXEEXT -ac_ct_CC -CPPFLAGS -LDFLAGS -CFLAGS -CC -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_test_internal -enable_info -enable_fort_real -enable_fort_double -enable_type_checking -' - ac_precious_vars='build_alias -host_alias -target_alias -CC -CFLAGS -LDFLAGS -LIBS -CPPFLAGS -FC -FCFLAGS -AR -RANLIB -CPP -INCLUDEFLAG' - - -# 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 - -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-test-internal Specify internal test as opposed to full suite test - - --enable-info Print extra debugging info - --enable-fort-real=SIZE Specify Fortran real size - --enable-fort-double=SIZE Specify Fortran double size - --enable-type-checking Perform type checking during communications - -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 - AR Archive Command - RANLIB Archive index update command - CPP C preprocessor - INCLUDEFLAG Fortran compiler flag for specifying module search path - -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_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_config_headers="$ac_config_headers config.h" - -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 - -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 - - -# ARCHIVE COMMAND SIMILAR ACROSS ALL PLATFORMS - -if test -z "$AR"; then - AR="ar cruv" -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 { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$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 { 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_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 - - -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 - "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 - - -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 long" >&5 -$as_echo_n "checking size of long... " >&6; } -if ${ac_cv_sizeof_long+:} false; then : - $as_echo_n "(cached) " >&6 -else - if ac_fn_c_compute_int "$LINENO" "(long int) (sizeof (long))" "ac_cv_sizeof_long" "$ac_includes_default"; then : - -else - if test "$ac_cv_type_long" = 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 (long) -See \`config.log' for more details" "$LINENO" 5; } - else - ac_cv_sizeof_long=0 - fi -fi - -fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_sizeof_long" >&5 -$as_echo "$ac_cv_sizeof_long" >&6; } - - - -cat >>confdefs.h <<_ACEOF -#define SIZEOF_LONG $ac_cv_sizeof_long -_ACEOF - - - -# Check whether --enable-test-internal was given. -if test "${enable_test_internal+set}" = set; then : - enableval=$enable_test_internal; -$as_echo "#define TEST_INTERNAL /**/" >>confdefs.h - -fi - - -# Check whether --enable-info was given. -if test "${enable_info+set}" = set; then : - enableval=$enable_info; -$as_echo "#define INFO /**/" >>confdefs.h - -fi - - -# Check whether --enable-fort-real was given. -if test "${enable_fort_real+set}" = set; then : - enableval=$enable_fort_real; -cat >>confdefs.h <<_ACEOF -#define CONFIG_FORT_REAL $enable_fort_real -_ACEOF - -fi - -# Check whether --enable-fort-double was given. -if test "${enable_fort_double+set}" = set; then : - enableval=$enable_fort_double; -cat >>confdefs.h <<_ACEOF -#define CONFIG_FORT_DOUBLE $enable_fort_double -_ACEOF - -fi - -# Check whether --enable-type-checking was given. -if test "${enable_type_checking+set}" = set; then : - enableval=$enable_type_checking; -$as_echo "#define TYPE_CHECKING /**/" >>confdefs.h - -fi - - - -# Determine flag for fortran module include path -# taken from the MCT configure - - -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 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:4480: \"$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 - - - -if echo $ac_fc_version_output | grep -i absoft >/dev/null 2>&1; then - echo "Fortran Compiler is Absoft" - if test -z "$INCLUDEFLAG"; then - INCLUDEFLAG="-p" - fi -elif echo $ac_fc_version_output | grep -i workshop >/dev/null 2>&1; then - echo "Fortran Compiler is Workshop" - if test -z "$INCLUDEFLAG"; then - INCLUDEFLAG="-M" - fi -elif echo $ac_fc_version_output | grep -i pgf >/dev/null 2>&1; then - echo "Fortran Compiler is Portland Group" - LIBS="$LIBS -pgf90libs" -elif echo $ac_fc_version_output | grep -i nag >/dev/null 2>&1; then - echo "Fortran Compiler is NAG" - CPRDEF="NAG" - if test -z "$FCFLAGS"; then - FCFLAGS="-mismatch" - fi -fi -# INCLUDE FLAG IF NOT ALREADY SET IS MOST LIKELY -I -if test -z "$INCLUDEFLAG"; then - INCLUDEFLAG="-I" -fi - - -ac_config_files="$ac_config_files Makefile.conf" - -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 -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 - - -# 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 - -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'" - - -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 $as_me, which was -generated by GNU Autoconf 2.68. 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="\\ -config.status -configured by $0, generated by GNU Autoconf 2.68, - with options \\"\$ac_cs_config\\" - -Copyright (C) 2010 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 - "config.h") CONFIG_HEADERS="$CONFIG_HEADERS config.h" ;; - "Makefile.conf") CONFIG_FILES="$CONFIG_FILES Makefile.conf" ;; - - *) 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 - diff --git a/cime/src/externals/mct/mpi-serial/configure.in b/cime/src/externals/mct/mpi-serial/configure.in deleted file mode 100644 index 8d3a750b18cb..000000000000 --- a/cime/src/externals/mct/mpi-serial/configure.in +++ /dev/null @@ -1,91 +0,0 @@ -dnl initialize autoconf -AC_INIT(mpi.h) -dnl specify config header file -AC_CONFIG_HEADER(config.h) -dnl find c compiler, and fort compiler -AC_PROG_CC -AC_PROG_FC - -# ARCHIVE COMMAND SIMILAR ACROSS ALL PLATFORMS -AC_ARG_VAR(AR,Archive Command) -if test -z "$AR"; then - AR="ar cruv" -fi - -# RANLIB -AC_ARG_VAR(RANLIB,Archive index update command) -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 - -dnl determine fortran name-mangling -dnl result functions end up in config.h -AC_FC_WRAPPERS - -dnl to determine type of integer needed for fortran -AC_CHECK_SIZEOF(long) - -dnl these are to specify the possible arguments to configure. -AC_ARG_ENABLE([test-internal], - [ --enable-test-internal Specify internal test as opposed to full suite test] - ,AC_DEFINE([TEST_INTERNAL],[], - [Perform tests on data copies internally instead of using MPI_Send])) - -AC_ARG_ENABLE([info],[ --enable-info Print extra debugging info], - AC_DEFINE([INFO],[],[Print extra debug info])) - -AC_ARG_ENABLE([fort-real], - [ --enable-fort-real=SIZE Specify Fortran real size], - AC_DEFINE_UNQUOTED([CONFIG_FORT_REAL],[$enable_fort_real], - [User-set Fortran real size])) -AC_ARG_ENABLE([fort-double], - [ --enable-fort-double=SIZE Specify Fortran double size], - AC_DEFINE_UNQUOTED([CONFIG_FORT_DOUBLE],[$enable_fort_double], - [User-set Fortran double size])) -AC_ARG_ENABLE([type-checking], - [ --enable-type-checking Perform type checking during communications], - AC_DEFINE([TYPE_CHECKING],[],[Perform type checking during communications])) - - -# Determine flag for fortran module include path -# taken from the MCT configure - -AC_ARG_VAR(INCLUDEFLAG,Fortran compiler flag for specifying module search path) -AC_LANG_PUSH(Fortran) -AX_FC_VERSION() -AC_LANG_POP(Fortran) - - -if echo $ac_fc_version_output | grep -i absoft >/dev/null 2>&1; then - echo "Fortran Compiler is Absoft" - if test -z "$INCLUDEFLAG"; then - INCLUDEFLAG="-p" - fi -elif echo $ac_fc_version_output | grep -i workshop >/dev/null 2>&1; then - echo "Fortran Compiler is Workshop" - if test -z "$INCLUDEFLAG"; then - INCLUDEFLAG="-M" - fi -elif echo $ac_fc_version_output | grep -i pgf >/dev/null 2>&1; then - echo "Fortran Compiler is Portland Group" - LIBS="$LIBS -pgf90libs" -elif echo $ac_fc_version_output | grep -i nag >/dev/null 2>&1; then - echo "Fortran Compiler is NAG" - CPRDEF="NAG" - if test -z "$FCFLAGS"; then - FCFLAGS="-mismatch" - fi -fi -# INCLUDE FLAG IF NOT ALREADY SET IS MOST LIKELY -I -if test -z "$INCLUDEFLAG"; then - INCLUDEFLAG="-I" -fi - - -AC_OUTPUT(Makefile.conf) diff --git a/cime/src/externals/mct/mpi-serial/copy.c b/cime/src/externals/mct/mpi-serial/copy.c deleted file mode 100644 index 66d4d07efcbe..000000000000 --- a/cime/src/externals/mct/mpi-serial/copy.c +++ /dev/null @@ -1,91 +0,0 @@ -/* - * copy.c - * - * memcpy "wrapper" to copy MPI Datatypes - * - */ - -#include "mpiP.h" -#include "type.h" -#include -#include -#include -#include - -//For type matching -#ifdef HAVE_CONFIG_H -#include -#endif - -/* - * rml: this prototype should be in mpiP.h, but mpiP.h does not currently - * include type.h so it can't just be added right now. Come back and - * fix this issue later... - */ - -extern int Pcopy_data2(void *source, int src_count, Datatype src_type, - void *dest, int dest_count, Datatype dest_type); - - -int copy_data2(void *source, int src_count, MPI_Datatype src_type, - void *dest, int dest_count, MPI_Datatype dest_type) -{ - Datatype src_ptr = *(Datatype*) mpi_handle_to_datatype(src_type); - Datatype dest_ptr = *(Datatype*) mpi_handle_to_datatype(dest_type); - - return Pcopy_data2(source, src_count, src_ptr, dest, dest_count, dest_ptr); -} - - - - -int Pcopy_data2(void *source, int src_count, Datatype src_type, - void *dest, int dest_count, Datatype dest_type) -{ - int i; - int soffset, doffset; - MPI_Aint src_extent, dest_extent; - - //commit checking here, since if any datatype is used in this function - // it is considered "communication". Should it be somewhere else? - - if (!(src_type->committed && dest_type->committed)) - { - fprintf(stderr, "Type not committed\n"); - exit(-1); - } - - // A receive of less elements than sent - // is valid, but the reverse is a violation - - if (src_type->count * src_count < dest_type->count * dest_count) - { - printf("copy_data: Trying to over-receive\n"); - exit(1); - } - - Type_extent(src_type, &src_extent); - Type_extent(dest_type, &dest_extent); - - for (i = 0; i < dest_count * dest_type->count; i++) - { - -#ifdef TYPE_CHECKING - if ( src_type->pairs[i % src_type->count].type != - dest_type->pairs[i % dest_type->count].type) - { - printf("copy_data: Types don't match.\n"); - exit(1); - } -#endif - - soffset = src_type->pairs[i % src_type->count].disp + ((i / src_type->count) * src_extent); - doffset = dest_type->pairs[i % dest_type->count].disp + ((i / dest_type->count) * dest_extent); - - memcpy(dest+doffset, source+soffset, Simpletype_length(dest_type->pairs[i % dest_type->count].type)); - } -} - - - - diff --git a/cime/src/externals/mct/mpi-serial/fort.F90 b/cime/src/externals/mct/mpi-serial/fort.F90 deleted file mode 100644 index f07e51855b44..000000000000 --- a/cime/src/externals/mct/mpi-serial/fort.F90 +++ /dev/null @@ -1,62 +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 - - -! -! mpi_get_fort_pointers -! -! In Fortran, various values e.g. MPI_STATUS_IGNORE, MPI_STATUSES_IGNORE, -! and MPI_IN_PLACE are in a COMMON block and not accessible by C code. -! This routine calls back a C routine to store the addresses. -! - - subroutine mpi_get_fort_pointers - implicit none - include "mpif.h" - - call mpi_save_fort_pointers(MPI_STATUS_IGNORE,MPI_STATUSES_IGNORE,MPI_IN_PLACE) - - end subroutine mpi_get_fort_pointers - diff --git a/cime/src/externals/mct/mpi-serial/getcount.c b/cime/src/externals/mct/mpi-serial/getcount.c deleted file mode 100644 index 1313a7cca3d5..000000000000 --- a/cime/src/externals/mct/mpi-serial/getcount.c +++ /dev/null @@ -1,40 +0,0 @@ -/* getcount.c - * - * 07/2007 JCY - * Functions for count information regarding MPI_Status - */ - -#include "type.h" -#include "mpiP.h" - - -FC_FUNC( mpi_get_count , MPI_GET_COUNT ) - (int *status, int *datatype, int *count, int *ierr) -{ - *ierr = MPI_Get_count((MPI_Status *)status, *datatype, count); -} - - -int MPI_Get_count(MPI_Status *status, MPI_Datatype datatype, int *count) -{ - *count = status->get_count; -} - - -/********/ - - -FC_FUNC( mpi_get_elements , MPI_GET_ELEMENTS ) - (MPI_Status *status, int *datatype, int *count, int *ierr) -{ - *ierr = MPI_Get_elements(status, *datatype, count); -} - - -int MPI_Get_elements(MPI_Status *status, MPI_Datatype datatype, int *count) -{ - Datatype dt_ptr = *(Datatype*)mpi_handle_to_datatype(datatype); - *count = status->get_count * dt_ptr->count; -} - - diff --git a/cime/src/externals/mct/mpi-serial/group.c b/cime/src/externals/mct/mpi-serial/group.c deleted file mode 100644 index cec4879f4b62..000000000000 --- a/cime/src/externals/mct/mpi-serial/group.c +++ /dev/null @@ -1,264 +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); -} - - -/*********/ - - -/* MPI_Group_range_incl - * Include a strided range of ranks in a group. For one processor, if - * "0" is included in any of these ranges, it can only be the first rank. - * Thus, if rank 0 is specified, include it, otherwise use GROUP_NULL - */ - - -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; - Datatype* type; - - } 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/cime/src/externals/mct/mpi-serial/info.c b/cime/src/externals/mct/mpi-serial/info.c deleted file mode 100644 index 32593cb7937f..000000000000 --- a/cime/src/externals/mct/mpi-serial/info.c +++ /dev/null @@ -1,53 +0,0 @@ - -#include "mpiP.h" - - - -/***/ - - -FC_FUNC( mpi_info_create , MPI_INFO_CREATE ) (int *info, int *ierror) -{ - *ierror=MPI_Info_create(info); -} - - - -int MPI_Info_create(MPI_Info *info) -{ - /* For now, we aren't storing anything, so don't bother with a real handle */ - *info=0; - return(MPI_SUCCESS); -} - - -/***/ - - -FC_FUNC( mpi_info_set , MPI_INFO_SET ) (int *info, char *key, char *value, int *ierror) -{ - *ierror=MPI_Info_set(*info, key, value); -} - - -int MPI_Info_set(MPI_Info info, char *key, char *value) -{ - /* for now, don't bother storing anything */ - return(MPI_SUCCESS); -} - -/***/ - -FC_FUNC( mpi_info_free , MPI_INFO_FREE ) (int *info, int *ierror) -{ - *ierror=MPI_Info_free(info); -} - - - -int MPI_Info_free(MPI_Info *info) -{ - /* For now, we aren't storing anything, so don't bother with a real handle */ - *info=0; - return(MPI_SUCCESS); -} diff --git a/cime/src/externals/mct/mpi-serial/list.c b/cime/src/externals/mct/mpi-serial/list.c deleted file mode 100644 index 90ef049b75f1..000000000000 --- a/cime/src/externals/mct/mpi-serial/list.c +++ /dev/null @@ -1,705 +0,0 @@ -/* - * (C) 2000 UNIVERSITY OF CHICAGO - * See COPYRIGHT in top-level directory. - */ - - - -#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 ",(long 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 ",(long 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/cime/src/externals/mct/mpi-serial/list.h b/cime/src/externals/mct/mpi-serial/list.h deleted file mode 100644 index 3d533fef6133..000000000000 --- a/cime/src/externals/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/cime/src/externals/mct/mpi-serial/listP.h b/cime/src/externals/mct/mpi-serial/listP.h deleted file mode 100644 index 2fa9e8596127..000000000000 --- a/cime/src/externals/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/cime/src/externals/mct/mpi-serial/listops.h b/cime/src/externals/mct/mpi-serial/listops.h deleted file mode 100644 index fa0ef725751a..000000000000 --- a/cime/src/externals/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/cime/src/externals/mct/mpi-serial/m4/README b/cime/src/externals/mct/mpi-serial/m4/README deleted file mode 100644 index b748178e2c79..000000000000 --- a/cime/src/externals/mct/mpi-serial/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/cime/src/externals/mct/mpi-serial/m4/ax_fc_version.m4 b/cime/src/externals/mct/mpi-serial/m4/ax_fc_version.m4 deleted file mode 100644 index c7e2eaec3c70..000000000000 --- a/cime/src/externals/mct/mpi-serial/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/cime/src/externals/mct/mpi-serial/mpi.c b/cime/src/externals/mct/mpi-serial/mpi.c deleted file mode 100644 index d6f58adbce19..000000000000 --- a/cime/src/externals/mct/mpi-serial/mpi.c +++ /dev/null @@ -1,364 +0,0 @@ - - -#include "mpiP.h" -#include "mpi.h" -#include "type.h" - -/****************************************************************************/ - -static int initialized=0; - - -/* Store fortran pointer values here */ - -static int *f_MPI_STATUS_IGNORE; -static int *f_MPI_STATUSES_IGNORE; -static int *f_MPI_IN_PLACE; - -static char *mpi_version_string="mpi-serial 2.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 consistent " \ - "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 consistent " \ - "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))) != Simpletype_length( \ - (*(Datatype*)mpi_handle_to_datatype(*f_##name))->pairs[0].type) ) \ - { 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 inconsistent 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(); - } - - // call this to have the fortran routine call back and save - // values for f_MPI_STATUS_IGNORE and f_MPI_STATUSES_IGNORE - FC_FUNC(mpi_get_fort_pointers,MPI_GET_FORT_POINTERS)(); // the () are important - - 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); -} - - -/**********/ - - -void FC_FUNC( mpi_get_library_version, MPI_GET_LIBRARY_VERSION) (char *version, int *resultlen, int *ierror) -{ - MPI_Get_library_version(version,resultlen); - - // Sanity check before the memset() - if ( (*resultlen) > (MPI_MAX_LIBRARY_VERSION_STRING-1) ) - abort(); - - memset(version+(*resultlen),' ',MPI_MAX_LIBRARY_VERSION_STRING-(*resultlen)); - - *ierror=MPI_SUCCESS; -} - - - -int MPI_Get_library_version(char *version, int *resultlen) -{ - - strncpy(version,mpi_version_string,MPI_MAX_LIBRARY_VERSION_STRING); - // Make sure it is null terminated - version[MPI_MAX_LIBRARY_VERSION_STRING-1]='\0'; - *resultlen=strlen(version); - - return(MPI_SUCCESS); -} - - - -/**********/ - - -void FC_FUNC( mpi_save_fort_pointers, MPI_SAVE_FORT_POINTERS ) (int *status, int *statuses, int *in_place) -{ - f_MPI_STATUS_IGNORE=status; - f_MPI_STATUSES_IGNORE=statuses; - f_MPI_IN_PLACE=in_place; -} - - - -MPI_Status *mpi_c_status(int *status) -{ - if (status==f_MPI_STATUS_IGNORE) - return(MPI_STATUS_IGNORE); - - return((MPI_Status *)status); -} - - -MPI_Status *mpi_c_statuses(int *statuses) -{ - if (statuses==f_MPI_STATUSES_IGNORE) - return(MPI_STATUSES_IGNORE); - - return((MPI_Status *)statuses); -} - - -void *mpi_c_in_place(void *buffer) -{ - if (buffer==(void *)f_MPI_IN_PLACE) - return(MPI_IN_PLACE); - - return(buffer); -} diff --git a/cime/src/externals/mct/mpi-serial/mpi.h b/cime/src/externals/mct/mpi-serial/mpi.h deleted file mode 100644 index 529b57b853ab..000000000000 --- a/cime/src/externals/mct/mpi-serial/mpi.h +++ /dev/null @@ -1,423 +0,0 @@ - -#ifndef _MPI_H_ -#define _MPI_H_ - -#define MPI_MAX_LIBRARY_VERSION_STRING (80) - -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) -#define MPI_IN_PLACE (void *)(-1) -typedef int MPI_Datatype; - - -/* The type's value is now a handle */ - -#define MPI_DATATYPE_NULL (0) - -//C types -#define MPI_CHAR (-1) -#define MPI_SHORT (-2) -#define MPI_INT (-3) -#define MPI_LONG (-4) -#define MPI_UNSIGNED_CHAR (-5) -#define MPI_UNSIGNED_SHORT (-6) -#define MPI_UNSIGNED (-7) -#define MPI_UNSIGNED_LONG (-8) -#define MPI_FLOAT (-9) -#define MPI_DOUBLE (-10) -#define MPI_LONG_DOUBLE (-11) - -//Cross-language -#define MPI_BYTE (-12) -#define MPI_PACKED (-13) -#define MPI_LB (-14) -#define MPI_UB (-15) - -// Fortran types -#define MPI_INTEGER (-16) // RML: why not (MPI_INT) -#define MPI_REAL (-17) // RML: why not (MPI_FLOAT) -#define MPI_DOUBLE_PRECISION (-18) // RML: why not (MPI_DOUBLE) - -#define MPI_COMPLEX (-19) -#define MPI_DOUBLE_COMPLEX (-20) -#define MPI_LOGICAL (-21) -#define MPI_CHARACTER (-22) -#define MPI_2REAL (-23) -#define MPI_2DOUBLE_PRECISION (-24) -#define MPI_2INTEGER (-25) - -//Reduction function types - -#define MPI_FLOAT_INT (-26) -#define MPI_DOUBLE_INT (-27) -#define MPI_LONG_INT (-28) -#define MPI_2INT (-29) -#define MPI_SHORT_INT (-30) -#define MPI_LONG_DOUBLE_INT (-31) - - -/* Fortran size-specific types */ - -#define MPI_INTEGER1 (-32) -#define MPI_INTEGER2 (-33) -#define MPI_INTEGER4 (-34) -#define MPI_INTEGER8 (-35) -#define MPI_INTEGER16 (-36) - -#define MPI_REAL4 (-37) -#define MPI_REAL8 (-38) -#define MPI_REAL16 (-39) - -#define MPI_COMPLEX8 (-40) -#define MPI_COMPLEX16 (-41) -#define MPI_COMPLEX32 (-42) - -/* Some more types */ - -#define MPI_LONG_LONG_INT (-43) -#define MPI_LONG_LONG MPI_LONG_LONG_INT -#define MPI_UNSIGNED_LONG_LONG (-44) - -#define MPI_OFFSET (-45) - - -/* - * 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) */ - int get_count; /* Number specified for send */ - -} MPI_Status; - - -#define MPI_STATUS_IGNORE ((MPI_Status *)0) -#define MPI_STATUSES_IGNORE ((MPI_Status *)0) - - - -/* - * 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) - - - -#define MPI_STATUS_SIZE (sizeof(MPI_Status) / sizeof(int)) - - -/* NOTE: the C type MPI_Offset is NOT the same as MPI datatype MPI_OFFSET */ -typedef long long int MPI_Offset; - - -/* info - */ - -typedef int MPI_Info; /* handle */ - -#define MPI_INFO_NULL (0) - - - -/********************************************************** - * - * Note: if you need to regenerate the prototypes below, - * you can use 'protify.awk' and paste the output here. - * - */ - - -extern int MPI_Intercomm_create(MPI_Comm local_comm, int local_leader, - MPI_Comm peer_comm, int remote_leader, - int tag, MPI_Comm *newintercomm); - -extern int MPI_Cart_create(MPI_Comm comm_old, int ndims, int *dims, - int *periods, int reorder, MPI_Comm *comm_cart); -extern int MPI_Cart_get(MPI_Comm comm, int maxdims, int *dims, - int *periods, int *coords); -extern int MPI_Cart_coords(MPI_Comm comm, int rank, int maxdims, - int *coords); -extern int MPI_Dims_create(int nnodes, int ndims, int *dims); - -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_Reduce_scatter(void* sendbuf, void* recvbuf, int *recvcounts, - MPI_Datatype datatype, MPI_Op op, 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_Alltoallw(void *sendbuf, int *sendcounts, - int *sdispls, MPI_Datatype *sendtypes, - void *recvbuf, int *recvcounts, - int *rdispls, MPI_Datatype *recvtypes, - 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_Op_free(MPI_Op *op); -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_Info_create(MPI_Info *info); -extern int MPI_Info_set(MPI_Info info, char *key, char *value); - -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_Testany(int count, MPI_Request *array_of_requests, - int *index, int *flag, MPI_Status *status); -extern int MPI_Waitany(int count, MPI_Request *array_of_requests, - int *index, MPI_Status *status); -extern int MPI_Testall(int count, MPI_Request *array_of_requests, - int *flag, MPI_Status *array_of_statuses); -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_Testsome(int incount, MPI_Request *array_of_requests, - int *outcount, int *array_of_indices, - MPI_Status *array_of_statuses); -extern int MPI_Waitsome(int incount, MPI_Request *array_of_requests, - int *outcount, int *array_of_indices, - MPI_Status *array_of_statuses); -extern int MPI_Request_free(MPI_Request * req); -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 int MPI_Probe(int source, int tag, MPI_Comm comm, MPI_Status *status); -extern int MPI_Iprobe(int source, int tag, MPI_Comm comm, - int *flag, MPI_Status *status); - -extern int MPI_Pack_size(int incount, MPI_Datatype type, MPI_Comm comm, MPI_Aint * size); - -/* new type functions */ -extern int MPI_Get_count(MPI_Status *status, MPI_Datatype datatype, int *count); -extern int MPI_Get_elements(MPI_Status *status, MPI_Datatype datatype, int *count); -extern int MPI_Type_contiguous(int count, MPI_Datatype oldtype, MPI_Datatype *newtype); - -extern int MPI_Type_vector(int count, int blocklen, int stride, MPI_Datatype oldtype, - MPI_Datatype *newtype); - -extern int MPI_Type_hvector(int count, int blocklen, MPI_Aint stride, - MPI_Datatype oldtype, MPI_Datatype *newtype); - -extern int MPI_Type_indexed(int count, int *blocklens, int *displacements, - MPI_Datatype oldtype, MPI_Datatype *newtype); - -extern int MPI_Type_create_indexed_block(int count, int blocklen, int *displacements, - MPI_Datatype oldtype, MPI_Datatype *newtype); -extern int MPI_Type_hindexed(int count, int *blocklens, MPI_Aint *displacements, - MPI_Datatype oldtype, MPI_Datatype *newtype); -extern int MPI_Type_size(MPI_Datatype type, int * size); -extern int MPI_Type_struct(int count, int *blocklens, MPI_Aint *displacements, - MPI_Datatype *oldtypes, MPI_Datatype *newtype); -extern int MPI_Type_dup(MPI_Datatype oldtype, MPI_Datatype *newtype); - -extern int MPI_Type_extent(MPI_Datatype datatype, MPI_Aint * extent); -extern int MPI_Type_commit(MPI_Datatype * datatype); -extern int MPI_Type_free(MPI_Datatype * datatype); -extern int MPI_Type_lb(MPI_Datatype datatype, MPI_Aint * lb); -extern int MPI_Type_ub(MPI_Datatype datatype, MPI_Aint * ub); - -extern double MPI_Wtime(void); - -#endif diff --git a/cime/src/externals/mct/mpi-serial/mpiP.h b/cime/src/externals/mct/mpi-serial/mpiP.h deleted file mode 100644 index 290d3cf9f4db..000000000000 --- a/cime/src/externals/mct/mpi-serial/mpiP.h +++ /dev/null @@ -1,128 +0,0 @@ -#ifndef _MPIP_H -#define _MPIP_H - -/* - * Private .h file for MPI - */ - - -#include -#include -#include -#include - -#include "listops.h" -#include "mpi.h" - -/* Autoconf Fortran name mangling - * - * config.h defines F77_FUNC and F77_FUNC_ - * Since we are generally using FC_FUNC, and - * all of our functions will ONLY use F77_FUNC_ - * (with the underscore, define FC_FUNC as the - * aforementioned. - * - * If config.h is not present, default to the old - * approach. - */ - -#ifdef HAVE_CONFIG_H -#include -/* config.h should define FC_FUNC */ -#else - -/* - * Fortran name mangling - * - * the configure.ac specifies these - * - * cpp does not have the ability to change the case - * of the argument, so the invocation of the macro - * has to be give both e.g. FC_FUNC(hello,HELLO) - * and maps to "hello_", "hello", and "HELLO" repectively. - * - * IMPORTANT NOTE: - * In the case of FORTRAN_GNUF2C (e.g. g95), the rule is this: - * name does not contain an underscore -> append *one* underscore - * name contains an underscore -> append *two* underscore - * Since all the mpi-serial names exported to fortran start with "mpi_", - * we only support the latter. - * - * Note: FORTRANUNDERSCORE is needed by ccsm - * - */ - - -#if defined(FORTRAN_UNDERSCORE_) || defined(FORTRANUNDERSCORE) -#define FC_FUNC(lower,upper) lower##_ -#elif defined(FORTRAN_GNUF2C) -#define FC_FUNC(lower,upper) lower##__ -#elif defined(FORTRAN_SAME) -#define FC_FUNC(lower,upper) lower -#elif defined(FORTRAN_CAPS_) -#define FC_FUNC(lower,upper) upper -#else -#error "Unrecognized Fortran-mangle type" -/* set to something reasonable to avoid cascade of cc errors */ -#define FC_FUNC(lower,upper) lower##_ -#endif -#endif /* HAVE_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; - - -/****************************************************************************/ - -/* copy functions */ -extern int copy_data2(void * source, int src_count, MPI_Datatype src_type, - void * dest, int dest_count, MPI_Datatype dest_type); - -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); - -extern void FC_FUNC(mpi_get_fort_pointers,MPI_GET_FORT_POINTERS)(void); - -extern MPI_Status *mpi_c_status(int *status); -extern MPI_Status *mpi_c_statuses(int *statuses); -extern void *mpi_c_in_place(void *buffer); - - -#endif /* _MPIP_H */ diff --git a/cime/src/externals/mct/mpi-serial/mpif.F90 b/cime/src/externals/mct/mpi-serial/mpif.F90 deleted file mode 100644 index 369b71459dcb..000000000000 --- a/cime/src/externals/mct/mpi-serial/mpif.F90 +++ /dev/null @@ -1,12 +0,0 @@ -#ifdef HAVE_CONFIG_H -#include -#endif - -Module mpi -implicit none -! MPI_ADDRESS_KIND: need an 8-byte integer. - INTEGER, PARAMETER, PUBLIC :: MPI_ADDRESS_KIND=selected_int_kind(13) - - - include "mpif.h" -end Module mpi diff --git a/cime/src/externals/mct/mpi-serial/mpif.h b/cime/src/externals/mct/mpi-serial/mpif.h deleted file mode 100644 index b8071791e4bd..000000000000 --- a/cime/src/externals/mct/mpi-serial/mpif.h +++ /dev/null @@ -1,334 +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=4) - - INTEGER MPI_SOURCE, MPI_TAG, MPI_ERROR - PARAMETER(MPI_SOURCE=1, MPI_TAG=2, MPI_ERROR=3) - ! There is a 4th value only used internally - - INTEGER MPI_STATUS_IGNORE(MPI_STATUS_SIZE) - INTEGER MPI_STATUSES_IGNORE(MPI_STATUS_SIZE,1) - COMMON /MPISERIAL/ MPI_STATUS_IGNORE - COMMON /MPISERIAL/ MPI_STATUSES_IGNORE - -! -! MPI_IN_PLACE -! - - INTEGER MPI_IN_PLACE - COMMON /MPISERIAL/ MPI_IN_PLACE - - SAVE /MPISERIAL/ ! Technically needed in case goes out of scope - - -! -! MPI_Datatype values -! -! New datatype values -! Type constants represent integer handles, matching up to the index of the -! type array equal to the absolute value of the constant plus one. For -! example, MPI_BYTE=-12, corresponding to type index 11. -! (Array in type_const.c) -! - - - INTEGER MPI_DATATYPE_NULL - PARAMETER (MPI_DATATYPE_NULL=0) - - INTEGER MPI_BYTE - PARAMETER (MPI_BYTE=-12) - - INTEGER MPI_PACKED - PARAMETER (MPI_PACKED=-13) - - INTEGER MPI_LB - PARAMETER (MPI_LB=-14) - - INTEGER MPI_UB - PARAMETER (MPI_UB=-15) - - INTEGER MPI_INTEGER - PARAMETER (MPI_INTEGER=-16) - - INTEGER MPI_REAL - PARAMETER (MPI_REAL=-17) - - INTEGER MPI_DOUBLE_PRECISION - PARAMETER (MPI_DOUBLE_PRECISION=-18) - - INTEGER MPI_COMPLEX - PARAMETER (MPI_COMPLEX=-19) - - INTEGER MPI_DOUBLE_COMPLEX - PARAMETER (MPI_DOUBLE_COMPLEX=-20) - - INTEGER MPI_LOGICAL - PARAMETER (MPI_LOGICAL=-21) - - INTEGER MPI_CHARACTER - PARAMETER (MPI_CHARACTER=-22) - - integer MPI_2REAL - parameter (MPI_2REAL= -23) - - integer MPI_2DOUBLE_PRECISION - parameter (MPI_2DOUBLE_PRECISION= -24) - - integer MPI_2INTEGER - parameter (MPI_2INTEGER= -25) - - -! -! Size-specific types -! - - INTEGER MPI_INTEGER1 - PARAMETER (MPI_INTEGER1= -32 ) - - INTEGER MPI_INTEGER2 - PARAMETER (MPI_INTEGER2= -33 ) - - INTEGER MPI_INTEGER4 - PARAMETER (MPI_INTEGER4= -34 ) - - INTEGER MPI_INTEGER8 - PARAMETER (MPI_INTEGER8= -35 ) - - INTEGER MPI_INTEGER16 - PARAMETER (MPI_INTEGER16= -36 ) - - - INTEGER MPI_REAL4 - PARAMETER (MPI_REAL4= -37 ) - - INTEGER MPI_REAL8 - PARAMETER (MPI_REAL8= -38 ) - - INTEGER MPI_REAL16 - PARAMETER (MPI_REAL16= -39 ) - - - integer MPI_COMPLEX8 - parameter (MPI_COMPLEX8= -40 ) - - integer MPI_COMPLEX16 - parameter (MPI_COMPLEX16= -41 ) - - integer MPI_COMPLEX32 - parameter (MPI_COMPLEX32= -42 ) - - integer MPI_LONG_LONG_INT - parameter (MPI_LONG_LONG_INT= -43) - - integer MPI_LONG_LONG - parameter (MPI_LONG_LONG= MPI_LONG_LONG_INT) - - integer MPI_UNSIGNED_LONG_LONG - parameter (MPI_UNSIGNED_LONG_LONG= -44) - - integer MPI_OFFSET - parameter (MPI_OFFSET= -45) - -! -! 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_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) - - -! -! Info -! - - INTEGER MPI_INFO_NULL - PARAMETER (MPI_INFO_NULL=0) - - -! -! Library version string (must match C value) -! - - INTEGER MPI_MAX_LIBRARY_VERSION_STRING - PARAMETER (MPI_MAX_LIBRARY_VERSION_STRING=80) - - diff --git a/cime/src/externals/mct/mpi-serial/op.c b/cime/src/externals/mct/mpi-serial/op.c deleted file mode 100644 index 64efbc1004a1..000000000000 --- a/cime/src/externals/mct/mpi-serial/op.c +++ /dev/null @@ -1,28 +0,0 @@ -#include "mpi.h" -#include "mpiP.h" -/* Because operations based on one processor are essentially no operation, - * all MPI_Ops are handled as null ops. Therefore, returning 0 (OP_NULL) - * suffices here. - */ - -FC_FUNC(mpi_op_create, MPI_OP_CREATE)(MPI_User_function *func, int * commute, int * op, int * ierr) -{ - *ierr = MPI_Op_create(func, *commute, op); -} - -int MPI_Op_create(MPI_User_function *function, int commute, MPI_Op *op) -{ - *op = 0; - return MPI_SUCCESS; -} - -FC_FUNC(mpi_op_free, MPI_OP_FREE)(int * op, int * ierr) -{ - *ierr = MPI_Op_free(op); -} - -int MPI_Op_free(MPI_Op * op) -{ - return MPI_SUCCESS; -} - diff --git a/cime/src/externals/mct/mpi-serial/pack.c b/cime/src/externals/mct/mpi-serial/pack.c deleted file mode 100644 index 83ff87998564..000000000000 --- a/cime/src/externals/mct/mpi-serial/pack.c +++ /dev/null @@ -1,145 +0,0 @@ -#include -#include -#include -#include "mpiP.h" -#include "type.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 ret; - - Datatype type_ptr = *(Datatype*) mpi_handle_to_datatype(datatype); - Comm* comm_ptr = mpi_handle_to_ptr(comm); - - ret = Pack(inbuf, incount, type_ptr, outbuf, outsize, position, comm_ptr); - - return ret; -} - - - -int Pack(void *inbuf, int incount, Datatype type, - void *outbuf, int outsize, int *position, Comm * comm) -{ - int i, j; - MPI_Aint extent; - //check that buffer is large enough - Type_extent(type, &extent); - for (i = 0; i < incount; i++) - { - for (j = 0; j < type->count; j++) - { - if ((*position) + Simpletype_length(type->pairs[j].type) > outsize) - { - printf("MPI_Pack: data exceeds buffer size\n"); - exit(1); - } - memcpy(((char*) outbuf)+(*position), inbuf+type->pairs[j].disp + (extent*i), - Simpletype_length(type->pairs[j].type)); - *position += Simpletype_length(type->pairs[j].type); - } - } -} - -FC_FUNC( mpi_pack_size, MPI_PACK_SIZE )(int * incount, int * datatype, - int * comm, long * size, int *ierr) -{ - *ierr = MPI_Pack_size(*incount, *datatype, *comm, size); -} - -int MPI_Pack_size(int incount, MPI_Datatype datatype, - MPI_Comm comm, MPI_Aint * size) -{ - int ret; - Datatype type_ptr = *(Datatype*) mpi_handle_to_datatype(datatype); - Comm * comm_ptr = mpi_handle_to_ptr(comm); - - ret = Pack_size(incount, type_ptr, comm_ptr, size); - - return ret; -} - - -int Pack_size(int incount, Datatype datatype, - Comm * comm, MPI_Aint * size) -{ - int i; - *size = 0; - //sum up all sizes - for(i = 0; i < datatype->count; i++) - { - *size += Simpletype_length(datatype->pairs[i].type); - } - *size *= incount; - printf("Size = %d\n", *size); -} - - -/* - * - */ - - -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 type, MPI_Comm comm) -{ - int ret; - Datatype type_ptr = *(Datatype*) mpi_handle_to_datatype(type); - Comm * comm_ptr = mpi_handle_to_ptr(comm); - - ret = Unpack(inbuf, insize, position, outbuf, outcount, type_ptr, comm_ptr); - - return ret; -} - -int Unpack(void * inbuf, int insize, int * position, void *outbuf, - int outcount, Datatype type, Comm* comm) -{ - int i, j; - MPI_Aint extent; - - Type_extent(type, &extent); - - for (i = 0; i < outcount; i++) - { - for (j = 0; j < type->count; j++) - { - if ((*position) + Simpletype_length(type->pairs[j].type) > insize) - { - printf("MPI_Unpack: Data exceeds buffer size\n"); - exit(1); - } - memcpy(outbuf+type->pairs[j].disp + (extent*i), ((char*) inbuf)+(*position) , - Simpletype_length(type->pairs[j].type)); - *position += Simpletype_length(type->pairs[j].type); - } - } -} - - diff --git a/cime/src/externals/mct/mpi-serial/probe.c b/cime/src/externals/mct/mpi-serial/probe.c deleted file mode 100644 index 29c3c52e07b0..000000000000 --- a/cime/src/externals/mct/mpi-serial/probe.c +++ /dev/null @@ -1,88 +0,0 @@ -//probe.c -#include "mpiP.h" - -static int mpi_match_send(void *r, void *tag) -{ - return( *((int *)tag) == MPI_ANY_TAG || - *((int *)tag) == ((Req *)r)->tag ); -} - -FC_FUNC(mpi_iprobe, MPI_IPROBE)(int * source, int * tag, int * comm, - int * flag, int *status, int * ierr) -{ - *ierr = MPI_Iprobe(*source, *tag, *comm, flag, mpi_c_status(status)); -} - -/* Iprobe - * Search for existing message, return status about it - */ - -int MPI_Iprobe(int source, int tag, MPI_Comm comm, int *flag, - MPI_Status *status) - -{ - pListitem match; - Comm *mycomm; - Req *sreq; - - mycomm=mpi_handle_to_ptr(comm); /* mycomm=(Comm *)comm; */ - -#ifdef INFO - fflush(stdout); - fprintf(stderr,"MPI_IProbev: Comm=%d tag=%d count=%d type=%d\n", - mycomm->num,tag,count,datatype); -#endif - - - if (source!=0 && source!=MPI_ANY_SOURCE) - { - fprintf(stderr,"MPI_Irecv: bad source %d\n",source); - abort(); - } - - match=AP_list_search_func(mycomm->sendlist,mpi_match_send,&tag); - - *flag= (match==NULL ? 0:1 ); - - if (*flag) - { - sreq=(Req *)AP_listitem_data(match); - - if (status!=MPI_STATUS_IGNORE) - { - status->MPI_SOURCE=0 ; - status->MPI_TAG= sreq->tag; - } - } - - return(MPI_SUCCESS); -} - - -//probe: wait for message, and return status -// (either message will immediately be available, or deadlock. - -FC_FUNC(mpi_probe,MPI_PROBE)(int *source, int *tag, int *comm, int *status, - int *ierr) -{ - *ierr=MPI_Probe(*source,*tag,*comm,mpi_c_status(status)); -} - - - -int MPI_Probe(int source, int tag, MPI_Comm comm, MPI_Status *status) -{ - - int flag; - - MPI_Iprobe(source,tag,comm,&flag,status); - - if (!flag) - { - fprintf(stderr,"MPI_Probe: no existing match, deadlock\n"); - abort(); - } - - return(MPI_SUCCESS); -} - diff --git a/cime/src/externals/mct/mpi-serial/protify.awk b/cime/src/externals/mct/mpi-serial/protify.awk deleted file mode 100755 index 483fc2ec0d1e..000000000000 --- a/cime/src/externals/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/cime/src/externals/mct/mpi-serial/recv.c b/cime/src/externals/mct/mpi-serial/recv.c deleted file mode 100644 index d70344a37651..000000000000 --- a/cime/src/externals/mct/mpi-serial/recv.c +++ /dev/null @@ -1,164 +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); - copy_data2(sreq->buf, count, datatype, 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_c_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); - - if (status!=MPI_STATUS_IGNORE) - status->get_count = count; // rml: shouldn't this depend on send? - - 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/cime/src/externals/mct/mpi-serial/req.c b/cime/src/externals/mct/mpi-serial/req.c deleted file mode 100644 index 5cfa827fe5e6..000000000000 --- a/cime/src/externals/mct/mpi-serial/req.c +++ /dev/null @@ -1,301 +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_c_status(status)); -} - - - -int MPI_Test(MPI_Request *request, int *flag, MPI_Status *status) -{ - Req *req; - - if (*request==MPI_REQUEST_NULL) - { - if (status!=MPI_STATUS_IGNORE) - { - 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) - { - if (status!=MPI_STATUS_IGNORE) - { - 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_c_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_c_status(status)); -} - - - -int MPI_Waitany(int count, MPI_Request *array_of_requests, - int *index, MPI_Status *status) -{ - int flag; - - MPI_Testany(count, array_of_requests, index, &flag, status); - - if (!flag) - { - /* none are completed */ - - fprintf(stderr,"MPI_Waitany: no requests complete, deadlock\n"); - abort(); - - } - - return(MPI_SUCCESS); -} - -/* MPI_Testany: looks for any message matching an element - * in request array and returns its status. - * flag=0 means no match was found. - */ - -FC_FUNC(mpi_testany, MPI_TESTANY) - (int * count, int * array_of_requests, - int * index, int * flag, int *status, int * ierr) -{ - *ierr = MPI_Testany(*count, array_of_requests, index, - flag, mpi_c_status(status)); -} - -int MPI_Testany(int count, MPI_Request *array_of_requests, - int *index, int *flag, MPI_Status *status) -{ - int i; - - 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); - copy_data2(buf, count, datatype, rreq->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_c_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/cime/src/externals/mct/mpi-serial/tests/.gitignore b/cime/src/externals/mct/mpi-serial/tests/.gitignore deleted file mode 100644 index 2037e022f76b..000000000000 --- a/cime/src/externals/mct/mpi-serial/tests/.gitignore +++ /dev/null @@ -1,4 +0,0 @@ -ctest -ctest2 -ftest -ftest2 diff --git a/cime/src/externals/mct/mpi-serial/tests/Makefile b/cime/src/externals/mct/mpi-serial/tests/Makefile deleted file mode 100644 index c03c1fe9d962..000000000000 --- a/cime/src/externals/mct/mpi-serial/tests/Makefile +++ /dev/null @@ -1,41 +0,0 @@ -############################### - -# -# test programs Makefile -# - -# Parent dir Makefile.conf has all necessary vars -include ../Makefile.conf - -TINC = -I.. -LDFLAGS = -L.. -MYLIBS = $(LIBS) -l$(MODULE) -MYF90FLAGS=$(INCPATH) $(DEFS) $(FCFLAGS) $(MPEUFLAGS) - -runtests: all - ./ctest - @echo - ./ftest - @echo - -all: ctest ftest - -ctest: ctest.c - $(CC) $(DEFS) $(TINC) $(ALLCFLAGS) -o $@ ctest.c $(LDFLAGS) $(MYLIBS) - -ftest: ftest.F90 - $(FC) $(DEFS) $(TINC) $(MYF90FLAGS) -o $@ ftest.F90 $(LDFLAGS) $(MYLIBS) - -ctest2: ctest_old.c - $(CC) $(DEFS) $(TINC) $(ALLCFLAGS) -o $@ ctest_old.c $(LDFLAGS) $(MYLIBS) - -ftest2: ftest_old.F90 - $(FC) $(DEFS) $(TINC) $(MYF90FLAGS) -o $@ ftest_old.F90 $(LDFLAGS) $(MYLIBS) - -stest: stest.F90 stest2.o - $(FC) $(DEFS) $(TINC) $(MYF90FLAGS) -o $@ stest.F90 stest2.o $(LDFLAGS) $(MYLIBS) - - -clean: - rm -f ctest ftest ctest2 ftest2 - rm -f *.o diff --git a/cime/src/externals/mct/mpi-serial/tests/ctest.c b/cime/src/externals/mct/mpi-serial/tests/ctest.c deleted file mode 100644 index 4a9b50abb644..000000000000 --- a/cime/src/externals/mct/mpi-serial/tests/ctest.c +++ /dev/null @@ -1,967 +0,0 @@ -#include -#include -#include - -#ifdef HAVE_CONFIG_H -#include -#endif - -#ifdef TEST_INTERNAL -#include -#include -#else -MPI_Request req; -#endif - - -int errcount = 0; -//simplest example: contiguous -// type of 5 MPI_INT - -void test_simple_contig() -{ - int i; - int a [5] = {1, 2, 3, 4, 5}; - int b [5]; - MPI_Datatype contig_type; - - //Contiguous type of simple types - printf("\nContiguous type of 5 x MPI_INT\n"); - MPI_Type_contiguous(5, MPI_INT, &contig_type); - MPI_Type_commit(&contig_type); - -#ifdef TEST_INTERNAL - print_typemap(contig_type); - copy_data(&a, &b, contig_type); -#else - MPI_Isend(&a, 1, contig_type, 0, 0, MPI_COMM_WORLD, &req); - MPI_Irecv(&b, 1, contig_type, MPI_ANY_SOURCE, MPI_ANY_TAG, MPI_COMM_WORLD,&req); -#endif - - printf("a = ["); - for (i = 0; i < 5; i++) - printf("%d ", a[i]); - printf("]\n"); - - printf("b = ["); - for (i = 0; i < 5; i++) - printf("%d ", b[i]); - printf("]\n"); - - for (i = 0; i < 5; i++) - if (a[i]!=b[i]) - { - printf(">>>FAILED: test_simple_contig\n"); - errcount++; - return; - } -} - -// vector type of MPI_INTs - -void test_simple_vector() -{ - int i; - int a[10] = {1, 2, 3, 4, 5, 6, 7, 8, 9, 10}; - int b[10] = {0, 0, 0, 0, 0, 0, 0, 0, 0, 0 }; - int index_test []= {0, 1, 3, 4, 6, 7}; - MPI_Datatype vector_type; - - //Vector type of simple types - printf("\nVector type of 3 groups of 2 MPI_INT, stride of 3.\n"); - MPI_Type_vector(3, 2, 3, MPI_INT, &vector_type); - MPI_Type_commit(&vector_type); - -#ifdef TEST_INTERNAL - print_typemap(vector_type); - copy_data(&a, &b, vector_type); -#else - MPI_Isend(&a, 1, vector_type, 0, 0, MPI_COMM_WORLD, &req); - MPI_Irecv(&b, 1, vector_type, 0, 0, MPI_COMM_WORLD, &req); -#endif - - printf("a = ["); - for (i = 0; i < 10; i++) - printf("%d ", a[i]); - printf("]\n"); - - printf("b = ["); - for (i = 0; i < 10; i++) - printf("%d ", b[i]); - printf("]\n"); - - for (i = 0; i < 6; i++) - if (a[index_test[i]]!=b[index_test[i]]) - { - printf(">>>FAILED: test_simple_vector\n"); - errcount++; - return; - } -} -//vector type (byte addressed, using -// sizeof(int) to compute stride - -void test_simple_hvector() -{ - MPI_Datatype vector_type; - int i; - int a[10] = {1, 2, 3, 4, 5, 6, 7, 8, 9, 10}; - int b[10] = {0, 0, 0, 0, 0, 0, 0, 0, 0, 0}; - int index_test [6] = {0, 1, 4, 5, 8, 9}; - //Vector (byte-addressed) of simple types - printf("\nVector type of 3 groups of 2 MPI_INT, stride of 16 bytes.\n"); - MPI_Type_hvector(3, 2, 4*sizeof(int), MPI_INT, &vector_type); - MPI_Type_commit(&vector_type); - -#ifdef TEST_INTERNAL - print_typemap(vector_type); - copy_data(&a, &b, vector_type); -#else - MPI_Isend(&a, 1, vector_type, 0, 0, MPI_COMM_WORLD, &req); - MPI_Irecv(&b, 1, vector_type, 0, 0, MPI_COMM_WORLD, &req); -#endif - - printf("a = ["); - for (i = 0; i < 10; i++) - printf("%d ", a[i]); - printf("]\n"); - - printf("b = ["); - for (i = 0; i < 10; i++) - printf("%d ", b[i]); - printf("]\n"); - - for (i = 0; i < 6; i++) - if (a[index_test[i]]!=b[index_test[i]]) - { - printf(">>>FAILED: test_simple_hvector\n"); - errcount++; - return; - } -} - -//indexed type. - -void test_simple_indexed() -{ - int i; - int a[15] = {1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15}; - int b[15] = {0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0}; - int index_test [6] = {0, 5, 6, 10, 11, 12}; - int blens[3] = {2, 1, 3}; - int disps[3] = {5, 0, 10}; - MPI_Datatype indexed_type; - //Indexed of simple types - - printf("\nIndexed type of MPI_INT.\n"); - - MPI_Type_indexed(3, blens, disps, MPI_INT, &indexed_type); - MPI_Type_commit(&indexed_type); - -#ifdef TEST_INTERNAL - print_typemap(indexed_type); - copy_data(&a, &b, indexed_type); -#else - MPI_Isend(&a, 1, indexed_type, 0, 0, MPI_COMM_WORLD, &req); - MPI_Irecv(&b, 1, indexed_type, 0, 0, MPI_COMM_WORLD, &req); -#endif - - printf("a = ["); - for (i = 0; i < 15; i++) - printf("%d ", a[i]); - printf("]\n"); - - printf("b = ["); - for (i = 0; i < 15; i++) - printf("%d ", b[i]); - printf("]\n"); - - for (i = 0; i < 6; i++) - if (a[index_test[i]]!=b[index_test[i]]) - { - printf(">>>FAILED: test_simple_indexed\n"); - errcount++; - return; - } -} - -//block indexed. Same as indexed except -//static block length - -void test_simple_bindexed() -{ - int i; - int disps[3] = {0, 4, 7}; - int a [10] = {1, 2, 3, 4, 5, 6, 7, 8, 9, 10}; - int b [10] = {0, 0, 0, 0, 0, 0, 0, 0, 0, 0}; - int index_test[6] = {0, 1, 4, 5, 7, 8}; - MPI_Datatype indexed_type; - - //block indexed of simple types - printf("\nBlock indexed type of MPI_INT.\n"); - MPI_Type_create_indexed_block(3, 2, disps, MPI_INT, &indexed_type); - MPI_Type_commit(&indexed_type); -#ifdef TEST_INTERNAL - copy_data(&a, &b, indexed_type); - print_typemap(indexed_type); -#else - MPI_Isend(&a, 1, indexed_type, 0, 0, MPI_COMM_WORLD, &req); - MPI_Irecv(&b, 1, indexed_type, 0, 0, MPI_COMM_WORLD, &req); -#endif - - printf("a = ["); - for (i = 0; i < 10; i++) - printf("%d ", a[i]); - printf("]\n"); - - printf("b = ["); - for (i = 0; i < 10; i++) - printf("%d ", b[i]); - printf("]\n"); - - for (i = 0; i < 6; i++) - if (a[index_test[i]]!=b[index_test[i]]) - { - printf(">>>FAILED: test_simple_bindexed\n"); - errcount++; - return; - } -} - -//hindexed: same as indexed, but -//using byte displacements based off of sizeof(int) -//(no reason why this shouldn't work) - -void test_simple_hindexed() -{ - int i; - int a [10] = {1, 2, 3, 4, 5, 6, 7, 8, 9, 10}; - int b [10] = {0, 0, 0, 0, 0, 0, 0, 0, 0, 0 }; - int index_test [6] = {0, 2, 3, 5, 6, 7}; - int blens[3] = {2, 1, 3}; - MPI_Aint disps[3] = {2*sizeof(int), 0, 5*sizeof(int)}; - MPI_Datatype indexed_type; - -//Indexed (byte-addressed) of simple types - printf("\nBlock indexed (byte addressed) type of MPI_INT.\n"); - MPI_Type_hindexed(3, blens, disps, MPI_INT, &indexed_type); - MPI_Type_commit(&indexed_type); -#ifdef TEST_INTERNAL - print_typemap(indexed_type); - copy_data(&a, &b, indexed_type); -#else - MPI_Isend(&a, 1, indexed_type, 0, 0, MPI_COMM_WORLD, &req); - MPI_Irecv(&b, 1, indexed_type, 0, 0, MPI_COMM_WORLD, &req); -#endif - - printf("a = ["); - for (i = 0; i < 10; i++) - printf("%d ", a[i]); - printf("]\n"); - - printf("b = ["); - for (i = 0; i < 10; i++) - printf("%d ", b[i]); - printf("]\n"); - - for (i = 0; i < 6; i++) - if (a[index_test[i]]!=b[index_test[i]]) - { - printf(">>>FAILED: test_simple_hindexed\n"); - errcount++; - return; - } -} - - -/* - * void struct_test() -{ - int blocklengths[6]; - int offsets[6]; - MPI_Aint boffsets[6]; - MPI_Datatype types[6]; - MPI_Datatype struct_type, newtype, newtype2, sstruct, - indexed_type, vector_type; - MPI_Aint extent2, extent3; - //struct type of simple types - printf("\nStruct of simple types\n"); - blocklengths[0] = 3; - blocklengths[1] = 5; - blocklengths[2] = 2; - blocklengths[3] = 1; - boffsets[0] = 0; - boffsets[1] = 24; - boffsets[2] = 32; - boffsets[3] = 40; - types[0] = MPI_DOUBLE; - types[1] = MPI_CHAR; - types[2] = MPI_INT; - types[3] = MPI_LONG_DOUBLE; - - MPI_Type_struct(4, blocklengths, boffsets, types, &struct_type); - print_typemap(struct_type); - - //struct type of simple types, with artificial LB and UB - printf("\nStruct type of simple types, with LB and UB.\n"); - blocklengths[0] = 2; - blocklengths[1] = 4; - blocklengths[2] = 1; - blocklengths[3] = 24; - blocklengths[4] = 1; - boffsets[0] = 0; - boffsets[1] = 40; - boffsets[2] = 80; - boffsets[3] = 48; - boffsets[4] = -8; - types[0] = MPI_LONG; - types[1] = MPI_INT; - types[2] = MPI_UB; - types[3] = MPI_CHAR; - types[4] = MPI_LB; - - MPI_Type_struct(5, blocklengths, boffsets, types, &newtype2); - print_typemap(newtype2); - - //struct type: 2 int, 1 float - printf("\nSimple struct for use: 2 int, 1 float\n"); - blocklengths[0] = 2; - blocklengths[1] = 1; - boffsets[0] = 0; - boffsets[1] = 8; - types[0] = MPI_INT; - types[1] = MPI_FLOAT; - - MPI_Type_struct(2, blocklengths, boffsets, types, &sstruct); - print_typemap(sstruct); - - //contiguous type of complex (struct) type - printf("\nContiguous type of complex (struct) type\n"); - MPI_Type_contiguous(3, newtype2, &newtype); - print_typemap(newtype); - - //vector type of complex type - printf("\nVector type of struct\n"); - MPI_Type_vector(3, 2, 2, struct_type, &vector_type); - print_typemap(vector_type); - - //indexed of complex type - printf("\nIndexed type of struct\n"); - blocklengths[0] = 1; - blocklengths[1] = 2; - offsets[0] = 0; - offsets[1] = 7; - MPI_Type_indexed(2, blocklengths, offsets, sstruct, &indexed_type); - print_typemap(indexed_type); - - //struct of simple/complex - printf("\nStruct of smaller structs and simple types\n"); - MPI_Type_extent(sstruct, &extent2); - MPI_Type_extent(indexed_type, &extent3); - blocklengths[0] = 2; - blocklengths[1] = 1; - blocklengths[2] = 4; - blocklengths[3] = 5; - boffsets[0] = 0; - boffsets[1] = 2 * extent2; - boffsets[2] = boffsets[1] + extent3; - boffsets[3] = boffsets[2] + 4; - types[0] = sstruct; - types[1] = indexed_type; - types[2] = MPI_CHAR; - types[3] = newtype2; - - MPI_Type_struct(4, blocklengths, boffsets, types, &struct_type); - print_typemap(struct_type); -} -*/ - -//simple struct, comprised of an int, 2 chars -// and a long int value. - -void test_simple_struct() -{ - struct {int a; char b; char c; long d; } s1; - struct {int a; char b; char c; long d; } s2; - - int blens[4] = {1, 2, 1}; - MPI_Aint disps[4] = {0, 4, 8}; - MPI_Datatype types[4] = {MPI_INT, MPI_CHAR, MPI_LONG}; - MPI_Datatype struct_type; - - printf("\nSimple struct type: 1 int, 2 char, 1 long\n"); - MPI_Type_struct(3, blens, disps, types, &struct_type); - MPI_Type_commit(&struct_type); - s1.a = 10; - s1.b = 'x'; - s1.c = 'a'; - s1.d = 3000; - -#ifdef TEST_INTERNAL - print_typemap(struct_type); - copy_data(&s1, &s2, struct_type); -#else - MPI_Isend(&s1, 1, struct_type, 0, 0, MPI_COMM_WORLD, &req); - MPI_Irecv(&s2, 1, struct_type, 0, 0, MPI_COMM_WORLD, &req); -#endif - - if (!(s1.a==s2.a && s1.b==s2.b && s1.c==s2.c && s1.d==s2.d)) - { - printf(">>>FAILED: test_simple_struct\n"); - errcount++; - return; - } -} - -// combine one struct into another struct for a complex -// type. This should test any funny padding issues - -void test_complex_struct() -{ - MPI_Datatype sstruct; - typedef struct {long a; long b; char c; int d; int e;} st; - typedef struct {st a; int b; char c;} st2; - st s1 = {.a = 100, .b = 200, .c = 'x', .d = 45, .e = 50}; - st s2; - st2 s3 = {.a = { .a = 40, .b = 100, .c = 'x', .d = 50, .e = 20}, .b = 100, .c = 'g'} ; - st2 s4; - int blens[3] = {2, 2, 1}; - MPI_Aint disps[3] = {0, 2*sizeof(long) + sizeof(int), 2*sizeof(long)}; - MPI_Datatype types[3] = {MPI_LONG, MPI_INT, MPI_CHAR}; - MPI_Datatype newtype; - - - printf("\nSimple struct to create complex struct\n"); - MPI_Type_struct(3, blens, disps, types, &newtype); - MPI_Type_commit(&newtype); -#ifdef TEST_INTERNAL - print_typemap(newtype); - copy_data(&s1, &s2, newtype); -#else - MPI_Isend(&s1, 1, newtype, 0, 0, MPI_COMM_WORLD, &req); - MPI_Irecv(&s2, 1, newtype, 0, 0, MPI_COMM_WORLD, &req); -#endif - - if (!(s1.a==s2.a && s1.b==s2.b && s1.c==s2.c && s1.d==s2.d && s1.e==s2.e)) - { - printf(">>>FAILED: test_complex_struct\n"); - errcount++; - return; - } - MPI_Datatype newtype2; - - blens[0] = 1; - blens[1] = 1; - blens[2] = 1; - disps[0] = 0; - disps[1] = sizeof(st); - disps[2] = sizeof(st) + sizeof(int); - types[0] = newtype; - types[1] = MPI_INT; - types[2] = MPI_CHAR; - - printf("\nComplex struct type composed of other struct.\n"); - MPI_Type_struct(3, blens, disps, types, &newtype2); - MPI_Type_commit(&newtype2); -#ifdef TEST_INTERNAL - print_typemap(newtype2); - copy_data(&s3, &s4, newtype2); -#else - MPI_Isend(&s3, 1, newtype2, 0, 0, MPI_COMM_WORLD, &req); - MPI_Irecv(&s4, 1, newtype2, 0, 0, MPI_COMM_WORLD, &req); -#endif - - if (!(s3.a.a==s4.a.a && s3.a.b==s4.a.b && s3.a.c==s4.a.c && s3.b==s4.b && s3.c==s4.c)) - { - printf(">>>FAILED: test_complex_struct\n"); - errcount++; - return; - } -} - -// Indexed struct. This one is a bit complicated -// as to datatype layout, so it will also test the -// padding issue - -void test_indexed_struct() -{ - int i; - - //simple struct vars - int s_blens[4] = {1,1,1,2}; - MPI_Aint s_disps[4]; - MPI_Datatype s_types[4] = {MPI_CHAR, MPI_LONG, - MPI_CHAR, MPI_INT}; - MPI_Datatype s_struct; - int i_blens[3] = {3, 1, 2}; - int i_disps[3] = {0, 5, 7}; - MPI_Datatype i_struct_indexed; - int index_test [6] = {0,1,2,5,7,8}; - char* sadd; - typedef struct - {char a; long b; char c; int d; int e;} - struct_t; - - struct_t send[10]; - struct_t recv[10]; - - //initialize the structs - for (i = 0; i < 10; i++) - { - send[i].a = i; - send[i].b = 2*i; - send[i].c = 'A' + i; - send[i].d = i; - send[i].e =-i; - recv[i].a=0; - recv[i].b=0; - recv[i].c=' '; - recv[i].d=0; - recv[i].e=0; - } - - //set the displacements by using address differences - sadd = (char *)&send[0]; - s_disps[0] = (char*)&(send[0].a) - sadd; - s_disps[1] = (char*)&(send[0].b) - sadd; - s_disps[2] = (char*)&(send[0].c) - sadd; - s_disps[3] = (char*)&(send[0].d) - sadd; - //e is "contiguous" of d - - - MPI_Type_struct(4, s_blens, s_disps, s_types, &s_struct); - MPI_Type_commit(&s_struct); -#ifdef TEST_INTERNAL - print_typemap(s_struct); -#endif - - //now, create an indexed type of this struct - MPI_Type_indexed(3, i_blens, i_disps, - s_struct, &i_struct_indexed); - MPI_Type_commit(&i_struct_indexed); - -#ifdef TEST_INTERNAL - print_typemap(i_struct_indexed); - copy_data2(send, 1, i_struct_indexed, recv, 1, i_struct_indexed); -#else - MPI_Isend(&send, 1, i_struct_indexed, 0, 0, MPI_COMM_WORLD, &req); - MPI_Irecv(&recv, 1, i_struct_indexed, 0, 0, MPI_COMM_WORLD, &req); -#endif - - for (i = 0; i < 6; i++) - { - if (!(send[index_test[i]].a==recv[index_test[i]].a - && send[index_test[i]].b==recv[index_test[i]].b - && send[index_test[i]].c==recv[index_test[i]].c - && send[index_test[i]].d==recv[index_test[i]].d - && send[index_test[i]].e==recv[index_test[i]].e)) - { - printf(">>>FAILED: test_indexed_struct\n"); - errcount++; - return; - } - } - - //to make things really interesting, let's send as the - //indexed type, and receive instead as _count_ - //consecutive struct types -#ifdef TEST_INTERNAL - copy_data2(send, 1, i_struct_indexed, recv, 6, s_struct); -#else - MPI_Gather(&send, 1, i_struct_indexed, &recv, - 6, s_struct, 0, MPI_COMM_WORLD); - -// MPI_Isend(&send, 1, i_struct_indexed, 0, 0, MPI_COMM_WORLD, &req); -// MPI_Irecv(&recv, 6, s_struct, 0, 0, MPI_COMM_WORLD, &req); - -#endif - - for (i = 0; i < 6; i++) - { - if (!(send[index_test[i]].a==recv[i].a - && send[index_test[i]].b==recv[i].b - && send[index_test[i]].c==recv[i].c - && send[index_test[i]].d==recv[i].d - && send[index_test[i]].e==recv[i].e)) - { - printf(">>>FAILED: test_indexed_struct (multiple recv)\n"); - errcount++; - return; - } - } - -} - - -//test a differing issue with send/receive -//A contiguous type of 5 MPI_INTs is sent, and is -//received using a receive x5 of MPI_INT - -void test_multiple() -{ - int i; - int a[5] = {1, 2, 3, 4, 5}; - int b[5] = {0, 0, 0, 0, 0}; - - - - MPI_Datatype contig5int; - - printf("\nSend contiguous of 5 MPI_INT, receive 5 x MPI_INT\n"); - MPI_Type_contiguous(5, MPI_INT, &contig5int); - MPI_Type_commit(&contig5int); - -#ifdef TEST_INTERNAL - copy_data2(&a, 5, MPI_INT, &b, 1, contig5int); -#else - MPI_Isend(&a, 5, MPI_INT, 0, 0, MPI_COMM_WORLD, &req); - MPI_Irecv(&b, 1, contig5int, 0, 0, MPI_COMM_WORLD, &req); -#endif - - - printf("a = ["); - for (i = 0; i < 5; i++) - printf("%d ", a[i]); - printf("]\n"); - - printf("b = ["); - for (i = 0; i < 5; i++) - printf("%d ", b[i]); - printf("]\n"); - - for (i = 0; i < 5; i++) - if (a[i]!=b[i]) - { - printf(">>>FAILED: test_multiple\n"); - errcount++; - return; - } -} - -void test_multiple_struct() -{ - int i; - typedef struct {int a; double b; char c;} struct_t; - struct_t s1[5],s2[5]; - MPI_Aint disps[3]; - int blens[3] = {1,1,1}; - MPI_Datatype types[3] = {MPI_INT, MPI_DOUBLE, MPI_CHAR}; - MPI_Datatype struct_type, contig_struct; - - disps[0] = 0; - disps[1] = (char*) &(s1[0].b) - (char*) &s1[0]; - disps[2] = (char*) &(s1[0].c) - (char*) &s1[0]; - - for (i=0; i<5; i++) - { - s1[i].a=i; s1[i].b=i+15.0; s1[i].c='a'+i; - s2[i].a=0; s2[i].b=0.0 ; s2[i].c=0 ; - } - - MPI_Type_struct(3, blens, disps, types, &struct_type); - MPI_Type_commit(&struct_type); - MPI_Type_contiguous(5, struct_type, &contig_struct); - MPI_Type_commit(&contig_struct); - printf("\nSend contiguous of 5 struct, receive 5x struct\n"); - -#ifdef TEST_INTERNAL - copy_data2(&s1, 1, contig_struct, &s2, 5, struct_type); -#else - MPI_Isend(&s1, 1, contig_struct, 0, 0, MPI_COMM_WORLD, &req); - MPI_Irecv(&s2, 5, struct_type, 0, 0, MPI_COMM_WORLD, &req); -#endif - - for (i = 0; i < 5; i++) - if (!(s1[i].a == s2[i].a && s1[i].b == s2[i].b && s1[i].c == s2[i].c)) - { - printf(">>>FAILED: test_multiple_struct\n"); - errcount++; - return; - } -} - -// packed type. Pack some arbitrary simple -// values into a buffer and copy. - -void test_packed() -{ - int SIZE = 77; - int i = 8; - char c[] = "abcdefghijklmnopqrstuvwxyabcdefghijklmnopqrstuvwxyabcdefghijklmnopqrstuvwxyabcdefghijklmnopqrstuvwxyzabcdefg\0"; - int j; - double k = 0.234234, l; - char d[SIZE]; - char buffer[110]; - char recv[110]; - int position = 0; - - printf("\nSimple packed type (int, char, double)\n"); - c[SIZE-1] = '\0'; - MPI_Pack(&i, 1, MPI_INT, buffer, 110, &position, MPI_COMM_WORLD); - MPI_Pack(c, SIZE, MPI_CHAR, buffer, 110, &position, MPI_COMM_WORLD); - MPI_Pack(&k, 1, MPI_DOUBLE, buffer, 110, &position, MPI_COMM_WORLD); -#ifdef TEST_INTERNAL - copy_data2(&buffer, position, MPI_PACKED, &recv, position, MPI_PACKED); -#else - MPI_Isend(&buffer, position, MPI_PACKED, 0, 0, MPI_COMM_WORLD, &req); - MPI_Irecv(&recv, position, MPI_PACKED, 0, 0, MPI_COMM_WORLD,&req); -#endif - - position = 0; - - MPI_Unpack(&recv, 110, &position, &j, 1, MPI_INT, MPI_COMM_WORLD); - MPI_Unpack(&recv, 110, &position, d, SIZE, MPI_CHAR, MPI_COMM_WORLD); - MPI_Unpack(&recv, 110, &position, &l, 1, MPI_DOUBLE, MPI_COMM_WORLD); - - if (!(i==j && k==l)) - { - printf(">>>FAILED: test_packed\n"); - errcount++; - return; - } -} - -// Complex pack. Includes struct types that are packed - -void test_packed_complex() -{ - struct {int a; char b; char c; long d; } s1; - struct {int a; char b; char c; long d; } s2; - - MPI_Aint size; - int pos = 0; - int x = 10, y; - float f = 0.345, g; - char buf[100]; - char rbuf[100]; - int blens[3] = {1, 1, 1}; - MPI_Aint disps[3]; - MPI_Datatype types[3] = {MPI_INT, MPI_CHAR, MPI_LONG}; - MPI_Datatype struct_type; - - disps[0] = 0; - disps[1] = (char*) &s1.b - (char*)&s1.a; - disps[2] = (char*) &s1.d - (char*)&s1.a; - - printf("\nComplex packed type\n"); - - MPI_Type_struct(3, blens, disps, types, &struct_type); - s1.a = 10; - s1.b = 'x'; - s1.c = 'a'; - s1.d = 3000; - - MPI_Pack_size(1, struct_type,MPI_COMM_WORLD, &size); - MPI_Pack(&x, 1, MPI_INT, buf, 100, &pos, MPI_COMM_WORLD); - MPI_Pack(&s1, 1, struct_type, buf, 100, &pos, MPI_COMM_WORLD); - MPI_Pack(&f, 1, MPI_FLOAT, buf, 100, &pos, MPI_COMM_WORLD); - -#ifdef TEST_INTERNAL - copy_data2(&buf, pos, MPI_PACKED, &rbuf, pos, MPI_PACKED); -#else - MPI_Isend(&buf, pos, MPI_PACKED, 0, 0, MPI_COMM_WORLD, &req); - MPI_Irecv(&rbuf, pos, MPI_PACKED, 0, 0, MPI_COMM_WORLD,&req); -#endif - - pos = 0; - MPI_Unpack(&rbuf, 100, &pos, &y, 1, MPI_INT, 0); - MPI_Unpack(&rbuf, 100, &pos, &s2, 1, struct_type, 0); - MPI_Unpack(&rbuf, 100, &pos, &g, 1, MPI_FLOAT, 0); - - if (!(s1.a==s2.a && s1.b==s2.b /*&& s1.c==s2.c*/ && s1.d==s2.d && x == y && f == g)) - { - printf(">>>FAILED: test_packed_complex\n"); - errcount++; - return; - } - -} - -//Macro used in test_collectives -#define test_eq(s1, s2, op) { \ - printf("testing %s\n",op); \ - if (!(s1.a == s2.a && s1.b == s2.b && \ - s1.c == s2.c && s1.d == s2.d)) {\ - errcount++; \ - printf(">>>FAILED: test_collectives: %s\n", op); \ - } \ -} - -void test_collectives() -{ - typedef struct {int a; int b; double c; long d;} struct_t; - MPI_Datatype struct_type; - struct_t s1 = {.a=1, .b=2, .c=4.00, .d=100}, - s2 = {.a=0, .b=0, .c=0.00, .d=0 }; - MPI_Aint disps[3]; - - int disp = 0; - int sendcount = 1, recvcount = 1; - - - int blens[3] = {2,1,1}; - MPI_Datatype types[3] = {MPI_INT, MPI_DOUBLE, MPI_LONG}; - - disps[0] = 0; - disps[1] = (char*)&s1.c - (char*) &s1.a; - disps[2] = (char*)&s1.d - (char*) &s1.a; - - MPI_Type_struct(3, blens, disps, types, &struct_type); - MPI_Type_commit(&struct_type); - - MPI_Bcast(&s1, sendcount, struct_type, 0, MPI_COMM_WORLD); - MPI_Gather(&s1, sendcount, struct_type, &s2, recvcount, - struct_type, 0, MPI_COMM_WORLD); - test_eq(s1,s2,"MPI_Gather"); - - s2.a=0; s2.b=0; s2.c=0.00; s2.d=0; - MPI_Gatherv(&s1, sendcount, struct_type, &s2, &recvcount, &disp, - struct_type, 0, MPI_COMM_WORLD); - test_eq(s1,s2,"MPI_Gatherv"); - s2.a=0; s2.b=0; s2.c=0.00; s2.d=0; - MPI_Allgather(&s1, sendcount, struct_type, &s2, recvcount, - struct_type, MPI_COMM_WORLD); - test_eq(s1,s2,"MPI_Allgather"); - s2.a=0; s2.b=0; s2.c=0.00; s2.d=0; - MPI_Allgatherv(&s1, sendcount, struct_type, &s2, &recvcount, &disp, - struct_type, MPI_COMM_WORLD); - test_eq(s1,s2,"MPI_Allgatherv"); - - s2.a=0; s2.b=0; s2.c=0.00; s2.d=0; - MPI_Scatter(&s1, sendcount, struct_type, - &s2, recvcount, struct_type, - 0, MPI_COMM_WORLD); - test_eq(s1,s2,"MPI_Scatter"); - - s2.a=0; s2.b=0; s2.c=0.00; s2.d=0; - MPI_Scatterv(&s1, &sendcount, &disp, struct_type, &s2, recvcount, - struct_type, 0, MPI_COMM_WORLD); - test_eq(s1,s2,"MPI_Scatterv"); - - s2.a=0; s2.b=0; s2.c=0.00; s2.d=0; - MPI_Reduce(&s1, &s2, sendcount, struct_type, MPI_MAX, 0, MPI_COMM_WORLD); - test_eq(s1, s2, "MPI_Reduce"); - - s2.a=0; s2.b=0; s2.c=0.00; s2.d=0; - MPI_Allreduce(&s1, &s2, sendcount, struct_type, MPI_MAX, MPI_COMM_WORLD); - test_eq(s1, s2, "MPI_Allreduce"); - - s2.a=0; s2.b=0; s2.c=0.00; s2.d=0; - MPI_Alltoall(&s1, sendcount, struct_type, - &s2, recvcount, struct_type, MPI_COMM_WORLD); - test_eq(s1, s2, "MPI_Alltoall"); - - s2.a=0; s2.b=0; s2.c=0.00; s2.d=0; - MPI_Alltoallv(&s1, &sendcount, &disp, struct_type, - &s2, &recvcount, &disp, struct_type, MPI_COMM_WORLD); - test_eq(s1, s2, "MPI_Alltoallv"); - - s2.a=0; s2.b=0; s2.c=0.00; s2.d=0; - MPI_Reduce_scatter(&s1, &s2, &recvcount,struct_type, MPI_MAX, MPI_COMM_WORLD); - test_eq(s1, s2, "MPI_Reduce_scatter"); - - s2.a=0; s2.b=0; s2.c=0.00; s2.d=0; - MPI_Scan(&s1, &s2, sendcount,struct_type, MPI_MAX, MPI_COMM_WORLD); - test_eq(s1, s2, "MPI_Scan"); -} -/* -void vector_test() -{ - int c[3][2] = { {1, 2}, {3, 4}, {5, 6} }; - int d[3][2] = { {0, 0}, {0, 0}, {0, 0} }; - int i; - MPI_Datatype vector_type; - //test vector. First and third rows of array - printf("\nVector type of first and third rows in INT array\n"); - MPI_Type_vector(2, 2, 4, MPI_INT, &vector_type); - - print_typemap(vector_type); - - copy_data(&c, &d, vector_type); - - for (i = 0; i < 3; i++) - printf("%d %d\n", d[i][0], d[i][1]); -} - -void indexed_test() -{ - //we want the 2nd, 3rd, 5th, and 8th elements (starting at 0) - int i; - int a[10] = {1, 2, 3, 4, 5, 6, 7, 8, 9, 10}; - int b[10] = {0, 0, 0, 0, 0, 0, 0, 0, 0, 0}; - int blens[3] = {2, 1, 1}; - int disps[3] = {2, 5, 8}; - MPI_Datatype indexed_type; - - printf("\nIndexed: 2nd, 3rd, 5th, and 8th elements (0 base)\n"); - MPI_Type_indexed(3, blens, disps, MPI_INT, &indexed_type); - - print_typemap(indexed_type); - - copy_data(&a, &b, indexed_type); - - for (i = 0; i < 10; i++) - printf("%d ", b[i]); - printf("\n"); -} - -void structtests() -{ - int a[5] = {1, 2, 3, 4, 5}; - int b[5]; - - MPI_Datatype type, vector_type; - - //test contiguous - printf("\nContiguous type of 5 MPI_INT\n"); - MPI_Type_contiguous(5, MPI_INT, &type); - printf("Done.\n"); - fflush(stdout); - print_typemap(type); - copy_data(&a, &b, type); - printf("b = %d\n", a[4]); -} -*/ - -int main(int argc, char ** argv) -{ - char version[MPI_MAX_LIBRARY_VERSION_STRING]; - int vlen; - - MPI_Init(&argc, &argv); - - MPI_Get_library_version(version,&vlen); - printf("MPI version=\"%s\" (len=%d)\n",version,vlen); - -// structtests(); -// indexed_test(); -// struct_test(); - -// printf("\n\n---End of samples: Testing now---\n\n"); -#ifdef TEST_INTERNAL - printf("Using internal tests\n"); -#endif - test_simple_contig(); - test_simple_vector(); - test_simple_hvector(); - test_simple_indexed(); - test_simple_bindexed(); - test_simple_hindexed(); - test_simple_struct(); - test_complex_struct(); - test_indexed_struct(); - test_multiple(); - test_multiple_struct(); - test_packed(); - test_packed_complex(); - test_collectives(); - - MPI_Finalize(); - if (errcount) - printf("Found %d errors\n", errcount); - else - printf(">>>PASSED ALL TESTS. No errors. <<<\n"); - - return(errcount); -} - diff --git a/cime/src/externals/mct/mpi-serial/tests/ctest_old.c b/cime/src/externals/mct/mpi-serial/tests/ctest_old.c deleted file mode 100644 index e4ff3cb806f6..000000000000 --- a/cime/src/externals/mct/mpi-serial/tests/ctest_old.c +++ /dev/null @@ -1,181 +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]; - int i,j; - MPI_Comm comm2; - int flag; - MPI_Group mygroup; - char pname[MPI_MAX_PROCESSOR_NAME]; - int pnamelen; - - int position, temp; - int errcount = 0; - - 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 isend %d tag %d\n",sbuf[i],tag); - MPI_Isend(&sbuf[2*i],1,MPI_2INT,0,tag,MPI_COMM_WORLD,&sreq[i]); - } - - for (i=0; i < 5; i++) - { - if (sbuf[9-(2*i)] != rbuf[2*i+1] || sbuf[8-2*i] != rbuf[2*i]) - { - errcount++; - printf("Error for COMWORLD send\n"); - printf("buf[%d] = %d, rbuf= %d\n", i, sbuf[9-2*i], rbuf[2*i+1]); - printf("buf[%d] = %d, rbuf= %d\n", i, sbuf[8-2*i], rbuf[2*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]); - - if (rbuf2[i] != sbuf2[i]) - { - errcount++; - printf("Error for COM2 send %d\n", i); - printf("Found %d should be %d\n", rbuf2[i], sbuf2[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); - } - - for (i=0; i<5; i++) - { - if (sbuf[i] != rbuf[i]) - { - errcount++; - printf("Error for pack/send/unpack\n"); - printf("Found %d should be %d\n", rbuf[i], sbuf[i]); - } - } - - MPI_Finalize(); - - - for (i=0; i<5; i++) - { - printf("Time: %f\n",MPI_Wtime()); - sleep(1); - } - - - if (errcount) - printf("Finished with %d errors.\n", errcount); - else - printf("No errors\n"); -} - - - diff --git a/cime/src/externals/mct/mpi-serial/tests/ftest.F90 b/cime/src/externals/mct/mpi-serial/tests/ftest.F90 deleted file mode 100644 index b292b8b73cd9..000000000000 --- a/cime/src/externals/mct/mpi-serial/tests/ftest.F90 +++ /dev/null @@ -1,680 +0,0 @@ -#ifdef HAVE_CONFIG_H -#include -#endif - - program test - use mpi - implicit none - integer ierr - integer ec - character*(MPI_MAX_LIBRARY_VERSION_STRING) version - integer vlen - - ec = 0 -#ifdef TEST_INTERNAL - print *, "Using internal tests" -#endif - - call mpi_init(ierr) - - call MPI_GET_LIBRARY_VERSION(version,vlen,ierr) - print *,"MPI Version '",version,"' len=",vlen - - call test_contiguous(ec) - call test_vector(ec) - call test_simple_hvector(ec) - call test_simple_indexed(ec) - call test_simple_bindexed(ec) - call test_simple_hindexed(ec) - call test_complex_indexed(ec) - call test_packed(ec) - call test_multiple(ec) - call test_multiple_indexed(ec) - call test_collectives(ec) - - call mpi_finalize(ierr) - if (ec .eq. 0) then - print *, "PASSED ALL TESTS" - else - print *, "Errors:",ec - end if - stop - end - -!!!!!!!!!!!!!!!!!!! -! Contiguous type. Simplest example. Strings 5 -! integers together and tests their equality after -! a send operation -!!!!!!!!!!!!!!!!!!! - - subroutine test_contiguous(ec) - use mpi - integer ec - integer ierr - integer datatype - integer a(5) - integer b(5) - integer i - data a/1,2,3,4,5/ - data b/5 * 0/ - integer req - - print *, "Test Contiguous of 5 x MPI_INTEGER" - call mpi_type_contiguous(5, mpi_integer, datatype,ierr) - call mpi_type_commit(datatype, ierr) - -#ifdef TEST_INTERNAL - call copy_data2(a,1,datatype,b,1,datatype,ierr) -#else - call mpi_isend(a, 1, datatype, 0, 0, mpi_comm_world, req, ierr) - call mpi_irecv(b, 1, datatype, mpi_any_source, mpi_any_tag, & - mpi_comm_world, req, ierr) -#endif - - do i=1,5 - if (a(i) .ne. b(i)) then - print *,">>>FAILED: mpi_type_contiguous" - ec = ec+1 - return - end if - end do - - end - -!!!!!!!!!!!!!!!!!!!!!!!! -! Vector type. collect a series of indices with -! set stride from an array. -!!!!!!!!!!!!!!!!!!!!!!!! - - subroutine test_vector(ec) - use mpi - integer ec - integer ierr - integer datatype - integer a(10) != (1,2,3,4,5,6,7,8,9,0) - integer b(10) - integer check_index(6) - data a/1,2,3,4,5,6,7,8,9,10/ - data b/10 * 0/ - data check_index/1,2,4,5,7,8/ - integer i - integer req - - print *, "Test vector of MPI_INTEGER" - - call mpi_type_vector(3, 2, 3, mpi_integer, datatype, ierr) - call mpi_type_commit(datatype, ierr) -#ifdef TEST_INTERNAL - call copy_data2(a,1,datatype,b,1,datatype,ierr) -#else - call mpi_isend(a, 1, datatype, 0, 0, mpi_comm_world, req, ierr) - call mpi_irecv(b, 1, datatype, mpi_any_source, mpi_any_tag, & - mpi_comm_world, req, ierr) -#endif - do i=1,6 - if (a(check_index(i)) .ne. b(check_index(i))) then - print *,">>>FAILED: mpi_type_vector" - ec = ec+1 - return - end if - end do - end - -!!!!!!!!!!!!!!!!!!!!! -! Byte-addressed vector. -! values calculated with mpi_type_extent(), -! so basically we are doing the work here in the -! test program instead of in the library -!!!!!!!!!!!!!!!!!!!!! - - subroutine test_simple_hvector(ec) - use mpi - integer ec - integer vector_type - integer (kind=mpi_address_kind) extent - integer i - integer a(10) - integer b(10) - integer index_test(6) - integer ierr - integer req - - data a/1,2,3,4,5,6,7,8,9,10/, b/0,0,0,0,0,0,0,0,0,0/ - data index_test/1,2,5,6,9,10/ - - print *, "Vector type with stride 4 in bytes" - - call mpi_type_extent(mpi_integer, extent, ierr) - call mpi_type_hvector(3, 2, 4 * extent, mpi_integer, & - vector_type, ierr) - call mpi_type_commit(vector_type, ierr) -#ifdef TEST_INTERNAL - call copy_data2(a,1,vector_type, b,1,vector_type, ierr) -#else - call mpi_isend(a, 1, vector_type, 0, 0, mpi_comm_world,req,ierr) - call mpi_irecv(b, 1, vector_type, mpi_any_source, mpi_any_tag, & - mpi_comm_world, req, ierr) -#endif - do i=1,6 - if (a(index_test(i)) .ne. (b(index_test(i)))) then - print *, ">>>FAILED: test_simple_hvector" - ec = ec+1 - return - end if - end do - end subroutine - -!!!!!!!!!!!!!!!!!!!! -! indexed type. test certain indices of an array -!!!!!!!!!!!!!!!!!!!! - - subroutine test_simple_indexed(ec) - use mpi - integer ec - integer i - double complex a(15) - double complex b(15) - integer index_test(6) - integer blens(3) - integer disps(3) - integer indexed_type - integer ierr - integer req - - data a/1,2,3,4,5,6,7,8,9,10,11,12,13,14,15/ - data b/0,0,0,0,0,0,0,0,0,0,0,0,0,0,0/ - data index_test/1,6,7,11,12,13/ - data blens/2,1,3/ - data disps/5,0,10/ - print *, "Indexed type" - - call mpi_type_indexed(3, blens, disps, mpi_double_complex, & - indexed_type, ierr) - call mpi_type_commit(indexed_type, ierr) -#ifdef TEST_INTERNAL - call copy_data2(a,1,indexed_type,b,1,indexed_type,ierr) -#else - call mpi_isend(a, 1, indexed_type,0, 0, mpi_comm_world,req,ierr) - call mpi_irecv(b, 1, indexed_type, mpi_any_source, mpi_any_tag,& - mpi_comm_world, req, ierr) -#endif - - do i=1,6 - if (a(index_test(i)) .ne. b(index_test(i))) then - print *, ">>>FAILED: test_simple_indexed" - ec = ec+1 - return - end if - end do - end subroutine - -!!!!!!!!!!!!!!!! -! Block indexed. All blocks have same length -!!!!!!!!!!!!!!!! - - subroutine test_simple_bindexed(ec) - use mpi - integer ec - integer i - integer disps(3) - integer a(10), b(10) - integer index_test(6) - integer indexed_type - integer ierr - integer req - - data disps/0,4,7/ - data a/1,2,3,4,5,6,7,8,9,10/ - data b/0,0,0,0,0,0,0,0,0,0/ - data index_test/1,2,5,6,8,9/ - print *, "Block indexed type" - - call mpi_type_create_indexed_block(3,2,disps,mpi_integer, & - indexed_type, ierr) - call mpi_type_commit(indexed_type, ierr) -#ifdef TEST_INTERNAL - call copy_data2(a,1,indexed_type, b,1,indexed_type, ierr) -#else - call mpi_isend(a, 1, indexed_type,0, 0, mpi_comm_world,req,ierr) - call mpi_irecv(b, 1, indexed_type,mpi_any_source,mpi_any_tag, & - mpi_comm_world, req, ierr) -#endif - do i=1,6 - if (a(index_test(i)) .ne. b(index_test(i))) then - print *, ">>>FAILED:test_simple_bindexed" - ec = ec+1 - return - end if - end do - end subroutine - -!!!!!!!!!!!!!!!! -! test_simple_hindexed -! test equality of a byte-addressed -! type of integer array -! (disps calculated through mpi_type_extent() -!!!!!!!!!!!!!!! - subroutine test_simple_hindexed(ec) - use mpi - integer ec - integer i - integer a(10), b(10) - integer index_test(6) - integer blens(3) - integer(kind=mpi_address_kind) disps(3) - integer indexed_type - integer(kind=mpi_address_kind) extent - integer ierr - integer req - integer (kind=mpi_address_kind) addr, baddr - - data a/1,2,3,4,5,6,7,8,9,10/ - data b/0,0,0,0,0,0,0,0,0,0/ - data index_test/1,3,4,6,7,8/ - data blens/2,1,3/ - - call mpi_address(a(1), baddr,ierr) - call mpi_address(a(3), addr ,ierr) - disps(1) = addr - baddr - call mpi_address(a(6), addr, ierr) - disps(3) = addr - baddr -! call mpi_type_extent(mpi_integer, extent, ierr) -! disps(1) = 2*extent - disps(2) = 0 -! disps(3) = 5*extent - - - print *, "Byte addressed indexed type" - call mpi_type_hindexed(3,blens,disps, MPI_INTEGER, & - indexed_type,ierr) - call mpi_type_commit(indexed_type, ierr) -#ifdef TEST_INTERNAL - call copy_data2(a,1,indexed_type, b,1,indexed_type, ierr) -#else - call mpi_isend(a, 1, indexed_type,0, 0, mpi_comm_world,req,ierr) - call mpi_irecv(b, 1, indexed_type,mpi_any_source,mpi_any_tag, & - mpi_comm_world,req,ierr) -#endif - do i=1,6 - if (a(index_test(i)) .ne. b(index_test(i))) then - print *, ">>>FAILED: test_simple_hindexed" - ec = ec+1 - return - end if - end do - end subroutine - - subroutine test_complex_indexed(ec) - use mpi - integer ec - integer i - double precision a(72), b(72) - integer disps(3), blens(3) - integer cdisps(2), cblens(2) - integer index_test(8), cindex_test(3) - integer ierr - integer req - integer indexed_type, complex_indexed - - data blens/3,1,4/ - data disps/0,5,8/ - data cindex_test/1,4,5/ - data index_test/1,2,3, 6, 9,10,11,12/ - - data a/1, 2, 3, 4, 5, 6, 7, 8, 9,10,11,12,13,14,15, & - 16,17,18,19,20,21,22,23,24,25,26,27,28,29,30, & - 31,32,33,34,35,36,37,38,39,40,41,42,43,44,45, & - 46,47,48,49,50,51,52,53,54,55,56,57,58,59,60, & - 61,62,63,64,65,66,67,68,69,70,71,72/ - data b/0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, & - 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, & - 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, & - 0,0,0,0,0,0,0,0,0,0,0,0/ - - call mpi_type_indexed(3,blens,disps, MPI_DOUBLE_PRECISION, & - indexed_type, ierr) - call mpi_type_commit(indexed_type, ierr) - - data cblens/1, 2/ - data cdisps/1, 4/ - call mpi_type_indexed(2,cblens,cdisps,indexed_type, & - complex_indexed, ierr) - call mpi_type_commit(complex_indexed, ierr) -#ifdef TEST_INTERNAL - call copy_data2(a,1,complex_indexed,b,1,complex_indexed,ierr) -#else - call mpi_isend(a,1,complex_indexed,0,0,mpi_comm_world,req,ierr) - call mpi_irecv(b,1,complex_indexed,mpi_any_source,mpi_any_tag,& - mpi_comm_world, req, ierr) -#endif - do i=1,3 - do j=1,8 - if (a(index_test(j)+12*cindex_test(i)) .ne. & - b(index_test(j)+12*cindex_test(i))) then - print *, ">>>FAILED: test_complex_indexed" - print *, "index ",index_test(j)+12*cindex_test(i) - print *, "Found:",b(index_test(j)+12*cindex_test(i)) - print *, "Should be:",a(index_test(j)+12*cindex_test(i)) - ec = ec+1 - end if - end do - end do - - call mpi_type_free(complex_indexed, ierr) - call mpi_type_free(indexed_type, ierr) - end subroutine -!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! test_packed() -! Creates a few variable pairs, assigns the first -! of each pair, then packs their values and unpacks -! them to the other set. -!!!!!!!!!!!!!!!!!!!!!!!!!!!! - subroutine test_packed(ec) - use mpi - integer ec - integer size - integer x, y - real f, g - complex c, d - character*5 a, b - character buf(100), rbuf(100) - integer blens(3) - integer(kind=mpi_address_kind) disps(3) - integer pos - integer req - - x = 10 - f = 14.333 - c = (100, 20) - a = "xyzab" - - pos = 0 - data blens/1,2,1/, disps/0,4,8/ - - print *, "Packed type " - - call mpi_pack(x, 1, mpi_integer, buf, 100, pos, 0, ierr) - call mpi_pack(f, 1, mpi_real, buf, 100, pos, 0, ierr) - call mpi_pack(c, 1, mpi_complex, buf, 100, pos, 0, ierr) - call mpi_pack(a, 5, mpi_character, buf, 100, pos, 0, ierr) -#ifdef TEST_INTERNAL - call copy_data2(buf, pos, mpi_packed, rbuf, pos, & - mpi_packed, ierr) -#else - call mpi_isend(buf, pos, mpi_packed,0,0,mpi_comm_world,req,ierr) - call mpi_irecv(rbuf, pos, mpi_packed,mpi_any_source,mpi_any_tag& - ,mpi_comm_world, req, ierr) -#endif - pos = 0; - - call mpi_unpack(rbuf, 100, pos, y, 1, mpi_integer, 0, ierr) - call mpi_unpack(rbuf, 100, pos, g, 1, mpi_real, 0, ierr) - call mpi_unpack(rbuf, 100, pos, d, 1, mpi_complex, 0, ierr) - call mpi_unpack(rbuf, 100, pos, b, 5, mpi_character, & - 0, ierr) - - if (x .ne. y .OR. f .ne. g & - .OR. c .ne. d .OR. a .ne. b) & - then - print *, ">>>FAILED: mpi_pack" - ec = ec+1 - return - end if - - end subroutine - - subroutine test_multiple(ec) - use mpi - integer ec - integer i - complex a(10) - complex b(10) - integer contig_type - integer ierr - integer req - - data a/1,2,3,4,5,6,7,8,9,10/ - data b/0,0,0,0,0,0,0,0,0,0/ - print *, "Contig type send, multiple receive" - - call mpi_type_contiguous(10, mpi_complex, contig_type, ierr) - call mpi_type_commit(contig_type, ierr) -#ifdef TEST_INTERNAL - call copy_data2(a,1,contig_type, b,10, mpi_complex, ierr) -#else - call mpi_isend(a, 1, contig_type,0,0,mpi_comm_world,req,ierr) - call mpi_irecv(b, 10, mpi_complex,mpi_any_source,mpi_any_tag, & - mpi_comm_world,req,ierr) -#endif - - do i=1,10 - if (a(i) .ne. b(i)) then - print *, ">>>FAILED: test_multiple" - ec = ec+1 - return - end if - end do - end subroutine - -!!!!!!!!!!!!!!!!!!!!!!!!! -! Test an indexed send with a multiple receive -!!!!!!!!!!!!!!!!!!!!!!!!! - subroutine test_multiple_indexed(ec) - use mpi - integer ec - integer i,j - complex a(75) - complex b(75) - integer index_test(6) - integer blens(3) - integer disps(3) - integer indexed_type,contig_indexed - integer ierr - integer req - - data a/ 1, 2, 3, 4, 5, 6, 7, 8, 9,10,11,12,13,14,15,& - 16,17,18,19,20,21,22,23,24,25,26,27,28,29,30,& - 31,32,33,34,35,36,37,38,39,40,41,42,43,44,45,& - 46,47,48,49,50,51,52,53,54,55,56,57,58,59,60,& - 61,62,63,64,65,66,67,68,69,70,71,72,73,74,75/ - data b/75*0/ - data index_test/1,6,7,11,12,13/ - data blens/1,2,3/ - data disps/0,5,10/ - print *, "Indexed type send, multiple indexed receive" - - call mpi_type_indexed(3, blens, disps, mpi_complex, & - indexed_type, ierr) - call mpi_type_commit(indexed_type, ierr) - - call mpi_type_contiguous(5, indexed_type, contig_indexed,ierr) - call mpi_type_commit(contig_indexed, ierr) -#ifdef TEST_INTERNAL - call copy_data2(a,1,contig_indexed,b,5,indexed_type,ierr) -#else - call mpi_isend(a, 1, contig_indexed,0,0,mpi_comm_world,req,ierr) - call mpi_irecv(b, 5, indexed_type,mpi_any_source,mpi_any_tag, & - mpi_comm_world,req,ierr) -#endif - do i=0,4 - do j=1,6 - if (a(index_test(j)+(13*i)) .ne. b(index_test(j)+(13*i))) then - print *, ">>>FAILED: test_multiple_indexed" - print *, " Found:",a(index_test(j)+13*i) - print *, " Expected:",b(index_test(j)+13*i) - ec = ec+1 -! return - end if - end do - end do - end subroutine - - subroutine test_collectives(ec) - use mpi - integer ec - integer i - integer a(10) - integer b(10) - integer disps(3) - integer blens(3) - integer itype - integer ierr - integer scount - integer rcount - integer disp - integer index_test(7) - - data scount/1/rcount/1/disp/0/ - data disps/0,5,8/ - data blens/4,2,1/ - data a/1,2,3,4,5,6,7,8,9,10/ - data b/10*0/ - data index_test/1,2,3,4,6,7,9/ - - call mpi_type_indexed(3, blens, disps, MPI_LOGICAL,& - itype, ierr) - call mpi_type_commit(itype, ierr) - - call mpi_bcast(a, scount, itype, 0, & - mpi_comm_world, ierr) - call mpi_gather(a,scount, itype, b, rcount, & - itype, 0, mpi_comm_world, ierr) - print *, "Testing mpi_gather" - do i=1,7 - if (a(index_test(i)) .ne. b(index_test(i))) then - print *, "mpi_gather failed" - ec=ec+1 - end if - end do - do i=1,10 - b(i) = 0 - end do - print *, "Testing mpi_gatherv" - call mpi_gatherv(a, scount, itype, b, rcount, & - disp, itype, 0, mpi_comm_world, ierr) - do i=1,7 - if (a(index_test(i)) .ne. b(index_test(i))) then - print *, "mpi_gatherv failed" - ec=ec+1 - end if - end do - do i=1,10 - b(i) = 0 - end do - print *, "Testing mpi_allgather" - call mpi_allgather(a, scount, itype, b, rcount, & - itype, mpi_comm_world, ierr) - do i=1,7 - if (a(index_test(i)) .ne. b(index_test(i))) then - print *, "mpi_allgather failed" - ec=ec+1 - end if - end do - print *, "Testing mpi_allgatherv" - call mpi_allgatherv(a, scount, itype, b, rcount, & - disp, itype, mpi_comm_world, ierr) - do i=1,7 - if (a(index_test(i)) .ne. b(index_test(i))) then - print *, "mpi_allgatherv failed" - ec=ec+1 - end if - end do - do i=1,10 - b(i) = 0 - end do - print *, "Testing mpi_scatter" - call mpi_scatter(a, scount, itype, b, rcount, & - itype, 0, mpi_comm_world, ierr) - do i=1,7 - if (a(index_test(i)) .ne. b(index_test(i))) then - print *, "mpi_scatter failed" - ec=ec+1 - end if - end do - do i=1,10 - b(i) = 0 - end do - print *, "Testing mpi_scatterv" - call mpi_scatterv(a, scount, disp, itype, b, & - rcount, itype, 0, mpi_comm_world, ierr) - do i=1,7 - if (a(index_test(i)) .ne. b(index_test(i))) then - print *, "mpi_scatterv failed" - ec=ec+1 - end if - end do - do i=1,10 - b(i) = 0 - end do - print *, "Testing mpi_reduce" - call mpi_reduce(a, b, scount, itype, mpi_max, & - 0, mpi_comm_world, ierr) - do i=1,7 - if (a(index_test(i)) .ne. b(index_test(i))) then - print *, "mpi_reduce failed" - ec=ec+1 - end if - end do - do i=1,10 - b(i) = 0 - end do - print *, "Testing mpi_allreduce" - call mpi_allreduce(a, b, scount, itype, mpi_max, & - mpi_comm_world, ierr) - do i=1,7 - if (a(index_test(i)) .ne. b(index_test(i))) then - print *, "mpi_allreduce failed" - ec=ec+1 - end if - end do - do i=1,10 - b(i) = 0 - end do - print *, "Testing mpi_alltoall" - call mpi_alltoall(a, scount, itype, b, rcount, & - itype, mpi_comm_world, ierr) - do i=1,7 - if (a(index_test(i)) .ne. b(index_test(i))) then - print *, "mpi_alltoall failed" - ec=ec+1 - end if - end do - do i=1,10 - b(i) = 0 - end do - print *, "Testing mpi_alltoallv" - call mpi_alltoallv(a, scount, disp, itype, b, & - rcount, disp, itype, mpi_comm_world, ierr) - do i=1,7 - if (a(index_test(i)) .ne. b(index_test(i))) then - print *, "mpi_alltoallv failed" - ec=ec+1 - end if - end do - do i=1,10 - b(i) = 0 - end do - print *, "Testing mpi_reduce_scatter" - call mpi_reduce_scatter(a, b, rcount, itype, & - mpi_max, mpi_comm_world, ierr) - do i=1,7 - if (a(index_test(i)) .ne. b(index_test(i))) then - print *, "mpi_reduce_scatter failed" - ec=ec+1 - end if - end do - do i=1,10 - b(i) = 0 - end do - print *, "Testing mpi_scan" - call mpi_scan(a, b, scount, itype, mpi_max, & - mpi_comm_world, ierr) - - do i=1,7 - if (a(index_test(i)) .ne. b(index_test(i))) then - print *, "mpi_scan failed" - ec=ec+1 - end if - end do - end subroutine - diff --git a/cime/src/externals/mct/mpi-serial/tests/ftest_internal.F90 b/cime/src/externals/mct/mpi-serial/tests/ftest_internal.F90 deleted file mode 100644 index 9e1f6a676c63..000000000000 --- a/cime/src/externals/mct/mpi-serial/tests/ftest_internal.F90 +++ /dev/null @@ -1,328 +0,0 @@ - program test - use mpi - implicit none - - call test_contiguous() - call test_vector() - call test_simple_hvector() - call test_simple_indexed() - call test_simple_bindexed() - call test_simple_hindexed() - call test_packed() - call test_multiple() - stop - end - -!!!!!!!!!!!!!!!!!!! -! Contiguous type. Simplest example. Strings 5 -! integers together and tests their equality after -! a send operation -!!!!!!!!!!!!!!!!!!! - - subroutine test_contiguous() - use mpi - integer ierr - integer datatype - integer a(5) - integer b(5) - integer i - data a/1,2,3,4,5/ - data b/5 * 0/ - - print *, "Test Contiguous of 5 x MPI_INTEGER" - call mpi_type_contiguous(5, mpi_integer, datatype,ierr) - - call mpi_type_commit(datatype, ierr) - - call print_typemap(datatype,ierr) - call copy_data2(a,1,datatype, b,1,datatype, ierr) - - do i=1,5 - if (a(i) .ne. b(i)) then - print *,">>>FAILED: mpi_type_contiguous" - stop - end if - end do - print *, ">>>PASSED: mpi_type_contiguous" - end - -!!!!!!!!!!!!!!!!!!!!!!!! -! Vector type. collect a series of indices with -! set stride from an array. -!!!!!!!!!!!!!!!!!!!!!!!! - - subroutine test_vector() - use mpi - integer ierr - integer datatype - integer a(10) != (1,2,3,4,5,6,7,8,9,0) - integer b(10) - integer check_index(6) - data a/1,2,3,4,5,6,7,8,9,10/ - data b/10 * 0/ - data check_index/1,2,4,5,7,8/ - integer i - - print *, "Test vector of MPI_INTEGER" - - call mpi_type_vector(3, 2, 3, mpi_integer, datatype, ierr) - call mpi_type_commit(datatype, ierr) - call print_typemap(datatype,ierr) - call copy_data2(a,1,datatype,b,1,datatype,ierr) - - do i=1,6 - if (a(check_index(i)) .ne. b(check_index(i))) then - print *,">>>FAILED: mpi_type_vector" - stop - end if - end do - print *, ">>>PASSED: mpi_type_vector" - end - -!!!!!!!!!!!!!!!!!!!!! -! Byte-addressed vector. -! values calculated with mpi_type_extent(), -! so basically we are doing the work here in the -! test program instead of in the library -!!!!!!!!!!!!!!!!!!!!! - - subroutine test_simple_hvector() - use mpi - integer vector_type - integer (kind=mpi_address_kind) extent - integer i - integer a(10) - integer b(10) - integer index_test(6) - integer ierr - - data a/1,2,3,4,5,6,7,8,9,10/, b/0,0,0,0,0,0,0,0,0,0/ - data index_test/1,2,5,6,9,10/ - - print *, "Vector type of 3 groups of 2 MPI_INTEGER" - print *, "Stride of 4 (in bytes)" - - call mpi_type_extent(mpi_integer, extent, ierr) - call mpi_type_hvector(3, 2, 4 * extent, mpi_integer, & - vector_type, ierr) - call mpi_type_commit(vector_type, ierr) - call print_typemap(vector_type,ierr) - call copy_data2(a,1,vector_type, b,1,vector_type,ierr) - - do i=1,7 - if (a(index_test(i)) .ne. (b(index_test(i)))) then - print *, ">>>FAILED: test_simple_hvector" - stop - end if - end do - print *, ">>>PASSED: test_simple_hvector" - end subroutine - -!!!!!!!!!!!!!!!!!!!! -! indexed type. test certain indices of an array -!!!!!!!!!!!!!!!!!!!! - - subroutine test_simple_indexed() - use mpi - integer i - complex a(15) - complex b(15) - integer index_test(6) - integer blens(3) - integer disps(3) - integer indexed_type - integer ierr - - data a/1,2,3,4,5,6,7,8,9,10,11,12,13,14,15/ - data b/0,0,0,0,0,0,0,0,0,0,0,0,0,0,0/ - data index_test/1,6,7,11,12,13/ - data blens/2,1,3/ - data disps/5,0,10/ - print *, "Indexed type" - - call mpi_type_indexed(3, blens, disps, mpi_complex, & - indexed_type, ierr) - call mpi_type_commit(indexed_type, ierr) - call print_typemap(indexed_type, ierr) - call copy_data2(a,1,indexed_type, b,1,indexed_type,ierr) - - do i=1,6 - if (a(index_test(i)) .ne. b(index_test(i))) then - print *, ">>>FAILED: test_simple_indexed" - stop - end if - end do - print *, ">>>PASSED: test_simple_indexed" - end subroutine - -!!!!!!!!!!!!!!!! -! Block indexed. All blocks have same length -!!!!!!!!!!!!!!!! - - subroutine test_simple_bindexed() - use mpi - integer i - integer disps(3) - integer a(10), b(10) - integer index_test(6) - integer indexed_type - integer ierr - - data disps/0,4,7/ - data a/1,2,3,4,5,6,7,8,9,10/ - data b/0,0,0,0,0,0,0,0,0,0/ - data index_test/1,2,5,6,8,9/ - print *, "Block indexed type" - - call mpi_type_indexed_block(3,2,disps,mpi_integer, & - indexed_type, ierr) - - call mpi_type_commit(indexed_type, ierr) - call print_typemap(indexed_type, ierr) - call copy_data2(a,1,indexed_type, b,1,indexed_type, ierr) - - do i=1,6 - if (a(index_test(i)) .ne. b(index_test(i))) then - print *, ">>>FAILED: test_simple_bindexed" - stop - end if - end do - print *, ">>>PASSED: test_simple_bindexed" - end subroutine - -!!!!!!!!!!!!!!!! -! test_simple_indexed -! test equality of a byte-addressed -! type of integer array -! (disps calculated through mpi_type_extent() -!!!!!!!!!!!!!!! - subroutine test_simple_hindexed() - use mpi - integer i - integer a(10), b(10) - integer index_test(6) - integer blens(3) - integer*8 disps(3) - integer indexed_type - integer*8 extent - integer ierr - - data a/1,2,3,4,5,6,7,8,9,10/ - data b/0,0,0,0,0,0,0,0,0,0/ - data index_test/1,3,4,6,7,8/ - data blens/2,1,3/ - - call mpi_type_extent(mpi_integer, extent, ierr) - disps(1) = 2*extent - disps(2) = 0 - disps(3) = 5*extent - - - print *, "Byte addressed indexed type" - call mpi_type_hindexed(3,blens,disps, MPI_INTEGER, & - indexed_type,ierr) - call mpi_type_commit(indexed_type, ierr) - call print_typemap(indexed_type, ierr) - call copy_data2(a,1,indexed_type, b,1,indexed_type, ierr) - - do i=1,6 - if (a(index_test(i)) .ne. b(index_test(i))) then - print *, ">>>FAILED: test_simple_hindexed" - stop - end if - end do - print *, ">>>PASSED: test_simple_hindexed" - end subroutine - -!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! test_packed() -! Creates a few variable pairs, assigns the first -! of each pair, then packs their values and unpacks -! them to the other set. -!!!!!!!!!!!!!!!!!!!!!!!!!!!! - subroutine test_packed() - use mpi - integer size - integer x, y - real f, g - complex c, d - character*5 a, b - character buf(100), rbuf(100) - integer blens(3) - integer(kind=mpi_address_kind) disps(3) - integer pos - - - x = 10 - f = 14.333 - c = (100, 20) - a = "xyzab" - - pos = 0 - data blens/1,2,1/, disps/0,4,8/ - - print *, "Packed type " - - call mpi_pack(x, 1, mpi_integer, buf, 100, pos, 0, ierr) - call mpi_pack(f, 1, mpi_real, buf, 100, pos, 0, ierr) - call mpi_pack(c, 1, mpi_complex, buf, 100, pos, 0, ierr) - call mpi_pack(a, 5, mpi_character, buf, 100, pos, 0, ierr) - - call copy_data2(buf, pos, mpi_packed, rbuf, pos, & - mpi_packed, ierr) - - pos = 0; - - call mpi_unpack(rbuf, 100, pos, y, 1, mpi_integer, 0, ierr) - call mpi_unpack(rbuf, 100, pos, g, 1, mpi_real, 0, ierr) - call mpi_unpack(rbuf, 100, pos, d, 1, mpi_complex, 0, ierr) - call mpi_unpack(rbuf, 100, pos, b, 5, mpi_character, & - 0, ierr) - - if (x .ne. y .OR. f .ne. g & - .OR. c .ne. d .OR. a .ne. b) & - then - print *, ">>>FAILED: mpi_pack" - stop - end if - - print *, ">>>PASSED: mpi_pack" - - end subroutine - -!!!!!!!!!!!!!!!!!!!!!!!!! -! Test an indexed send with a multiple receive -!!!!!!!!!!!!!!!!!!!!!!!!! - - subroutine test_multiple() - use mpi - integer i - complex a(15) - complex b(15) - integer index_test(6) - integer blens(3) - integer disps(3) - integer indexed_type - integer ierr - - data a/1,2,3,4,5,6,7,8,9,10,11,12,13,14,15/ - data b/0,0,0,0,0,0,0,0,0,0,0,0,0,0,0/ - data index_test/1,6,7,11,12,13/ - data blens/1,2,3/ - data disps/0,5,10/ - print *, "Indexed type" - - call mpi_type_indexed(3, blens, disps, mpi_complex, & - indexed_type, ierr) - call mpi_type_commit(indexed_type, ierr) - call copy_data2(a,1,indexed_type, b,6, mpi_complex, ierr) - - do i=1,6 - if (a(index_test(i)) .ne. b(i)) then - print *, ">>>FAILED: test_multiple" - stop - end if - end do - print *, ">>>PASSED: test_multiple" - end subroutine - diff --git a/cime/src/externals/mct/mpi-serial/tests/ftest_old.F90 b/cime/src/externals/mct/mpi-serial/tests/ftest_old.F90 deleted file mode 100644 index 93075219def5..000000000000 --- a/cime/src/externals/mct/mpi-serial/tests/ftest_old.F90 +++ /dev/null @@ -1,165 +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 - integer errcount - - errcount = 0 - - 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 - - do i=1,5 - if (sbuf(i) .ne. rbuf(i)) then - errcount = errcount+1 - print *, 'error on Send2' - print *, 'found ',sbuf2(i),' should be ',rbuf2(i) - end if - end do - - do i=1,5 - if (sbuf2(i) .ne. rbuf2(i)) then - errcount = errcount+1 - print *, 'error on Send2' - print *, 'found ',sbuf2(i),' should be ',rbuf2(i) - end if - 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) - print *,temp - end do - - do i=1,5 - if (rbuf(i) .ne. sbuf(i)) then - errcount = errcount + 1 - print *,"Error for pack/send/unpack" - print *,"found ",rbuf(i)," should be ",sbuf(i) - end if - end do -! - - - call mpi_finalize(ier) - - do i=1,5 - print *, 'Time=',mpi_wtime() - call sleep(1) - end do - - if (errcount .gt. 0) then - print *,errcount," errors" - else - print *,"No errors" - end if - - end - diff --git a/cime/src/externals/mct/mpi-serial/time.c b/cime/src/externals/mct/mpi-serial/time.c deleted file mode 100644 index 6170009e17d8..000000000000 --- a/cime/src/externals/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/cime/src/externals/mct/mpi-serial/type.c b/cime/src/externals/mct/mpi-serial/type.c deleted file mode 100644 index 22e3d305b387..000000000000 --- a/cime/src/externals/mct/mpi-serial/type.c +++ /dev/null @@ -1,829 +0,0 @@ -/* - * JCY - * 07/2007 - * Derived Datatype functions for mpi-serial - */ - -#include "type.h" -#include "mpiP.h" -#include -#include -#include - -#ifdef HAVE_CONFIG_H -#include -#endif - -/* - * NOTES: All MPI_ prefixed (public) functions operate - * using the integer handle for a datatype. Most of these - * functions are wrapper functions for a different function, - * _not_ prefixed with MPI_. These functions translate the - * handle to a pointer and call the non-MPI_ func. - * - * Fortran bindings use FC_FUNC, as defined in mpiP.h. - */ - - -/* - * Wrapper for mpi_handle_to_ptr in handles.c - * specific for datatype handles, which may be - * predefined negative handles - */ -Datatype* mpi_handle_to_datatype(int handle) -{ - if (handle < 0) - return (Datatype*) &simpletypes[-1-handle]; - else - return (Datatype*) mpi_handle_to_ptr(handle); -} - -/* - * Calculate the epsilon value of typemap - * using the largest element in the typemap - */ - -int calc_padding(Datatype datatype) -{ - long size_max = INT_MIN; - long type_len; - int i; - //find the largest datatype size. The epsilon padding is (probably) based on this. - - for (i = 0; i < datatype->count; i++) - { - type_len = Simpletype_length(datatype->pairs[i].type); - size_max = type_len > size_max ? type_len : size_max; - } - - return size_max; -} - -/* Retrieve size of any simple type - * C sizes use sizeof the literal type - * they represent. Fortran types are those - * as defined in type.h - */ - -int Simpletype_length(Simpletype t) -{ - switch(t) - { - case SIMPLE_CHAR: - return sizeof(char); break; - case SIMPLE_SHORT: - return sizeof(short); break; - case SIMPLE_INT: - return sizeof(int); break; - case SIMPLE_LONG: - return sizeof(long); break; - case SIMPLE_UCHAR: - return sizeof(unsigned char); break; - case SIMPLE_USHORT: - return sizeof(unsigned short); break; - case SIMPLE_UINT: - return sizeof(unsigned int); break; - case SIMPLE_ULONG: - return sizeof(unsigned long); break; - case SIMPLE_FLOAT: - return sizeof(float); break; - case SIMPLE_DOUBLE: - return sizeof(double); break; - case SIMPLE_LDOUBLE: - return sizeof(long double); break; - case SIMPLE_BYTE: - return sizeof(char); break; - case SIMPLE_FINTEGER: - return FSIZE_INTEGER; break; - case SIMPLE_FREAL: - return FSIZE_REAL; break; - case SIMPLE_FDPRECISION: - return FSIZE_DPRECISION; break; - case SIMPLE_FCOMPLEX: - return FSIZE_COMPLEX; break; - case SIMPLE_FDCOMPLEX: - return FSIZE_DCOMPLEX; break; - case SIMPLE_FLOGICAL: - return FSIZE_LOGICAL; break; - case SIMPLE_FCHARACTER: - return FSIZE_CHARACTER; break; - case SIMPLE_FINTEGER1: - return 1; break; - case SIMPLE_FINTEGER2: - return 2; break; - case SIMPLE_FINTEGER4: - return 4; break; - case SIMPLE_FINTEGER8: - return 8; break; - case SIMPLE_FREAL4: - return 4; break; - case SIMPLE_FREAL8: - return 8; break; - case SIMPLE_FREAL16: - return 16; break; - case SIMPLE_FCOMPLEX8: - return 8; break; - case SIMPLE_FCOMPLEX16: - return 16; break; - case SIMPLE_FCOMPLEX32: - return 32; break; - case SIMPLE_LONGLONG: - return sizeof(long long); break; - case SIMPLE_ULONGLONG: - return sizeof(unsigned long long); break; - case SIMPLE_OFFSET: - return sizeof(MPI_Offset); break; - - default: - printf("Invalid simple type\n"); - exit(1); - } -} - -/* - * calculates the lower bound of a datatype using typemap - * (This gives no regard to MPI_LB, but rather uses only displacements) - */ -long calc_lb(Datatype type) -{ - int i; - int min_disp = INT_MAX; - typepair * tp; - - for(i =0; i < type->count; i++) - { - tp = type->pairs+i; - min_disp = tp->disp < min_disp - ? tp->disp - : min_disp; - } - return min_disp; -} - -/* - * Calculate upper bound using typemap - * (Gives no regard to MPI_UB, just calculates - * highest displacement+size of its respective data type) - */ -long calc_ub(Datatype type) -{ - int i; - long max_disp = INT_MIN; - typepair * tp; - - for(i = 0; i < type->count; i++) - { - tp = type->pairs+i; - max_disp = tp->disp + Simpletype_length(tp->type) > max_disp - ? tp->disp + Simpletype_length(tp->type) - : max_disp; - } - - return max_disp; -} - - -/*******************************************************/ -/* MPI_Type_struct is the most general type constructor that - * does the common work other constructors. - * All other type constructors call this function. - */ - -FC_FUNC( mpi_type_struct, MPI_TYPE_STRUCT ) - (int * count, int * blocklens, long * displacements, - int *oldtypes_ptr, int *newtype, int *ierror) -{ - *ierror=MPI_Type_struct(*count, blocklens, displacements, - oldtypes_ptr, newtype); -} - -/* Public function, wrapper for Type_struct that translates handle to - * pointer (see NOTES at top of file) - */ -int MPI_Type_struct(int count, int * blocklens, MPI_Aint * displacements, - MPI_Datatype *oldtypes, MPI_Datatype *newtype) -{ - int i; - Datatype oldtypes_ptr[count]; - Datatype * newtype_ptr; - - for (i = 0; i < count; i++) - { - oldtypes_ptr[i] = *(Datatype*) mpi_handle_to_datatype(oldtypes[i]); - } - - mpi_alloc_handle(newtype, (void**) &newtype_ptr); - - return Type_struct(count, blocklens, displacements, - oldtypes_ptr, newtype_ptr); -} - -int Type_struct(int count, int * blocklens, MPI_Aint * displacements, - Datatype *oldtypes_ptr, Datatype *newtype) -{ - int i, j, k; - Datatype temp, temp2; - int newcount; - char override_lower = 0, //whether to override - override_upper = 0; - MPI_Aint new_lb = LONG_MAX, - new_ub = LONG_MIN, - clb, cub; //calculated lb and ub - int simpletype_count = 0; //total additional blocks for malloc - MPI_Aint tmp_offset; //for contiguous blocks of type - MPI_Aint extent; - - // find the total number of elements in the typemap we need to add. - for (i = 0; i < count; i++) - { - //check for MPI_UB or MPI_LB. These types are special - // cases and will be skipped over - - temp2 = oldtypes_ptr[i]; - if (temp2->pairs[0].type == SIMPLE_LOWER) - { - //found MPI_LB. This is a candidate for the actual lb - if (new_lb > displacements[i]) - new_lb = displacements[i]; - override_lower = 1; - } - else if (temp2->pairs[0].type == SIMPLE_UPPER) - { - //same as above, but ub - if (new_ub < displacements[i]) - new_ub = displacements[i]; - override_upper = 1; - } - else - { - //this is not MPI_LB or MPI_UB - //However it may still have overriding bounds - //Test for these and add its size to the typemap. - - if (temp2->o_lb) - // this type's lb has been overridden. - // ONLY an overriding lb can be the actual lb now. - override_lower = 1; - if (temp2->o_ub) - //same as above, but ub - override_upper = 1; - - simpletype_count += blocklens[i] * oldtypes_ptr[i]->count; - } - } - temp = malloc(sizeof(Typestruct) + - ((simpletype_count-1) * sizeof(typepair))); - - temp->count = simpletype_count; - - i = 0; //old type's index - newcount = 0; //new type's index - - while (i < count) - { - tmp_offset = 0; - - temp2 = oldtypes_ptr[i]; - - //test for previous MPI_LB or MPI_UB in one of the comprising types. - //If found, skip over. - if (!((temp2->pairs[0].type == SIMPLE_LOWER) || - (temp2->pairs[0].type == SIMPLE_UPPER))) - { - for (j = 0; j < blocklens[i]; j++) - { - //Copy the old type's typemap and merge into the new type - //by a "flattening" process - Type_extent((Datatype) oldtypes_ptr[i], &extent); - - tmp_offset = j * extent; - - if (temp2->o_lb && temp2->lb+displacements[i]+tmp_offset < new_lb) - new_lb = temp2->lb+displacements[i]+tmp_offset; - if (temp2->o_ub && temp2->ub+displacements[i]+tmp_offset > new_ub) - { - new_ub = temp2->ub+displacements[i]+tmp_offset; - } - - for (k = 0; k < oldtypes_ptr[i]->count; k++) - { - Copy_type( (typepair*) oldtypes_ptr[i]->pairs+k, - (typepair*) (temp->pairs+newcount)); - - - ((typepair*) temp->pairs+(newcount))->disp += - displacements[i] + tmp_offset; - newcount++; - } - } - } - i++; - } - //type is NOT committed - temp->committed = 0; - - //assign upper and lower bounds here - if (override_lower) - { - //use lowest previous overridden lower bound - temp->o_lb = 1; - temp->lb = new_lb; - } - else - { - //use calculation - temp->lb = calc_lb(temp); - } - - if (override_upper) - { - temp->o_ub = 1; - temp->ub = new_ub; - } - else - { - temp->ub = calc_ub(temp); - } - - *newtype = temp; - temp = MPI_DATATYPE_NULL; - - return MPI_SUCCESS; -} - -/*******************************************************/ -/* MPI_Type_contiguous. Create count copies of a type. - * this creates arrays of the singleton arguments and use them to call - * MPI_Type_struct() - */ - -FC_FUNC( mpi_type_contiguous, MPI_TYPE_CONTIGUOUS ) - (int *count, int *oldtype, int * newtype, int * ierr) -{ - *ierr = MPI_Type_contiguous(*count, *oldtype, newtype); -} - -int MPI_Type_contiguous(int count, MPI_Datatype old, MPI_Datatype * new) -{ - int ret; - Datatype old_ptr = *(Datatype*) mpi_handle_to_datatype(old); - Datatype * new_ptr; - - mpi_alloc_handle(new, (void**) &new_ptr); - - return Type_contiguous(count, old_ptr, new_ptr); -} - -int Type_contiguous(int count, Datatype oldtype, Datatype *newtype) -{ - int i; - int blocklengths[count]; - Datatype oldtypes[count]; - MPI_Aint offsets[count]; - MPI_Aint extent; - - //each copy is strided by the extent of the datatype. - // Calculate that here. - Type_extent(oldtype, &extent); - for (i = 0; i < count; i++) - { - blocklengths[i] = 1; - offsets[i] = extent * i; - oldtypes[i] = oldtype; - } - return Type_struct(count, blocklengths, offsets, oldtypes, newtype); -} - -/*************************/ -/* Type_vector - */ - -FC_FUNC( mpi_type_vector, MPI_TYPE_VECTOR ) - (int * count, int * blocklen, int * stride, - int * oldtype, int * newtype, int * ierr) -{ - *ierr = MPI_Type_vector(*count, *blocklen, *stride, *oldtype, newtype); -} - -int MPI_Type_vector(int count, int blocklen, int stride, - MPI_Datatype oldtype, MPI_Datatype * newtype) -{ - Datatype old_ptr = *(Datatype*) mpi_handle_to_datatype(oldtype); - Datatype * new_ptr; - - mpi_alloc_handle(newtype, (void**) &new_ptr); - - return Type_vector(count, blocklen, stride, old_ptr, new_ptr); -} - - -int Type_vector(int count, int blocklen, int stride, - Datatype oldtype, Datatype *newtype) -{ - MPI_Aint extent; - MPI_Aint bstride; - - Type_extent(oldtype, &extent); - bstride = stride * extent; - - return Type_hvector(count, blocklen, bstride, oldtype, newtype); -} - -/*******************************************************/ - -FC_FUNC( mpi_type_hvector, MPI_TYPE_HVECTOR ) - (int * count, long * blocklen, long * stride, - int * oldtype, int * newtype, int * ierr) -{ - *ierr = MPI_Type_hvector(*count, *blocklen, *stride, *oldtype, newtype); -} - -int MPI_Type_hvector(int count, int blocklen, MPI_Aint stride, - MPI_Datatype oldtype, MPI_Datatype * newtype) -{ - Datatype old_ptr = *(Datatype*) mpi_handle_to_datatype(oldtype); - Datatype * new_ptr; - - mpi_alloc_handle(newtype, (void**) &new_ptr); - return Type_hvector(count, blocklen, stride, old_ptr, new_ptr); -} - - -int Type_hvector(int count, int blocklen, MPI_Aint stride, - Datatype oldtype, Datatype *newtype) -{ - int i; - int blocklengths[count]; - Datatype oldtypes[count]; - MPI_Aint offsets[count]; - MPI_Aint extent; - - Type_extent(oldtype, &extent); - for (i = 0; i < count; i++) - { - blocklengths[i] = blocklen; - offsets[i] = stride * i; - oldtypes[i] = oldtype; - } - - return Type_struct(count, blocklengths, offsets, oldtypes, newtype); -} - -/*******************************************************/ - -FC_FUNC( mpi_type_indexed, MPI_TYPE_INDEXED ) - (int * count, int * blocklens, int * displacements, - int * oldtype, int * newtype, int * ierr) -{ - *ierr = MPI_Type_indexed(*count, blocklens, displacements, *oldtype, newtype); -} - - -int MPI_Type_indexed(int count, int *blocklens, int *displacements, - MPI_Datatype oldtype, MPI_Datatype * newtype) -{ - Datatype old_ptr = *(Datatype*) mpi_handle_to_datatype(oldtype); - Datatype * new_ptr; - - mpi_alloc_handle(newtype, (void**) &new_ptr); - return Type_indexed(count, blocklens, displacements, old_ptr, new_ptr); -} - -int Type_indexed(int count, int *blocklens, int *displacements, - Datatype oldtype, Datatype *newtype) -{ - int i; - MPI_Aint extent; - MPI_Aint bdisps[count]; - - for (i = 0; i < count; i++) - { - Type_extent(oldtype, &extent); - bdisps[i] = displacements[i] * extent; - } - - return Type_hindexed(count, blocklens, bdisps, oldtype, newtype); -} - -/*******************************************************/ - -FC_FUNC( mpi_type_create_indexed_block, MPI_TYPE_CREATE_INDEXED_BLOCK ) - (int * count, int * blocklen, int * displacements, - int * oldtype, int * newtype, int * ierr) -{ - *ierr = MPI_Type_create_indexed_block(*count, *blocklen, displacements, - *oldtype, newtype); -} - -int MPI_Type_create_indexed_block(int count, int blocklen, int *displacements, - MPI_Datatype oldtype, MPI_Datatype * newtype) -{ - int ret; - Datatype old_ptr = *(Datatype*) mpi_handle_to_datatype(oldtype); - Datatype * new_ptr; - - mpi_alloc_handle(newtype, (void**) &new_ptr); - return Type_create_indexed_block(count, blocklen, displacements, old_ptr, new_ptr); -} - -int Type_create_indexed_block(int count, int blocklen, int *displacements, - Datatype oldtype, Datatype *newtype) -{ - int i; - int blocklens[count]; - - for (i = 0; i < count; i++) - blocklens[i] = blocklen; - - return Type_indexed(count, blocklens, displacements, oldtype, newtype); -} - -/*******************************************************/ - -FC_FUNC( mpi_type_hindexed, MPI_TYPE_HINDEXED ) - (int * count, int * blocklens, MPI_Aint * displacements, - int * oldtype, int * newtype, int * ierr) -{ - *ierr = MPI_Type_hindexed(*count, blocklens, displacements, - *oldtype, newtype); -} - -int MPI_Type_hindexed(int count, int *blocklens, MPI_Aint * disps, - MPI_Datatype oldtype, MPI_Datatype * newtype) -{ - Datatype old_ptr = *(Datatype*) mpi_handle_to_datatype(oldtype); - Datatype * new_ptr; - - mpi_alloc_handle(newtype, (void**) &new_ptr); - return Type_hindexed(count, blocklens, disps, old_ptr, new_ptr); -} - -int Type_hindexed(int count, int *blocklens, MPI_Aint *displacements, - Datatype oldtype, Datatype *newtype) -{ - int i; - Datatype oldtypes[count]; - - for (i = 0; i < count; i++) - { - oldtypes[i] = oldtype; - } - - return Type_struct(count, blocklens, displacements, oldtypes, newtype); -} - - -/*******************************************************/ - -int Type_dup(Datatype oldtype, Datatype *newtype) -{ - int i; - //create a deep copy of given Datatype - newtype = malloc(sizeof(oldtype)); - (*newtype)->committed = oldtype->committed; - (*newtype)->lb = oldtype->lb; - (*newtype)->ub = oldtype->ub; - (*newtype)->o_lb = oldtype->o_lb; - (*newtype)->o_ub = oldtype->o_ub; - - for (i = 0; i < oldtype->count; i++) - { - Copy_type((typepair*) oldtype->pairs + i, - (typepair*) (*newtype)->pairs + i ); - } -} - -/* copy_type: Creates a deep copy of source typepair into dest - */ -int Copy_type(typepair *source, typepair *dest) -{ - dest->type = source->type; - dest->disp = source->disp; -} - -/* MPI_Type_size: Returns the sum of the lengths of each simple - * type that makes up the data type argument - */ -FC_FUNC( mpi_type_size, MPI_TYPE_SIZE )(int * type, int * size, int * ierr) -{ - *ierr=MPI_Type_size(*type, size); -} - -int MPI_Type_size(MPI_Datatype type, int * size) -{ - Datatype type_ptr = *(Datatype*) mpi_handle_to_datatype(type); - return Type_size(type_ptr, size); -} - -int Type_size(Datatype type, int * size) -{ - int i; - *size = 0; - for (i=0; i < type->count; i++) - *size += Simpletype_length(type->pairs[i].type); - - - return MPI_SUCCESS; -} -/* MPI_Type_lb: Returns the lower bound (which may be overridden - * or calculated) - */ -FC_FUNC( mpi_type_lb, MPI_TYPE_LB )(int * type, long * lb, int * ierr) -{ - *ierr = MPI_Type_lb(*type, lb); -} - -int MPI_Type_lb(MPI_Datatype type, MPI_Aint * lb) -{ - Datatype type_ptr = *(Datatype*) mpi_handle_to_datatype(type); - - return Type_lb(type_ptr, lb); -} - -int Type_lb(Datatype type, MPI_Aint * lb) -{ - *lb = type->lb; -} - -/* MPI_Type_ub: Return upper bound (which may be overridden - * or calculated - */ -FC_FUNC( mpi_type_ub, MPI_TYPE_UB )(int * type, long * ub, int * ierr) -{ - *ierr = MPI_Type_ub(*type, ub); -} - -int MPI_Type_ub(MPI_Datatype type, MPI_Aint * ub) -{ - Datatype type_ptr = *(Datatype*) mpi_handle_to_datatype(type); - - return Type_ub(type_ptr, ub); -} - -int Type_ub(Datatype type, MPI_Aint * ub) -{ - *ub = type->ub; -} - -/* MPI_Get_address - * MPI_Address - * Return address of an object - */ -FC_FUNC( mpi_get_address, MPI_ADDRESS )(void * loc, long * address, int * ierr) -{ - *ierr = FGet_address(loc, address); -} - -FC_FUNC( mpi_address, MPI_ADDRESS )(void * loc, long * address, int * ierr) -{ - *address = (long) loc; - *ierr = FGet_address(loc, address); -} - -int FGet_address(void * loc, long * address, int * ierr) -{ - *address = (long) loc; - return MPI_SUCCESS; -} - -int MPI_Address(void * loc, MPI_Aint * address) -{ - return MPI_Get_address(loc, address); -} - -int MPI_Get_address(void * loc, MPI_Aint * address) -{ - *address = (MPI_Aint) loc; - return MPI_SUCCESS; -} - -/* MPI_Type_extent: return ub-lb, plus padding - */ -FC_FUNC( mpi_type_extent, MPI_TYPE_EXTENT)(int * type, long * extent, int * ierr) -{ - *ierr = MPI_Type_extent(*type, extent); -} - -int MPI_Type_extent(MPI_Datatype type, MPI_Aint * extent) -{ - Datatype type_ptr = *(Datatype*) mpi_handle_to_datatype(type); - - return Type_extent(type_ptr, extent); -} - -int Type_extent(Datatype datatype, MPI_Aint * extent) -{ - - if (!(datatype->o_lb || datatype->o_ub)) - { - int epsilon = calc_padding(datatype); - //current epsilon value is based off of largest datatype size - int mod = (datatype->ub - datatype->lb) % epsilon; - if (mod == 0) - epsilon = 0; - else - epsilon = epsilon - mod; - *extent = (datatype->ub - datatype->lb) + epsilon; - } - else - { - *extent = datatype->ub - datatype->lb; - } - - return MPI_SUCCESS; -} - -/* True_extent returns an extent based only on - * calculated upper and lower bound, regardless of any - * override using MPI_LB or MPI_UB - */ -int Type_get_true_extent(Datatype type, MPI_Aint * extent) -{ - long epsilon = calc_padding(type); - long ub = calc_ub(type); - long lb = calc_lb(type); - //current epsilon value is based off of largest datatype size - long mod = (ub - lb) % epsilon; - if (mod == 0) - epsilon = 0; - else - epsilon = epsilon - mod; - *extent = (ub - lb) + epsilon; - - return MPI_SUCCESS; -} - -/***********************/ - -FC_FUNC( mpi_type_commit, MPI_TYPE_COMMIT )(int * datatype, int * ierr) -{ - *ierr = MPI_Type_commit(datatype); -} - -int MPI_Type_commit(MPI_Datatype * datatype) -{ - Datatype type_ptr = *(Datatype*) mpi_handle_to_datatype(*datatype); - (type_ptr)->committed = 1; - - return MPI_SUCCESS; -} - -/**********************/ -FC_FUNC( mpi_type_free, MPI_TYPE_FREE )(int * datatype, int * ierr) -{ - *ierr = MPI_Type_free(datatype); -} - -int MPI_Type_free(MPI_Datatype * datatype) -{ - Datatype type_ptr = *(Datatype*) mpi_handle_to_datatype(*datatype); - free(type_ptr); - type_ptr = MPI_DATATYPE_NULL; - - mpi_free_handle(*datatype); - - return MPI_SUCCESS; -} - -/* Print_typemap is used in test programs only when - * --enable-test-internal is enabled in configure. - */ - -#ifdef TEST_INTERNAL -FC_FUNC( print_typemap, PRINT_TYPEMAP )(int * type, int * ierr) -{ - *ierr = print_typemap(*type); -} - -int print_typemap(MPI_Datatype type) -{ - Datatype type_ptr = *(Datatype*) mpi_handle_to_datatype(type); - - return Pprint_typemap(type_ptr); -} - -int Pprint_typemap(Datatype type) -{ - int i; - MPI_Aint extent; - Type_extent(type, &extent); - - printf("Type with %d type pairs.\n>> lb is %d\n>> ub is %d\n>>" - "Extent is %d\n>>Epsilon based on %d\nTypemap: \n{", - type->count, type->lb, type->ub, extent, calc_padding(type)); - - for (i = 0; i < type->count; i++) - { - printf("(t%d:%d, o%d)", type->pairs[i].type, - Simpletype_length(type->pairs[i].type), - type->pairs[i].disp); - - if (i != type->count-1) - printf(", "); - } - printf("}\n"); - - return MPI_SUCCESS; -} -#endif //TEST_INTERNAL - diff --git a/cime/src/externals/mct/mpi-serial/type.h b/cime/src/externals/mct/mpi-serial/type.h deleted file mode 100644 index cd92b78f1b7d..000000000000 --- a/cime/src/externals/mct/mpi-serial/type.h +++ /dev/null @@ -1,124 +0,0 @@ -#ifndef TYPE_H -#define TYPE_H - -/* type.h */ -/* defines interface and types used for mpi-serial user-defined datatypes */ - -#include "mpiP.h" - -//for Fortran type sizes -#ifdef HAVE_CONFIG_H -#include -#endif - -//predefined type value used in typemap -typedef int Simpletype; - -typedef struct -{ - long disp; - Simpletype type; -} typepair; - -typedef struct -{ - int count; - long ub; - long lb; - int committed; //type has been committed - int o_lb; //overridden lower/upper bound - int o_ub; // " - /* pairs[] is size 2 because of predefined types - * such as MPI_2INT that have 2 typemap entries - * upon initialization. - */ - typepair pairs[2]; -} Typestruct; - -typedef Typestruct* Datatype; - -//Simpletype constants -#define SIMPLE_CHAR 0 -#define SIMPLE_SHORT 1 -#define SIMPLE_INT 2 -#define SIMPLE_LONG 3 -#define SIMPLE_UCHAR 4 -#define SIMPLE_USHORT 5 -#define SIMPLE_UINT 6 -#define SIMPLE_ULONG 7 -#define SIMPLE_FLOAT 8 -#define SIMPLE_DOUBLE 9 -#define SIMPLE_LDOUBLE 10 -#define SIMPLE_BYTE 11 -#define SIMPLE_LOWER 12 -#define SIMPLE_UPPER 13 -#define SIMPLE_FINTEGER 14 -#define SIMPLE_FREAL 15 -#define SIMPLE_FDPRECISION 16 -#define SIMPLE_FCOMPLEX 17 -#define SIMPLE_FDCOMPLEX 18 -#define SIMPLE_FLOGICAL 19 -#define SIMPLE_FCHARACTER 20 - -#define SIMPLE_FINTEGER1 21 -#define SIMPLE_FINTEGER2 22 -#define SIMPLE_FINTEGER4 23 -#define SIMPLE_FINTEGER8 24 -#define SIMPLE_FINTEGER16 25 - -#define SIMPLE_FREAL4 26 -#define SIMPLE_FREAL8 27 -#define SIMPLE_FREAL16 28 - -#define SIMPLE_FCOMPLEX8 29 -#define SIMPLE_FCOMPLEX16 30 -#define SIMPLE_FCOMPLEX32 31 - -#define SIMPLE_LONGLONG 32 -#define SIMPLE_ULONGLONG 33 - -#define SIMPLE_OFFSET 34 - -//internal type functions -int Simpletype_length(Simpletype s); - -//testing only -int print_typemap(MPI_Datatype in); - - -/* - * Fortran type sizes - * - * If config.h is used and the user has specified - * sizes using --enable-fort-real and --enable-fort-double - * args, they will be used here. Otherwise just take a shot - * in the dark? - * - */ - -#ifdef CONFIG_FORT_REAL -#define FSIZE_REAL CONFIG_FORT_REAL -#else -#define FSIZE_REAL 4 //guess something reasonable -#endif - -#ifdef CONFIG_FORT_DOUBLE -#define FSIZE_DPRECISION CONFIG_FORT_DOUBLE -#else -#define FSIZE_DPRECISION 8 -#endif - -#define FSIZE_INTEGER 4 -#define FSIZE_COMPLEX 2*FSIZE_REAL -#define FSIZE_DCOMPLEX 2*FSIZE_DPRECISION -#define FSIZE_LOGICAL 4 -#define FSIZE_CHARACTER 1 - -const extern Datatype simpletypes[]; -Datatype* mpi_handle_to_datatype(int handle); - -extern int Unpack(void * inbuf, int insize, int * position, void *outbuf, - int outcount, Datatype type, Comm* comm); -extern int Pack(void *inbuf, int incount, Datatype type, - void *outbuf, int outsize, int *position, Comm * comm); -#endif /* TYPE_H */ diff --git a/cime/src/externals/mct/mpi-serial/type_const.c b/cime/src/externals/mct/mpi-serial/type_const.c deleted file mode 100644 index fcb6ed4e46dd..000000000000 --- a/cime/src/externals/mct/mpi-serial/type_const.c +++ /dev/null @@ -1,189 +0,0 @@ -#include "type.h" - - /* Here are the statically initialized structs for the predefined datatypes. - */ - - //C type structs - Typestruct TSchar = {.count=1, .lb=0, .ub=sizeof(char), - .committed=1, .o_lb=0, .o_ub=0, .pairs[0] = - {.disp = 0, .type = (Simpletype) SIMPLE_CHAR }}; - Typestruct TSshort = {.count=1, .lb=0, .ub=sizeof(short), - .committed=1, .o_lb=0, .o_ub=0, .pairs[0] = - {.disp = 0, .type = (Simpletype) SIMPLE_SHORT }}; - Typestruct TSint = {.count = 1, .lb = 0, .ub=sizeof(int), - .committed=1, .o_lb = 0, .o_ub = 0, .pairs[0]= - {.disp = 0, .type = (Simpletype) SIMPLE_INT }}; - Typestruct TSlong = {.count = 1, .lb = 0, .ub = sizeof(long), - .committed=1, .o_lb = 0, .o_ub = 0, .pairs[0] = - {.disp = 0, .type = (Simpletype) SIMPLE_LONG }}; - Typestruct TSuchar = {.count = 1, .lb = 0, .ub=sizeof(unsigned char), - .committed=1, .o_lb = 0, .o_ub = 0, .pairs[0] = - {.disp = 0, .type = (Simpletype) SIMPLE_UCHAR }}; - Typestruct TSushort = {.count = 1, .lb = 0, .ub=sizeof(unsigned short), - .committed=1, .o_lb = 0, .o_ub = 0, .pairs[0] = - {.disp = 0, .type = (Simpletype) SIMPLE_USHORT }}; - Typestruct TSuint = {.count = 1, .lb = 0, .ub = sizeof(unsigned int), - .committed=1, .o_lb = 0, .o_ub = 0, .pairs[0] = - {.disp = 0, .type = (Simpletype) SIMPLE_UINT }}; - Typestruct TSulong = {.count = 1, .lb = 0, .ub = sizeof(unsigned long), - .committed=1, .o_lb = 0, .o_ub = 0, .pairs[0] = - {.disp = 0, .type = (Simpletype) SIMPLE_ULONG }}; - Typestruct TSfloat = {.count = 1, .lb = 0, .ub = sizeof(float), - .committed=1, .o_lb = 0, .o_ub = 0, .pairs[0] = - {.disp = 0, .type = (Simpletype) SIMPLE_FLOAT }}; - Typestruct TSdouble = {.count = 1, .lb = 0, .ub = sizeof(double), - .committed=1, .o_lb = 0, .o_ub = 0, .pairs[0] = - {.disp = 0, .type = (Simpletype) SIMPLE_DOUBLE }}; - Typestruct TSldouble = {.count = 1, .lb = 0, .ub = sizeof(long double), - .committed=1,.o_lb = 0, .o_ub = 0, .pairs[0] = - {.disp = 0, .type = (Simpletype) SIMPLE_LDOUBLE }}; - - //Cross-language types - Typestruct TSbyte = { .count = 1, .lb = 0, .ub = sizeof(char), .committed = 1, - .o_lb = 0, .o_ub = 0, .pairs[0] = { .disp = 0, .type = (Simpletype) SIMPLE_BYTE } }; - Typestruct TSpacked = { .count = 1, .lb = 0, .ub = sizeof(char), .committed = 1, - .o_lb = 0, .o_ub = 0, .pairs[0] = { .disp = 0, .type = (Simpletype) SIMPLE_BYTE } }; - Typestruct TSlower = { .count = 1, .lb = 0, .ub = 0, .committed = 1, - .o_lb = 0, .o_ub = 0, .pairs[0] = { .disp = 0, .type = (Simpletype) SIMPLE_LOWER } }; - Typestruct TSupper = { .count = 1, .lb = 0, .ub = 0, .committed = 1, - .o_lb = 0, .o_ub = 0, .pairs[0] = { .disp = 0, .type = (Simpletype) SIMPLE_UPPER } }; - - //Fortran type structs - Typestruct TSinteger = { .count = 1, .lb = 0, .ub = FSIZE_INTEGER, .committed = 1, - .o_lb = 0, .o_ub = 0, .pairs[0] = { .disp = 0, .type = (Simpletype) SIMPLE_FINTEGER } }; - Typestruct TSreal = { .count = 1, .lb = 0, .ub = FSIZE_REAL, .committed = 1, - .o_lb = 0, .o_ub = 0, .pairs[0] = { .disp = 0, .type = (Simpletype) SIMPLE_FREAL } }; - Typestruct TSdprecision = { .count = 1, .lb = 0, .ub = FSIZE_DPRECISION, .committed = 1, - .o_lb = 0, .o_ub = 0, .pairs[0] = { .disp = 0, .type = (Simpletype) SIMPLE_FDPRECISION } }; - Typestruct TScomplex = { .count = 1, .lb = 0, .ub = FSIZE_COMPLEX, .committed = 1, - .o_lb = 0, .o_ub = 0, .pairs[0] = { .disp = 0, .type = (Simpletype) SIMPLE_FCOMPLEX } }; - Typestruct TSdcomplex = { .count = 1, .lb = 0, .ub = FSIZE_DCOMPLEX, .committed = 1, - .o_lb = 0, .o_ub = 0, .pairs[0] = { .disp = 0, .type = (Simpletype) SIMPLE_FDCOMPLEX } }; - Typestruct TSlogical = { .count = 1, .lb = 0, .ub = FSIZE_LOGICAL, .committed = 1, - .o_lb = 0, .o_ub = 0, .pairs[0] = { .disp = 0, .type = (Simpletype) SIMPLE_FLOGICAL } }; - Typestruct TScharacter = { .count = 1, .lb = 0, .ub = FSIZE_CHARACTER, .committed = 1, - .o_lb = 0, .o_ub = 0, .pairs[0] = { .disp = 0, .type = (Simpletype) SIMPLE_FCHARACTER } }; - - /*Reduction function types (C) - */ - Typestruct TSfloat_int = { .count = 2, .lb = 0, .ub = sizeof(struct {float a; int b;}), .committed = 1, - .o_lb = 0, .o_ub = 0, .pairs[0] = { .disp = 0, .type = (Simpletype) SIMPLE_FLOAT }, - .pairs[1] = { .disp=sizeof(float), .type = (Simpletype) SIMPLE_INT}}; - Typestruct TSdouble_int = { .count = 2, .lb = 0, .ub = sizeof(struct {double a; int b;}), .committed = 1, - .o_lb = 0, .o_ub = 0, .pairs[0] = { .disp = 0, .type = (Simpletype) SIMPLE_DOUBLE }, - .pairs[1] = { .disp=sizeof(double), .type = (Simpletype) SIMPLE_INT}}; - Typestruct TSlong_int = { .count = 2, .lb = 0, .ub = sizeof(struct {long a; int b;}), .committed = 1, - .o_lb = 0, .o_ub = 0, .pairs[0] = { .disp = 0, .type = (Simpletype) SIMPLE_LONG }, - .pairs[1] = { .disp=sizeof(long), .type = (Simpletype) SIMPLE_INT}}; - Typestruct TS2int = { .count = 2, .lb = 0, .ub = 2*sizeof(int), .committed = 1, - .o_lb = 0, .o_ub = 0, .pairs[0] = { .disp = 0, .type = (Simpletype) SIMPLE_INT }, - .pairs[1] = { .disp=sizeof(int), .type = (Simpletype) SIMPLE_INT}}; - Typestruct TSshort_int = { .count = 2, .lb = 0, .ub = sizeof(struct {short a; int b;}), .committed = 1, - .o_lb = 0, .o_ub = 0, .pairs[0] = { .disp = 0, .type = (Simpletype) SIMPLE_SHORT }, - .pairs[1] = { .disp=sizeof(int), .type = (Simpletype) SIMPLE_INT}}; - Typestruct TSldouble_int = { .count = 2, .lb = 0, .ub = sizeof(struct {long double a; int b;}), .committed = 1, - .o_lb = 0, .o_ub = 0, .pairs[0] = { .disp = 0, .type = (Simpletype) SIMPLE_LDOUBLE }, - .pairs[1] = { .disp=sizeof(long double), .type = (Simpletype) SIMPLE_INT}}; - - /* Reduction function types (Fortran) - */ - Typestruct TS2real = { .count = 2, .lb = 0, .ub = 2*FSIZE_REAL, .committed = 1, - .o_lb = 0, .o_ub = 0, .pairs[0] = { .disp = 0, .type = (Simpletype) SIMPLE_FREAL }, - .pairs[1] = { .disp=FSIZE_REAL, .type = (Simpletype) SIMPLE_FREAL}}; - Typestruct TS2dprecision = { .count = 2, .lb = 0, .ub = 2*FSIZE_DPRECISION, .committed = 1, - .o_lb = 0, .o_ub = 0, .pairs[0] = { .disp = 0, .type = (Simpletype) SIMPLE_FDPRECISION }, - .pairs[1] = { .disp=FSIZE_DPRECISION, .type = (Simpletype) SIMPLE_FDPRECISION}}; - Typestruct TS2integer = { .count = 2, .lb = 0, .ub = 2*FSIZE_INTEGER, .committed = 1, - .o_lb = 0, .o_ub = 0, .pairs[0] = { .disp = 0, .type = (Simpletype) SIMPLE_FINTEGER }, - .pairs[1] = { .disp=FSIZE_INTEGER, .type = (Simpletype) SIMPLE_FINTEGER}}; - - - /* Fortran sized types - */ - - Typestruct TSinteger1 = {.count = 1, .lb = 0, .ub=1, - .committed=1, .o_lb = 0, .o_ub = 0, .pairs[0]= - {.disp = 0, .type = (Simpletype) SIMPLE_FINTEGER1 }}; - - Typestruct TSinteger2 = {.count = 1, .lb = 0, .ub=2, - .committed=1, .o_lb = 0, .o_ub = 0, .pairs[0]= - {.disp = 0, .type = (Simpletype) SIMPLE_FINTEGER2 }}; - - Typestruct TSinteger4 = {.count = 1, .lb = 0, .ub=4, - .committed=1, .o_lb = 0, .o_ub = 0, .pairs[0]= - {.disp = 0, .type = (Simpletype) SIMPLE_FINTEGER4 }}; - - Typestruct TSinteger8 = {.count = 1, .lb = 0, .ub=8, - .committed=1, .o_lb = 0, .o_ub = 0, .pairs[0]= - {.disp = 0, .type = (Simpletype) SIMPLE_FINTEGER8 }}; - - Typestruct TSinteger16 = {.count = 1, .lb = 0, .ub=16, - .committed=1, .o_lb = 0, .o_ub = 0, .pairs[0]= - {.disp = 0, .type = (Simpletype) SIMPLE_FINTEGER16 }}; - - - Typestruct TSreal4 = {.count = 1, .lb = 0, .ub=4, - .committed=1, .o_lb = 0, .o_ub = 0, .pairs[0]= - {.disp = 0, .type = (Simpletype) SIMPLE_FREAL4 }}; - - Typestruct TSreal8 = {.count = 1, .lb = 0, .ub=8, - .committed=1, .o_lb = 0, .o_ub = 0, .pairs[0]= - {.disp = 0, .type = (Simpletype) SIMPLE_FREAL8 }}; - - Typestruct TSreal16 = {.count = 1, .lb = 0, .ub=16, - .committed=1, .o_lb = 0, .o_ub = 0, .pairs[0]= - {.disp = 0, .type = (Simpletype) SIMPLE_FREAL16 }}; - - Typestruct TScomplex8 = {.count = 1, .lb = 0, .ub=8, - .committed=1, .o_lb = 0, .o_ub = 0, .pairs[0]= - {.disp = 0, .type = (Simpletype) SIMPLE_FCOMPLEX8 }}; - - Typestruct TScomplex16 = {.count = 1, .lb = 0, .ub=16, - .committed=1, .o_lb = 0, .o_ub = 0, .pairs[0]= - {.disp = 0, .type = (Simpletype) SIMPLE_FCOMPLEX16 }}; - - Typestruct TScomplex32 = {.count = 1, .lb = 0, .ub=32, - .committed=1, .o_lb = 0, .o_ub = 0, .pairs[0]= - {.disp = 0, .type = (Simpletype) SIMPLE_FCOMPLEX32 }}; - - /* Additions - */ - -Typestruct TSlonglong = {.count = 1, .lb = 0, .ub=sizeof(long long), - .committed=1, .o_lb = 0, .o_ub = 0, .pairs[0]= - {.disp = 0, .type = (Simpletype) SIMPLE_LONGLONG }}; - -Typestruct TSulonglong = {.count = 1, .lb = 0, .ub=sizeof(unsigned long long), - .committed=1, .o_lb = 0, .o_ub = 0, .pairs[0]= - {.disp = 0, .type = (Simpletype) SIMPLE_ULONGLONG }}; - -Typestruct TSoffset = {.count = 1, .lb = 0, .ub=sizeof(MPI_Offset), - .committed=1, .o_lb = 0, .o_ub = 0, .pairs[0]= - {.disp = 0, .type = (Simpletype) SIMPLE_OFFSET }}; - - - - /* RML NOTE: the order and numbering of the elements of simpletypes[] MUST match - * the values for the MPI type constants e.g. MPI_INT - * This should be coded in a better way to avoid human error. - */ - - const Datatype simpletypes[64] = - {&TSchar , &TSshort , &TSint , &TSlong, - &TSuchar , &TSushort , &TSuint , &TSulong, //4 - &TSfloat , &TSdouble , &TSldouble , &TSbyte, //8 - &TSpacked , &TSlower , &TSupper , &TSinteger, //12 - &TSreal , &TSdprecision, &TScomplex , &TSdcomplex, //16 - &TSlogical , &TScharacter , &TS2real , &TS2dprecision,//20 - &TS2integer, &TSfloat_int , &TSdouble_int , &TSlong_int, //24 - &TS2int , &TSshort_int , &TSldouble_int, &TSinteger1, //28 - &TSinteger2, &TSinteger4 , &TSinteger8 , &TSinteger16, //32 - &TSreal4 , &TSreal8 , &TSreal16 , &TScomplex8, //36 - &TScomplex16, &TScomplex32, &TSlonglong , &TSulonglong, //40 - &TSoffset - }; - - - /* optional datatypes (Fortran) MPI_INTEGER1 MPI_INTEGER2 MPI_INTEGER4 MPI_REAL2 MPI_REAL4 MPI_REAL8 - - /* optional datatypes (C) MPI_LONG_LONG_INT */ diff --git a/cime/src/externals/mct/protex/protex b/cime/src/externals/mct/protex/protex deleted file mode 100755 index 000708e31063..000000000000 --- a/cime/src/externals/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/cime/src/externals/mct/testsystem/Makefile b/cime/src/externals/mct/testsystem/Makefile deleted file mode 100644 index b3614ef25ff5..000000000000 --- a/cime/src/externals/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/cime/src/externals/mct/testsystem/testall/.gitignore b/cime/src/externals/mct/testsystem/testall/.gitignore deleted file mode 100644 index d675e0fa576f..000000000000 --- a/cime/src/externals/mct/testsystem/testall/.gitignore +++ /dev/null @@ -1,6 +0,0 @@ -testall -*.clog -fort.* -*.log -*testall.* -*.script diff --git a/cime/src/externals/mct/testsystem/testall/Makefile b/cime/src/externals/mct/testsystem/testall/Makefile deleted file mode 100644 index 3c99e0d9cc0c..000000000000 --- a/cime/src/externals/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/cime/src/externals/mct/testsystem/testall/ReadSparseMatrixAsc.F90 b/cime/src/externals/mct/testsystem/testall/ReadSparseMatrixAsc.F90 deleted file mode 100644 index b865e44ddaff..000000000000 --- a/cime/src/externals/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/cime/src/externals/mct/testsystem/testall/UNTESTED b/cime/src/externals/mct/testsystem/testall/UNTESTED deleted file mode 100644 index 0840bdbc40e1..000000000000 --- a/cime/src/externals/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/cime/src/externals/mct/testsystem/testall/ccm.F90 b/cime/src/externals/mct/testsystem/testall/ccm.F90 deleted file mode 100644 index 919de17bf53e..000000000000 --- a/cime/src/externals/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/cime/src/externals/mct/testsystem/testall/convertPOPT.F90 b/cime/src/externals/mct/testsystem/testall/convertPOPT.F90 deleted file mode 100644 index 52c0098298bd..000000000000 --- a/cime/src/externals/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/cime/src/externals/mct/testsystem/testall/convertgauss.F90 b/cime/src/externals/mct/testsystem/testall/convertgauss.F90 deleted file mode 100644 index ec4e7996399e..000000000000 --- a/cime/src/externals/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/cime/src/externals/mct/testsystem/testall/cpl.F90 b/cime/src/externals/mct/testsystem/testall/cpl.F90 deleted file mode 100644 index a709dd7d3296..000000000000 --- a/cime/src/externals/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/cime/src/externals/mct/testsystem/testall/job.ut-all.jaguar b/cime/src/externals/mct/testsystem/testall/job.ut-all.jaguar deleted file mode 100644 index c61a7432023b..000000000000 --- a/cime/src/externals/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/cime/src/externals/mct/testsystem/testall/m_ACTEST.F90 b/cime/src/externals/mct/testsystem/testall/m_ACTEST.F90 deleted file mode 100644 index 01a89ba4ec43..000000000000 --- a/cime/src/externals/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/cime/src/externals/mct/testsystem/testall/m_AVTEST.F90 b/cime/src/externals/mct/testsystem/testall/m_AVTEST.F90 deleted file mode 100644 index 5632926d821c..000000000000 --- a/cime/src/externals/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/cime/src/externals/mct/testsystem/testall/m_GGRIDTEST.F90 b/cime/src/externals/mct/testsystem/testall/m_GGRIDTEST.F90 deleted file mode 100644 index df2f8c0889b4..000000000000 --- a/cime/src/externals/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/cime/src/externals/mct/testsystem/testall/m_GMAPTEST.F90 b/cime/src/externals/mct/testsystem/testall/m_GMAPTEST.F90 deleted file mode 100644 index 032d07723472..000000000000 --- a/cime/src/externals/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/cime/src/externals/mct/testsystem/testall/m_GSMAPTEST.F90 b/cime/src/externals/mct/testsystem/testall/m_GSMAPTEST.F90 deleted file mode 100644 index 55ce3ada9039..000000000000 --- a/cime/src/externals/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/cime/src/externals/mct/testsystem/testall/m_MCTWORLDTEST.F90 b/cime/src/externals/mct/testsystem/testall/m_MCTWORLDTEST.F90 deleted file mode 100644 index bf16a337c5c5..000000000000 --- a/cime/src/externals/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/cime/src/externals/mct/testsystem/testall/m_ROUTERTEST.F90 b/cime/src/externals/mct/testsystem/testall/m_ROUTERTEST.F90 deleted file mode 100644 index 2634c6db5315..000000000000 --- a/cime/src/externals/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/cime/src/externals/mct/testsystem/testall/m_SMATTEST.F90 b/cime/src/externals/mct/testsystem/testall/m_SMATTEST.F90 deleted file mode 100644 index 060a6b5bee43..000000000000 --- a/cime/src/externals/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/cime/src/externals/mct/testsystem/testall/master.F90 b/cime/src/externals/mct/testsystem/testall/master.F90 deleted file mode 100644 index 4081f31656a5..000000000000 --- a/cime/src/externals/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/cime/src/externals/mct/testsystem/testall/mph.F90 b/cime/src/externals/mct/testsystem/testall/mph.F90 deleted file mode 100644 index 0779705c867e..000000000000 --- a/cime/src/externals/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/cime/src/externals/mct/testsystem/testall/pop.F90 b/cime/src/externals/mct/testsystem/testall/pop.F90 deleted file mode 100644 index 74c8f35e6cb1..000000000000 --- a/cime/src/externals/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/cime/src/externals/mct/testsystem/testall/processors_map.in b/cime/src/externals/mct/testsystem/testall/processors_map.in deleted file mode 100644 index dc260c7e40f7..000000000000 --- a/cime/src/externals/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/cime/src/externals/mct/testsystem/testall/script.jag b/cime/src/externals/mct/testsystem/testall/script.jag deleted file mode 100644 index d62277c7019a..000000000000 --- a/cime/src/externals/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/cime/src/externals/mct/testsystem/testall/ut_SparseMatrix.rc b/cime/src/externals/mct/testsystem/testall/ut_SparseMatrix.rc deleted file mode 100644 index 0aaa729738cf..000000000000 --- a/cime/src/externals/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/cime/src/externals/mct/testunit/.gitignore b/cime/src/externals/mct/testunit/.gitignore deleted file mode 100644 index bebbb2047a51..000000000000 --- a/cime/src/externals/mct/testunit/.gitignore +++ /dev/null @@ -1,4 +0,0 @@ -mctTester -AttrVect.log.* -pbs.mct.script -MCTtestunit.o* diff --git a/cime/src/externals/mct/testunit/AttrVect_Test.F90 b/cime/src/externals/mct/testunit/AttrVect_Test.F90 deleted file mode 100644 index 764e5b8e47da..000000000000 --- a/cime/src/externals/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/cime/src/externals/mct/testunit/Makefile b/cime/src/externals/mct/testunit/Makefile deleted file mode 100644 index d337249c6b94..000000000000 --- a/cime/src/externals/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/cime/src/externals/mct/testunit/master.F90 b/cime/src/externals/mct/testunit/master.F90 deleted file mode 100644 index 7a222ccba2ae..000000000000 --- a/cime/src/externals/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 - From caf63ed5d861b8000fedf9534b9814f803c61aa7 Mon Sep 17 00:00:00 2001 From: Robert Jacob Date: Tue, 25 Apr 2017 10:50:13 -0500 Subject: [PATCH 2/4] Squashed 'cime/src/externals/mct/' content from commit 72c0d28 git-subtree-dir: cime/src/externals/mct git-subtree-split: 72c0d28f1a7730190e34c78eee38d00041aea230 --- .gitignore | 9 + COPYRIGHT | 51 + Makefile | 33 + Makefile.conf.in | 89 + README | 198 + aclocal.m4 | 16 + benchmarks/.gitignore | 4 + benchmarks/Makefile | 58 + benchmarks/RouterTestDis.F90 | 200 + benchmarks/RouterTestOvr.F90 | 195 + benchmarks/T42.8pC | 516 ++ benchmarks/T42.8pR | 12 + benchmarks/gx1.8pC | 3076 ++++++++ benchmarks/gx1.8pR | 12 + benchmarks/importBench.F90 | 215 + config.h.in | 81 + configure | 6849 ++++++++++++++++ configure.ac | 611 ++ doc/.gitignore | 7 + doc/Makefile | 27 + doc/README | 20 + doc/coupler.bib | 254 + doc/mct_APIs.tex | 338 + doc/texsrc/.gitignore | 2 + doc/texsrc/Makefile | 29 + doc/texsrc/SRCS_tex.mk | 31 + examples/Makefile | 20 + examples/README | 22 + examples/climate_concur1/.gitignore | 5 + examples/climate_concur1/Makefile | 52 + examples/climate_concur1/README | 38 + examples/climate_concur1/coupler.F90 | 315 + examples/climate_concur1/master.F90 | 89 + examples/climate_concur1/model.F90 | 198 + examples/climate_sequen1/.gitignore | 5 + examples/climate_sequen1/Makefile | 51 + examples/climate_sequen1/README | 42 + examples/climate_sequen1/TS1.dat | 8193 ++++++++++++++++++++ examples/climate_sequen1/coupler.F90 | 214 + examples/climate_sequen1/dst.rc | 6 + examples/climate_sequen1/dstmodel.F90 | 231 + examples/climate_sequen1/master.F90 | 103 + examples/climate_sequen1/mutils.F90 | 139 + examples/climate_sequen1/src.rc | 6 + examples/climate_sequen1/srcmodel.F90 | 248 + examples/simple/.gitignore | 4 + examples/simple/Makefile | 53 + examples/simple/README | 51 + examples/simple/script.babyblue | 29 + examples/simple/twocmp.con.F90 | 222 + examples/simple/twocmp.seq.F90 | 204 + examples/simple/twocmp.seqNB.F90 | 283 + examples/simple/twocmp.seqUnvn.F90 | 242 + install-sh | 276 + m4/README | 5 + m4/acx_mpi.m4 | 146 + m4/ax_fc_version.m4 | 51 + m4/fortran.m4 | 855 ++ mct/Makefile | 110 + mct/README | 39 + mct/m_Accumulator.F90 | 2471 ++++++ mct/m_AccumulatorComms.F90 | 803 ++ mct/m_AttrVect.F90 | 4138 ++++++++++ mct/m_AttrVectComms.F90 | 1683 ++++ mct/m_AttrVectReduce.F90 | 1108 +++ mct/m_ConvertMaps.F90 | 438 ++ mct/m_ExchangeMaps.F90 | 613 ++ mct/m_GeneralGrid.F90 | 3315 ++++++++ mct/m_GeneralGridComms.F90 | 1536 ++++ mct/m_GlobalMap.F90 | 672 ++ mct/m_GlobalSegMap.F90 | 2667 +++++++ mct/m_GlobalSegMapComms.F90 | 555 ++ mct/m_GlobalToLocal.F90 | 719 ++ mct/m_MCTWorld.F90 | 883 +++ mct/m_MatAttrVectMul.F90 | 642 ++ mct/m_Merge.F90 | 2912 +++++++ mct/m_Navigator.F90 | 666 ++ mct/m_Rearranger.F90 | 1426 ++++ mct/m_Router.F90 | 869 +++ mct/m_SPMDutils.F90 | 1148 +++ mct/m_SparseMatrix.F90 | 2767 +++++++ mct/m_SparseMatrixComms.F90 | 699 ++ mct/m_SparseMatrixDecomp.F90 | 756 ++ mct/m_SparseMatrixPlus.F90 | 872 +++ mct/m_SparseMatrixToMaps.F90 | 456 ++ mct/m_SpatialIntegral.F90 | 2034 +++++ mct/m_SpatialIntegralV.F90 | 2017 +++++ mct/m_Transfer.F90 | 818 ++ mkinstalldirs | 111 + mpeu/Makefile | 126 + mpeu/README | 59 + mpeu/assertmpeu.H | 55 + mpeu/get_zeits.c | 76 + mpeu/m_FcComms.F90 | 688 ++ mpeu/m_FileResolv.F90 | 273 + mpeu/m_Filename.F90 | 106 + mpeu/m_IndexBin_char.F90 | 257 + mpeu/m_IndexBin_integer.F90 | 257 + mpeu/m_IndexBin_logical.F90 | 105 + mpeu/m_List.F90 | 2112 +++++ mpeu/m_MergeSorts.F90 | 1469 ++++ mpeu/m_Permuter.F90 | 1284 +++ mpeu/m_SortingTools.F90 | 96 + mpeu/m_StrTemplate.F90 | 454 ++ mpeu/m_String.F90 | 831 ++ mpeu/m_StringLinkedList.F90 | 553 ++ mpeu/m_TraceBack.F90 | 240 + mpeu/m_chars.F90 | 107 + mpeu/m_die.F90 | 404 + mpeu/m_dropdead.F90 | 191 + mpeu/m_flow.F90 | 196 + mpeu/m_inpak90.F90 | 2049 +++++ mpeu/m_ioutil.F90 | 439 ++ mpeu/m_mall.F90 | 1669 ++++ mpeu/m_mpif.F90 | 69 + mpeu/m_mpif90.F90 | 719 ++ mpeu/m_mpout.F90 | 353 + mpeu/m_rankMerge.F90 | 620 ++ mpeu/m_realkinds.F90 | 52 + mpeu/m_stdio.F90 | 53 + mpeu/m_zeit.F90 | 1008 +++ mpi-serial/.gitignore | 1 + mpi-serial/Makefile | 93 + mpi-serial/Makefile.conf.in | 16 + mpi-serial/README | 140 + mpi-serial/aclocal.m4 | 15 + mpi-serial/cart.c | 128 + mpi-serial/collective.c | 506 ++ mpi-serial/comm.c | 247 + mpi-serial/config.h.in | 84 + mpi-serial/configure | 5833 ++++++++++++++ mpi-serial/configure.in | 91 + mpi-serial/copy.c | 91 + mpi-serial/error.c | 13 + mpi-serial/fort.F90 | 62 + mpi-serial/getcount.c | 40 + mpi-serial/group.c | 264 + mpi-serial/handles.c | 309 + mpi-serial/ic_merge.c | 15 + mpi-serial/info.c | 53 + mpi-serial/list.c | 705 ++ mpi-serial/list.h | 45 + mpi-serial/listP.h | 33 + mpi-serial/listops.h | 23 + mpi-serial/m4/README | 5 + mpi-serial/m4/ax_fc_version.m4 | 51 + mpi-serial/mpi.c | 364 + mpi-serial/mpi.h | 436 ++ mpi-serial/mpiP.h | 128 + mpi-serial/mpif.F90 | 12 + mpi-serial/mpif.h | 327 + mpi-serial/op.c | 28 + mpi-serial/pack.c | 145 + mpi-serial/probe.c | 88 + mpi-serial/protify.awk | 46 + mpi-serial/recv.c | 164 + mpi-serial/req.c | 301 + mpi-serial/send.c | 251 + mpi-serial/tests/.gitignore | 4 + mpi-serial/tests/Makefile | 41 + mpi-serial/tests/ctest.c | 967 +++ mpi-serial/tests/ctest_old.c | 181 + mpi-serial/tests/ftest.F90 | 680 ++ mpi-serial/tests/ftest_internal.F90 | 328 + mpi-serial/tests/ftest_old.F90 | 165 + mpi-serial/time.c | 35 + mpi-serial/type.c | 846 ++ mpi-serial/type.h | 124 + mpi-serial/type_const.c | 189 + protex/protex | 879 +++ testsystem/Makefile | 20 + testsystem/testall/.gitignore | 6 + testsystem/testall/Makefile | 60 + testsystem/testall/ReadSparseMatrixAsc.F90 | 244 + testsystem/testall/UNTESTED | 13 + testsystem/testall/ccm.F90 | 835 ++ testsystem/testall/convertPOPT.F90 | 454 ++ testsystem/testall/convertgauss.F90 | 516 ++ testsystem/testall/cpl.F90 | 1270 +++ testsystem/testall/job.ut-all.jaguar | 23 + testsystem/testall/m_ACTEST.F90 | 633 ++ testsystem/testall/m_AVTEST.F90 | 857 ++ testsystem/testall/m_GGRIDTEST.F90 | 636 ++ testsystem/testall/m_GMAPTEST.F90 | 160 + testsystem/testall/m_GSMAPTEST.F90 | 377 + testsystem/testall/m_MCTWORLDTEST.F90 | 121 + testsystem/testall/m_ROUTERTEST.F90 | 120 + testsystem/testall/m_SMATTEST.F90 | 627 ++ testsystem/testall/master.F90 | 39 + testsystem/testall/mph.F90 | 1068 +++ testsystem/testall/pop.F90 | 650 ++ testsystem/testall/processors_map.in | 12 + testsystem/testall/script.jag | 18 + testsystem/testall/ut_SparseMatrix.rc | 29 + testunit/.gitignore | 4 + testunit/AttrVect_Test.F90 | 1907 +++++ testunit/Makefile | 41 + testunit/master.F90 | 101 + 198 files changed, 108677 insertions(+) create mode 100644 .gitignore create mode 100644 COPYRIGHT create mode 100644 Makefile create mode 100644 Makefile.conf.in create mode 100644 README create mode 100644 aclocal.m4 create mode 100644 benchmarks/.gitignore create mode 100644 benchmarks/Makefile create mode 100644 benchmarks/RouterTestDis.F90 create mode 100644 benchmarks/RouterTestOvr.F90 create mode 100644 benchmarks/T42.8pC create mode 100644 benchmarks/T42.8pR create mode 100644 benchmarks/gx1.8pC create mode 100644 benchmarks/gx1.8pR create mode 100644 benchmarks/importBench.F90 create mode 100644 config.h.in create mode 100755 configure create mode 100644 configure.ac create mode 100644 doc/.gitignore create mode 100644 doc/Makefile create mode 100644 doc/README create mode 100644 doc/coupler.bib create mode 100755 doc/mct_APIs.tex create mode 100644 doc/texsrc/.gitignore create mode 100644 doc/texsrc/Makefile create mode 100644 doc/texsrc/SRCS_tex.mk create mode 100644 examples/Makefile create mode 100644 examples/README create mode 100644 examples/climate_concur1/.gitignore create mode 100644 examples/climate_concur1/Makefile create mode 100644 examples/climate_concur1/README create mode 100644 examples/climate_concur1/coupler.F90 create mode 100644 examples/climate_concur1/master.F90 create mode 100644 examples/climate_concur1/model.F90 create mode 100644 examples/climate_sequen1/.gitignore create mode 100644 examples/climate_sequen1/Makefile create mode 100644 examples/climate_sequen1/README create mode 100644 examples/climate_sequen1/TS1.dat create mode 100644 examples/climate_sequen1/coupler.F90 create mode 100644 examples/climate_sequen1/dst.rc create mode 100644 examples/climate_sequen1/dstmodel.F90 create mode 100644 examples/climate_sequen1/master.F90 create mode 100644 examples/climate_sequen1/mutils.F90 create mode 100644 examples/climate_sequen1/src.rc create mode 100644 examples/climate_sequen1/srcmodel.F90 create mode 100644 examples/simple/.gitignore create mode 100644 examples/simple/Makefile create mode 100644 examples/simple/README create mode 100644 examples/simple/script.babyblue create mode 100644 examples/simple/twocmp.con.F90 create mode 100644 examples/simple/twocmp.seq.F90 create mode 100644 examples/simple/twocmp.seqNB.F90 create mode 100644 examples/simple/twocmp.seqUnvn.F90 create mode 100755 install-sh create mode 100644 m4/README create mode 100644 m4/acx_mpi.m4 create mode 100644 m4/ax_fc_version.m4 create mode 100644 m4/fortran.m4 create mode 100644 mct/Makefile create mode 100644 mct/README create mode 100644 mct/m_Accumulator.F90 create mode 100644 mct/m_AccumulatorComms.F90 create mode 100644 mct/m_AttrVect.F90 create mode 100644 mct/m_AttrVectComms.F90 create mode 100644 mct/m_AttrVectReduce.F90 create mode 100644 mct/m_ConvertMaps.F90 create mode 100644 mct/m_ExchangeMaps.F90 create mode 100644 mct/m_GeneralGrid.F90 create mode 100644 mct/m_GeneralGridComms.F90 create mode 100644 mct/m_GlobalMap.F90 create mode 100644 mct/m_GlobalSegMap.F90 create mode 100644 mct/m_GlobalSegMapComms.F90 create mode 100644 mct/m_GlobalToLocal.F90 create mode 100644 mct/m_MCTWorld.F90 create mode 100644 mct/m_MatAttrVectMul.F90 create mode 100644 mct/m_Merge.F90 create mode 100644 mct/m_Navigator.F90 create mode 100644 mct/m_Rearranger.F90 create mode 100644 mct/m_Router.F90 create mode 100644 mct/m_SPMDutils.F90 create mode 100644 mct/m_SparseMatrix.F90 create mode 100644 mct/m_SparseMatrixComms.F90 create mode 100644 mct/m_SparseMatrixDecomp.F90 create mode 100644 mct/m_SparseMatrixPlus.F90 create mode 100644 mct/m_SparseMatrixToMaps.F90 create mode 100644 mct/m_SpatialIntegral.F90 create mode 100644 mct/m_SpatialIntegralV.F90 create mode 100644 mct/m_Transfer.F90 create mode 100755 mkinstalldirs create mode 100644 mpeu/Makefile create mode 100644 mpeu/README create mode 100644 mpeu/assertmpeu.H create mode 100644 mpeu/get_zeits.c create mode 100644 mpeu/m_FcComms.F90 create mode 100644 mpeu/m_FileResolv.F90 create mode 100644 mpeu/m_Filename.F90 create mode 100644 mpeu/m_IndexBin_char.F90 create mode 100644 mpeu/m_IndexBin_integer.F90 create mode 100644 mpeu/m_IndexBin_logical.F90 create mode 100644 mpeu/m_List.F90 create mode 100644 mpeu/m_MergeSorts.F90 create mode 100644 mpeu/m_Permuter.F90 create mode 100644 mpeu/m_SortingTools.F90 create mode 100644 mpeu/m_StrTemplate.F90 create mode 100644 mpeu/m_String.F90 create mode 100644 mpeu/m_StringLinkedList.F90 create mode 100644 mpeu/m_TraceBack.F90 create mode 100644 mpeu/m_chars.F90 create mode 100644 mpeu/m_die.F90 create mode 100644 mpeu/m_dropdead.F90 create mode 100644 mpeu/m_flow.F90 create mode 100644 mpeu/m_inpak90.F90 create mode 100644 mpeu/m_ioutil.F90 create mode 100644 mpeu/m_mall.F90 create mode 100644 mpeu/m_mpif.F90 create mode 100644 mpeu/m_mpif90.F90 create mode 100644 mpeu/m_mpout.F90 create mode 100644 mpeu/m_rankMerge.F90 create mode 100644 mpeu/m_realkinds.F90 create mode 100644 mpeu/m_stdio.F90 create mode 100644 mpeu/m_zeit.F90 create mode 100644 mpi-serial/.gitignore create mode 100644 mpi-serial/Makefile create mode 100644 mpi-serial/Makefile.conf.in create mode 100644 mpi-serial/README create mode 100644 mpi-serial/aclocal.m4 create mode 100644 mpi-serial/cart.c create mode 100644 mpi-serial/collective.c create mode 100644 mpi-serial/comm.c create mode 100644 mpi-serial/config.h.in create mode 100755 mpi-serial/configure create mode 100644 mpi-serial/configure.in create mode 100644 mpi-serial/copy.c create mode 100644 mpi-serial/error.c create mode 100644 mpi-serial/fort.F90 create mode 100644 mpi-serial/getcount.c create mode 100644 mpi-serial/group.c create mode 100644 mpi-serial/handles.c create mode 100644 mpi-serial/ic_merge.c create mode 100644 mpi-serial/info.c create mode 100644 mpi-serial/list.c create mode 100644 mpi-serial/list.h create mode 100644 mpi-serial/listP.h create mode 100644 mpi-serial/listops.h create mode 100644 mpi-serial/m4/README create mode 100644 mpi-serial/m4/ax_fc_version.m4 create mode 100644 mpi-serial/mpi.c create mode 100644 mpi-serial/mpi.h create mode 100644 mpi-serial/mpiP.h create mode 100644 mpi-serial/mpif.F90 create mode 100644 mpi-serial/mpif.h create mode 100644 mpi-serial/op.c create mode 100644 mpi-serial/pack.c create mode 100644 mpi-serial/probe.c create mode 100755 mpi-serial/protify.awk create mode 100644 mpi-serial/recv.c create mode 100644 mpi-serial/req.c create mode 100644 mpi-serial/send.c create mode 100644 mpi-serial/tests/.gitignore create mode 100644 mpi-serial/tests/Makefile create mode 100644 mpi-serial/tests/ctest.c create mode 100644 mpi-serial/tests/ctest_old.c create mode 100644 mpi-serial/tests/ftest.F90 create mode 100644 mpi-serial/tests/ftest_internal.F90 create mode 100644 mpi-serial/tests/ftest_old.F90 create mode 100644 mpi-serial/time.c create mode 100644 mpi-serial/type.c create mode 100644 mpi-serial/type.h create mode 100644 mpi-serial/type_const.c create mode 100755 protex/protex create mode 100644 testsystem/Makefile create mode 100644 testsystem/testall/.gitignore create mode 100644 testsystem/testall/Makefile create mode 100644 testsystem/testall/ReadSparseMatrixAsc.F90 create mode 100644 testsystem/testall/UNTESTED create mode 100644 testsystem/testall/ccm.F90 create mode 100644 testsystem/testall/convertPOPT.F90 create mode 100644 testsystem/testall/convertgauss.F90 create mode 100644 testsystem/testall/cpl.F90 create mode 100644 testsystem/testall/job.ut-all.jaguar create mode 100644 testsystem/testall/m_ACTEST.F90 create mode 100644 testsystem/testall/m_AVTEST.F90 create mode 100644 testsystem/testall/m_GGRIDTEST.F90 create mode 100644 testsystem/testall/m_GMAPTEST.F90 create mode 100644 testsystem/testall/m_GSMAPTEST.F90 create mode 100644 testsystem/testall/m_MCTWORLDTEST.F90 create mode 100644 testsystem/testall/m_ROUTERTEST.F90 create mode 100644 testsystem/testall/m_SMATTEST.F90 create mode 100644 testsystem/testall/master.F90 create mode 100644 testsystem/testall/mph.F90 create mode 100644 testsystem/testall/pop.F90 create mode 100644 testsystem/testall/processors_map.in create mode 100644 testsystem/testall/script.jag create mode 100644 testsystem/testall/ut_SparseMatrix.rc create mode 100644 testunit/.gitignore create mode 100644 testunit/AttrVect_Test.F90 create mode 100644 testunit/Makefile create mode 100644 testunit/master.F90 diff --git a/.gitignore b/.gitignore new file mode 100644 index 000000000000..6e04052969bd --- /dev/null +++ b/.gitignore @@ -0,0 +1,9 @@ +Makefile.conf +config.log +config.status +config.h +autom4te.cache +*.o +*.mod +lib*.a +data diff --git a/COPYRIGHT b/COPYRIGHT new file mode 100644 index 000000000000..f4aa22117eb8 --- /dev/null +++ b/COPYRIGHT @@ -0,0 +1,51 @@ + 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/Makefile b/Makefile new file mode 100644 index 000000000000..6b5bfe7a444b --- /dev/null +++ b/Makefile @@ -0,0 +1,33 @@ + +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/Makefile.conf.in b/Makefile.conf.in new file mode 100644 index 000000000000..bc2896d90efe --- /dev/null +++ b/Makefile.conf.in @@ -0,0 +1,89 @@ +# 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/README b/README new file mode 100644 index 000000000000..fa38a8e9767f --- /dev/null +++ b/README @@ -0,0 +1,198 @@ +###################################################################### + + -- Mathematics + Computer Science Div. / Argonne National Laboratory + + Model Coupling Toolkit (MCT) + + Robert Jacob + Jay Larson + Everest Ong + Ray Loy + + For more information, see http://www.mcs.anl.gov/mct + + See MCT/COPYRIGHT for license. + +###################################################################### + + This is version 2.9 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. + NO LONGER SUPPORTED + +###################################################################### + REQUIREMENTS: + + Building MCT requires a Fortran90 compiler. + + A full 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 full MPI installation with mpirun + 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, use: + > ./configure FC=bgxlf90_r CC=mpixlc_r MPIFC=mpixlf90_r (can also use versions without _r) + +###################################################################### + 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 + included in the MCT source and available from: + http://gmao.gsfc.nasa.gov/software/protex/ + + 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 + 19 Jun, 2015 -- version 2.9.0 diff --git a/aclocal.m4 b/aclocal.m4 new file mode 100644 index 000000000000..ae3d396d8c87 --- /dev/null +++ b/aclocal.m4 @@ -0,0 +1,16 @@ +# 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/benchmarks/.gitignore b/benchmarks/.gitignore new file mode 100644 index 000000000000..1c6273f3704a --- /dev/null +++ b/benchmarks/.gitignore @@ -0,0 +1,4 @@ +importBench +RouterTestDis +RouterTestOvr +fort.* diff --git a/benchmarks/Makefile b/benchmarks/Makefile new file mode 100644 index 000000000000..75d393ff55a7 --- /dev/null +++ b/benchmarks/Makefile @@ -0,0 +1,58 @@ + +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/benchmarks/RouterTestDis.F90 b/benchmarks/RouterTestDis.F90 new file mode 100644 index 000000000000..635acca2a646 --- /dev/null +++ b/benchmarks/RouterTestDis.F90 @@ -0,0 +1,200 @@ + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! 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/benchmarks/RouterTestOvr.F90 b/benchmarks/RouterTestOvr.F90 new file mode 100644 index 000000000000..b9895b0dd9f2 --- /dev/null +++ b/benchmarks/RouterTestOvr.F90 @@ -0,0 +1,195 @@ + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! 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/benchmarks/T42.8pC b/benchmarks/T42.8pC new file mode 100644 index 000000000000..f80c0b8b0b72 --- /dev/null +++ b/benchmarks/T42.8pC @@ -0,0 +1,516 @@ + 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/benchmarks/T42.8pR b/benchmarks/T42.8pR new file mode 100644 index 000000000000..5f3cd204fb5d --- /dev/null +++ b/benchmarks/T42.8pR @@ -0,0 +1,12 @@ + 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/benchmarks/gx1.8pC b/benchmarks/gx1.8pC new file mode 100644 index 000000000000..a183292daf32 --- /dev/null +++ b/benchmarks/gx1.8pC @@ -0,0 +1,3076 @@ + 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/benchmarks/gx1.8pR b/benchmarks/gx1.8pR new file mode 100644 index 000000000000..c90fd783a547 --- /dev/null +++ b/benchmarks/gx1.8pR @@ -0,0 +1,12 @@ + 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/benchmarks/importBench.F90 b/benchmarks/importBench.F90 new file mode 100644 index 000000000000..ac7603e9d47b --- /dev/null +++ b/benchmarks/importBench.F90 @@ -0,0 +1,215 @@ +! 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/config.h.in b/config.h.in new file mode 100644 index 000000000000..5ea9c79519e9 --- /dev/null +++ b/config.h.in @@ -0,0 +1,81 @@ +/* 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/configure b/configure new file mode 100755 index 000000000000..83614aa08dbd --- /dev/null +++ b/configure @@ -0,0 +1,6849 @@ +#! /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" + +enable_option_checking=no +ac_subst_vars='LTLIBOBJS +LIBOBJS +subdirs +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' +ac_subdirs_all='mpi-serial' + +# 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:4070: \"$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 + +if test -n "$DONOTCHECKMPI"; then + echo "MPISERIAL ENABLED: CONFIGURING mpi-serial" + ac_aux_dir= +for ac_dir in "$srcdir" "$srcdir/.." "$srcdir/../.."; do + if test -f "$ac_dir/install-sh"; then + ac_aux_dir=$ac_dir + ac_install_sh="$ac_aux_dir/install-sh -c" + break + elif test -f "$ac_dir/install.sh"; then + ac_aux_dir=$ac_dir + ac_install_sh="$ac_aux_dir/install.sh -c" + break + elif test -f "$ac_dir/shtool"; then + ac_aux_dir=$ac_dir + ac_install_sh="$ac_aux_dir/shtool install -c" + break + fi +done +if test -z "$ac_aux_dir"; then + as_fn_error $? "cannot find install-sh, install.sh, or shtool in \"$srcdir\" \"$srcdir/..\" \"$srcdir/../..\"" "$LINENO" 5 +fi + +# These three variables are undocumented and unsupported, +# and are intended to be withdrawn in a future Autoconf release. +# They can cause serious problems if a builder's source tree is in a directory +# whose full name contains unusual characters. +ac_config_guess="$SHELL $ac_aux_dir/config.guess" # Please don't use this var. +ac_config_sub="$SHELL $ac_aux_dir/config.sub" # Please don't use this var. +ac_configure="$SHELL $ac_aux_dir/configure" # Please don't use this var. + + + + +subdirs="$subdirs mpi-serial" + +fi + +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 + +# +# CONFIG_SUBDIRS section. +# +if test "$no_recursion" != yes; then + + # Remove --cache-file, --srcdir, and --disable-option-checking arguments + # so they do not pile up. + ac_sub_configure_args= + ac_prev= + eval "set x $ac_configure_args" + shift + for ac_arg + do + if test -n "$ac_prev"; then + ac_prev= + continue + fi + case $ac_arg in + -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=*) + ;; + --config-cache | -C) + ;; + -srcdir | --srcdir | --srcdi | --srcd | --src | --sr) + ac_prev=srcdir ;; + -srcdir=* | --srcdir=* | --srcdi=* | --srcd=* | --src=* | --sr=*) + ;; + -prefix | --prefix | --prefi | --pref | --pre | --pr | --p) + ac_prev=prefix ;; + -prefix=* | --prefix=* | --prefi=* | --pref=* | --pre=* | --pr=* | --p=*) + ;; + --disable-option-checking) + ;; + *) + case $ac_arg in + *\'*) ac_arg=`$as_echo "$ac_arg" | sed "s/'/'\\\\\\\\''/g"` ;; + esac + as_fn_append ac_sub_configure_args " '$ac_arg'" ;; + esac + done + + # Always prepend --prefix to ensure using the same prefix + # in subdir configurations. + ac_arg="--prefix=$prefix" + case $ac_arg in + *\'*) ac_arg=`$as_echo "$ac_arg" | sed "s/'/'\\\\\\\\''/g"` ;; + esac + ac_sub_configure_args="'$ac_arg' $ac_sub_configure_args" + + # Pass --silent + if test "$silent" = yes; then + ac_sub_configure_args="--silent $ac_sub_configure_args" + fi + + # Always prepend --disable-option-checking to silence warnings, since + # different subdirs can have different --enable and --with options. + ac_sub_configure_args="--disable-option-checking $ac_sub_configure_args" + + ac_popdir=`pwd` + for ac_dir in : $subdirs; do test "x$ac_dir" = x: && continue + + # Do not complain, so a configure script can configure whichever + # parts of a large source tree are present. + test -d "$srcdir/$ac_dir" || continue + + ac_msg="=== configuring in $ac_dir (`pwd`/$ac_dir)" + $as_echo "$as_me:${as_lineno-$LINENO}: $ac_msg" >&5 + $as_echo "$ac_msg" >&6 + 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 + + + cd "$ac_dir" + + # Check for guested configure; otherwise get Cygnus style configure. + if test -f "$ac_srcdir/configure.gnu"; then + ac_sub_configure=$ac_srcdir/configure.gnu + elif test -f "$ac_srcdir/configure"; then + ac_sub_configure=$ac_srcdir/configure + elif test -f "$ac_srcdir/configure.in"; then + # This should be Cygnus configure. + ac_sub_configure=$ac_aux_dir/configure + else + { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: no configuration information is in $ac_dir" >&5 +$as_echo "$as_me: WARNING: no configuration information is in $ac_dir" >&2;} + ac_sub_configure= + fi + + # The recursion is here. + if test -n "$ac_sub_configure"; then + # Make the cache file name correct relative to the subdirectory. + case $cache_file in + [\\/]* | ?:[\\/]* ) ac_sub_cache_file=$cache_file ;; + *) # Relative name. + ac_sub_cache_file=$ac_top_build_prefix$cache_file ;; + esac + + { $as_echo "$as_me:${as_lineno-$LINENO}: running $SHELL $ac_sub_configure $ac_sub_configure_args --cache-file=$ac_sub_cache_file --srcdir=$ac_srcdir" >&5 +$as_echo "$as_me: running $SHELL $ac_sub_configure $ac_sub_configure_args --cache-file=$ac_sub_cache_file --srcdir=$ac_srcdir" >&6;} + # The eval makes quoting arguments work. + eval "\$SHELL \"\$ac_sub_configure\" $ac_sub_configure_args \ + --cache-file=\"\$ac_sub_cache_file\" --srcdir=\"\$ac_srcdir\"" || + as_fn_error $? "$ac_sub_configure failed for $ac_dir" "$LINENO" 5 + fi + + cd "$ac_popdir" + done +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/configure.ac b/configure.ac new file mode 100644 index 000000000000..248708870237 --- /dev/null +++ b/configure.ac @@ -0,0 +1,611 @@ +# -*- 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 + +if test -n "$DONOTCHECKMPI"; then + echo "MPISERIAL ENABLED: CONFIGURING mpi-serial" + AC_CONFIG_SUBDIRS(mpi-serial) +fi + +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/doc/.gitignore b/doc/.gitignore new file mode 100644 index 000000000000..aadc44c83991 --- /dev/null +++ b/doc/.gitignore @@ -0,0 +1,7 @@ +*.toc +*.log +*.dvi +*.aux +*.blg +*.bbl +*.pdf diff --git a/doc/Makefile b/doc/Makefile new file mode 100644 index 000000000000..48d6e1e122cf --- /dev/null +++ b/doc/Makefile @@ -0,0 +1,27 @@ +#!/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/doc/README b/doc/README new file mode 100644 index 000000000000..9ccfdfe50e3a --- /dev/null +++ b/doc/README @@ -0,0 +1,20 @@ + +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/doc/coupler.bib b/doc/coupler.bib new file mode 100644 index 000000000000..9d583a0326d7 --- /dev/null +++ b/doc/coupler.bib @@ -0,0 +1,254 @@ +@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/doc/mct_APIs.tex b/doc/mct_APIs.tex new file mode 100755 index 000000000000..7a05358dcca1 --- /dev/null +++ b/doc/mct_APIs.tex @@ -0,0 +1,338 @@ +%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.9 +\\ } %%% 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 +Version 2.9.0 & Jun 19, 2015 & 2.9.0 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/doc/texsrc/.gitignore b/doc/texsrc/.gitignore new file mode 100644 index 000000000000..89a588f67135 --- /dev/null +++ b/doc/texsrc/.gitignore @@ -0,0 +1,2 @@ +*.tex +*.F90 diff --git a/doc/texsrc/Makefile b/doc/texsrc/Makefile new file mode 100644 index 000000000000..7d4049643f32 --- /dev/null +++ b/doc/texsrc/Makefile @@ -0,0 +1,29 @@ +#!/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/doc/texsrc/SRCS_tex.mk b/doc/texsrc/SRCS_tex.mk new file mode 100644 index 000000000000..556c7218bcca --- /dev/null +++ b/doc/texsrc/SRCS_tex.mk @@ -0,0 +1,31 @@ +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/examples/Makefile b/examples/Makefile new file mode 100644 index 000000000000..dfd79727493f --- /dev/null +++ b/examples/Makefile @@ -0,0 +1,20 @@ + +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/examples/README b/examples/README new file mode 100644 index 000000000000..a7e19528ead1 --- /dev/null +++ b/examples/README @@ -0,0 +1,22 @@ + +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/examples/climate_concur1/.gitignore b/examples/climate_concur1/.gitignore new file mode 100644 index 000000000000..d4f2ff7e9f34 --- /dev/null +++ b/examples/climate_concur1/.gitignore @@ -0,0 +1,5 @@ +climate +*.mod +poe.* +*.script +*.o* diff --git a/examples/climate_concur1/Makefile b/examples/climate_concur1/Makefile new file mode 100644 index 000000000000..3f4f30e1ed47 --- /dev/null +++ b/examples/climate_concur1/Makefile @@ -0,0 +1,52 @@ + +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/examples/climate_concur1/README b/examples/climate_concur1/README new file mode 100644 index 000000000000..b7b61d9c1ea0 --- /dev/null +++ b/examples/climate_concur1/README @@ -0,0 +1,38 @@ + +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/examples/climate_concur1/coupler.F90 b/examples/climate_concur1/coupler.F90 new file mode 100644 index 000000000000..465781a8b41b --- /dev/null +++ b/examples/climate_concur1/coupler.F90 @@ -0,0 +1,315 @@ +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! 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/examples/climate_concur1/master.F90 b/examples/climate_concur1/master.F90 new file mode 100644 index 000000000000..e9252daa9ee5 --- /dev/null +++ b/examples/climate_concur1/master.F90 @@ -0,0 +1,89 @@ + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! 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/examples/climate_concur1/model.F90 b/examples/climate_concur1/model.F90 new file mode 100644 index 000000000000..60a245a3f321 --- /dev/null +++ b/examples/climate_concur1/model.F90 @@ -0,0 +1,198 @@ +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! 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/examples/climate_sequen1/.gitignore b/examples/climate_sequen1/.gitignore new file mode 100644 index 000000000000..f2d3c73f037b --- /dev/null +++ b/examples/climate_sequen1/.gitignore @@ -0,0 +1,5 @@ +*.mod +climate +TS1out.dat +*.script +*.o* diff --git a/examples/climate_sequen1/Makefile b/examples/climate_sequen1/Makefile new file mode 100644 index 000000000000..7992fa00f9c2 --- /dev/null +++ b/examples/climate_sequen1/Makefile @@ -0,0 +1,51 @@ + +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/examples/climate_sequen1/README b/examples/climate_sequen1/README new file mode 100644 index 000000000000..fa7f9afb57dd --- /dev/null +++ b/examples/climate_sequen1/README @@ -0,0 +1,42 @@ + +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/examples/climate_sequen1/TS1.dat b/examples/climate_sequen1/TS1.dat new file mode 100644 index 000000000000..6e9ce15fbecd --- /dev/null +++ b/examples/climate_sequen1/TS1.dat @@ -0,0 +1,8193 @@ +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/examples/climate_sequen1/coupler.F90 b/examples/climate_sequen1/coupler.F90 new file mode 100644 index 000000000000..7ea8bacf4bab --- /dev/null +++ b/examples/climate_sequen1/coupler.F90 @@ -0,0 +1,214 @@ +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! 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/examples/climate_sequen1/dst.rc b/examples/climate_sequen1/dst.rc new file mode 100644 index 000000000000..cbb9449b80de --- /dev/null +++ b/examples/climate_sequen1/dst.rc @@ -0,0 +1,6 @@ +# Resource file for dst model +# nx and ny:: global grid size in x and y + + nx: 320 + ny: 384 + decomp: R diff --git a/examples/climate_sequen1/dstmodel.F90 b/examples/climate_sequen1/dstmodel.F90 new file mode 100644 index 000000000000..3344e7604ca0 --- /dev/null +++ b/examples/climate_sequen1/dstmodel.F90 @@ -0,0 +1,231 @@ +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! 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/examples/climate_sequen1/master.F90 b/examples/climate_sequen1/master.F90 new file mode 100644 index 000000000000..0f9a4786782b --- /dev/null +++ b/examples/climate_sequen1/master.F90 @@ -0,0 +1,103 @@ + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! 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/examples/climate_sequen1/mutils.F90 b/examples/climate_sequen1/mutils.F90 new file mode 100644 index 000000000000..0a1829f0a59d --- /dev/null +++ b/examples/climate_sequen1/mutils.F90 @@ -0,0 +1,139 @@ +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! 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/examples/climate_sequen1/src.rc b/examples/climate_sequen1/src.rc new file mode 100644 index 000000000000..1dd5275e5386 --- /dev/null +++ b/examples/climate_sequen1/src.rc @@ -0,0 +1,6 @@ +# Resource file for src model +# nx and ny:: global grid size in x and y + + nx: 128 + ny: 64 + decomp: R diff --git a/examples/climate_sequen1/srcmodel.F90 b/examples/climate_sequen1/srcmodel.F90 new file mode 100644 index 000000000000..b0c8be56db4a --- /dev/null +++ b/examples/climate_sequen1/srcmodel.F90 @@ -0,0 +1,248 @@ +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! 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/examples/simple/.gitignore b/examples/simple/.gitignore new file mode 100644 index 000000000000..40296985e55d --- /dev/null +++ b/examples/simple/.gitignore @@ -0,0 +1,4 @@ +twocon +twoseq +twosequn +twoseqNB diff --git a/examples/simple/Makefile b/examples/simple/Makefile new file mode 100644 index 000000000000..773fb149744e --- /dev/null +++ b/examples/simple/Makefile @@ -0,0 +1,53 @@ + +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/examples/simple/README b/examples/simple/README new file mode 100644 index 000000000000..037bde5bcf4f --- /dev/null +++ b/examples/simple/README @@ -0,0 +1,51 @@ + + +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/examples/simple/script.babyblue b/examples/simple/script.babyblue new file mode 100644 index 000000000000..a30fea12731b --- /dev/null +++ b/examples/simple/script.babyblue @@ -0,0 +1,29 @@ +#! /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/examples/simple/twocmp.con.F90 b/examples/simple/twocmp.con.F90 new file mode 100644 index 000000000000..8bbd1916b3da --- /dev/null +++ b/examples/simple/twocmp.con.F90 @@ -0,0 +1,222 @@ +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! 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/examples/simple/twocmp.seq.F90 b/examples/simple/twocmp.seq.F90 new file mode 100644 index 000000000000..d828d38f4962 --- /dev/null +++ b/examples/simple/twocmp.seq.F90 @@ -0,0 +1,204 @@ +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! 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/examples/simple/twocmp.seqNB.F90 b/examples/simple/twocmp.seqNB.F90 new file mode 100644 index 000000000000..82c93610e500 --- /dev/null +++ b/examples/simple/twocmp.seqNB.F90 @@ -0,0 +1,283 @@ +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! 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/examples/simple/twocmp.seqUnvn.F90 b/examples/simple/twocmp.seqUnvn.F90 new file mode 100644 index 000000000000..7e36e5a26a95 --- /dev/null +++ b/examples/simple/twocmp.seqUnvn.F90 @@ -0,0 +1,242 @@ +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! 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/install-sh b/install-sh new file mode 100755 index 000000000000..36f96f3e033c --- /dev/null +++ b/install-sh @@ -0,0 +1,276 @@ +#!/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/m4/README b/m4/README new file mode 100644 index 000000000000..b748178e2c79 --- /dev/null +++ b/m4/README @@ -0,0 +1,5 @@ +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/m4/acx_mpi.m4 b/m4/acx_mpi.m4 new file mode 100644 index 000000000000..77f433d82170 --- /dev/null +++ b/m4/acx_mpi.m4 @@ -0,0 +1,146 @@ +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/m4/ax_fc_version.m4 b/m4/ax_fc_version.m4 new file mode 100644 index 000000000000..c7e2eaec3c70 --- /dev/null +++ b/m4/ax_fc_version.m4 @@ -0,0 +1,51 @@ +#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/m4/fortran.m4 b/m4/fortran.m4 new file mode 100644 index 000000000000..c835ce232aa7 --- /dev/null +++ b/m4/fortran.m4 @@ -0,0 +1,855 @@ +# 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/mct/Makefile b/mct/Makefile new file mode 100644 index 000000000000..97aa186e77b9 --- /dev/null +++ b/mct/Makefile @@ -0,0 +1,110 @@ +.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_SPMDutils.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_SPMDutils.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_SPMDutils.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/mct/README b/mct/README new file mode 100644 index 000000000000..139553c6c2d3 --- /dev/null +++ b/mct/README @@ -0,0 +1,39 @@ +###################################################################### + + -- 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/mct/m_Accumulator.F90 b/mct/m_Accumulator.F90 new file mode 100644 index 000000000000..c7b1e29054dc --- /dev/null +++ b/mct/m_Accumulator.F90 @@ -0,0 +1,2471 @@ +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! 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/mct/m_AccumulatorComms.F90 b/mct/m_AccumulatorComms.F90 new file mode 100644 index 000000000000..e790418c30cd --- /dev/null +++ b/mct/m_AccumulatorComms.F90 @@ -0,0 +1,803 @@ +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! 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/mct/m_AttrVect.F90 b/mct/m_AttrVect.F90 new file mode 100644 index 000000000000..d186fb84ce58 --- /dev/null +++ b/mct/m_AttrVect.F90 @@ -0,0 +1,4138 @@ +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! 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 + if(associated(aV%iAttr) .and. (nIAttr_(aV)>0)) then +!DIR$ COLLAPSE + aV%iAttr=0 + endif + endif + endif + + if(myZeroReals) then ! zero out REAL attributes + if(List_allocated(aV%rList)) then + if(associated(aV%rAttr) .and. (nRAttr_(aV)>0)) then +!DIR$ COLLAPSE + aV%rAttr=0._FP + endif + 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 + + 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 :: inxmin, outxmin ! 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 + + outxmin=mySharedIndices%aVindices2(1)-1 + inxmin=mySharedIndices%aVindices1(1)-1 + if(usevector) then +!$OMP PARALLEL DO PRIVATE(i,j) + do i=1,mySharedIndices%num_indices +!CDIR SELECT(VECTOR) +!DIR$ IVDEP + do j=1,aVsize + aVout%rAttr(outxmin+i,j) = aVin%rAttr(inxmin+i,j) + enddo + enddo + else +!$OMP PARALLEL DO PRIVATE(j,i) COLLAPSE(2) + do j=1,aVsize + 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) COLLAPSE(2) + do j=1,aVsize + do i=1,mySharedIndices%num_indices + aVout%rAttr(mySharedIndices%aVindices2(i),j) = aVin%rAttr(mySharedIndices%aVindices1(i),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 : 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 :: inxmin, outxmin ! 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. + + ! 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) then + contiguous = .false. + exit + endif + enddo + if(contiguous) then + do i=2,num_indices + if(aVoutindices(i) /= aVoutindices(i-1)+1) then + contiguous=.false. + exit + endif + enddo + endif + +! Start copying (arranged loop order optimized for xlf90) + if(contiguous) then + + outxmin=aVoutindices(1)-1 + inxmin=aVinindices(1)-1 + if(usevector) then +!$OMP PARALLEL DO PRIVATE(i,j) + do i=1,num_indices +!DIR$ IVDEP + do j=1,aVsize + aVout%rAttr(outxmin+i,j) = aVin%rAttr(inxmin+i,j) + enddo + enddo + else +!$OMP PARALLEL DO PRIVATE(j,i) COLLAPSE(2) + do j=1,aVsize + 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) COLLAPSE(2) + do j=1,aVsize + do i=1,num_indices + aVout%rAttr(aVoutindices(i),j) = aVin%rAttr(aVinindices(i),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 + + 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 :: inxmin, outxmin ! 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 + + outxmin=mySharedIndices%aVindices2(1)-1 + inxmin=mySharedIndices%aVindices1(1)-1 + if(usevector) then +!$OMP PARALLEL DO PRIVATE(i,j) + do i=1,mySharedIndices%num_indices +!CDIR SELECT(VECTOR) +!DIR$ IVDEP + do j=1,aVsize + aVout%iAttr(outxmin+i,j) = aVin%iAttr(inxmin+i,j) + enddo + enddo + else +!$OMP PARALLEL DO PRIVATE(j,i) COLLAPSE(2) + do j=1,aVsize + 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) COLLAPSE(2) + do j=1,aVsize + do i=1,mySharedIndices%num_indices + aVout%iAttr(mySharedIndices%aVindices2(i),j) = aVin%iAttr(mySharedIndices%aVindices1(i),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 :: inxmin, outxmin ! 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. + + ! 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) then + contiguous = .false. + exit + endif + enddo + if(contiguous) then + do i=2,num_indices + if(aVoutindices(i) /= aVoutindices(i-1)+1) then + contiguous=.false. + exit + endif + enddo + endif + +! Start copying (arranged loop order optimized for xlf90) + if(contiguous) then + + outxmin=aVoutindices(1)-1 + inxmin=aVinindices(1)-1 + if(usevector) then +!$OMP PARALLEL DO PRIVAtE(i,j) + do i=1,num_indices +!CDIR SELECT(VECTOR) +!DIR$ IVDEP + do j=1,aVsize + aVout%iAttr(outxmin+i,j) = aVin%iAttr(inxmin+i,j) + enddo + enddo + else +!$OMP PARALLEL DO PRIVATE(j,i) COLLAPSE(2) + do j=1,aVsize + 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) COLLAPSE(2) + do j=1,aVsize + do i=1,num_indices + aVout%iAttr(aVoutindices(i),j) = aVin%iAttr(aVinindices(i),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 + + 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. + + ! 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) + endif + + 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) + endif + + 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. + exit + 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. + exit + 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/mct/m_AttrVectComms.F90 b/mct/m_AttrVectComms.F90 new file mode 100644 index 000000000000..777a1e504adc --- /dev/null +++ b/mct/m_AttrVectComms.F90 @@ -0,0 +1,1683 @@ +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! 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/mct/m_AttrVectReduce.F90 b/mct/m_AttrVectReduce.F90 new file mode 100644 index 000000000000..e05eda342e3b --- /dev/null +++ b/mct/m_AttrVectReduce.F90 @@ -0,0 +1,1108 @@ +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! 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/mct/m_ConvertMaps.F90 b/mct/m_ConvertMaps.F90 new file mode 100644 index 000000000000..5132a697d7df --- /dev/null +++ b/mct/m_ConvertMaps.F90 @@ -0,0 +1,438 @@ +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! 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/mct/m_ExchangeMaps.F90 b/mct/m_ExchangeMaps.F90 new file mode 100644 index 000000000000..cb6100b23de3 --- /dev/null +++ b/mct/m_ExchangeMaps.F90 @@ -0,0 +1,613 @@ +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! 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/mct/m_GeneralGrid.F90 b/mct/m_GeneralGrid.F90 new file mode 100644 index 000000000000..474fbf9089a7 --- /dev/null +++ b/mct/m_GeneralGrid.F90 @@ -0,0 +1,3315 @@ +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! 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/mct/m_GeneralGridComms.F90 b/mct/m_GeneralGridComms.F90 new file mode 100644 index 000000000000..f5118309694a --- /dev/null +++ b/mct/m_GeneralGridComms.F90 @@ -0,0 +1,1536 @@ +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! 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/mct/m_GlobalMap.F90 b/mct/m_GlobalMap.F90 new file mode 100644 index 000000000000..b5273e566b7e --- /dev/null +++ b/mct/m_GlobalMap.F90 @@ -0,0 +1,672 @@ +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! 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/mct/m_GlobalSegMap.F90 b/mct/m_GlobalSegMap.F90 new file mode 100644 index 000000000000..a1960885fa8e --- /dev/null +++ b/mct/m_GlobalSegMap.F90 @@ -0,0 +1,2667 @@ +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! 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 + + 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 + integer :: max_activepe, p + logical, dimension(:), allocatable :: process_list + + ! retrieve total number of segments in the map: + + ngseg = ngseg_(GSMap) + + ! retrieve maximum active process id in the map: + + max_activepe = maxval(GSMap%pe_loc(:)) + + ! allocate workspace to tally process id list: + + allocate(process_list(0:max_activepe), stat=ierr) + if(ierr /= 0) call die(myname_,'allocate(process_list)',ierr) + + ! initialize process_list to false (i.e. no active pes) + + process_list = .false. + + ! 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 + + if (.not. process_list(GSMap%pe_loc(n))) then + process_list(GSMap%pe_loc(n)) = .true. + count = count + 1 + 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 and fill it + + if(present(pe_list)) then + + ! allocate pe_list + + allocate(pe_list(count), stat=ierr) + if (ierr /= 0) then + call die(myname_,'allocate(pe_list)',ierr) + endif + + i = 0 + do p=0,max_activepe + if (process_list(p)) then + i = i+1 + if (i > count) exit + pe_list(i) = p + endif + enddo + + if (i > count) then + call die(myname_,'pe_list fill error',count) + endif + + endif ! if(present(pe_list))... + + ! deallocate work array process_list... + + deallocate(process_list, stat=ierr) + if (ierr /= 0) then + call die(myname_,'deallocate(process_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. +! 18Oct16 - P. Worley - added algorithm options: +! new default changes complexity from O(npoints*ngseg) to +! O(gsize + ngseg) (worst case), and much better in current +! usage. Worst case memory requirements are O(gsize), but +! not seen in current usage. Other new algorithm is a little +! slower in practice, and worst case memory requirement is +! O(ngseg), which is also not seen in current usage. +! Original algorithm is recovered if compiled with +! LOW_MEMORY_PELOCS defined. Otherwise nondefault new +! algorithm is enabled if compiled with MEDIUM_MEMORY_PELOCS +! defined. +!EOP ___________________________________________________________________ + + character(len=*),parameter :: myname_=myname//'::peLocs_' + integer :: ierr + integer :: iseg, ngseg, ipoint + integer :: lower_index, upper_index + integer :: min_points_index, max_points_index +#if defined MEDIUM_MEMORY_PELOCS + integer :: ifseg, nfseg + integer, dimension(:), allocatable :: feasible_seg +#else + integer, dimension(:), allocatable :: pindices_to_pes +#endif + +! Input argument checks: + + if (npoints < 1) then + return + endif + + 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) + +#if defined LOW_MEMORY_PELOCS + + 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) + + exit + + endif + + end do ! do iseg=1, ngseg + + end do ! do ipoint=1,npoints + +#elif defined MEDIUM_MEMORY_PELOCS + +! Determine index range for points vector + max_points_index = 0 + min_points_index = pointGSMap%gsize + 1 + do ipoint=1,npoints ! loop over points + + max_points_index = max(points(ipoint), max_points_index) + min_points_index = min(points(ipoint), min_points_index) + + end do ! do ipoint=1,npoints + +! Determine number of segments that need to be examined + nfseg = 0 + do iseg=1,ngseg ! loop over segments + + lower_index = pointGSMap%start(iseg) + upper_index = lower_index + pointGSMap%length(iseg) - 1 + + if ((lower_index <= max_points_index) .and. & + (upper_index >= min_points_index) ) then + + nfseg = nfseg + 1 + + endif + + end do ! do iseg=1, ngseg + + if(nfseg < 1) then + ierr = nfseg + call die(myname_,'no feasible segments',ierr) + endif + + ! Allocate temporary array + allocate(feasible_seg(nfseg), stat=ierr) + if (ierr /= 0) then + call die(myname_,'allocate(feasible_seg)',ierr) + endif + + ! Determine segments that need to be examined + feasible_seg(:) = 1 + nfseg = 0 + do iseg=1,ngseg ! loop over segments + + lower_index = pointGSMap%start(iseg) + upper_index = lower_index + pointGSMap%length(iseg) - 1 + + if ((lower_index <= max_points_index) .and. & + (upper_index >= min_points_index) ) then + + nfseg = nfseg + 1 + feasible_seg(nfseg) = iseg + + endif + + end do ! do iseg=1, ngseg + + ! Calculate map from local points to pes + do ipoint=1,npoints ! loop over points + + do ifseg=1,nfseg ! loop over feasible segments + + iseg = feasible_seg(ifseg) + 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) + exit + endif + + end do ! do ifseg=1,nfseg + end do ! do ipoint=1,npoints + + ! Clean up + deallocate(feasible_seg, stat=ierr) + if (ierr /= 0) then + call die(myname_,'deallocate(feasible_seg)',ierr) + endif + +#else + +! Determine index range for points assigned to points vector + max_points_index = 0 + min_points_index = pointGSMap%gsize + 1 + do ipoint=1,npoints ! loop over points + + max_points_index = max(points(ipoint), max_points_index) + min_points_index = min(points(ipoint), min_points_index) + + end do ! do ipoint=1,npoints + +! Allocate temporary array + allocate(pindices_to_pes(min_points_index:max_points_index), stat=ierr) + if (ierr /= 0) then + call die(myname_,'allocate(pindices_to_pes)',ierr) + endif + +! Calculate map from (global) point indices to pes + do iseg=1,ngseg ! loop over segments + + lower_index = pointGSMap%start(iseg) + upper_index = lower_index + pointGSMap%length(iseg) - 1 + + lower_index = max(lower_index, min_points_index) + upper_index = min(upper_index, max_points_index) + + if (lower_index <= upper_index) then + do ipoint=lower_index,upper_index + pindices_to_pes(ipoint) = pointGSMap%pe_loc(iseg) + enddo + endif + + end do ! do iseg=1, ngseg + +! Calculate map from local point indices to pes + do ipoint=1,npoints ! loop over points + + pe_locs(ipoint) = pindices_to_pes(points(ipoint)) + + end do ! do ipoint=1,npoints + +! Clean up + deallocate(pindices_to_pes, stat=ierr) + if (ierr /= 0) then + call die(myname_,'deallocate(pindices_to_pes)',ierr) + endif + +#endif + + 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/mct/m_GlobalSegMapComms.F90 b/mct/m_GlobalSegMapComms.F90 new file mode 100644 index 000000000000..a5192a3b3e47 --- /dev/null +++ b/mct/m_GlobalSegMapComms.F90 @@ -0,0 +1,555 @@ +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! 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/mct/m_GlobalToLocal.F90 b/mct/m_GlobalToLocal.F90 new file mode 100644 index 000000000000..0b80a8362747 --- /dev/null +++ b/mct/m_GlobalToLocal.F90 @@ -0,0 +1,719 @@ +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! 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/mct/m_MCTWorld.F90 b/mct/m_MCTWorld.F90 new file mode 100644 index 000000000000..3ec6498526eb --- /dev/null +++ b/mct/m_MCTWorld.F90 @@ -0,0 +1,883 @@ +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! 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:root_nprocs(i)-1,i) + call MPI_IRECV(apoint, 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_mpif90 + 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) + + call MP_comm_free(ThisMCTWorld%MCT_comm, ier) + if(ier /= 0) call MP_perr_die(myname_,'MP_comm_free()',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/mct/m_MatAttrVectMul.F90 b/mct/m_MatAttrVectMul.F90 new file mode 100644 index 000000000000..080214c677a3 --- /dev/null +++ b/mct/m_MatAttrVectMul.F90 @@ -0,0 +1,642 @@ +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! 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_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$ IVDEP + do m=1,num_indices + do l=1,sMat%tbl_end +!CDIR NOLOOPCHG +!DIR$ IVDEP + 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$ IVDEP + 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) then + contiguous = .false. + exit + endif + enddo + if(contiguous) then + do i=2,num_indices + if(yAVindices(i) /= yAVindices(i-1)+1) then + contiguous=.false. + ycontiguous=.false. + exit + 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 +!dir$ collapse + 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$ IVDEP + 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$ IVDEP + 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, & + tag=sMatPlus%Tag, vector=usevector,& + alltoall=.true., handshake=.true. ) + + ! 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, & + tag=sMatPlus%Tag, sum=.TRUE., Vector=usevector, & + alltoall=.true., handshake=.true. ) + call AttrVect_Rcopy(yAVre,yAV,vector=usevector) + call AttrVect_clean(yAVre, ierr) + else + call Rearrange(yPrimeAV, yAV, sMatPlus%YPrimeToY, & + tag=sMatPlus%Tag, sum=.TRUE., Vector=usevector, & + alltoall=.true., handshake=.true. ) + 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, & + tag=sMatPlus%Tag, Vector=usevector, & + alltoall=.true., handshake=.true. ) + + ! 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, & + tag=sMatPlus%Tag, sum=.TRUE., Vector=usevector, & + alltoall=.true., handshake=.true. ) + call AttrVect_Rcopy(yAVre,yAV,vector=usevector) + call AttrVect_clean(yAVre, ierr) + else + call Rearrange(yPrimeAV, yAV, sMatPlus%YPrimeToY, & + tag=sMatPlus%Tag, sum=.TRUE., Vector=usevector, & + alltoall=.true., handshake=.true. ) + 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/mct/m_Merge.F90 b/mct/m_Merge.F90 new file mode 100644 index 000000000000..6700c3bc228d --- /dev/null +++ b/mct/m_Merge.F90 @@ -0,0 +1,2912 @@ +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! 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/mct/m_Navigator.F90 b/mct/m_Navigator.F90 new file mode 100644 index 000000000000..6c43ab36a924 --- /dev/null +++ b/mct/m_Navigator.F90 @@ -0,0 +1,666 @@ +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! 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/mct/m_Rearranger.F90 b/mct/m_Rearranger.F90 new file mode 100644 index 000000000000..654c72f1a8d1 --- /dev/null +++ b/mct/m_Rearranger.F90 @@ -0,0 +1,1426 @@ +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! 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,HandShake,ISend,MaxReq) + +! +! !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_SPMDutils, only : m_swapm_int, m_swapm_FP + 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 + logical, optional, intent(in) :: HandShake + logical, optional, intent(in) :: ISend + integer, optional, intent(in) :: MaxReq + +! !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. +! 29Sep16 - P. Worley - added swapm variant of +! alltoall option +!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, useswapm + 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 + + ! declare arrays to hold MPI data types for m_swapm_XXX calls + integer :: ITypes(0:max_nprocs-1) + integer :: RTypes(0:max_nprocs-1) + + ! 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 + + ! local swapm protocol variables and defaults + logical,parameter :: DEF_SWAPM_HS = .true. + logical swapm_hs + + logical,parameter :: DEF_SWAPM_ISEND = .false. + logical swapm_isend + + integer,parameter :: DEF_SWAPM_MAXREQ = 512 + integer swapm_maxreq + +!:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: + + 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 +!pw++ + ! forcing use of alltoall protocol until additional tuning + ! capabilities are added to calling routines +!pw usealltoall=.true. +!pw-- + + useswapm=.false. + if (usealltoall) then + ! if any swapm-related optional parameters are present, + ! enable swapm variant of alltoall + + swapm_hs = DEF_SWAPM_HS + if(present(HandShake)) then + if(HandShake) swapm_hs=.true. + useswapm=.true. + endif + + swapm_isend = DEF_SWAPM_ISEND + if(present(ISend)) then + if(ISend) swapm_isend=.true. + useswapm=.true. + endif + + swapm_maxreq = DEF_SWAPM_MAXREQ + if(present(MaxReq)) then + swapm_maxreq=MaxReq + useswapm=.true. + endif + +!pw++ + ! forcing use of swapm variant of alltoall protocol + ! until additional tuning capabilities are added to + ! calling routines +!pw useswapm=.true. +!pw-- + 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 + + ! SET MPI DATA TYPES + ITypes(:) = MP_INTEGER + RTypes(:) = mp_Type_rp + 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 (useswapm) then + + if (numi .ge. 1) then + call m_swapm_int(max_pe, myPid, & + ISendBuf, ISendSize, ISendCnts, ISdispls, ITypes, & + IRecvBuf, IRecvSize, IRecvCnts, IRdispls, ITypes, & + ThisMCTWorld%MCT_comm, & + swapm_hs, swapm_isend, swapm_maxreq ) + endif + + if (numr .ge. 1) then + call m_swapm_FP (max_pe, myPid, & + RSendBuf, RSendSize, RSendCnts, RSdispls, RTypes, & + RRecvBuf, RRecvSize, RRecvCnts, RRdispls, RTypes, & + ThisMCTWorld%MCT_comm, & + swapm_hs, swapm_isend, swapm_maxreq ) + endif + + else + + 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 + + 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/mct/m_Router.F90 b/mct/m_Router.F90 new file mode 100644 index 000000000000..f8788d608f79 --- /dev/null +++ b/mct/m_Router.F90 @@ -0,0 +1,869 @@ +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! 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. +! 12Nov16 - P. Worley - eliminate iterations in nested +! loop that can be determined to be unnecessary +!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 :: my_leftmost ! Leftmost point in local segments (global memory) + integer :: my_rightmost ! Rightmost point in local segments (global memory) + integer :: r_left ! Left point in remote segment (global memory) + integer :: r_right ! Right point in remote segment (global memory) + integer :: r_leftmost ! Leftmost point and rightmost point + integer :: r_rightmost ! in remote segments in given process (global memory) + integer :: nsegs_overlap ! Number of segments that overlap between two procs + + + integer :: ngseg, nlseg + integer :: myseg, rseg + integer :: rseg_leftbase, rseg_start + 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,allocatable :: rgs_count(:),rgs_lb(:,:),rgs_ub(:,:) + integer,allocatable :: nsegs_overlap_arr(:) + + integer :: overlap_left, overlap_right, overlap_diff + + integer :: proc, nprocs + integer :: feas_proc, feas_nprocs + integer,allocatable :: feas_procs(:), inv_feas_procs(:) + + 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 possibly overlapping segments +!! in RGSMap that are local to each proc +!! + nprocs=ThisMCTWorld%nprocspid(othercomp) + r_ngseg = GlobalSegMap_ngseg(RGSMap) + + if (nlseg > 0) then + my_leftmost = mygs_lb(1) + my_rightmost = mygs_ub(nlseg) + +!! +!! count number of potentially overlapping remote segments +!! and which and how many processes hold these +!! + if(present(name)) then + tagname='04'//name//'rloop' + call zeit_ci(trim(tagname)) + endif + + !! number of potentially overlapping segments in RGSMap local to proc + !! and mapping from processes that hold these to actual process id + allocate( rgs_count(nprocs), feas_procs(nprocs), & + inv_feas_procs(nprocs), stat=ier ) + if(ier/=0) call die(myname_,'allocate rgs_count, feas_procs',ier) + + rgs_count = 0 + do i=1,r_ngseg + r_left = RGSMap%start(i) + r_right = RGSMap%start(i) + RGSMap%length(i) - 1 + + if (.not. (my_rightmost < r_left .or. & ! potential overlap + my_leftmost > r_right ) ) then + 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 + endif + + enddo + + feas_nprocs = 0 + feas_procs = -1 + inv_feas_procs = -1 + do proc=1,nprocs + if (rgs_count(proc) > 0) then + feas_nprocs = feas_nprocs + 1 + feas_procs(feas_nprocs) = proc + inv_feas_procs(proc) = feas_nprocs + endif + enddo + +!! +!! build list of potentially overlapping remote segments +!! + !! 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) + !! then further reduced to (max_rgs_count,feas_nprocs) + + max_rgs_count=0 + do proc=1,nprocs + max_rgs_count = max( max_rgs_count, rgs_count(proc) ) + enddo + + allocate( rgs_lb(max_rgs_count,feas_nprocs), & + rgs_ub(max_rgs_count,feas_nprocs), & + nsegs_overlap_arr(feas_nprocs), stat=ier ) + if(ier/=0) call die(myname_,'allocate rgs, nsegs',ier) + + !! (note: redefining rgs_count to be indexed as 1:feas_nprocs + !! instead of as 1:nprocs) + rgs_count = 0 + do i=1,r_ngseg + r_left = RGSMap%start(i) + r_right = RGSMap%start(i) + RGSMap%length(i) -1 + + if (.not. (my_rightmost < r_left .or. & ! potential overlap + my_leftmost > r_right) ) then + proc = RGSMap%pe_loc(i) + 1 + feas_proc = inv_feas_procs(proc) + rgs_count(feas_proc) = rgs_count(feas_proc) + 1 + rgs_lb( rgs_count(feas_proc) , feas_proc ) = RGSMap%start(i) + rgs_ub( rgs_count(feas_proc) , feas_proc ) = RGSMap%start(i) + RGSMap%length(i) -1 + endif + + enddo + + deallocate(inv_feas_procs,stat=ier) + if(ier/=0) call die(myname_,'deallocate inv_feas_procs',ier) + + if(present(name)) then + call zeit_co(trim(tagname)) + endif + + else + + max_rgs_count = 0 + feas_nprocs = 0 + + 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_overlap_segs = max(nlseg,max_rgs_count) + + allocate(tmpsegcount(feas_nprocs, max_overlap_segs),& + tmpsegstart(feas_nprocs, max_overlap_segs),& + tmppe_list(feas_nprocs),stat=ier) + if(ier/=0) & + call die( myname_,'allocate tmpsegcount etc. size ', & + feas_nprocs, ' by ',max_overlap_segs) + + if (feas_nprocs > 0) then + tmpsegcount=0 + tmpsegstart=0 + endif + count =0 + maxsegcount=0 + +!!!!!!!!!!!!!!!!!! + + do feas_proc = 1, feas_nprocs + nsegs_overlap = 0 + tmppe_list(feas_proc) = .FALSE. ! no overlaps with proc yet + + r_leftmost = rgs_lb(1,feas_proc) + r_rightmost = rgs_ub(rgs_count(feas_proc),feas_proc) + + rseg_leftbase = 0 + do myseg = 1, nlseg ! loop over local segs on 'myPID' + + my_left = mygs_lb(myseg) + my_right= mygs_ub(myseg) + + ! determine whether any overlap + if (.not. (my_right < r_leftmost .or. & + my_left > r_rightmost) ) then + + rseg_start = rseg_leftbase + 1 ! rseg loop index to start searching from + + ! loop over candidate overlapping remote segs on 'feas_proc' + do rseg = rseg_start, rgs_count(feas_proc) + + r_right = rgs_ub(rseg,feas_proc) + if (r_right < my_left ) then ! to the left + rseg_leftbase = rseg ! remember to start to the right of + ! this for next myseg + cycle ! try the next remote segment + endif + + r_left = rgs_lb(rseg,feas_proc) + if (r_left > my_right) exit ! to the right, so no more segments + ! need to be examined + + ! otherwise, overlaps + if (nsegs_overlap == 0) then ! first overlap w/this proc + count = count + 1 + tmppe_list(feas_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 + + enddo + + endif + + enddo + + nsegs_overlap_arr(feas_proc)=nsegs_overlap + enddo + + !! pull this out of the loop to vectorize + do feas_proc = 1, feas_nprocs + maxsegcount=max(maxsegcount,nsegs_overlap_arr(feas_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, stat=ier) + if(ier/=0) call die(myname_,'deallocate mygs,nsegs',ier) + + if (nlseg > 0) then + deallocate( rgs_count, rgs_lb, rgs_ub, & + nsegs_overlap_arr, stat=ier) + if(ier/=0) call die(myname_,'deallocate p_rgs, nsegs',ier) + endif + +! 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,feas_nprocs + if(tmppe_list(i))then + m=m+1 + ! load processor rank in MCT_comm + proc = feas_procs(i) + Rout%pe_list(m)=ThisMCTWorld%idGprocid(othercomp,proc-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 + + if (nlseg > 0) then + deallocate(feas_procs,stat=ier) + if(ier/=0) call die(myname_,'deallocate feas_procs',ier) + endif + + deallocate(tmpsegstart,tmpsegcount,tmppe_list,stat=ier) + if(ier/=0) call die(myname_,'deallocate tmp',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/mct/m_SPMDutils.F90 b/mct/m_SPMDutils.F90 new file mode 100644 index 000000000000..d2bbd59cfa54 --- /dev/null +++ b/mct/m_SPMDutils.F90 @@ -0,0 +1,1148 @@ +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! Math and Computer Science Division, Argonne National Laboratory ! +!----------------------------------------------------------------------- +! CVS $Id$ +! CVS $Name$ +!BOP ------------------------------------------------------------------- +! +! !MODULE: m_SPMDutils -- Communication operators to address performance +! issues for specific communication patterns +! +! !DESCRIPTION: +! This module provides the swapm equivalent to MPI_Alltoallv that +! has proven to be more robust with respect to performance than the +! MPI collective or the native MCT communication algorithms when the +! communication pattern is sparse and when load imbalance or send/receive +! asymmetry leads some processes to be flooded by unexpected messages. +! +! Based on algorithms implemented in CAM, but this version modelled after +! pio_spmd_utils.F90 in PIO1 +! +! !SEE ALSO: +! m_Rearranger +! +! +! !INTERFACE: + +! Disable the use of the MPI ready send protocol by default, to +! address recurrent issues with poor performance or incorrect +! functionality in MPI libraries. When support is known to be robust, +! or for experimentation, can be re-enabled by defining the CPP token +! _USE_MPI_RSEND during the build process. +! +#ifndef _USE_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_SPMDutils + + implicit none + + private ! except + +! !PUBLIC MEMBER FUNCTIONS: + + public :: m_swapm_int ! swapm alternative to MPI_AlltoallV for integer data + public :: m_swapm_FP ! swapm alternative to MPI_AlltoallV for FP data + +! !DEFINED PARAMETERS: + + character(len=*), parameter :: myname='MCT::m_SPMDutils' + +! !REVISION HISTORY: +! 28Sep16 - P. Worley - initial prototype +!EOP ___________________________________________________________________ + + contains + +!======================================================================== +! + + integer function pair(np,p,k) + + integer np,p,k,q + q = ieor(p,k) + if(q.gt.np-1) then + pair = -1 + else + pair = q + endif + return + + end function pair + +! +!======================================================================== +! + + integer function ceil2(n) + integer n,p + p=1 + do while(p.lt.n) + p=p*2 + enddo + ceil2=p + return + end function ceil2 + +! +!======================================================================== +! + subroutine m_swapm_int ( nprocs, mytask, & + sndbuf, sbuf_siz, sndlths, sdispls, stypes, & + rcvbuf, rbuf_siz, rcvlths, rdispls, rtypes, & + comm, comm_hs, comm_isend, comm_maxreq ) + +!----------------------------------------------------------------------- +! +!> Purpose: +!! Reduced version of original swapm (for swap of multiple messages +!! using MPI point-to-point routines), more efficiently implementing a +!! subset of the swap protocols. +!! +!! Method: +!! comm_protocol: +!! comm_isend == .true.: use nonblocking send, else use blocking send +!! comm_hs == .true.: use handshaking protocol +!! comm_maxreq: +!! =-1,0: do not limit number of outstanding send/receive requests +!! >0: do not allow more than min(comm_maxreq, steps) outstanding +!! nonblocking send requests or nonblocking receive requests +!! +!! Author of original version: P. Worley +!! Ported from PIO1: P. Worley, September 2016 +!< +!----------------------------------------------------------------------- +!----------------------------------------------------------------------- + use m_mpif90 + use m_realkinds, only : FP + use m_die, only : MP_perr_die + + implicit none +!---------------------------Input arguments-------------------------- +! + integer, intent(in) :: nprocs ! size of communicator + integer, intent(in) :: mytask ! MPI task id with communicator + integer, intent(in) :: sbuf_siz ! size of send buffer + integer, intent(in) :: rbuf_siz ! size of receive buffer + + integer, intent(in) :: sndlths(0:nprocs-1)! length of outgoing message + integer, intent(in) :: sdispls(0:nprocs-1)! offset from beginning of send + ! buffer where outgoing messages + ! should be sent from + integer, intent(in) :: stypes(0:nprocs-1) ! MPI data types + integer, intent(in) :: rcvlths(0:nprocs-1)! length of incoming messages + integer, intent(in) :: rdispls(0:nprocs-1)! offset from beginning of receive + ! buffer where incoming messages + ! should be placed + integer, intent(in) :: rtypes(0:nprocs-1) ! MPI data types + integer, intent(in) :: sndbuf(sbuf_siz) ! outgoing message buffer + + integer, intent(in) :: comm ! MPI communicator + logical, intent(in) :: comm_hs ! handshaking protocol? + logical, intent(in) :: comm_isend ! nonblocking send protocol? + integer, intent(in) :: comm_maxreq ! maximum number of outstanding + ! nonblocking requests + +!---------------------------Output arguments-------------------------- +! + integer, intent(out) :: rcvbuf(rbuf_siz) ! incoming message buffer + +! +!---------------------------Local workspace------------------------------------------- +! + character(len=*), parameter :: subName=myname//'::m_swapm_int' + + integer :: steps ! number of swaps to initiate + integer :: swapids(nprocs) ! MPI process id of swap partners + integer :: p ! process index + integer :: istep ! loop index + integer :: tag ! MPI message tag + integer :: offset_t ! MPI message tag offset, for addressing + ! message conflict bug (if necessary) + integer :: offset_s ! index of message beginning in + ! send buffer + integer :: offset_r ! index of message beginning in + ! receive buffer + integer :: sndids(nprocs) ! send request ids + integer :: rcvids(nprocs) ! receive request ids + integer :: hs_rcvids(nprocs) ! handshake receive request ids + + integer :: maxreq, maxreqh ! maximum number of outstanding + ! nonblocking requests (and half) + integer :: hs ! handshake variable + integer :: rstep ! "receive" step index + + logical :: handshake, sendd ! protocol option flags + + integer :: ier ! return error status + integer :: status(MP_STATUS_SIZE) ! MPI status +! +!------------------------------------------------------------------------------------- +! +#ifdef _NO_M_SWAPM_TAG_OFFSET + offset_t = 0 +#else + offset_t = nprocs +#endif +! + ! if necessary, send to self + if (sndlths(mytask) > 0) then + tag = mytask + offset_t + + offset_r = rdispls(mytask)+1 + call mpi_irecv( rcvbuf(offset_r), rcvlths(mytask), rtypes(mytask), & + mytask, tag, comm, rcvids(1), ier ) + if(ier /= 0) call MP_perr_die(subName,'MPI_IRECV',ier) + + offset_s = sdispls(mytask)+1 + call mpi_send( sndbuf(offset_s), sndlths(mytask), stypes(mytask), & + mytask, tag, comm, ier ) + if(ier /= 0) call MP_perr_die(subName,'MPI_SEND',ier) + + call mpi_wait( rcvids(1), status, ier ) + if(ier /= 0) call MP_perr_die(subName,'MPI_WAIT',ier) + endif + + ! calculate swap partners and communication ordering + steps = 0 + do istep=1,ceil2(nprocs)-1 + p = pair(nprocs,istep,mytask) + if (p >= 0) then + if (sndlths(p) > 0 .or. rcvlths(p) > 0) then + steps = steps + 1 + swapids(steps) = p + end if + end if + end do + + if (steps .eq. 0) return + + ! identify communication protocol + if (comm_isend) then + sendd = .false. + else + sendd = .true. + endif + handshake = comm_hs + + ! identify maximum number of outstanding nonblocking requests to permit + if (steps .eq. 1) then + maxreq = 1 + maxreqh = 1 + else + if (comm_maxreq >= -1) then + maxreq = comm_maxreq + else + maxreq = steps + endif + + if ((maxreq .le. steps) .and. (maxreq > 0)) then + if (maxreq > 1) then + maxreqh = maxreq/2 + else + maxreq = 2 + maxreqh = 1 + endif + else + maxreq = steps + maxreqh = steps + endif + endif + +! Four protocol options: +! (1) handshaking + blocking sends + if ((handshake) .and. (sendd)) then + + ! Initialize hs variable + hs = 1 + + ! Post initial handshake receive requests + do istep=1,maxreq + p = swapids(istep) + if (sndlths(p) > 0) then + tag = mytask + offset_t + call mpi_irecv( hs, 1, MP_INTEGER, p, tag, comm, & + hs_rcvids(istep), ier ) + if(ier /= 0) call MP_perr_die(subName,'MPI_IRECV',ier) + endif + enddo + + ! Post initial receive requests + do istep=1,maxreq + p = swapids(istep) + if (rcvlths(p) > 0) then + tag = p + offset_t + + offset_r = rdispls(p)+1 + call mpi_irecv( rcvbuf(offset_r), rcvlths(p), rtypes(p), & + p, tag, comm, rcvids(istep), ier ) + if(ier /= 0) call MP_perr_die(subName,'MPI_IRECV',ier) + + call mpi_send ( hs, 1, MP_INTEGER, p, tag, comm, ier ) + if(ier /= 0) call MP_perr_die(subName,'MPI_SEND',ier) + endif + enddo + rstep = maxreq + + ! Send (and start receiving) data + do istep=1,steps + p = swapids(istep) + + ! Submit new rsend request + if (sndlths(p) > 0) then + tag = mytask + offset_t + + offset_s = sdispls(p)+1 + call mpi_wait ( hs_rcvids(istep), status, ier ) + if(ier /= 0) call MP_perr_die(subName,'MPI_WAIT',ier) + + call mpi_rsend ( sndbuf(offset_s), sndlths(p), stypes(p), & + p, tag, comm, ier ) + if(ier /= 0) call MP_perr_die(subName,'MPI_RSEND',ier) + endif + + if (istep > maxreqh) then + + ! Wait for oldest irecv request to complete + p = swapids(istep-maxreqh) + if (rcvlths(p) > 0) then + call mpi_wait( rcvids(istep-maxreqh), status, ier ) + if(ier /= 0) call MP_perr_die(subName,'MPI_WAIT',ier) + endif + + if (rstep < steps) then + rstep = rstep + 1 + p = swapids(rstep) + + ! Submit a new handshake irecv request + if (sndlths(p) > 0) then + tag = mytask + offset_t + call mpi_irecv( hs, 1, MP_INTEGER, p, tag, comm, & + hs_rcvids(rstep), ier ) + if(ier /= 0) call MP_perr_die(subName,'MPI_IRECV',ier) + endif + + ! Submit a new irecv request + if (rcvlths(p) > 0) then + tag = p + offset_t + + offset_r = rdispls(p)+1 + call mpi_irecv( rcvbuf(offset_r), rcvlths(p), rtypes(p), & + p, tag, comm, rcvids(rstep), ier ) + if(ier /= 0) call MP_perr_die(subName,'MPI_IRECV',ier) + + call mpi_send ( hs, 1, MP_INTEGER, p, tag, comm, ier ) + if(ier /= 0) call MP_perr_die(subName,'MPI_SEND',ier) + endif + endif + + endif +! + enddo + + ! wait for rest of receive requests to complete + do istep=steps-maxreqh+1,steps + p = swapids(istep) + if (rcvlths(p) > 0) then + call mpi_wait( rcvids(istep), status, ier ) + if(ier /= 0) call MP_perr_die(subName,'MPI_WAIT',ier) + endif + enddo + +! (2) handshaking + nonblocking sends + elseif ((handshake) .and. (.not. sendd)) then + + ! Initialize hs variable + hs = 1 + + ! Post initial handshake receive requests + do istep=1,maxreq + p = swapids(istep) + if (sndlths(p) > 0) then + tag = mytask + offset_t + call mpi_irecv( hs, 1, MP_INTEGER, p, tag, comm, & + hs_rcvids(istep), ier ) + if(ier /= 0) call MP_perr_die(subName,'MPI_IRECV',ier) + endif + enddo + + ! Post initial receive requests + do istep=1,maxreq + p = swapids(istep) + if (rcvlths(p) > 0) then + tag = p + offset_t + + offset_r = rdispls(p)+1 + call mpi_irecv( rcvbuf(offset_r), rcvlths(p), rtypes(p), & + p, tag, comm, rcvids(istep), ier ) + if(ier /= 0) call MP_perr_die(subName,'MPI_IRECV',ier) + + call mpi_send ( hs, 1, MP_INTEGER, p, tag, comm, ier ) + if(ier /= 0) call MP_perr_die(subName,'MPI_SEND',ier) + endif + enddo + rstep = maxreq + + ! Send (and start receiving) data + do istep=1,steps + p = swapids(istep) + + ! Submit new irsend request + if (sndlths(p) > 0) then + tag = mytask + offset_t + + offset_s = sdispls(p)+1 + call mpi_wait ( hs_rcvids(istep), status, ier ) + if(ier /= 0) call MP_perr_die(subName,'MPI_WAIT',ier) + + call mpi_irsend( sndbuf(offset_s), sndlths(p), stypes(p), & + p, tag, comm, sndids(istep), ier ) + if(ier /= 0) call MP_perr_die(subName,'MPI_IRSEND',ier) + endif + + if (istep > maxreqh) then + + ! Wait for oldest irecv request to complete + p = swapids(istep-maxreqh) + if (rcvlths(p) > 0) then + call mpi_wait( rcvids(istep-maxreqh), status, ier ) + if(ier /= 0) call MP_perr_die(subName,'MPI_WAIT',ier) + endif + + if (rstep < steps) then + rstep = rstep + 1 + p = swapids(rstep) + + ! Submit a new handshake irecv request + if (sndlths(p) > 0) then + tag = mytask + offset_t + call mpi_irecv( hs, 1, MP_INTEGER, p, tag, comm, & + hs_rcvids(rstep), ier ) + if(ier /= 0) call MP_perr_die(subName,'MPI_IRECV',ier) + endif + + ! Submit a new irecv request + if (rcvlths(p) > 0) then + tag = p + offset_t + + offset_r = rdispls(p)+1 + call mpi_irecv( rcvbuf(offset_r), rcvlths(p), rtypes(p), & + p, tag, comm, rcvids(rstep), ier ) + if(ier /= 0) call MP_perr_die(subName,'MPI_IRECV',ier) + + call mpi_send ( hs, 1, MP_INTEGER, p, tag, comm, ier ) + if(ier /= 0) call MP_perr_die(subName,'MPI_SEND',ier) + endif + endif + + ! Wait for outstanding i(r)send request to complete + p = swapids(istep-maxreqh) + if (sndlths(p) > 0) then + call mpi_wait( sndids(istep-maxreqh), status, ier ) + if(ier /= 0) call MP_perr_die(subName,'MPI_WAIT',ier) + endif + + endif + + enddo + + ! wait for rest of send and receive requests to complete + do istep=steps-maxreqh+1,steps + p = swapids(istep) + if (rcvlths(p) > 0) then + call mpi_wait( rcvids(istep), status, ier ) + if(ier /= 0) call MP_perr_die(subName,'MPI_WAIT',ier) + endif + if (sndlths(p) > 0) then + call mpi_wait( sndids(istep), status, ier ) + if(ier /= 0) call MP_perr_die(subName,'MPI_WAIT',ier) + endif + enddo + +! (3) no handshaking + blocking sends + elseif ((.not. handshake) .and. (sendd)) then + + ! Post receive requests + do istep=1,maxreq + p = swapids(istep) + if (rcvlths(p) > 0) then + tag = p + offset_t + + offset_r = rdispls(p)+1 + call mpi_irecv( rcvbuf(offset_r), rcvlths(p), rtypes(p), & + p, tag, comm, rcvids(istep), ier ) + if(ier /= 0) call MP_perr_die(subName,'MPI_IRECV',ier) + endif + enddo + rstep = maxreq + + ! Send (and start receiving) data + do istep=1,steps + p = swapids(istep) + + ! Submit new send request + if (sndlths(p) > 0) then + tag = mytask + offset_t + + offset_s = sdispls(p)+1 + call mpi_send( sndbuf(offset_s), sndlths(p), stypes(p), & + p, tag, comm, ier ) + if(ier /= 0) call MP_perr_die(subName,'MPI_SEND',ier) + endif + + if (istep > maxreqh) then + + ! Wait for oldest irecv request to complete + p = swapids(istep-maxreqh) + if (rcvlths(p) > 0) then + call mpi_wait( rcvids(istep-maxreqh), status, ier ) + if(ier /= 0) call MP_perr_die(subName,'MPI_WAIT',ier) + endif + + ! Submit a new irecv request + if (rstep < steps) then + rstep = rstep + 1 + p = swapids(rstep) + if (rcvlths(p) > 0) then + tag = p + offset_t + + offset_r = rdispls(p)+1 + call mpi_irecv( rcvbuf(offset_r), rcvlths(p), rtypes(p), & + p, tag, comm, rcvids(rstep), ier ) + if(ier /= 0) call MP_perr_die(subName,'MPI_IRECV',ier) + endif + endif + + endif + + enddo + + ! wait for rest of send and receive requests to complete + do istep=steps-maxreqh+1,steps + p = swapids(istep) + if (rcvlths(p) > 0) then + call mpi_wait( rcvids(istep), status, ier ) + if(ier /= 0) call MP_perr_die(subName,'MPI_WAIT',ier) + endif + enddo + +! (4) no handshaking + nonblocking sends + elseif ((.not. handshake) .and. (.not. sendd)) then + + ! Post receive requests + do istep=1,maxreq + p = swapids(istep) + if (rcvlths(p) > 0) then + tag = p + offset_t + + offset_r = rdispls(p)+1 + call mpi_irecv( rcvbuf(offset_r), rcvlths(p), rtypes(p), & + p, tag, comm, rcvids(istep), ier ) + if(ier /= 0) call MP_perr_die(subName,'MPI_IRECV',ier) + endif + enddo + rstep = maxreq + + ! Send (and start receiving) data + do istep=1,steps + p = swapids(istep) + + ! Submit new isend request + if (sndlths(p) > 0) then + tag = mytask + offset_t + + offset_s = sdispls(p)+1 + call mpi_isend( sndbuf(offset_s), sndlths(p), stypes(p), & + p, tag, comm, sndids(istep), ier ) + if(ier /= 0) call MP_perr_die(subName,'MPI_ISEND',ier) + endif + + if (istep > maxreqh) then + + ! Wait for oldest irecv request to complete + p = swapids(istep-maxreqh) + if (rcvlths(p) > 0) then + call mpi_wait( rcvids(istep-maxreqh), status, ier ) + if(ier /= 0) call MP_perr_die(subName,'MPI_WAIT',ier) + endif + + ! Submit a new irecv request + if (rstep < steps) then + rstep = rstep + 1 + p = swapids(rstep) + if (rcvlths(p) > 0) then + tag = p + offset_t + + offset_r = rdispls(p)+1 + call mpi_irecv( rcvbuf(offset_r), rcvlths(p), rtypes(p), & + p, tag, comm, rcvids(rstep), ier ) + if(ier /= 0) call MP_perr_die(subName,'MPI_IRECV',ier) + endif + endif + + ! Wait for outstanding i(r)send request to complete + p = swapids(istep-maxreqh) + if (sndlths(p) > 0) then + call mpi_wait( sndids(istep-maxreqh), status, ier ) + if(ier /= 0) call MP_perr_die(subName,'MPI_WAIT',ier) + endif + + endif + + enddo + + ! wait for rest of send and receive requests to complete + do istep=steps-maxreqh+1,steps + p = swapids(istep) + if (rcvlths(p) > 0) then + call mpi_wait( rcvids(istep), status, ier ) + if(ier /= 0) call MP_perr_die(subName,'MPI_WAIT',ier) + endif + if (sndlths(p) > 0) then + call mpi_wait( sndids(istep), status, ier ) + if(ier /= 0) call MP_perr_die(subName,'MPI_WAIT',ier) + endif + enddo + + endif + + return + + end subroutine m_swapm_int + +! +!======================================================================== +! + subroutine m_swapm_FP ( nprocs, mytask, & + sndbuf, sbuf_siz, sndlths, sdispls, stypes, & + rcvbuf, rbuf_siz, rcvlths, rdispls, rtypes, & + comm, comm_hs, comm_isend, comm_maxreq ) + +!----------------------------------------------------------------------- +! +!> Purpose: +!! Reduced version of original swapm (for swap of multiple messages +!! using MPI point-to-point routines), more efficiently implementing a +!! subset of the swap protocols. +!! +!! Method: +!! comm_protocol: +!! comm_isend == .true.: use nonblocking send, else use blocking send +!! comm_hs == .true.: use handshaking protocol +!! comm_maxreq: +!! =-1,0: do not limit number of outstanding send/receive requests +!! >0: do not allow more than min(comm_maxreq, steps) outstanding +!! nonblocking send requests or nonblocking receive requests +!! +!! Author of original version: P. Worley +!! Ported from PIO1: P. Worley, September 2016 +!< +!----------------------------------------------------------------------- +!----------------------------------------------------------------------- + use m_mpif90 + use m_realkinds, only : FP + use m_die, only : MP_perr_die + + implicit none +!---------------------------Input arguments-------------------------- +! + integer, intent(in) :: nprocs ! size of communicator + integer, intent(in) :: mytask ! MPI task id with communicator + integer, intent(in) :: sbuf_siz ! size of send buffer + integer, intent(in) :: rbuf_siz ! size of receive buffer + + integer, intent(in) :: sndlths(0:nprocs-1)! length of outgoing message + integer, intent(in) :: sdispls(0:nprocs-1)! offset from beginning of send + ! buffer where outgoing messages + ! should be sent from + integer, intent(in) :: stypes(0:nprocs-1) ! MPI data types + integer, intent(in) :: rcvlths(0:nprocs-1)! length of incoming messages + integer, intent(in) :: rdispls(0:nprocs-1)! offset from beginning of receive + ! buffer where incoming messages + ! should be placed + integer, intent(in) :: rtypes(0:nprocs-1) ! MPI data types + real(FP),intent(in) :: sndbuf(sbuf_siz) ! outgoing message buffer + + integer, intent(in) :: comm ! MPI communicator + logical, intent(in) :: comm_hs ! handshaking protocol? + logical, intent(in) :: comm_isend ! nonblocking send protocol? + integer, intent(in) :: comm_maxreq ! maximum number of outstanding + ! nonblocking requests + +!---------------------------Output arguments-------------------------- +! + real(FP), intent(out) :: rcvbuf(rbuf_siz) ! incoming message buffer + +! +!---------------------------Local workspace------------------------------------------- +! + character(len=*), parameter :: subName=myname//'::m_swapm_FP' + + integer :: steps ! number of swaps to initiate + integer :: swapids(nprocs) ! MPI process id of swap partners + integer :: p ! process index + integer :: istep ! loop index + integer :: tag ! MPI message tag + integer :: offset_t ! MPI message tag offset, for addressing + ! message conflict bug (if necessary) + integer :: offset_s ! index of message beginning in + ! send buffer + integer :: offset_r ! index of message beginning in + ! receive buffer + integer :: sndids(nprocs) ! send request ids + integer :: rcvids(nprocs) ! receive request ids + integer :: hs_rcvids(nprocs) ! handshake receive request ids + + integer :: maxreq, maxreqh ! maximum number of outstanding + ! nonblocking requests (and half) + integer :: hs ! handshake variable + integer :: rstep ! "receive" step index + + logical :: handshake, sendd ! protocol option flags + + integer :: ier ! return error status + integer :: status(MP_STATUS_SIZE) ! MPI status +! +!------------------------------------------------------------------------------------- +! +#ifdef _NO_M_SWAPM_TAG_OFFSET + offset_t = 0 +#else + offset_t = nprocs +#endif +! + ! if necessary, send to self + if (sndlths(mytask) > 0) then + tag = mytask + offset_t + + offset_r = rdispls(mytask)+1 + call mpi_irecv( rcvbuf(offset_r), rcvlths(mytask), rtypes(mytask), & + mytask, tag, comm, rcvids(1), ier ) + if(ier /= 0) call MP_perr_die(subName,'MPI_IRECV',ier) + + offset_s = sdispls(mytask)+1 + call mpi_send( sndbuf(offset_s), sndlths(mytask), stypes(mytask), & + mytask, tag, comm, ier ) + if(ier /= 0) call MP_perr_die(subName,'MPI_SEND',ier) + + call mpi_wait( rcvids(1), status, ier ) + if(ier /= 0) call MP_perr_die(subName,'MPI_WAIT',ier) + endif + + ! calculate swap partners and communication ordering + steps = 0 + do istep=1,ceil2(nprocs)-1 + p = pair(nprocs,istep,mytask) + if (p >= 0) then + if (sndlths(p) > 0 .or. rcvlths(p) > 0) then + steps = steps + 1 + swapids(steps) = p + end if + end if + end do + + if (steps .eq. 0) return + + ! identify communication protocol + if (comm_isend) then + sendd = .false. + else + sendd = .true. + endif + handshake = comm_hs + + ! identify maximum number of outstanding nonblocking requests to permit + if (steps .eq. 1) then + maxreq = 1 + maxreqh = 1 + else + if (comm_maxreq >= -1) then + maxreq = comm_maxreq + else + maxreq = steps + endif + + if ((maxreq .le. steps) .and. (maxreq > 0)) then + if (maxreq > 1) then + maxreqh = maxreq/2 + else + maxreq = 2 + maxreqh = 1 + endif + else + maxreq = steps + maxreqh = steps + endif + endif + +! Four protocol options: +! (1) handshaking + blocking sends + if ((handshake) .and. (sendd)) then + + ! Initialize hs variable + hs = 1 + + ! Post initial handshake receive requests + do istep=1,maxreq + p = swapids(istep) + if (sndlths(p) > 0) then + tag = mytask + offset_t + call mpi_irecv( hs, 1, MP_INTEGER, p, tag, comm, & + hs_rcvids(istep), ier ) + if(ier /= 0) call MP_perr_die(subName,'MPI_IRECV',ier) + endif + enddo + + ! Post initial receive requests + do istep=1,maxreq + p = swapids(istep) + if (rcvlths(p) > 0) then + tag = p + offset_t + + offset_r = rdispls(p)+1 + call mpi_irecv( rcvbuf(offset_r), rcvlths(p), rtypes(p), & + p, tag, comm, rcvids(istep), ier ) + if(ier /= 0) call MP_perr_die(subName,'MPI_IRECV',ier) + + call mpi_send ( hs, 1, MP_INTEGER, p, tag, comm, ier ) + if(ier /= 0) call MP_perr_die(subName,'MPI_SEND',ier) + endif + enddo + rstep = maxreq + + ! Send (and start receiving) data + do istep=1,steps + p = swapids(istep) + + ! Submit new rsend request + if (sndlths(p) > 0) then + tag = mytask + offset_t + + offset_s = sdispls(p)+1 + call mpi_wait ( hs_rcvids(istep), status, ier ) + if(ier /= 0) call MP_perr_die(subName,'MPI_WAIT',ier) + + call mpi_rsend ( sndbuf(offset_s), sndlths(p), stypes(p), & + p, tag, comm, ier ) + if(ier /= 0) call MP_perr_die(subName,'MPI_RSEND',ier) + endif + + if (istep > maxreqh) then + + ! Wait for oldest irecv request to complete + p = swapids(istep-maxreqh) + if (rcvlths(p) > 0) then + call mpi_wait( rcvids(istep-maxreqh), status, ier ) + if(ier /= 0) call MP_perr_die(subName,'MPI_WAIT',ier) + endif + + if (rstep < steps) then + rstep = rstep + 1 + p = swapids(rstep) + + ! Submit a new handshake irecv request + if (sndlths(p) > 0) then + tag = mytask + offset_t + call mpi_irecv( hs, 1, MP_INTEGER, p, tag, comm, & + hs_rcvids(rstep), ier ) + if(ier /= 0) call MP_perr_die(subName,'MPI_IRECV',ier) + endif + + ! Submit a new irecv request + if (rcvlths(p) > 0) then + tag = p + offset_t + + offset_r = rdispls(p)+1 + call mpi_irecv( rcvbuf(offset_r), rcvlths(p), rtypes(p), & + p, tag, comm, rcvids(rstep), ier ) + if(ier /= 0) call MP_perr_die(subName,'MPI_IRECV',ier) + + call mpi_send ( hs, 1, MP_INTEGER, p, tag, comm, ier ) + if(ier /= 0) call MP_perr_die(subName,'MPI_SEND',ier) + endif + endif + + endif +! + enddo + + ! wait for rest of receive requests to complete + do istep=steps-maxreqh+1,steps + p = swapids(istep) + if (rcvlths(p) > 0) then + call mpi_wait( rcvids(istep), status, ier ) + if(ier /= 0) call MP_perr_die(subName,'MPI_WAIT',ier) + endif + enddo + +! (2) handshaking + nonblocking sends + elseif ((handshake) .and. (.not. sendd)) then + + ! Initialize hs variable + hs = 1 + + ! Post initial handshake receive requests + do istep=1,maxreq + p = swapids(istep) + if (sndlths(p) > 0) then + tag = mytask + offset_t + call mpi_irecv( hs, 1, MP_INTEGER, p, tag, comm, & + hs_rcvids(istep), ier ) + if(ier /= 0) call MP_perr_die(subName,'MPI_IRECV',ier) + endif + enddo + + ! Post initial receive requests + do istep=1,maxreq + p = swapids(istep) + if (rcvlths(p) > 0) then + tag = p + offset_t + + offset_r = rdispls(p)+1 + call mpi_irecv( rcvbuf(offset_r), rcvlths(p), rtypes(p), & + p, tag, comm, rcvids(istep), ier ) + if(ier /= 0) call MP_perr_die(subName,'MPI_IRECV',ier) + + call mpi_send ( hs, 1, MP_INTEGER, p, tag, comm, ier ) + if(ier /= 0) call MP_perr_die(subName,'MPI_SEND',ier) + endif + enddo + rstep = maxreq + + ! Send (and start receiving) data + do istep=1,steps + p = swapids(istep) + + ! Submit new irsend request + if (sndlths(p) > 0) then + tag = mytask + offset_t + + offset_s = sdispls(p)+1 + call mpi_wait ( hs_rcvids(istep), status, ier ) + if(ier /= 0) call MP_perr_die(subName,'MPI_WAIT',ier) + + call mpi_irsend( sndbuf(offset_s), sndlths(p), stypes(p), & + p, tag, comm, sndids(istep), ier ) + if(ier /= 0) call MP_perr_die(subName,'MPI_IRSEND',ier) + endif + + if (istep > maxreqh) then + + ! Wait for oldest irecv request to complete + p = swapids(istep-maxreqh) + if (rcvlths(p) > 0) then + call mpi_wait( rcvids(istep-maxreqh), status, ier ) + if(ier /= 0) call MP_perr_die(subName,'MPI_WAIT',ier) + endif + + if (rstep < steps) then + rstep = rstep + 1 + p = swapids(rstep) + + ! Submit a new handshake irecv request + if (sndlths(p) > 0) then + tag = mytask + offset_t + call mpi_irecv( hs, 1, MP_INTEGER, p, tag, comm, & + hs_rcvids(rstep), ier ) + if(ier /= 0) call MP_perr_die(subName,'MPI_IRECV',ier) + endif + + ! Submit a new irecv request + if (rcvlths(p) > 0) then + tag = p + offset_t + + offset_r = rdispls(p)+1 + call mpi_irecv( rcvbuf(offset_r), rcvlths(p), rtypes(p), & + p, tag, comm, rcvids(rstep), ier ) + if(ier /= 0) call MP_perr_die(subName,'MPI_IRECV',ier) + + call mpi_send ( hs, 1, MP_INTEGER, p, tag, comm, ier ) + if(ier /= 0) call MP_perr_die(subName,'MPI_SEND',ier) + endif + endif + + ! Wait for outstanding i(r)send request to complete + p = swapids(istep-maxreqh) + if (sndlths(p) > 0) then + call mpi_wait( sndids(istep-maxreqh), status, ier ) + if(ier /= 0) call MP_perr_die(subName,'MPI_WAIT',ier) + endif + + endif + + enddo + + ! wait for rest of send and receive requests to complete + do istep=steps-maxreqh+1,steps + p = swapids(istep) + if (rcvlths(p) > 0) then + call mpi_wait( rcvids(istep), status, ier ) + if(ier /= 0) call MP_perr_die(subName,'MPI_WAIT',ier) + endif + if (sndlths(p) > 0) then + call mpi_wait( sndids(istep), status, ier ) + if(ier /= 0) call MP_perr_die(subName,'MPI_WAIT',ier) + endif + enddo + +! (3) no handshaking + blocking sends + elseif ((.not. handshake) .and. (sendd)) then + + ! Post receive requests + do istep=1,maxreq + p = swapids(istep) + if (rcvlths(p) > 0) then + tag = p + offset_t + + offset_r = rdispls(p)+1 + call mpi_irecv( rcvbuf(offset_r), rcvlths(p), rtypes(p), & + p, tag, comm, rcvids(istep), ier ) + if(ier /= 0) call MP_perr_die(subName,'MPI_IRECV',ier) + endif + enddo + rstep = maxreq + + ! Send (and start receiving) data + do istep=1,steps + p = swapids(istep) + + ! Submit new send request + if (sndlths(p) > 0) then + tag = mytask + offset_t + + offset_s = sdispls(p)+1 + call mpi_send( sndbuf(offset_s), sndlths(p), stypes(p), & + p, tag, comm, ier ) + if(ier /= 0) call MP_perr_die(subName,'MPI_SEND',ier) + endif + + if (istep > maxreqh) then + + ! Wait for oldest irecv request to complete + p = swapids(istep-maxreqh) + if (rcvlths(p) > 0) then + call mpi_wait( rcvids(istep-maxreqh), status, ier ) + if(ier /= 0) call MP_perr_die(subName,'MPI_WAIT',ier) + endif + + ! Submit a new irecv request + if (rstep < steps) then + rstep = rstep + 1 + p = swapids(rstep) + if (rcvlths(p) > 0) then + tag = p + offset_t + + offset_r = rdispls(p)+1 + call mpi_irecv( rcvbuf(offset_r), rcvlths(p), rtypes(p), & + p, tag, comm, rcvids(rstep), ier ) + if(ier /= 0) call MP_perr_die(subName,'MPI_IRECV',ier) + endif + endif + + endif + + enddo + + ! wait for rest of send and receive requests to complete + do istep=steps-maxreqh+1,steps + p = swapids(istep) + if (rcvlths(p) > 0) then + call mpi_wait( rcvids(istep), status, ier ) + if(ier /= 0) call MP_perr_die(subName,'MPI_WAIT',ier) + endif + enddo + +! (4) no handshaking + nonblocking sends + elseif ((.not. handshake) .and. (.not. sendd)) then + + ! Post receive requests + do istep=1,maxreq + p = swapids(istep) + if (rcvlths(p) > 0) then + tag = p + offset_t + + offset_r = rdispls(p)+1 + call mpi_irecv( rcvbuf(offset_r), rcvlths(p), rtypes(p), & + p, tag, comm, rcvids(istep), ier ) + if(ier /= 0) call MP_perr_die(subName,'MPI_IRECV',ier) + endif + enddo + rstep = maxreq + + ! Send (and start receiving) data + do istep=1,steps + p = swapids(istep) + + ! Submit new isend request + if (sndlths(p) > 0) then + tag = mytask + offset_t + + offset_s = sdispls(p)+1 + call mpi_isend( sndbuf(offset_s), sndlths(p), stypes(p), & + p, tag, comm, sndids(istep), ier ) + if(ier /= 0) call MP_perr_die(subName,'MPI_ISEND',ier) + endif + + if (istep > maxreqh) then + + ! Wait for oldest irecv request to complete + p = swapids(istep-maxreqh) + if (rcvlths(p) > 0) then + call mpi_wait( rcvids(istep-maxreqh), status, ier ) + if(ier /= 0) call MP_perr_die(subName,'MPI_WAIT',ier) + endif + + ! Submit a new irecv request + if (rstep < steps) then + rstep = rstep + 1 + p = swapids(rstep) + if (rcvlths(p) > 0) then + tag = p + offset_t + + offset_r = rdispls(p)+1 + call mpi_irecv( rcvbuf(offset_r), rcvlths(p), rtypes(p), & + p, tag, comm, rcvids(rstep), ier ) + if(ier /= 0) call MP_perr_die(subName,'MPI_IRECV',ier) + endif + endif + + ! Wait for outstanding i(r)send request to complete + p = swapids(istep-maxreqh) + if (sndlths(p) > 0) then + call mpi_wait( sndids(istep-maxreqh), status, ier ) + if(ier /= 0) call MP_perr_die(subName,'MPI_WAIT',ier) + endif + + endif + + enddo + + ! wait for rest of send and receive requests to complete + do istep=steps-maxreqh+1,steps + p = swapids(istep) + if (rcvlths(p) > 0) then + call mpi_wait( rcvids(istep), status, ier ) + if(ier /= 0) call MP_perr_die(subName,'MPI_WAIT',ier) + endif + if (sndlths(p) > 0) then + call mpi_wait( sndids(istep), status, ier ) + if(ier /= 0) call MP_perr_die(subName,'MPI_WAIT',ier) + endif + enddo + + endif + + return + + end subroutine m_swapm_FP + +end module m_SPMDutils + + + + + diff --git a/mct/m_SparseMatrix.F90 b/mct/m_SparseMatrix.F90 new file mode 100644 index 000000000000..29716c5fd412 --- /dev/null +++ b/mct/m_SparseMatrix.F90 @@ -0,0 +1,2767 @@ +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! 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/mct/m_SparseMatrixComms.F90 b/mct/m_SparseMatrixComms.F90 new file mode 100644 index 000000000000..761cd81a3198 --- /dev/null +++ b/mct/m_SparseMatrixComms.F90 @@ -0,0 +1,699 @@ +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! 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/mct/m_SparseMatrixDecomp.F90 b/mct/m_SparseMatrixDecomp.F90 new file mode 100644 index 000000000000..eb914e74aa99 --- /dev/null +++ b/mct/m_SparseMatrixDecomp.F90 @@ -0,0 +1,756 @@ +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! 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/mct/m_SparseMatrixPlus.F90 b/mct/m_SparseMatrixPlus.F90 new file mode 100644 index 000000000000..de6e966b8041 --- /dev/null +++ b/mct/m_SparseMatrixPlus.F90 @@ -0,0 +1,872 @@ +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! 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.' + call die(myname_) + 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/mct/m_SparseMatrixToMaps.F90 b/mct/m_SparseMatrixToMaps.F90 new file mode 100644 index 000000000000..b28448a6231c --- /dev/null +++ b/mct/m_SparseMatrixToMaps.F90 @@ -0,0 +1,456 @@ +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! 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/mct/m_SpatialIntegral.F90 b/mct/m_SpatialIntegral.F90 new file mode 100644 index 000000000000..2cf709b93f52 --- /dev/null +++ b/mct/m_SpatialIntegral.F90 @@ -0,0 +1,2034 @@ +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! 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/mct/m_SpatialIntegralV.F90 b/mct/m_SpatialIntegralV.F90 new file mode 100644 index 000000000000..1c503b776aa2 --- /dev/null +++ b/mct/m_SpatialIntegralV.F90 @@ -0,0 +1,2017 @@ +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! 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/mct/m_Transfer.F90 b/mct/m_Transfer.F90 new file mode 100644 index 000000000000..475898a06dbf --- /dev/null +++ b/mct/m_Transfer.F90 @@ -0,0 +1,818 @@ +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! 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/mkinstalldirs b/mkinstalldirs new file mode 100755 index 000000000000..d2d5f21b6112 --- /dev/null +++ b/mkinstalldirs @@ -0,0 +1,111 @@ +#! /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/mpeu/Makefile b/mpeu/Makefile new file mode 100644 index 000000000000..dfadaec624ec --- /dev/null +++ b/mpeu/Makefile @@ -0,0 +1,126 @@ +.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/mpeu/README b/mpeu/README new file mode 100644 index 000000000000..06d3cc4d93e5 --- /dev/null +++ b/mpeu/README @@ -0,0 +1,59 @@ +!----------------------------------------------------------------------- +! 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/mpeu/assertmpeu.H b/mpeu/assertmpeu.H new file mode 100644 index 000000000000..ef83c6e464e5 --- /dev/null +++ b/mpeu/assertmpeu.H @@ -0,0 +1,55 @@ +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! 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/mpeu/get_zeits.c b/mpeu/get_zeits.c new file mode 100644 index 000000000000..b8065c5ebad3 --- /dev/null +++ b/mpeu/get_zeits.c @@ -0,0 +1,76 @@ +/*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! 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/mpeu/m_FcComms.F90 b/mpeu/m_FcComms.F90 new file mode 100644 index 000000000000..0bd675c2b75d --- /dev/null +++ b/mpeu/m_FcComms.F90 @@ -0,0 +1,688 @@ +!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: +! +! Disable the use of the MPI ready send protocol by default, to +! address recurrent issues with poor performance or incorrect +! functionality in MPI libraries. When support is known to be robust, +! or for experimentation, can be re-enabled by defining the CPP token +! _USE_MPI_RSEND during the build process. +! +#ifndef _USE_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/mpeu/m_FileResolv.F90 b/mpeu/m_FileResolv.F90 new file mode 100644 index 000000000000..8145aeb43a39 --- /dev/null +++ b/mpeu/m_FileResolv.F90 @@ -0,0 +1,273 @@ +!------------------------------------------------------------------------- +! 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/mpeu/m_Filename.F90 b/mpeu/m_Filename.F90 new file mode 100644 index 000000000000..1032a512c296 --- /dev/null +++ b/mpeu/m_Filename.F90 @@ -0,0 +1,106 @@ +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! 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/mpeu/m_IndexBin_char.F90 b/mpeu/m_IndexBin_char.F90 new file mode 100644 index 000000000000..db83e996ad89 --- /dev/null +++ b/mpeu/m_IndexBin_char.F90 @@ -0,0 +1,257 @@ +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! 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/mpeu/m_IndexBin_integer.F90 b/mpeu/m_IndexBin_integer.F90 new file mode 100644 index 000000000000..8eb5abf277c3 --- /dev/null +++ b/mpeu/m_IndexBin_integer.F90 @@ -0,0 +1,257 @@ +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! 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/mpeu/m_IndexBin_logical.F90 b/mpeu/m_IndexBin_logical.F90 new file mode 100644 index 000000000000..710600eb2129 --- /dev/null +++ b/mpeu/m_IndexBin_logical.F90 @@ -0,0 +1,105 @@ +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! 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/mpeu/m_List.F90 b/mpeu/m_List.F90 new file mode 100644 index 000000000000..0e420c4bf26c --- /dev/null +++ b/mpeu/m_List.F90 @@ -0,0 +1,2112 @@ +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! 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/mpeu/m_MergeSorts.F90 b/mpeu/m_MergeSorts.F90 new file mode 100644 index 000000000000..6dc4cd6db1da --- /dev/null +++ b/mpeu/m_MergeSorts.F90 @@ -0,0 +1,1469 @@ +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! 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 + + integer,parameter :: I8 = selected_int_kind (13) + + interface IndexSet + module procedure setn_ + module procedure set_ + end interface + interface IndexSort + module procedure iSortn_ + module procedure i8Sortn_ + module procedure rSortn_ + module procedure dSortn_ + module procedure cSortn_ + module procedure iSort_ + module procedure i8Sort_ + module procedure rSort_ + module procedure dSort_ + module procedure cSort_ + module procedure iSort1_ + module procedure i8Sort1_ + 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: +! 23Mar15 - Steve Goldhaber (goldy@ucar.edu) +! . Added interface to perform index sort on 8-byte integers +! 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: i8Sortn_ - A stable merge index sorting of 8-byte INTs. +! +! !DESCRIPTION: +! +! !INTERFACE: + + subroutine i8Sortn_(n,indx,keys,descend,stat) + implicit none + + integer,intent(in) :: n + integer, dimension(n), intent(inout) :: indx + integer(i8), dimension(n), intent(in) :: keys + logical, optional, intent(in) :: descend + integer, optional, intent(out) :: stat + +! !REVISION HISTORY: +! 23Mar15 - Steve Goldhaber (goldy@ucar.edu) +! . Added interface to perform index sort on 8-byte integers +! 15Mar00 - Jing Guo +! . initial prototype/prolog/code +! . redefined for the original interface +!EOP ___________________________________________________________________ + + character(len=*),parameter :: myname_=myname//'::i8Sortn_' + + call i8Sort_(indx(1:n),keys(1:n),descend,stat) +end subroutine i8Sortn_ + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! 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: i8Sort_ - A stable merge index sorting of 8-byte INTs. +! +! !DESCRIPTION: +! +! !INTERFACE: + + subroutine i8Sort_(indx,keys,descend,stat) + use m_stdio, only : stderr + use m_die, only : die + implicit none + + integer, dimension(:), intent(inout) :: indx + integer(i8), dimension(:), intent(in) :: keys + logical, optional, intent(in) :: descend + integer, optional, intent(out) :: stat + +! !REVISION HISTORY: +! 17Dec14 - goldy@ucar.edu - Added 8-byte version +! 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//'::i8Sort_' + + 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 i8Sort_ + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! 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//'::i8Sort1_' + + 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: i8Sort1_ - A stable merge index sorting of 8-byte INTs. +! +! !DESCRIPTION: +! +! !INTERFACE: + + subroutine i8Sort1_(indx,keys,ikey,descend,stat) + use m_stdio, only : stderr + use m_die, only : die + implicit none + + integer, dimension(:), intent(inout) :: indx + integer(i8), dimension(:,:), intent(in) :: keys + integer,intent(in) :: ikey + logical, optional, intent(in) :: descend + integer, optional, intent(out) :: stat + +! !REVISION HISTORY: +! 17Dec14 - goldy@ucar.edu - Added 8-byte version +! 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//'::i8Sort1_' + + 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 i8Sort1_ + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! 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/mpeu/m_Permuter.F90 b/mpeu/m_Permuter.F90 new file mode 100644 index 000000000000..202fc1de751c --- /dev/null +++ b/mpeu/m_Permuter.F90 @@ -0,0 +1,1284 @@ +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! 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/mpeu/m_SortingTools.F90 b/mpeu/m_SortingTools.F90 new file mode 100644 index 000000000000..2f7399a45fa8 --- /dev/null +++ b/mpeu/m_SortingTools.F90 @@ -0,0 +1,96 @@ +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! 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/mpeu/m_StrTemplate.F90 b/mpeu/m_StrTemplate.F90 new file mode 100644 index 000000000000..979e9800ac34 --- /dev/null +++ b/mpeu/m_StrTemplate.F90 @@ -0,0 +1,454 @@ +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! 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/mpeu/m_String.F90 b/mpeu/m_String.F90 new file mode 100644 index 000000000000..2b8bc42e7005 --- /dev/null +++ b/mpeu/m_String.F90 @@ -0,0 +1,831 @@ +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! 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/mpeu/m_StringLinkedList.F90 b/mpeu/m_StringLinkedList.F90 new file mode 100644 index 000000000000..50300a8b0cbd --- /dev/null +++ b/mpeu/m_StringLinkedList.F90 @@ -0,0 +1,553 @@ +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! 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/mpeu/m_TraceBack.F90 b/mpeu/m_TraceBack.F90 new file mode 100644 index 000000000000..1afcaf8eb71d --- /dev/null +++ b/mpeu/m_TraceBack.F90 @@ -0,0 +1,240 @@ +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! 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/mpeu/m_chars.F90 b/mpeu/m_chars.F90 new file mode 100644 index 000000000000..3ff275b138f3 --- /dev/null +++ b/mpeu/m_chars.F90 @@ -0,0 +1,107 @@ +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! 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/mpeu/m_die.F90 b/mpeu/m_die.F90 new file mode 100644 index 000000000000..9e10b443353c --- /dev/null +++ b/mpeu/m_die.F90 @@ -0,0 +1,404 @@ +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! 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/mpeu/m_dropdead.F90 b/mpeu/m_dropdead.F90 new file mode 100644 index 000000000000..0869fd904899 --- /dev/null +++ b/mpeu/m_dropdead.F90 @@ -0,0 +1,191 @@ +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! 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/mpeu/m_flow.F90 b/mpeu/m_flow.F90 new file mode 100644 index 000000000000..35d7b3c5b84b --- /dev/null +++ b/mpeu/m_flow.F90 @@ -0,0 +1,196 @@ +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! 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/mpeu/m_inpak90.F90 b/mpeu/m_inpak90.F90 new file mode 100644 index 000000000000..d1adfe11a1e7 --- /dev/null +++ b/mpeu/m_inpak90.F90 @@ -0,0 +1,2049 @@ +!------------------------------------------------------------------------- +! 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/mpeu/m_ioutil.F90 b/mpeu/m_ioutil.F90 new file mode 100644 index 000000000000..94cce456a7a6 --- /dev/null +++ b/mpeu/m_ioutil.F90 @@ -0,0 +1,439 @@ +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! 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/mpeu/m_mall.F90 b/mpeu/m_mall.F90 new file mode 100644 index 000000000000..416538a4ced8 --- /dev/null +++ b/mpeu/m_mall.F90 @@ -0,0 +1,1669 @@ +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! 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/mpeu/m_mpif.F90 b/mpeu/m_mpif.F90 new file mode 100644 index 000000000000..d8d6318a545c --- /dev/null +++ b/mpeu/m_mpif.F90 @@ -0,0 +1,69 @@ +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! 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/mpeu/m_mpif90.F90 b/mpeu/m_mpif90.F90 new file mode 100644 index 000000000000..42e5d3355795 --- /dev/null +++ b/mpeu/m_mpif90.F90 @@ -0,0 +1,719 @@ +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! 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/mpeu/m_rankMerge.F90 b/mpeu/m_rankMerge.F90 new file mode 100644 index 000000000000..b3f78fb42db8 --- /dev/null +++ b/mpeu/m_rankMerge.F90 @@ -0,0 +1,620 @@ +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! 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/mpeu/m_realkinds.F90 b/mpeu/m_realkinds.F90 new file mode 100644 index 000000000000..cb5f9994c0c3 --- /dev/null +++ b/mpeu/m_realkinds.F90 @@ -0,0 +1,52 @@ +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! 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/mpeu/m_stdio.F90 b/mpeu/m_stdio.F90 new file mode 100644 index 000000000000..9f9fad81fed2 --- /dev/null +++ b/mpeu/m_stdio.F90 @@ -0,0 +1,53 @@ +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! 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/mpeu/m_zeit.F90 b/mpeu/m_zeit.F90 new file mode 100644 index 000000000000..207de748c84c --- /dev/null +++ b/mpeu/m_zeit.F90 @@ -0,0 +1,1008 @@ +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! 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/mpi-serial/.gitignore b/mpi-serial/.gitignore new file mode 100644 index 000000000000..8b137891791f --- /dev/null +++ b/mpi-serial/.gitignore @@ -0,0 +1 @@ + diff --git a/mpi-serial/Makefile b/mpi-serial/Makefile new file mode 100644 index 000000000000..0b1ca1db6c2d --- /dev/null +++ b/mpi-serial/Makefile @@ -0,0 +1,93 @@ +SHELL = /bin/sh +############################### +include Makefile.conf + +VPATH=$(SRCDIR)/mpi-serial +# SOURCE FILES + +MODULE = mpi-serial + +SRCS_F90 = fort.F90 \ + mpif.F90 + +SRCS_C = mpi.c \ + send.c \ + recv.c \ + collective.c \ + req.c \ + list.c \ + handles.c \ + comm.c \ + error.c \ + ic_merge.c \ + group.c \ + time.c \ + pack.c \ + type.c \ + type_const.c \ + copy.c \ + op.c \ + cart.c \ + getcount.c \ + probe.c \ + info.c + + +OBJS_ALL = $(SRCS_C:.c=.o) \ + $(SRCS_F90:.F90=.o) + + +INCPATH:= -I . + + +############################### + +# TARGETS + +default: lib$(MODULE).a + + +fort.o: mpif.h + + +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) $(DEFS) $(CPPDEFS) $(CFLAGS) $< + +.F90.o: + $(FC) -c $(INCFLAG) . $(INCPATH) $(DEFS) $(FPPDEFS) $(FCFLAGS) $(MPEUFLAGS) $< + +MYF90FLAGS=$(INCPATH) $(DEFS) $(FCFLAGS) $(MPEUFLAGS) + +.PHONY: clean tests install + +clean: + /bin/rm -f *.o ctest ftest $(LIB) mpi.mod config.log config.status + cd tests ; $(MAKE) clean + +tests: + cd tests; make + +install: lib + $(MKINSTALLDIRS) $(libdir) $(includedir) + $(INSTALL) lib$(MODULE).a -m 644 $(libdir) + $(INSTALL) mpi.h -m 644 $(includedir) + $(INSTALL) mpif.h -m 644 $(includedir) + + + diff --git a/mpi-serial/Makefile.conf.in b/mpi-serial/Makefile.conf.in new file mode 100644 index 000000000000..9f4ec263480e --- /dev/null +++ b/mpi-serial/Makefile.conf.in @@ -0,0 +1,16 @@ +CC = @CC@ +FC = @FC@ +FCFLAGS = @FCFLAGS@ +INCLUDE = -I. +INCFLAG = @INCLUDEFLAG@ +DEFS = @DEFS@ +CFLAGS = @CFLAGS@ +AR = @AR@ +RANLIB = @RANLIB@ +LIBS = @LIBS@ +CRULE = .c.o +F90RULE = .F90.o + +SHELL = /bin/sh + +MODULE = mpi-serial diff --git a/mpi-serial/README b/mpi-serial/README new file mode 100644 index 000000000000..aaa728501f9b --- /dev/null +++ b/mpi-serial/README @@ -0,0 +1,140 @@ + +###################################################################### + +mpi-serial + + Version 2.0 + Ray Loy (rloy@alcf.anl.gov) + John Yackovich + +###################################################################### + + +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. + +Version 2.0 adds support for user-defined MPI types and MPI_STATUS_IGNORE. + + +--------------- +Quick Start +--------------- +./configure +make +make tests + + +--------------- +Configuration +--------------- + +There is now a dedicated configure for mpi-serial. + +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 an option to the mpi-serial configure, e.g.: + + ./configure --enable-fort-real=16 --enable-fort-double=32 + + + +-------------------------------- +Manual make targets +-------------------------------- + +'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 + mpi_get_processor_name + mpi_get_library_version + mpi_wtime + + 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_range_incl + mpi_group_union + mpi_group_intersection + mpi_group_difference + mpi_group_translate_ranks + mpi_group_free + mpi_cart_create + mpi_cart_coords + mpi_dims_create + + send/receive ops + mpi_irecv + mpi_recv + mpi_test + mpi_testany + mpi_testall + mpi_testsome + mpi_wait + mpi_waitany + mpi_waitall + mpi_waitsome + mpi_isend + mpi_send + mpi_ssend + mpi_rsend + mpi_irsend + mpi_sendrecv + mpi_iprobe + mpi_probe + mpi_request_free + + collective operations + mpi_barrier + mpi_bcast + mpi_gather + mpi_gatherv + mpi_allgather + mpi_scatter + mpi_scatterv + mpi_reduce + mpi_allreduce + mpi_reduce_scatter + mpi_scan + mpi_alltoall + mpi_alltoallv + mpi_alltoallw + mpi_op_create + mpi_op_free + + data types and info objects + mpi_get_count + mpi_get_elements + mpi_pack + mpi_pack_size + mpi_unpack + mpi_info_create + mpi_info_set + mpi_info_free + +----- +EOF diff --git a/mpi-serial/aclocal.m4 b/mpi-serial/aclocal.m4 new file mode 100644 index 000000000000..c5b6de47a45f --- /dev/null +++ b/mpi-serial/aclocal.m4 @@ -0,0 +1,15 @@ +# 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/ax_fc_version.m4]) diff --git a/mpi-serial/cart.c b/mpi-serial/cart.c new file mode 100644 index 000000000000..a53ef4814c65 --- /dev/null +++ b/mpi-serial/cart.c @@ -0,0 +1,128 @@ +#include "mpiP.h" + +/* + * MPI_Cart_create + * + * create a new communicator, + */ + + +FC_FUNC( mpi_cart_create , MPI_CART_CREATE ) + ( int *comm_old, int *ndims, int *dims, int *periods, + int *reorder, int *comm_cart, int *ierr) +{ + *ierr = MPI_Cart_create( *comm_old, *ndims, dims, periods, *reorder, + comm_cart); +} + + +int MPI_Cart_create( MPI_Comm comm_old, int ndims, int *dims, int *periods, + int reorder, MPI_Comm *comm_cart) +{ + int i; + for (i = 0; i < ndims; i++) + if (dims[i] > 1) + { + printf("MPI_Cart_create: Greater dimension than no. of procs\n"); + abort(); + } + + MPI_Comm_dup(comm_old, comm_cart); + + return MPI_SUCCESS; +} + + +/* + * MPI_Cart_get + * + * Returns information about the cartesian organization + * of the communicator. + * + * Assuming the user gives right maxdims, the only possible + * dimensions are (1,1,..,1) for however many dimensions + */ + + +FC_FUNC( mpi_cart_get , MPI_CART_GET ) + (int * comm, int * maxdims, int * dims, + int * periods, int * coords, int * ierr) +{ + *ierr = MPI_Cart_get(*comm, *maxdims, dims, periods, coords); +} + + +int MPI_Cart_get(MPI_Comm comm, int maxdims, int *dims, + int *periods, int *coords) +{ + int i; + for (i=0;i 1) + { + printf("MPI_Dims_create: More nodes than procs specified.\n"); + abort(); + } + + for (i=0; isendlist=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); +} + +/* Intercomm_create + * + */ + +FC_FUNC(mpi_intercomm_create, MPI_INTERCOMM_CREATE)( + int * local_comm, int * local_leader, + int * peer_comm, int * remote_leader, + int * tag, int * newintercomm, int* ierr) +{ + *ierr = MPI_Intercomm_create(*local_comm, *local_leader, *peer_comm, + *remote_leader, *tag, newintercomm); +} + +int MPI_Intercomm_create(MPI_Comm local_comm, int local_leader, + MPI_Comm peer_comm, int remote_leader, + int tag, MPI_Comm *newintercomm) +{ + if (local_comm==MPI_COMM_NULL && peer_comm==MPI_COMM_NULL) + *newintercomm = MPI_COMM_NULL; + else + MPI_Comm_dup(MPI_COMM_WORLD, newintercomm); + + 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/mpi-serial/config.h.in b/mpi-serial/config.h.in new file mode 100644 index 000000000000..eed022557ad8 --- /dev/null +++ b/mpi-serial/config.h.in @@ -0,0 +1,84 @@ +/* config.h.in. Generated from configure.in by autoheader. */ + +/* User-set Fortran double size */ +#undef CONFIG_FORT_DOUBLE + +/* User-set Fortran real size */ +#undef CONFIG_FORT_REAL + +/* 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 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 + +/* Print extra debug info */ +#undef INFO + +/* Name of package */ +#undef PACKAGE + +/* 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 version of this package. */ +#undef PACKAGE_VERSION + +/* The size of `long', as computed by sizeof. */ +#undef SIZEOF_LONG + +/* Define to 1 if you have the ANSI C header files. */ +#undef STDC_HEADERS + +/* Perform tests on data copies internally instead of using MPI_Send */ +#undef TEST_INTERNAL + +/* Perform type checking during communications */ +#undef TYPE_CHECKING + +/* Version number of package */ +#undef VERSION diff --git a/mpi-serial/configure b/mpi-serial/configure new file mode 100755 index 000000000000..5dd570dc928c --- /dev/null +++ b/mpi-serial/configure @@ -0,0 +1,5833 @@ +#! /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="mpi.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='LTLIBOBJS +LIBOBJS +INCLUDEFLAG +EGREP +GREP +CPP +FCLIBS +RANLIB +AR +ac_ct_FC +FCFLAGS +FC +OBJEXT +EXEEXT +ac_ct_CC +CPPFLAGS +LDFLAGS +CFLAGS +CC +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_test_internal +enable_info +enable_fort_real +enable_fort_double +enable_type_checking +' + ac_precious_vars='build_alias +host_alias +target_alias +CC +CFLAGS +LDFLAGS +LIBS +CPPFLAGS +FC +FCFLAGS +AR +RANLIB +CPP +INCLUDEFLAG' + + +# 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 + +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-test-internal Specify internal test as opposed to full suite test + + --enable-info Print extra debugging info + --enable-fort-real=SIZE Specify Fortran real size + --enable-fort-double=SIZE Specify Fortran double size + --enable-type-checking Perform type checking during communications + +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 + AR Archive Command + RANLIB Archive index update command + CPP C preprocessor + INCLUDEFLAG Fortran compiler flag for specifying module search path + +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_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_config_headers="$ac_config_headers config.h" + +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 + +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 + + +# ARCHIVE COMMAND SIMILAR ACROSS ALL PLATFORMS + +if test -z "$AR"; then + AR="ar cruv" +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 { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$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 { 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_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 + + +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 + "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 + + +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 long" >&5 +$as_echo_n "checking size of long... " >&6; } +if ${ac_cv_sizeof_long+:} false; then : + $as_echo_n "(cached) " >&6 +else + if ac_fn_c_compute_int "$LINENO" "(long int) (sizeof (long))" "ac_cv_sizeof_long" "$ac_includes_default"; then : + +else + if test "$ac_cv_type_long" = 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 (long) +See \`config.log' for more details" "$LINENO" 5; } + else + ac_cv_sizeof_long=0 + fi +fi + +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_sizeof_long" >&5 +$as_echo "$ac_cv_sizeof_long" >&6; } + + + +cat >>confdefs.h <<_ACEOF +#define SIZEOF_LONG $ac_cv_sizeof_long +_ACEOF + + + +# Check whether --enable-test-internal was given. +if test "${enable_test_internal+set}" = set; then : + enableval=$enable_test_internal; +$as_echo "#define TEST_INTERNAL /**/" >>confdefs.h + +fi + + +# Check whether --enable-info was given. +if test "${enable_info+set}" = set; then : + enableval=$enable_info; +$as_echo "#define INFO /**/" >>confdefs.h + +fi + + +# Check whether --enable-fort-real was given. +if test "${enable_fort_real+set}" = set; then : + enableval=$enable_fort_real; +cat >>confdefs.h <<_ACEOF +#define CONFIG_FORT_REAL $enable_fort_real +_ACEOF + +fi + +# Check whether --enable-fort-double was given. +if test "${enable_fort_double+set}" = set; then : + enableval=$enable_fort_double; +cat >>confdefs.h <<_ACEOF +#define CONFIG_FORT_DOUBLE $enable_fort_double +_ACEOF + +fi + +# Check whether --enable-type-checking was given. +if test "${enable_type_checking+set}" = set; then : + enableval=$enable_type_checking; +$as_echo "#define TYPE_CHECKING /**/" >>confdefs.h + +fi + + + +# Determine flag for fortran module include path +# taken from the MCT configure + + +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 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:4480: \"$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 + + + +if echo $ac_fc_version_output | grep -i absoft >/dev/null 2>&1; then + echo "Fortran Compiler is Absoft" + if test -z "$INCLUDEFLAG"; then + INCLUDEFLAG="-p" + fi +elif echo $ac_fc_version_output | grep -i workshop >/dev/null 2>&1; then + echo "Fortran Compiler is Workshop" + if test -z "$INCLUDEFLAG"; then + INCLUDEFLAG="-M" + fi +elif echo $ac_fc_version_output | grep -i pgf >/dev/null 2>&1; then + echo "Fortran Compiler is Portland Group" + LIBS="$LIBS -pgf90libs" +elif echo $ac_fc_version_output | grep -i nag >/dev/null 2>&1; then + echo "Fortran Compiler is NAG" + CPRDEF="NAG" + if test -z "$FCFLAGS"; then + FCFLAGS="-mismatch" + fi +fi +# INCLUDE FLAG IF NOT ALREADY SET IS MOST LIKELY -I +if test -z "$INCLUDEFLAG"; then + INCLUDEFLAG="-I" +fi + + +ac_config_files="$ac_config_files Makefile.conf" + +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 -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 + + +# 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 + +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'" + + +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 $as_me, which was +generated by GNU Autoconf 2.68. 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="\\ +config.status +configured by $0, generated by GNU Autoconf 2.68, + with options \\"\$ac_cs_config\\" + +Copyright (C) 2010 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 + "config.h") CONFIG_HEADERS="$CONFIG_HEADERS config.h" ;; + "Makefile.conf") CONFIG_FILES="$CONFIG_FILES Makefile.conf" ;; + + *) 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 + diff --git a/mpi-serial/configure.in b/mpi-serial/configure.in new file mode 100644 index 000000000000..8d3a750b18cb --- /dev/null +++ b/mpi-serial/configure.in @@ -0,0 +1,91 @@ +dnl initialize autoconf +AC_INIT(mpi.h) +dnl specify config header file +AC_CONFIG_HEADER(config.h) +dnl find c compiler, and fort compiler +AC_PROG_CC +AC_PROG_FC + +# ARCHIVE COMMAND SIMILAR ACROSS ALL PLATFORMS +AC_ARG_VAR(AR,Archive Command) +if test -z "$AR"; then + AR="ar cruv" +fi + +# RANLIB +AC_ARG_VAR(RANLIB,Archive index update command) +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 + +dnl determine fortran name-mangling +dnl result functions end up in config.h +AC_FC_WRAPPERS + +dnl to determine type of integer needed for fortran +AC_CHECK_SIZEOF(long) + +dnl these are to specify the possible arguments to configure. +AC_ARG_ENABLE([test-internal], + [ --enable-test-internal Specify internal test as opposed to full suite test] + ,AC_DEFINE([TEST_INTERNAL],[], + [Perform tests on data copies internally instead of using MPI_Send])) + +AC_ARG_ENABLE([info],[ --enable-info Print extra debugging info], + AC_DEFINE([INFO],[],[Print extra debug info])) + +AC_ARG_ENABLE([fort-real], + [ --enable-fort-real=SIZE Specify Fortran real size], + AC_DEFINE_UNQUOTED([CONFIG_FORT_REAL],[$enable_fort_real], + [User-set Fortran real size])) +AC_ARG_ENABLE([fort-double], + [ --enable-fort-double=SIZE Specify Fortran double size], + AC_DEFINE_UNQUOTED([CONFIG_FORT_DOUBLE],[$enable_fort_double], + [User-set Fortran double size])) +AC_ARG_ENABLE([type-checking], + [ --enable-type-checking Perform type checking during communications], + AC_DEFINE([TYPE_CHECKING],[],[Perform type checking during communications])) + + +# Determine flag for fortran module include path +# taken from the MCT configure + +AC_ARG_VAR(INCLUDEFLAG,Fortran compiler flag for specifying module search path) +AC_LANG_PUSH(Fortran) +AX_FC_VERSION() +AC_LANG_POP(Fortran) + + +if echo $ac_fc_version_output | grep -i absoft >/dev/null 2>&1; then + echo "Fortran Compiler is Absoft" + if test -z "$INCLUDEFLAG"; then + INCLUDEFLAG="-p" + fi +elif echo $ac_fc_version_output | grep -i workshop >/dev/null 2>&1; then + echo "Fortran Compiler is Workshop" + if test -z "$INCLUDEFLAG"; then + INCLUDEFLAG="-M" + fi +elif echo $ac_fc_version_output | grep -i pgf >/dev/null 2>&1; then + echo "Fortran Compiler is Portland Group" + LIBS="$LIBS -pgf90libs" +elif echo $ac_fc_version_output | grep -i nag >/dev/null 2>&1; then + echo "Fortran Compiler is NAG" + CPRDEF="NAG" + if test -z "$FCFLAGS"; then + FCFLAGS="-mismatch" + fi +fi +# INCLUDE FLAG IF NOT ALREADY SET IS MOST LIKELY -I +if test -z "$INCLUDEFLAG"; then + INCLUDEFLAG="-I" +fi + + +AC_OUTPUT(Makefile.conf) diff --git a/mpi-serial/copy.c b/mpi-serial/copy.c new file mode 100644 index 000000000000..66d4d07efcbe --- /dev/null +++ b/mpi-serial/copy.c @@ -0,0 +1,91 @@ +/* + * copy.c + * + * memcpy "wrapper" to copy MPI Datatypes + * + */ + +#include "mpiP.h" +#include "type.h" +#include +#include +#include +#include + +//For type matching +#ifdef HAVE_CONFIG_H +#include +#endif + +/* + * rml: this prototype should be in mpiP.h, but mpiP.h does not currently + * include type.h so it can't just be added right now. Come back and + * fix this issue later... + */ + +extern int Pcopy_data2(void *source, int src_count, Datatype src_type, + void *dest, int dest_count, Datatype dest_type); + + +int copy_data2(void *source, int src_count, MPI_Datatype src_type, + void *dest, int dest_count, MPI_Datatype dest_type) +{ + Datatype src_ptr = *(Datatype*) mpi_handle_to_datatype(src_type); + Datatype dest_ptr = *(Datatype*) mpi_handle_to_datatype(dest_type); + + return Pcopy_data2(source, src_count, src_ptr, dest, dest_count, dest_ptr); +} + + + + +int Pcopy_data2(void *source, int src_count, Datatype src_type, + void *dest, int dest_count, Datatype dest_type) +{ + int i; + int soffset, doffset; + MPI_Aint src_extent, dest_extent; + + //commit checking here, since if any datatype is used in this function + // it is considered "communication". Should it be somewhere else? + + if (!(src_type->committed && dest_type->committed)) + { + fprintf(stderr, "Type not committed\n"); + exit(-1); + } + + // A receive of less elements than sent + // is valid, but the reverse is a violation + + if (src_type->count * src_count < dest_type->count * dest_count) + { + printf("copy_data: Trying to over-receive\n"); + exit(1); + } + + Type_extent(src_type, &src_extent); + Type_extent(dest_type, &dest_extent); + + for (i = 0; i < dest_count * dest_type->count; i++) + { + +#ifdef TYPE_CHECKING + if ( src_type->pairs[i % src_type->count].type != + dest_type->pairs[i % dest_type->count].type) + { + printf("copy_data: Types don't match.\n"); + exit(1); + } +#endif + + soffset = src_type->pairs[i % src_type->count].disp + ((i / src_type->count) * src_extent); + doffset = dest_type->pairs[i % dest_type->count].disp + ((i / dest_type->count) * dest_extent); + + memcpy(dest+doffset, source+soffset, Simpletype_length(dest_type->pairs[i % dest_type->count].type)); + } +} + + + + diff --git a/mpi-serial/error.c b/mpi-serial/error.c new file mode 100644 index 000000000000..d26cfd164f91 --- /dev/null +++ b/mpi-serial/error.c @@ -0,0 +1,13 @@ + +#include "mpiP.h" + +/* + * Error handling code + * Just a stub for now to support the MPI interface without actually + * doing anything + */ + + int MPI_Errhandler_set(MPI_Comm comm, MPI_Errhandler handle) + { + return(MPI_SUCCESS); + } diff --git a/mpi-serial/fort.F90 b/mpi-serial/fort.F90 new file mode 100644 index 000000000000..f07e51855b44 --- /dev/null +++ b/mpi-serial/fort.F90 @@ -0,0 +1,62 @@ + + + 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 + + +! +! mpi_get_fort_pointers +! +! In Fortran, various values e.g. MPI_STATUS_IGNORE, MPI_STATUSES_IGNORE, +! and MPI_IN_PLACE are in a COMMON block and not accessible by C code. +! This routine calls back a C routine to store the addresses. +! + + subroutine mpi_get_fort_pointers + implicit none + include "mpif.h" + + call mpi_save_fort_pointers(MPI_STATUS_IGNORE,MPI_STATUSES_IGNORE,MPI_IN_PLACE) + + end subroutine mpi_get_fort_pointers + diff --git a/mpi-serial/getcount.c b/mpi-serial/getcount.c new file mode 100644 index 000000000000..1313a7cca3d5 --- /dev/null +++ b/mpi-serial/getcount.c @@ -0,0 +1,40 @@ +/* getcount.c + * + * 07/2007 JCY + * Functions for count information regarding MPI_Status + */ + +#include "type.h" +#include "mpiP.h" + + +FC_FUNC( mpi_get_count , MPI_GET_COUNT ) + (int *status, int *datatype, int *count, int *ierr) +{ + *ierr = MPI_Get_count((MPI_Status *)status, *datatype, count); +} + + +int MPI_Get_count(MPI_Status *status, MPI_Datatype datatype, int *count) +{ + *count = status->get_count; +} + + +/********/ + + +FC_FUNC( mpi_get_elements , MPI_GET_ELEMENTS ) + (MPI_Status *status, int *datatype, int *count, int *ierr) +{ + *ierr = MPI_Get_elements(status, *datatype, count); +} + + +int MPI_Get_elements(MPI_Status *status, MPI_Datatype datatype, int *count) +{ + Datatype dt_ptr = *(Datatype*)mpi_handle_to_datatype(datatype); + *count = status->get_count * dt_ptr->count; +} + + diff --git a/mpi-serial/group.c b/mpi-serial/group.c new file mode 100644 index 000000000000..cec4879f4b62 --- /dev/null +++ b/mpi-serial/group.c @@ -0,0 +1,264 @@ + +#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); +} + + +/*********/ + + +/* MPI_Group_range_incl + * Include a strided range of ranks in a group. For one processor, if + * "0" is included in any of these ranges, it can only be the first rank. + * Thus, if rank 0 is specified, include it, otherwise use GROUP_NULL + */ + + +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; + Datatype* type; + + } 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/mpi-serial/ic_merge.c b/mpi-serial/ic_merge.c new file mode 100644 index 000000000000..ea19b387155b --- /dev/null +++ b/mpi-serial/ic_merge.c @@ -0,0 +1,15 @@ + +#include "mpiP.h" + +/* + * MPI_Intercomm_merge - Creates an intracommunicator from an intercommunicator + * This is just a stub for now to support mpi function calls even in Serial + * applications. In the case of a serial program, this function is a no-op and + * only ever returns MPI_SUCCESS + */ + +int MPI_Intercomm_merge( MPI_Comm intercomm, int high, MPI_Comm *newintracomm ) +{ + newintracomm = (MPI_Comm *)intercomm; + return(MPI_SUCCESS); +} diff --git a/mpi-serial/info.c b/mpi-serial/info.c new file mode 100644 index 000000000000..32593cb7937f --- /dev/null +++ b/mpi-serial/info.c @@ -0,0 +1,53 @@ + +#include "mpiP.h" + + + +/***/ + + +FC_FUNC( mpi_info_create , MPI_INFO_CREATE ) (int *info, int *ierror) +{ + *ierror=MPI_Info_create(info); +} + + + +int MPI_Info_create(MPI_Info *info) +{ + /* For now, we aren't storing anything, so don't bother with a real handle */ + *info=0; + return(MPI_SUCCESS); +} + + +/***/ + + +FC_FUNC( mpi_info_set , MPI_INFO_SET ) (int *info, char *key, char *value, int *ierror) +{ + *ierror=MPI_Info_set(*info, key, value); +} + + +int MPI_Info_set(MPI_Info info, char *key, char *value) +{ + /* for now, don't bother storing anything */ + return(MPI_SUCCESS); +} + +/***/ + +FC_FUNC( mpi_info_free , MPI_INFO_FREE ) (int *info, int *ierror) +{ + *ierror=MPI_Info_free(info); +} + + + +int MPI_Info_free(MPI_Info *info) +{ + /* For now, we aren't storing anything, so don't bother with a real handle */ + *info=0; + return(MPI_SUCCESS); +} diff --git a/mpi-serial/list.c b/mpi-serial/list.c new file mode 100644 index 000000000000..90ef049b75f1 --- /dev/null +++ b/mpi-serial/list.c @@ -0,0 +1,705 @@ +/* + * (C) 2000 UNIVERSITY OF CHICAGO + * See COPYRIGHT in top-level directory. + */ + + + +#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 ",(long 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 ",(long 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/mpi-serial/list.h b/mpi-serial/list.h new file mode 100644 index 000000000000..3d533fef6133 --- /dev/null +++ b/mpi-serial/list.h @@ -0,0 +1,45 @@ +/* + * (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/mpi-serial/listP.h b/mpi-serial/listP.h new file mode 100644 index 000000000000..2fa9e8596127 --- /dev/null +++ b/mpi-serial/listP.h @@ -0,0 +1,33 @@ +/* + * (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/mpi-serial/listops.h b/mpi-serial/listops.h new file mode 100644 index 000000000000..fa0ef725751a --- /dev/null +++ b/mpi-serial/listops.h @@ -0,0 +1,23 @@ +/* + * (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/mpi-serial/m4/README b/mpi-serial/m4/README new file mode 100644 index 000000000000..b748178e2c79 --- /dev/null +++ b/mpi-serial/m4/README @@ -0,0 +1,5 @@ +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/mpi-serial/m4/ax_fc_version.m4 b/mpi-serial/m4/ax_fc_version.m4 new file mode 100644 index 000000000000..c7e2eaec3c70 --- /dev/null +++ b/mpi-serial/m4/ax_fc_version.m4 @@ -0,0 +1,51 @@ +#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/mpi-serial/mpi.c b/mpi-serial/mpi.c new file mode 100644 index 000000000000..d6f58adbce19 --- /dev/null +++ b/mpi-serial/mpi.c @@ -0,0 +1,364 @@ + + +#include "mpiP.h" +#include "mpi.h" +#include "type.h" + +/****************************************************************************/ + +static int initialized=0; + + +/* Store fortran pointer values here */ + +static int *f_MPI_STATUS_IGNORE; +static int *f_MPI_STATUSES_IGNORE; +static int *f_MPI_IN_PLACE; + +static char *mpi_version_string="mpi-serial 2.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 consistent " \ + "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 consistent " \ + "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))) != Simpletype_length( \ + (*(Datatype*)mpi_handle_to_datatype(*f_##name))->pairs[0].type) ) \ + { 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 inconsistent 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(); + } + + // call this to have the fortran routine call back and save + // values for f_MPI_STATUS_IGNORE and f_MPI_STATUSES_IGNORE + FC_FUNC(mpi_get_fort_pointers,MPI_GET_FORT_POINTERS)(); // the () are important + + 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); +} + + +/**********/ + + +void FC_FUNC( mpi_get_library_version, MPI_GET_LIBRARY_VERSION) (char *version, int *resultlen, int *ierror) +{ + MPI_Get_library_version(version,resultlen); + + // Sanity check before the memset() + if ( (*resultlen) > (MPI_MAX_LIBRARY_VERSION_STRING-1) ) + abort(); + + memset(version+(*resultlen),' ',MPI_MAX_LIBRARY_VERSION_STRING-(*resultlen)); + + *ierror=MPI_SUCCESS; +} + + + +int MPI_Get_library_version(char *version, int *resultlen) +{ + + strncpy(version,mpi_version_string,MPI_MAX_LIBRARY_VERSION_STRING); + // Make sure it is null terminated + version[MPI_MAX_LIBRARY_VERSION_STRING-1]='\0'; + *resultlen=strlen(version); + + return(MPI_SUCCESS); +} + + + +/**********/ + + +void FC_FUNC( mpi_save_fort_pointers, MPI_SAVE_FORT_POINTERS ) (int *status, int *statuses, int *in_place) +{ + f_MPI_STATUS_IGNORE=status; + f_MPI_STATUSES_IGNORE=statuses; + f_MPI_IN_PLACE=in_place; +} + + + +MPI_Status *mpi_c_status(int *status) +{ + if (status==f_MPI_STATUS_IGNORE) + return(MPI_STATUS_IGNORE); + + return((MPI_Status *)status); +} + + +MPI_Status *mpi_c_statuses(int *statuses) +{ + if (statuses==f_MPI_STATUSES_IGNORE) + return(MPI_STATUSES_IGNORE); + + return((MPI_Status *)statuses); +} + + +void *mpi_c_in_place(void *buffer) +{ + if (buffer==(void *)f_MPI_IN_PLACE) + return(MPI_IN_PLACE); + + return(buffer); +} diff --git a/mpi-serial/mpi.h b/mpi-serial/mpi.h new file mode 100644 index 000000000000..9183bf89d200 --- /dev/null +++ b/mpi-serial/mpi.h @@ -0,0 +1,436 @@ +#ifndef _MPI_H_ +#define _MPI_H_ + +#define MPI_MAX_LIBRARY_VERSION_STRING (80) + +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) +#define MPI_IN_PLACE (void *)(-1) +typedef int MPI_Datatype; + + +/* The type's value is now a handle */ + +#define MPI_DATATYPE_NULL (0) + +//C types +#define MPI_CHAR (-1) +#define MPI_SHORT (-2) +#define MPI_INT (-3) +#define MPI_LONG (-4) +#define MPI_UNSIGNED_CHAR (-5) +#define MPI_UNSIGNED_SHORT (-6) +#define MPI_UNSIGNED (-7) +#define MPI_UNSIGNED_LONG (-8) +#define MPI_FLOAT (-9) +#define MPI_DOUBLE (-10) +#define MPI_LONG_DOUBLE (-11) + +//Cross-language +#define MPI_BYTE (-12) +#define MPI_PACKED (-13) +#define MPI_LB (-14) +#define MPI_UB (-15) + +// Fortran types +#define MPI_INTEGER (-16) // RML: why not (MPI_INT) +#define MPI_REAL (-17) // RML: why not (MPI_FLOAT) +#define MPI_DOUBLE_PRECISION (-18) // RML: why not (MPI_DOUBLE) + +#define MPI_COMPLEX (-19) +#define MPI_DOUBLE_COMPLEX (-20) +#define MPI_LOGICAL (-21) +#define MPI_CHARACTER (-22) +#define MPI_2REAL (-23) +#define MPI_2DOUBLE_PRECISION (-24) +#define MPI_2INTEGER (-25) + +//Reduction function types + +#define MPI_FLOAT_INT (-26) +#define MPI_DOUBLE_INT (-27) +#define MPI_LONG_INT (-28) +#define MPI_2INT (-29) +#define MPI_SHORT_INT (-30) +#define MPI_LONG_DOUBLE_INT (-31) + + +/* Fortran size-specific types */ + +#define MPI_INTEGER1 (-32) +#define MPI_INTEGER2 (-33) +#define MPI_INTEGER4 (-34) +#define MPI_INTEGER8 (-35) +#define MPI_INTEGER16 (-36) + +#define MPI_REAL4 (-37) +#define MPI_REAL8 (-38) +#define MPI_REAL16 (-39) + +#define MPI_COMPLEX8 (-40) +#define MPI_COMPLEX16 (-41) +#define MPI_COMPLEX32 (-42) + +/* Some more types */ + +#define MPI_LONG_LONG_INT (-43) +#define MPI_LONG_LONG MPI_LONG_LONG_INT +#define MPI_UNSIGNED_LONG_LONG (-44) + +#define MPI_OFFSET (-45) + + +/* + * 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) */ + int get_count; /* Number specified for send */ + +} MPI_Status; + + +#define MPI_STATUS_IGNORE ((MPI_Status *)0) +#define MPI_STATUSES_IGNORE ((MPI_Status *)0) + + +/* + * MPI Errhandling stubs (Not functional currently) + */ +typedef int MPI_Errhandler; + +#define MPI_ERRORS_ARE_FATAL ((MPI_Errhandler)0) +#define MPI_ERRORS_RETURN ((MPI_Errhandler)-1) + + +/* + * 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) + + + +#define MPI_STATUS_SIZE (sizeof(MPI_Status) / sizeof(int)) + + +/* NOTE: the C type MPI_Offset is NOT the same as MPI datatype MPI_OFFSET */ +typedef long long int MPI_Offset; + + +/* info + */ + +typedef int MPI_Info; /* handle */ + +#define MPI_INFO_NULL (0) + + + +/********************************************************** + * + * Note: if you need to regenerate the prototypes below, + * you can use 'protify.awk' and paste the output here. + * + */ + + +extern int MPI_Intercomm_create(MPI_Comm local_comm, int local_leader, + MPI_Comm peer_comm, int remote_leader, + int tag, MPI_Comm *newintercomm); +extern int MPI_Intercomm_merge(MPI_Comm intercomm, int high, + MPI_Comm *newintercomm); +extern int MPI_Cart_create(MPI_Comm comm_old, int ndims, int *dims, + int *periods, int reorder, MPI_Comm *comm_cart); +extern int MPI_Cart_get(MPI_Comm comm, int maxdims, int *dims, + int *periods, int *coords); +extern int MPI_Cart_coords(MPI_Comm comm, int rank, int maxdims, + int *coords); +extern int MPI_Dims_create(int nnodes, int ndims, int *dims); + +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_Reduce_scatter(void* sendbuf, void* recvbuf, int *recvcounts, + MPI_Datatype datatype, MPI_Op op, 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_Alltoallw(void *sendbuf, int *sendcounts, + int *sdispls, MPI_Datatype *sendtypes, + void *recvbuf, int *recvcounts, + int *rdispls, MPI_Datatype *recvtypes, + 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_Op_free(MPI_Op *op); +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_Info_create(MPI_Info *info); +extern int MPI_Info_set(MPI_Info info, char *key, char *value); + +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_Testany(int count, MPI_Request *array_of_requests, + int *index, int *flag, MPI_Status *status); +extern int MPI_Waitany(int count, MPI_Request *array_of_requests, + int *index, MPI_Status *status); +extern int MPI_Testall(int count, MPI_Request *array_of_requests, + int *flag, MPI_Status *array_of_statuses); +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_Testsome(int incount, MPI_Request *array_of_requests, + int *outcount, int *array_of_indices, + MPI_Status *array_of_statuses); +extern int MPI_Waitsome(int incount, MPI_Request *array_of_requests, + int *outcount, int *array_of_indices, + MPI_Status *array_of_statuses); +extern int MPI_Request_free(MPI_Request * req); +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 int MPI_Probe(int source, int tag, MPI_Comm comm, MPI_Status *status); +extern int MPI_Iprobe(int source, int tag, MPI_Comm comm, + int *flag, MPI_Status *status); + +extern int MPI_Pack_size(int incount, MPI_Datatype type, MPI_Comm comm, MPI_Aint * size); + +/* Error handling stub, not currently functional */ +extern int MPI_Errhandler_set(MPI_Comm comm, MPI_Errhandler handle); + +/* new type functions */ +extern int MPI_Get_count(MPI_Status *status, MPI_Datatype datatype, int *count); +extern int MPI_Get_elements(MPI_Status *status, MPI_Datatype datatype, int *count); +extern int MPI_Type_contiguous(int count, MPI_Datatype oldtype, MPI_Datatype *newtype); + +extern int MPI_Type_vector(int count, int blocklen, int stride, MPI_Datatype oldtype, + MPI_Datatype *newtype); + +extern int MPI_Type_hvector(int count, int blocklen, MPI_Aint stride, + MPI_Datatype oldtype, MPI_Datatype *newtype); + +extern int MPI_Type_create_hvector(int count, int blocklen, MPI_Aint stride, + MPI_Datatype oldtype, MPI_Datatype *newtype); + +extern int MPI_Type_indexed(int count, int *blocklens, int *displacements, + MPI_Datatype oldtype, MPI_Datatype *newtype); + +extern int MPI_Type_create_indexed_block(int count, int blocklen, int *displacements, + MPI_Datatype oldtype, MPI_Datatype *newtype); +extern int MPI_Type_hindexed(int count, int *blocklens, MPI_Aint *displacements, + MPI_Datatype oldtype, MPI_Datatype *newtype); +extern int MPI_Type_size(MPI_Datatype type, int * size); +extern int MPI_Type_struct(int count, int *blocklens, MPI_Aint *displacements, + MPI_Datatype *oldtypes, MPI_Datatype *newtype); +extern int MPI_Type_dup(MPI_Datatype oldtype, MPI_Datatype *newtype); + +extern int MPI_Type_extent(MPI_Datatype datatype, MPI_Aint * extent); +extern int MPI_Type_commit(MPI_Datatype * datatype); +extern int MPI_Type_free(MPI_Datatype * datatype); +extern int MPI_Type_lb(MPI_Datatype datatype, MPI_Aint * lb); +extern int MPI_Type_ub(MPI_Datatype datatype, MPI_Aint * ub); + +extern double MPI_Wtime(void); + +#endif diff --git a/mpi-serial/mpiP.h b/mpi-serial/mpiP.h new file mode 100644 index 000000000000..290d3cf9f4db --- /dev/null +++ b/mpi-serial/mpiP.h @@ -0,0 +1,128 @@ +#ifndef _MPIP_H +#define _MPIP_H + +/* + * Private .h file for MPI + */ + + +#include +#include +#include +#include + +#include "listops.h" +#include "mpi.h" + +/* Autoconf Fortran name mangling + * + * config.h defines F77_FUNC and F77_FUNC_ + * Since we are generally using FC_FUNC, and + * all of our functions will ONLY use F77_FUNC_ + * (with the underscore, define FC_FUNC as the + * aforementioned. + * + * If config.h is not present, default to the old + * approach. + */ + +#ifdef HAVE_CONFIG_H +#include +/* config.h should define FC_FUNC */ +#else + +/* + * Fortran name mangling + * + * the configure.ac specifies these + * + * cpp does not have the ability to change the case + * of the argument, so the invocation of the macro + * has to be give both e.g. FC_FUNC(hello,HELLO) + * and maps to "hello_", "hello", and "HELLO" repectively. + * + * IMPORTANT NOTE: + * In the case of FORTRAN_GNUF2C (e.g. g95), the rule is this: + * name does not contain an underscore -> append *one* underscore + * name contains an underscore -> append *two* underscore + * Since all the mpi-serial names exported to fortran start with "mpi_", + * we only support the latter. + * + * Note: FORTRANUNDERSCORE is needed by ccsm + * + */ + + +#if defined(FORTRAN_UNDERSCORE_) || defined(FORTRANUNDERSCORE) +#define FC_FUNC(lower,upper) lower##_ +#elif defined(FORTRAN_GNUF2C) +#define FC_FUNC(lower,upper) lower##__ +#elif defined(FORTRAN_SAME) +#define FC_FUNC(lower,upper) lower +#elif defined(FORTRAN_CAPS_) +#define FC_FUNC(lower,upper) upper +#else +#error "Unrecognized Fortran-mangle type" +/* set to something reasonable to avoid cascade of cc errors */ +#define FC_FUNC(lower,upper) lower##_ +#endif +#endif /* HAVE_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; + + +/****************************************************************************/ + +/* copy functions */ +extern int copy_data2(void * source, int src_count, MPI_Datatype src_type, + void * dest, int dest_count, MPI_Datatype dest_type); + +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); + +extern void FC_FUNC(mpi_get_fort_pointers,MPI_GET_FORT_POINTERS)(void); + +extern MPI_Status *mpi_c_status(int *status); +extern MPI_Status *mpi_c_statuses(int *statuses); +extern void *mpi_c_in_place(void *buffer); + + +#endif /* _MPIP_H */ diff --git a/mpi-serial/mpif.F90 b/mpi-serial/mpif.F90 new file mode 100644 index 000000000000..369b71459dcb --- /dev/null +++ b/mpi-serial/mpif.F90 @@ -0,0 +1,12 @@ +#ifdef HAVE_CONFIG_H +#include +#endif + +Module mpi +implicit none +! MPI_ADDRESS_KIND: need an 8-byte integer. + INTEGER, PARAMETER, PUBLIC :: MPI_ADDRESS_KIND=selected_int_kind(13) + + + include "mpif.h" +end Module mpi diff --git a/mpi-serial/mpif.h b/mpi-serial/mpif.h new file mode 100644 index 000000000000..b4537b5d4a2e --- /dev/null +++ b/mpi-serial/mpif.h @@ -0,0 +1,327 @@ + +! +! 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, MPI_TAG_UB + parameter (mpi_any_source=-1, mpi_any_tag= -1, mpi_tag_ub=1681915906) + + 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_ERRORS_RETURN + parameter (MPI_ERRORS_RETURN= -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=4) + + INTEGER MPI_SOURCE, MPI_TAG, MPI_ERROR + PARAMETER(MPI_SOURCE=1, MPI_TAG=2, MPI_ERROR=3) + ! There is a 4th value only used internally + + INTEGER MPI_STATUS_IGNORE(MPI_STATUS_SIZE) + INTEGER MPI_STATUSES_IGNORE(MPI_STATUS_SIZE,1) + COMMON /MPISERIAL/ MPI_STATUS_IGNORE + COMMON /MPISERIAL/ MPI_STATUSES_IGNORE + + ! + ! MPI_IN_PLACE + ! + + INTEGER MPI_IN_PLACE + COMMON /MPISERIAL/ MPI_IN_PLACE + + SAVE /MPISERIAL/ ! Technically needed in case goes out of scope + + + ! + ! MPI_Datatype values + ! + ! New datatype values + ! Type constants represent integer handles, matching up to the index of the + ! type array equal to the absolute value of the constant plus one. For + ! example, MPI_BYTE=-12, corresponding to type index 11. + ! (Array in type_const.c) + ! + + + INTEGER MPI_DATATYPE_NULL + PARAMETER (MPI_DATATYPE_NULL=0) + + INTEGER MPI_BYTE + PARAMETER (MPI_BYTE=-12) + + INTEGER MPI_PACKED + PARAMETER (MPI_PACKED=-13) + + INTEGER MPI_LB + PARAMETER (MPI_LB=-14) + + INTEGER MPI_UB + PARAMETER (MPI_UB=-15) + + INTEGER MPI_INTEGER + PARAMETER (MPI_INTEGER=-16) + + INTEGER MPI_REAL + PARAMETER (MPI_REAL=-17) + + INTEGER MPI_DOUBLE_PRECISION + PARAMETER (MPI_DOUBLE_PRECISION=-18) + + INTEGER MPI_COMPLEX + PARAMETER (MPI_COMPLEX=-19) + + INTEGER MPI_DOUBLE_COMPLEX + PARAMETER (MPI_DOUBLE_COMPLEX=-20) + + INTEGER MPI_LOGICAL + PARAMETER (MPI_LOGICAL=-21) + + INTEGER MPI_CHARACTER + PARAMETER (MPI_CHARACTER=-22) + + integer MPI_2REAL + parameter (MPI_2REAL= -23) + + integer MPI_2DOUBLE_PRECISION + parameter (MPI_2DOUBLE_PRECISION= -24) + + integer MPI_2INTEGER + parameter (MPI_2INTEGER= -25) + + + ! + ! Size-specific types + ! + + INTEGER MPI_INTEGER1 + PARAMETER (MPI_INTEGER1= -32 ) + + INTEGER MPI_INTEGER2 + PARAMETER (MPI_INTEGER2= -33 ) + + INTEGER MPI_INTEGER4 + PARAMETER (MPI_INTEGER4= -34 ) + + INTEGER MPI_INTEGER8 + PARAMETER (MPI_INTEGER8= -35 ) + + INTEGER MPI_INTEGER16 + PARAMETER (MPI_INTEGER16= -36 ) + + + INTEGER MPI_REAL4 + PARAMETER (MPI_REAL4= -37 ) + + INTEGER MPI_REAL8 + PARAMETER (MPI_REAL8= -38 ) + + INTEGER MPI_REAL16 + PARAMETER (MPI_REAL16= -39 ) + + + integer MPI_COMPLEX8 + parameter (MPI_COMPLEX8= -40 ) + + integer MPI_COMPLEX16 + parameter (MPI_COMPLEX16= -41 ) + + integer MPI_COMPLEX32 + parameter (MPI_COMPLEX32= -42 ) + + integer MPI_LONG_LONG_INT + parameter (MPI_LONG_LONG_INT= -43) + + integer MPI_LONG_LONG + parameter (MPI_LONG_LONG= MPI_LONG_LONG_INT) + + integer MPI_UNSIGNED_LONG_LONG + parameter (MPI_UNSIGNED_LONG_LONG= -44) + + integer MPI_OFFSET + parameter (MPI_OFFSET= -45) + + ! + ! 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_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) + + + ! + ! Info + ! + + INTEGER MPI_INFO_NULL + PARAMETER (MPI_INFO_NULL=0) + + + ! + ! Library version string (must match C value) + ! + + INTEGER MPI_MAX_LIBRARY_VERSION_STRING + PARAMETER (MPI_MAX_LIBRARY_VERSION_STRING=80) diff --git a/mpi-serial/op.c b/mpi-serial/op.c new file mode 100644 index 000000000000..64efbc1004a1 --- /dev/null +++ b/mpi-serial/op.c @@ -0,0 +1,28 @@ +#include "mpi.h" +#include "mpiP.h" +/* Because operations based on one processor are essentially no operation, + * all MPI_Ops are handled as null ops. Therefore, returning 0 (OP_NULL) + * suffices here. + */ + +FC_FUNC(mpi_op_create, MPI_OP_CREATE)(MPI_User_function *func, int * commute, int * op, int * ierr) +{ + *ierr = MPI_Op_create(func, *commute, op); +} + +int MPI_Op_create(MPI_User_function *function, int commute, MPI_Op *op) +{ + *op = 0; + return MPI_SUCCESS; +} + +FC_FUNC(mpi_op_free, MPI_OP_FREE)(int * op, int * ierr) +{ + *ierr = MPI_Op_free(op); +} + +int MPI_Op_free(MPI_Op * op) +{ + return MPI_SUCCESS; +} + diff --git a/mpi-serial/pack.c b/mpi-serial/pack.c new file mode 100644 index 000000000000..83ff87998564 --- /dev/null +++ b/mpi-serial/pack.c @@ -0,0 +1,145 @@ +#include +#include +#include +#include "mpiP.h" +#include "type.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 ret; + + Datatype type_ptr = *(Datatype*) mpi_handle_to_datatype(datatype); + Comm* comm_ptr = mpi_handle_to_ptr(comm); + + ret = Pack(inbuf, incount, type_ptr, outbuf, outsize, position, comm_ptr); + + return ret; +} + + + +int Pack(void *inbuf, int incount, Datatype type, + void *outbuf, int outsize, int *position, Comm * comm) +{ + int i, j; + MPI_Aint extent; + //check that buffer is large enough + Type_extent(type, &extent); + for (i = 0; i < incount; i++) + { + for (j = 0; j < type->count; j++) + { + if ((*position) + Simpletype_length(type->pairs[j].type) > outsize) + { + printf("MPI_Pack: data exceeds buffer size\n"); + exit(1); + } + memcpy(((char*) outbuf)+(*position), inbuf+type->pairs[j].disp + (extent*i), + Simpletype_length(type->pairs[j].type)); + *position += Simpletype_length(type->pairs[j].type); + } + } +} + +FC_FUNC( mpi_pack_size, MPI_PACK_SIZE )(int * incount, int * datatype, + int * comm, long * size, int *ierr) +{ + *ierr = MPI_Pack_size(*incount, *datatype, *comm, size); +} + +int MPI_Pack_size(int incount, MPI_Datatype datatype, + MPI_Comm comm, MPI_Aint * size) +{ + int ret; + Datatype type_ptr = *(Datatype*) mpi_handle_to_datatype(datatype); + Comm * comm_ptr = mpi_handle_to_ptr(comm); + + ret = Pack_size(incount, type_ptr, comm_ptr, size); + + return ret; +} + + +int Pack_size(int incount, Datatype datatype, + Comm * comm, MPI_Aint * size) +{ + int i; + *size = 0; + //sum up all sizes + for(i = 0; i < datatype->count; i++) + { + *size += Simpletype_length(datatype->pairs[i].type); + } + *size *= incount; + printf("Size = %d\n", *size); +} + + +/* + * + */ + + +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 type, MPI_Comm comm) +{ + int ret; + Datatype type_ptr = *(Datatype*) mpi_handle_to_datatype(type); + Comm * comm_ptr = mpi_handle_to_ptr(comm); + + ret = Unpack(inbuf, insize, position, outbuf, outcount, type_ptr, comm_ptr); + + return ret; +} + +int Unpack(void * inbuf, int insize, int * position, void *outbuf, + int outcount, Datatype type, Comm* comm) +{ + int i, j; + MPI_Aint extent; + + Type_extent(type, &extent); + + for (i = 0; i < outcount; i++) + { + for (j = 0; j < type->count; j++) + { + if ((*position) + Simpletype_length(type->pairs[j].type) > insize) + { + printf("MPI_Unpack: Data exceeds buffer size\n"); + exit(1); + } + memcpy(outbuf+type->pairs[j].disp + (extent*i), ((char*) inbuf)+(*position) , + Simpletype_length(type->pairs[j].type)); + *position += Simpletype_length(type->pairs[j].type); + } + } +} + + diff --git a/mpi-serial/probe.c b/mpi-serial/probe.c new file mode 100644 index 000000000000..29c3c52e07b0 --- /dev/null +++ b/mpi-serial/probe.c @@ -0,0 +1,88 @@ +//probe.c +#include "mpiP.h" + +static int mpi_match_send(void *r, void *tag) +{ + return( *((int *)tag) == MPI_ANY_TAG || + *((int *)tag) == ((Req *)r)->tag ); +} + +FC_FUNC(mpi_iprobe, MPI_IPROBE)(int * source, int * tag, int * comm, + int * flag, int *status, int * ierr) +{ + *ierr = MPI_Iprobe(*source, *tag, *comm, flag, mpi_c_status(status)); +} + +/* Iprobe + * Search for existing message, return status about it + */ + +int MPI_Iprobe(int source, int tag, MPI_Comm comm, int *flag, + MPI_Status *status) + +{ + pListitem match; + Comm *mycomm; + Req *sreq; + + mycomm=mpi_handle_to_ptr(comm); /* mycomm=(Comm *)comm; */ + +#ifdef INFO + fflush(stdout); + fprintf(stderr,"MPI_IProbev: Comm=%d tag=%d count=%d type=%d\n", + mycomm->num,tag,count,datatype); +#endif + + + if (source!=0 && source!=MPI_ANY_SOURCE) + { + fprintf(stderr,"MPI_Irecv: bad source %d\n",source); + abort(); + } + + match=AP_list_search_func(mycomm->sendlist,mpi_match_send,&tag); + + *flag= (match==NULL ? 0:1 ); + + if (*flag) + { + sreq=(Req *)AP_listitem_data(match); + + if (status!=MPI_STATUS_IGNORE) + { + status->MPI_SOURCE=0 ; + status->MPI_TAG= sreq->tag; + } + } + + return(MPI_SUCCESS); +} + + +//probe: wait for message, and return status +// (either message will immediately be available, or deadlock. + +FC_FUNC(mpi_probe,MPI_PROBE)(int *source, int *tag, int *comm, int *status, + int *ierr) +{ + *ierr=MPI_Probe(*source,*tag,*comm,mpi_c_status(status)); +} + + + +int MPI_Probe(int source, int tag, MPI_Comm comm, MPI_Status *status) +{ + + int flag; + + MPI_Iprobe(source,tag,comm,&flag,status); + + if (!flag) + { + fprintf(stderr,"MPI_Probe: no existing match, deadlock\n"); + abort(); + } + + return(MPI_SUCCESS); +} + diff --git a/mpi-serial/protify.awk b/mpi-serial/protify.awk new file mode 100755 index 000000000000..483fc2ec0d1e --- /dev/null +++ b/mpi-serial/protify.awk @@ -0,0 +1,46 @@ +#!/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/mpi-serial/recv.c b/mpi-serial/recv.c new file mode 100644 index 000000000000..d70344a37651 --- /dev/null +++ b/mpi-serial/recv.c @@ -0,0 +1,164 @@ + +#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); + copy_data2(sreq->buf, count, datatype, 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_c_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); + + if (status!=MPI_STATUS_IGNORE) + status->get_count = count; // rml: shouldn't this depend on send? + + 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/mpi-serial/req.c b/mpi-serial/req.c new file mode 100644 index 000000000000..5cfa827fe5e6 --- /dev/null +++ b/mpi-serial/req.c @@ -0,0 +1,301 @@ +#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_c_status(status)); +} + + + +int MPI_Test(MPI_Request *request, int *flag, MPI_Status *status) +{ + Req *req; + + if (*request==MPI_REQUEST_NULL) + { + if (status!=MPI_STATUS_IGNORE) + { + 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) + { + if (status!=MPI_STATUS_IGNORE) + { + 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_c_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_c_status(status)); +} + + + +int MPI_Waitany(int count, MPI_Request *array_of_requests, + int *index, MPI_Status *status) +{ + int flag; + + MPI_Testany(count, array_of_requests, index, &flag, status); + + if (!flag) + { + /* none are completed */ + + fprintf(stderr,"MPI_Waitany: no requests complete, deadlock\n"); + abort(); + + } + + return(MPI_SUCCESS); +} + +/* MPI_Testany: looks for any message matching an element + * in request array and returns its status. + * flag=0 means no match was found. + */ + +FC_FUNC(mpi_testany, MPI_TESTANY) + (int * count, int * array_of_requests, + int * index, int * flag, int *status, int * ierr) +{ + *ierr = MPI_Testany(*count, array_of_requests, index, + flag, mpi_c_status(status)); +} + +int MPI_Testany(int count, MPI_Request *array_of_requests, + int *index, int *flag, MPI_Status *status) +{ + int i; + + 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); + copy_data2(buf, count, datatype, rreq->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_c_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/mpi-serial/tests/.gitignore b/mpi-serial/tests/.gitignore new file mode 100644 index 000000000000..2037e022f76b --- /dev/null +++ b/mpi-serial/tests/.gitignore @@ -0,0 +1,4 @@ +ctest +ctest2 +ftest +ftest2 diff --git a/mpi-serial/tests/Makefile b/mpi-serial/tests/Makefile new file mode 100644 index 000000000000..c03c1fe9d962 --- /dev/null +++ b/mpi-serial/tests/Makefile @@ -0,0 +1,41 @@ +############################### + +# +# test programs Makefile +# + +# Parent dir Makefile.conf has all necessary vars +include ../Makefile.conf + +TINC = -I.. +LDFLAGS = -L.. +MYLIBS = $(LIBS) -l$(MODULE) +MYF90FLAGS=$(INCPATH) $(DEFS) $(FCFLAGS) $(MPEUFLAGS) + +runtests: all + ./ctest + @echo + ./ftest + @echo + +all: ctest ftest + +ctest: ctest.c + $(CC) $(DEFS) $(TINC) $(ALLCFLAGS) -o $@ ctest.c $(LDFLAGS) $(MYLIBS) + +ftest: ftest.F90 + $(FC) $(DEFS) $(TINC) $(MYF90FLAGS) -o $@ ftest.F90 $(LDFLAGS) $(MYLIBS) + +ctest2: ctest_old.c + $(CC) $(DEFS) $(TINC) $(ALLCFLAGS) -o $@ ctest_old.c $(LDFLAGS) $(MYLIBS) + +ftest2: ftest_old.F90 + $(FC) $(DEFS) $(TINC) $(MYF90FLAGS) -o $@ ftest_old.F90 $(LDFLAGS) $(MYLIBS) + +stest: stest.F90 stest2.o + $(FC) $(DEFS) $(TINC) $(MYF90FLAGS) -o $@ stest.F90 stest2.o $(LDFLAGS) $(MYLIBS) + + +clean: + rm -f ctest ftest ctest2 ftest2 + rm -f *.o diff --git a/mpi-serial/tests/ctest.c b/mpi-serial/tests/ctest.c new file mode 100644 index 000000000000..4a9b50abb644 --- /dev/null +++ b/mpi-serial/tests/ctest.c @@ -0,0 +1,967 @@ +#include +#include +#include + +#ifdef HAVE_CONFIG_H +#include +#endif + +#ifdef TEST_INTERNAL +#include +#include +#else +MPI_Request req; +#endif + + +int errcount = 0; +//simplest example: contiguous +// type of 5 MPI_INT + +void test_simple_contig() +{ + int i; + int a [5] = {1, 2, 3, 4, 5}; + int b [5]; + MPI_Datatype contig_type; + + //Contiguous type of simple types + printf("\nContiguous type of 5 x MPI_INT\n"); + MPI_Type_contiguous(5, MPI_INT, &contig_type); + MPI_Type_commit(&contig_type); + +#ifdef TEST_INTERNAL + print_typemap(contig_type); + copy_data(&a, &b, contig_type); +#else + MPI_Isend(&a, 1, contig_type, 0, 0, MPI_COMM_WORLD, &req); + MPI_Irecv(&b, 1, contig_type, MPI_ANY_SOURCE, MPI_ANY_TAG, MPI_COMM_WORLD,&req); +#endif + + printf("a = ["); + for (i = 0; i < 5; i++) + printf("%d ", a[i]); + printf("]\n"); + + printf("b = ["); + for (i = 0; i < 5; i++) + printf("%d ", b[i]); + printf("]\n"); + + for (i = 0; i < 5; i++) + if (a[i]!=b[i]) + { + printf(">>>FAILED: test_simple_contig\n"); + errcount++; + return; + } +} + +// vector type of MPI_INTs + +void test_simple_vector() +{ + int i; + int a[10] = {1, 2, 3, 4, 5, 6, 7, 8, 9, 10}; + int b[10] = {0, 0, 0, 0, 0, 0, 0, 0, 0, 0 }; + int index_test []= {0, 1, 3, 4, 6, 7}; + MPI_Datatype vector_type; + + //Vector type of simple types + printf("\nVector type of 3 groups of 2 MPI_INT, stride of 3.\n"); + MPI_Type_vector(3, 2, 3, MPI_INT, &vector_type); + MPI_Type_commit(&vector_type); + +#ifdef TEST_INTERNAL + print_typemap(vector_type); + copy_data(&a, &b, vector_type); +#else + MPI_Isend(&a, 1, vector_type, 0, 0, MPI_COMM_WORLD, &req); + MPI_Irecv(&b, 1, vector_type, 0, 0, MPI_COMM_WORLD, &req); +#endif + + printf("a = ["); + for (i = 0; i < 10; i++) + printf("%d ", a[i]); + printf("]\n"); + + printf("b = ["); + for (i = 0; i < 10; i++) + printf("%d ", b[i]); + printf("]\n"); + + for (i = 0; i < 6; i++) + if (a[index_test[i]]!=b[index_test[i]]) + { + printf(">>>FAILED: test_simple_vector\n"); + errcount++; + return; + } +} +//vector type (byte addressed, using +// sizeof(int) to compute stride + +void test_simple_hvector() +{ + MPI_Datatype vector_type; + int i; + int a[10] = {1, 2, 3, 4, 5, 6, 7, 8, 9, 10}; + int b[10] = {0, 0, 0, 0, 0, 0, 0, 0, 0, 0}; + int index_test [6] = {0, 1, 4, 5, 8, 9}; + //Vector (byte-addressed) of simple types + printf("\nVector type of 3 groups of 2 MPI_INT, stride of 16 bytes.\n"); + MPI_Type_hvector(3, 2, 4*sizeof(int), MPI_INT, &vector_type); + MPI_Type_commit(&vector_type); + +#ifdef TEST_INTERNAL + print_typemap(vector_type); + copy_data(&a, &b, vector_type); +#else + MPI_Isend(&a, 1, vector_type, 0, 0, MPI_COMM_WORLD, &req); + MPI_Irecv(&b, 1, vector_type, 0, 0, MPI_COMM_WORLD, &req); +#endif + + printf("a = ["); + for (i = 0; i < 10; i++) + printf("%d ", a[i]); + printf("]\n"); + + printf("b = ["); + for (i = 0; i < 10; i++) + printf("%d ", b[i]); + printf("]\n"); + + for (i = 0; i < 6; i++) + if (a[index_test[i]]!=b[index_test[i]]) + { + printf(">>>FAILED: test_simple_hvector\n"); + errcount++; + return; + } +} + +//indexed type. + +void test_simple_indexed() +{ + int i; + int a[15] = {1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15}; + int b[15] = {0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0}; + int index_test [6] = {0, 5, 6, 10, 11, 12}; + int blens[3] = {2, 1, 3}; + int disps[3] = {5, 0, 10}; + MPI_Datatype indexed_type; + //Indexed of simple types + + printf("\nIndexed type of MPI_INT.\n"); + + MPI_Type_indexed(3, blens, disps, MPI_INT, &indexed_type); + MPI_Type_commit(&indexed_type); + +#ifdef TEST_INTERNAL + print_typemap(indexed_type); + copy_data(&a, &b, indexed_type); +#else + MPI_Isend(&a, 1, indexed_type, 0, 0, MPI_COMM_WORLD, &req); + MPI_Irecv(&b, 1, indexed_type, 0, 0, MPI_COMM_WORLD, &req); +#endif + + printf("a = ["); + for (i = 0; i < 15; i++) + printf("%d ", a[i]); + printf("]\n"); + + printf("b = ["); + for (i = 0; i < 15; i++) + printf("%d ", b[i]); + printf("]\n"); + + for (i = 0; i < 6; i++) + if (a[index_test[i]]!=b[index_test[i]]) + { + printf(">>>FAILED: test_simple_indexed\n"); + errcount++; + return; + } +} + +//block indexed. Same as indexed except +//static block length + +void test_simple_bindexed() +{ + int i; + int disps[3] = {0, 4, 7}; + int a [10] = {1, 2, 3, 4, 5, 6, 7, 8, 9, 10}; + int b [10] = {0, 0, 0, 0, 0, 0, 0, 0, 0, 0}; + int index_test[6] = {0, 1, 4, 5, 7, 8}; + MPI_Datatype indexed_type; + + //block indexed of simple types + printf("\nBlock indexed type of MPI_INT.\n"); + MPI_Type_create_indexed_block(3, 2, disps, MPI_INT, &indexed_type); + MPI_Type_commit(&indexed_type); +#ifdef TEST_INTERNAL + copy_data(&a, &b, indexed_type); + print_typemap(indexed_type); +#else + MPI_Isend(&a, 1, indexed_type, 0, 0, MPI_COMM_WORLD, &req); + MPI_Irecv(&b, 1, indexed_type, 0, 0, MPI_COMM_WORLD, &req); +#endif + + printf("a = ["); + for (i = 0; i < 10; i++) + printf("%d ", a[i]); + printf("]\n"); + + printf("b = ["); + for (i = 0; i < 10; i++) + printf("%d ", b[i]); + printf("]\n"); + + for (i = 0; i < 6; i++) + if (a[index_test[i]]!=b[index_test[i]]) + { + printf(">>>FAILED: test_simple_bindexed\n"); + errcount++; + return; + } +} + +//hindexed: same as indexed, but +//using byte displacements based off of sizeof(int) +//(no reason why this shouldn't work) + +void test_simple_hindexed() +{ + int i; + int a [10] = {1, 2, 3, 4, 5, 6, 7, 8, 9, 10}; + int b [10] = {0, 0, 0, 0, 0, 0, 0, 0, 0, 0 }; + int index_test [6] = {0, 2, 3, 5, 6, 7}; + int blens[3] = {2, 1, 3}; + MPI_Aint disps[3] = {2*sizeof(int), 0, 5*sizeof(int)}; + MPI_Datatype indexed_type; + +//Indexed (byte-addressed) of simple types + printf("\nBlock indexed (byte addressed) type of MPI_INT.\n"); + MPI_Type_hindexed(3, blens, disps, MPI_INT, &indexed_type); + MPI_Type_commit(&indexed_type); +#ifdef TEST_INTERNAL + print_typemap(indexed_type); + copy_data(&a, &b, indexed_type); +#else + MPI_Isend(&a, 1, indexed_type, 0, 0, MPI_COMM_WORLD, &req); + MPI_Irecv(&b, 1, indexed_type, 0, 0, MPI_COMM_WORLD, &req); +#endif + + printf("a = ["); + for (i = 0; i < 10; i++) + printf("%d ", a[i]); + printf("]\n"); + + printf("b = ["); + for (i = 0; i < 10; i++) + printf("%d ", b[i]); + printf("]\n"); + + for (i = 0; i < 6; i++) + if (a[index_test[i]]!=b[index_test[i]]) + { + printf(">>>FAILED: test_simple_hindexed\n"); + errcount++; + return; + } +} + + +/* + * void struct_test() +{ + int blocklengths[6]; + int offsets[6]; + MPI_Aint boffsets[6]; + MPI_Datatype types[6]; + MPI_Datatype struct_type, newtype, newtype2, sstruct, + indexed_type, vector_type; + MPI_Aint extent2, extent3; + //struct type of simple types + printf("\nStruct of simple types\n"); + blocklengths[0] = 3; + blocklengths[1] = 5; + blocklengths[2] = 2; + blocklengths[3] = 1; + boffsets[0] = 0; + boffsets[1] = 24; + boffsets[2] = 32; + boffsets[3] = 40; + types[0] = MPI_DOUBLE; + types[1] = MPI_CHAR; + types[2] = MPI_INT; + types[3] = MPI_LONG_DOUBLE; + + MPI_Type_struct(4, blocklengths, boffsets, types, &struct_type); + print_typemap(struct_type); + + //struct type of simple types, with artificial LB and UB + printf("\nStruct type of simple types, with LB and UB.\n"); + blocklengths[0] = 2; + blocklengths[1] = 4; + blocklengths[2] = 1; + blocklengths[3] = 24; + blocklengths[4] = 1; + boffsets[0] = 0; + boffsets[1] = 40; + boffsets[2] = 80; + boffsets[3] = 48; + boffsets[4] = -8; + types[0] = MPI_LONG; + types[1] = MPI_INT; + types[2] = MPI_UB; + types[3] = MPI_CHAR; + types[4] = MPI_LB; + + MPI_Type_struct(5, blocklengths, boffsets, types, &newtype2); + print_typemap(newtype2); + + //struct type: 2 int, 1 float + printf("\nSimple struct for use: 2 int, 1 float\n"); + blocklengths[0] = 2; + blocklengths[1] = 1; + boffsets[0] = 0; + boffsets[1] = 8; + types[0] = MPI_INT; + types[1] = MPI_FLOAT; + + MPI_Type_struct(2, blocklengths, boffsets, types, &sstruct); + print_typemap(sstruct); + + //contiguous type of complex (struct) type + printf("\nContiguous type of complex (struct) type\n"); + MPI_Type_contiguous(3, newtype2, &newtype); + print_typemap(newtype); + + //vector type of complex type + printf("\nVector type of struct\n"); + MPI_Type_vector(3, 2, 2, struct_type, &vector_type); + print_typemap(vector_type); + + //indexed of complex type + printf("\nIndexed type of struct\n"); + blocklengths[0] = 1; + blocklengths[1] = 2; + offsets[0] = 0; + offsets[1] = 7; + MPI_Type_indexed(2, blocklengths, offsets, sstruct, &indexed_type); + print_typemap(indexed_type); + + //struct of simple/complex + printf("\nStruct of smaller structs and simple types\n"); + MPI_Type_extent(sstruct, &extent2); + MPI_Type_extent(indexed_type, &extent3); + blocklengths[0] = 2; + blocklengths[1] = 1; + blocklengths[2] = 4; + blocklengths[3] = 5; + boffsets[0] = 0; + boffsets[1] = 2 * extent2; + boffsets[2] = boffsets[1] + extent3; + boffsets[3] = boffsets[2] + 4; + types[0] = sstruct; + types[1] = indexed_type; + types[2] = MPI_CHAR; + types[3] = newtype2; + + MPI_Type_struct(4, blocklengths, boffsets, types, &struct_type); + print_typemap(struct_type); +} +*/ + +//simple struct, comprised of an int, 2 chars +// and a long int value. + +void test_simple_struct() +{ + struct {int a; char b; char c; long d; } s1; + struct {int a; char b; char c; long d; } s2; + + int blens[4] = {1, 2, 1}; + MPI_Aint disps[4] = {0, 4, 8}; + MPI_Datatype types[4] = {MPI_INT, MPI_CHAR, MPI_LONG}; + MPI_Datatype struct_type; + + printf("\nSimple struct type: 1 int, 2 char, 1 long\n"); + MPI_Type_struct(3, blens, disps, types, &struct_type); + MPI_Type_commit(&struct_type); + s1.a = 10; + s1.b = 'x'; + s1.c = 'a'; + s1.d = 3000; + +#ifdef TEST_INTERNAL + print_typemap(struct_type); + copy_data(&s1, &s2, struct_type); +#else + MPI_Isend(&s1, 1, struct_type, 0, 0, MPI_COMM_WORLD, &req); + MPI_Irecv(&s2, 1, struct_type, 0, 0, MPI_COMM_WORLD, &req); +#endif + + if (!(s1.a==s2.a && s1.b==s2.b && s1.c==s2.c && s1.d==s2.d)) + { + printf(">>>FAILED: test_simple_struct\n"); + errcount++; + return; + } +} + +// combine one struct into another struct for a complex +// type. This should test any funny padding issues + +void test_complex_struct() +{ + MPI_Datatype sstruct; + typedef struct {long a; long b; char c; int d; int e;} st; + typedef struct {st a; int b; char c;} st2; + st s1 = {.a = 100, .b = 200, .c = 'x', .d = 45, .e = 50}; + st s2; + st2 s3 = {.a = { .a = 40, .b = 100, .c = 'x', .d = 50, .e = 20}, .b = 100, .c = 'g'} ; + st2 s4; + int blens[3] = {2, 2, 1}; + MPI_Aint disps[3] = {0, 2*sizeof(long) + sizeof(int), 2*sizeof(long)}; + MPI_Datatype types[3] = {MPI_LONG, MPI_INT, MPI_CHAR}; + MPI_Datatype newtype; + + + printf("\nSimple struct to create complex struct\n"); + MPI_Type_struct(3, blens, disps, types, &newtype); + MPI_Type_commit(&newtype); +#ifdef TEST_INTERNAL + print_typemap(newtype); + copy_data(&s1, &s2, newtype); +#else + MPI_Isend(&s1, 1, newtype, 0, 0, MPI_COMM_WORLD, &req); + MPI_Irecv(&s2, 1, newtype, 0, 0, MPI_COMM_WORLD, &req); +#endif + + if (!(s1.a==s2.a && s1.b==s2.b && s1.c==s2.c && s1.d==s2.d && s1.e==s2.e)) + { + printf(">>>FAILED: test_complex_struct\n"); + errcount++; + return; + } + MPI_Datatype newtype2; + + blens[0] = 1; + blens[1] = 1; + blens[2] = 1; + disps[0] = 0; + disps[1] = sizeof(st); + disps[2] = sizeof(st) + sizeof(int); + types[0] = newtype; + types[1] = MPI_INT; + types[2] = MPI_CHAR; + + printf("\nComplex struct type composed of other struct.\n"); + MPI_Type_struct(3, blens, disps, types, &newtype2); + MPI_Type_commit(&newtype2); +#ifdef TEST_INTERNAL + print_typemap(newtype2); + copy_data(&s3, &s4, newtype2); +#else + MPI_Isend(&s3, 1, newtype2, 0, 0, MPI_COMM_WORLD, &req); + MPI_Irecv(&s4, 1, newtype2, 0, 0, MPI_COMM_WORLD, &req); +#endif + + if (!(s3.a.a==s4.a.a && s3.a.b==s4.a.b && s3.a.c==s4.a.c && s3.b==s4.b && s3.c==s4.c)) + { + printf(">>>FAILED: test_complex_struct\n"); + errcount++; + return; + } +} + +// Indexed struct. This one is a bit complicated +// as to datatype layout, so it will also test the +// padding issue + +void test_indexed_struct() +{ + int i; + + //simple struct vars + int s_blens[4] = {1,1,1,2}; + MPI_Aint s_disps[4]; + MPI_Datatype s_types[4] = {MPI_CHAR, MPI_LONG, + MPI_CHAR, MPI_INT}; + MPI_Datatype s_struct; + int i_blens[3] = {3, 1, 2}; + int i_disps[3] = {0, 5, 7}; + MPI_Datatype i_struct_indexed; + int index_test [6] = {0,1,2,5,7,8}; + char* sadd; + typedef struct + {char a; long b; char c; int d; int e;} + struct_t; + + struct_t send[10]; + struct_t recv[10]; + + //initialize the structs + for (i = 0; i < 10; i++) + { + send[i].a = i; + send[i].b = 2*i; + send[i].c = 'A' + i; + send[i].d = i; + send[i].e =-i; + recv[i].a=0; + recv[i].b=0; + recv[i].c=' '; + recv[i].d=0; + recv[i].e=0; + } + + //set the displacements by using address differences + sadd = (char *)&send[0]; + s_disps[0] = (char*)&(send[0].a) - sadd; + s_disps[1] = (char*)&(send[0].b) - sadd; + s_disps[2] = (char*)&(send[0].c) - sadd; + s_disps[3] = (char*)&(send[0].d) - sadd; + //e is "contiguous" of d + + + MPI_Type_struct(4, s_blens, s_disps, s_types, &s_struct); + MPI_Type_commit(&s_struct); +#ifdef TEST_INTERNAL + print_typemap(s_struct); +#endif + + //now, create an indexed type of this struct + MPI_Type_indexed(3, i_blens, i_disps, + s_struct, &i_struct_indexed); + MPI_Type_commit(&i_struct_indexed); + +#ifdef TEST_INTERNAL + print_typemap(i_struct_indexed); + copy_data2(send, 1, i_struct_indexed, recv, 1, i_struct_indexed); +#else + MPI_Isend(&send, 1, i_struct_indexed, 0, 0, MPI_COMM_WORLD, &req); + MPI_Irecv(&recv, 1, i_struct_indexed, 0, 0, MPI_COMM_WORLD, &req); +#endif + + for (i = 0; i < 6; i++) + { + if (!(send[index_test[i]].a==recv[index_test[i]].a + && send[index_test[i]].b==recv[index_test[i]].b + && send[index_test[i]].c==recv[index_test[i]].c + && send[index_test[i]].d==recv[index_test[i]].d + && send[index_test[i]].e==recv[index_test[i]].e)) + { + printf(">>>FAILED: test_indexed_struct\n"); + errcount++; + return; + } + } + + //to make things really interesting, let's send as the + //indexed type, and receive instead as _count_ + //consecutive struct types +#ifdef TEST_INTERNAL + copy_data2(send, 1, i_struct_indexed, recv, 6, s_struct); +#else + MPI_Gather(&send, 1, i_struct_indexed, &recv, + 6, s_struct, 0, MPI_COMM_WORLD); + +// MPI_Isend(&send, 1, i_struct_indexed, 0, 0, MPI_COMM_WORLD, &req); +// MPI_Irecv(&recv, 6, s_struct, 0, 0, MPI_COMM_WORLD, &req); + +#endif + + for (i = 0; i < 6; i++) + { + if (!(send[index_test[i]].a==recv[i].a + && send[index_test[i]].b==recv[i].b + && send[index_test[i]].c==recv[i].c + && send[index_test[i]].d==recv[i].d + && send[index_test[i]].e==recv[i].e)) + { + printf(">>>FAILED: test_indexed_struct (multiple recv)\n"); + errcount++; + return; + } + } + +} + + +//test a differing issue with send/receive +//A contiguous type of 5 MPI_INTs is sent, and is +//received using a receive x5 of MPI_INT + +void test_multiple() +{ + int i; + int a[5] = {1, 2, 3, 4, 5}; + int b[5] = {0, 0, 0, 0, 0}; + + + + MPI_Datatype contig5int; + + printf("\nSend contiguous of 5 MPI_INT, receive 5 x MPI_INT\n"); + MPI_Type_contiguous(5, MPI_INT, &contig5int); + MPI_Type_commit(&contig5int); + +#ifdef TEST_INTERNAL + copy_data2(&a, 5, MPI_INT, &b, 1, contig5int); +#else + MPI_Isend(&a, 5, MPI_INT, 0, 0, MPI_COMM_WORLD, &req); + MPI_Irecv(&b, 1, contig5int, 0, 0, MPI_COMM_WORLD, &req); +#endif + + + printf("a = ["); + for (i = 0; i < 5; i++) + printf("%d ", a[i]); + printf("]\n"); + + printf("b = ["); + for (i = 0; i < 5; i++) + printf("%d ", b[i]); + printf("]\n"); + + for (i = 0; i < 5; i++) + if (a[i]!=b[i]) + { + printf(">>>FAILED: test_multiple\n"); + errcount++; + return; + } +} + +void test_multiple_struct() +{ + int i; + typedef struct {int a; double b; char c;} struct_t; + struct_t s1[5],s2[5]; + MPI_Aint disps[3]; + int blens[3] = {1,1,1}; + MPI_Datatype types[3] = {MPI_INT, MPI_DOUBLE, MPI_CHAR}; + MPI_Datatype struct_type, contig_struct; + + disps[0] = 0; + disps[1] = (char*) &(s1[0].b) - (char*) &s1[0]; + disps[2] = (char*) &(s1[0].c) - (char*) &s1[0]; + + for (i=0; i<5; i++) + { + s1[i].a=i; s1[i].b=i+15.0; s1[i].c='a'+i; + s2[i].a=0; s2[i].b=0.0 ; s2[i].c=0 ; + } + + MPI_Type_struct(3, blens, disps, types, &struct_type); + MPI_Type_commit(&struct_type); + MPI_Type_contiguous(5, struct_type, &contig_struct); + MPI_Type_commit(&contig_struct); + printf("\nSend contiguous of 5 struct, receive 5x struct\n"); + +#ifdef TEST_INTERNAL + copy_data2(&s1, 1, contig_struct, &s2, 5, struct_type); +#else + MPI_Isend(&s1, 1, contig_struct, 0, 0, MPI_COMM_WORLD, &req); + MPI_Irecv(&s2, 5, struct_type, 0, 0, MPI_COMM_WORLD, &req); +#endif + + for (i = 0; i < 5; i++) + if (!(s1[i].a == s2[i].a && s1[i].b == s2[i].b && s1[i].c == s2[i].c)) + { + printf(">>>FAILED: test_multiple_struct\n"); + errcount++; + return; + } +} + +// packed type. Pack some arbitrary simple +// values into a buffer and copy. + +void test_packed() +{ + int SIZE = 77; + int i = 8; + char c[] = "abcdefghijklmnopqrstuvwxyabcdefghijklmnopqrstuvwxyabcdefghijklmnopqrstuvwxyabcdefghijklmnopqrstuvwxyzabcdefg\0"; + int j; + double k = 0.234234, l; + char d[SIZE]; + char buffer[110]; + char recv[110]; + int position = 0; + + printf("\nSimple packed type (int, char, double)\n"); + c[SIZE-1] = '\0'; + MPI_Pack(&i, 1, MPI_INT, buffer, 110, &position, MPI_COMM_WORLD); + MPI_Pack(c, SIZE, MPI_CHAR, buffer, 110, &position, MPI_COMM_WORLD); + MPI_Pack(&k, 1, MPI_DOUBLE, buffer, 110, &position, MPI_COMM_WORLD); +#ifdef TEST_INTERNAL + copy_data2(&buffer, position, MPI_PACKED, &recv, position, MPI_PACKED); +#else + MPI_Isend(&buffer, position, MPI_PACKED, 0, 0, MPI_COMM_WORLD, &req); + MPI_Irecv(&recv, position, MPI_PACKED, 0, 0, MPI_COMM_WORLD,&req); +#endif + + position = 0; + + MPI_Unpack(&recv, 110, &position, &j, 1, MPI_INT, MPI_COMM_WORLD); + MPI_Unpack(&recv, 110, &position, d, SIZE, MPI_CHAR, MPI_COMM_WORLD); + MPI_Unpack(&recv, 110, &position, &l, 1, MPI_DOUBLE, MPI_COMM_WORLD); + + if (!(i==j && k==l)) + { + printf(">>>FAILED: test_packed\n"); + errcount++; + return; + } +} + +// Complex pack. Includes struct types that are packed + +void test_packed_complex() +{ + struct {int a; char b; char c; long d; } s1; + struct {int a; char b; char c; long d; } s2; + + MPI_Aint size; + int pos = 0; + int x = 10, y; + float f = 0.345, g; + char buf[100]; + char rbuf[100]; + int blens[3] = {1, 1, 1}; + MPI_Aint disps[3]; + MPI_Datatype types[3] = {MPI_INT, MPI_CHAR, MPI_LONG}; + MPI_Datatype struct_type; + + disps[0] = 0; + disps[1] = (char*) &s1.b - (char*)&s1.a; + disps[2] = (char*) &s1.d - (char*)&s1.a; + + printf("\nComplex packed type\n"); + + MPI_Type_struct(3, blens, disps, types, &struct_type); + s1.a = 10; + s1.b = 'x'; + s1.c = 'a'; + s1.d = 3000; + + MPI_Pack_size(1, struct_type,MPI_COMM_WORLD, &size); + MPI_Pack(&x, 1, MPI_INT, buf, 100, &pos, MPI_COMM_WORLD); + MPI_Pack(&s1, 1, struct_type, buf, 100, &pos, MPI_COMM_WORLD); + MPI_Pack(&f, 1, MPI_FLOAT, buf, 100, &pos, MPI_COMM_WORLD); + +#ifdef TEST_INTERNAL + copy_data2(&buf, pos, MPI_PACKED, &rbuf, pos, MPI_PACKED); +#else + MPI_Isend(&buf, pos, MPI_PACKED, 0, 0, MPI_COMM_WORLD, &req); + MPI_Irecv(&rbuf, pos, MPI_PACKED, 0, 0, MPI_COMM_WORLD,&req); +#endif + + pos = 0; + MPI_Unpack(&rbuf, 100, &pos, &y, 1, MPI_INT, 0); + MPI_Unpack(&rbuf, 100, &pos, &s2, 1, struct_type, 0); + MPI_Unpack(&rbuf, 100, &pos, &g, 1, MPI_FLOAT, 0); + + if (!(s1.a==s2.a && s1.b==s2.b /*&& s1.c==s2.c*/ && s1.d==s2.d && x == y && f == g)) + { + printf(">>>FAILED: test_packed_complex\n"); + errcount++; + return; + } + +} + +//Macro used in test_collectives +#define test_eq(s1, s2, op) { \ + printf("testing %s\n",op); \ + if (!(s1.a == s2.a && s1.b == s2.b && \ + s1.c == s2.c && s1.d == s2.d)) {\ + errcount++; \ + printf(">>>FAILED: test_collectives: %s\n", op); \ + } \ +} + +void test_collectives() +{ + typedef struct {int a; int b; double c; long d;} struct_t; + MPI_Datatype struct_type; + struct_t s1 = {.a=1, .b=2, .c=4.00, .d=100}, + s2 = {.a=0, .b=0, .c=0.00, .d=0 }; + MPI_Aint disps[3]; + + int disp = 0; + int sendcount = 1, recvcount = 1; + + + int blens[3] = {2,1,1}; + MPI_Datatype types[3] = {MPI_INT, MPI_DOUBLE, MPI_LONG}; + + disps[0] = 0; + disps[1] = (char*)&s1.c - (char*) &s1.a; + disps[2] = (char*)&s1.d - (char*) &s1.a; + + MPI_Type_struct(3, blens, disps, types, &struct_type); + MPI_Type_commit(&struct_type); + + MPI_Bcast(&s1, sendcount, struct_type, 0, MPI_COMM_WORLD); + MPI_Gather(&s1, sendcount, struct_type, &s2, recvcount, + struct_type, 0, MPI_COMM_WORLD); + test_eq(s1,s2,"MPI_Gather"); + + s2.a=0; s2.b=0; s2.c=0.00; s2.d=0; + MPI_Gatherv(&s1, sendcount, struct_type, &s2, &recvcount, &disp, + struct_type, 0, MPI_COMM_WORLD); + test_eq(s1,s2,"MPI_Gatherv"); + s2.a=0; s2.b=0; s2.c=0.00; s2.d=0; + MPI_Allgather(&s1, sendcount, struct_type, &s2, recvcount, + struct_type, MPI_COMM_WORLD); + test_eq(s1,s2,"MPI_Allgather"); + s2.a=0; s2.b=0; s2.c=0.00; s2.d=0; + MPI_Allgatherv(&s1, sendcount, struct_type, &s2, &recvcount, &disp, + struct_type, MPI_COMM_WORLD); + test_eq(s1,s2,"MPI_Allgatherv"); + + s2.a=0; s2.b=0; s2.c=0.00; s2.d=0; + MPI_Scatter(&s1, sendcount, struct_type, + &s2, recvcount, struct_type, + 0, MPI_COMM_WORLD); + test_eq(s1,s2,"MPI_Scatter"); + + s2.a=0; s2.b=0; s2.c=0.00; s2.d=0; + MPI_Scatterv(&s1, &sendcount, &disp, struct_type, &s2, recvcount, + struct_type, 0, MPI_COMM_WORLD); + test_eq(s1,s2,"MPI_Scatterv"); + + s2.a=0; s2.b=0; s2.c=0.00; s2.d=0; + MPI_Reduce(&s1, &s2, sendcount, struct_type, MPI_MAX, 0, MPI_COMM_WORLD); + test_eq(s1, s2, "MPI_Reduce"); + + s2.a=0; s2.b=0; s2.c=0.00; s2.d=0; + MPI_Allreduce(&s1, &s2, sendcount, struct_type, MPI_MAX, MPI_COMM_WORLD); + test_eq(s1, s2, "MPI_Allreduce"); + + s2.a=0; s2.b=0; s2.c=0.00; s2.d=0; + MPI_Alltoall(&s1, sendcount, struct_type, + &s2, recvcount, struct_type, MPI_COMM_WORLD); + test_eq(s1, s2, "MPI_Alltoall"); + + s2.a=0; s2.b=0; s2.c=0.00; s2.d=0; + MPI_Alltoallv(&s1, &sendcount, &disp, struct_type, + &s2, &recvcount, &disp, struct_type, MPI_COMM_WORLD); + test_eq(s1, s2, "MPI_Alltoallv"); + + s2.a=0; s2.b=0; s2.c=0.00; s2.d=0; + MPI_Reduce_scatter(&s1, &s2, &recvcount,struct_type, MPI_MAX, MPI_COMM_WORLD); + test_eq(s1, s2, "MPI_Reduce_scatter"); + + s2.a=0; s2.b=0; s2.c=0.00; s2.d=0; + MPI_Scan(&s1, &s2, sendcount,struct_type, MPI_MAX, MPI_COMM_WORLD); + test_eq(s1, s2, "MPI_Scan"); +} +/* +void vector_test() +{ + int c[3][2] = { {1, 2}, {3, 4}, {5, 6} }; + int d[3][2] = { {0, 0}, {0, 0}, {0, 0} }; + int i; + MPI_Datatype vector_type; + //test vector. First and third rows of array + printf("\nVector type of first and third rows in INT array\n"); + MPI_Type_vector(2, 2, 4, MPI_INT, &vector_type); + + print_typemap(vector_type); + + copy_data(&c, &d, vector_type); + + for (i = 0; i < 3; i++) + printf("%d %d\n", d[i][0], d[i][1]); +} + +void indexed_test() +{ + //we want the 2nd, 3rd, 5th, and 8th elements (starting at 0) + int i; + int a[10] = {1, 2, 3, 4, 5, 6, 7, 8, 9, 10}; + int b[10] = {0, 0, 0, 0, 0, 0, 0, 0, 0, 0}; + int blens[3] = {2, 1, 1}; + int disps[3] = {2, 5, 8}; + MPI_Datatype indexed_type; + + printf("\nIndexed: 2nd, 3rd, 5th, and 8th elements (0 base)\n"); + MPI_Type_indexed(3, blens, disps, MPI_INT, &indexed_type); + + print_typemap(indexed_type); + + copy_data(&a, &b, indexed_type); + + for (i = 0; i < 10; i++) + printf("%d ", b[i]); + printf("\n"); +} + +void structtests() +{ + int a[5] = {1, 2, 3, 4, 5}; + int b[5]; + + MPI_Datatype type, vector_type; + + //test contiguous + printf("\nContiguous type of 5 MPI_INT\n"); + MPI_Type_contiguous(5, MPI_INT, &type); + printf("Done.\n"); + fflush(stdout); + print_typemap(type); + copy_data(&a, &b, type); + printf("b = %d\n", a[4]); +} +*/ + +int main(int argc, char ** argv) +{ + char version[MPI_MAX_LIBRARY_VERSION_STRING]; + int vlen; + + MPI_Init(&argc, &argv); + + MPI_Get_library_version(version,&vlen); + printf("MPI version=\"%s\" (len=%d)\n",version,vlen); + +// structtests(); +// indexed_test(); +// struct_test(); + +// printf("\n\n---End of samples: Testing now---\n\n"); +#ifdef TEST_INTERNAL + printf("Using internal tests\n"); +#endif + test_simple_contig(); + test_simple_vector(); + test_simple_hvector(); + test_simple_indexed(); + test_simple_bindexed(); + test_simple_hindexed(); + test_simple_struct(); + test_complex_struct(); + test_indexed_struct(); + test_multiple(); + test_multiple_struct(); + test_packed(); + test_packed_complex(); + test_collectives(); + + MPI_Finalize(); + if (errcount) + printf("Found %d errors\n", errcount); + else + printf(">>>PASSED ALL TESTS. No errors. <<<\n"); + + return(errcount); +} + diff --git a/mpi-serial/tests/ctest_old.c b/mpi-serial/tests/ctest_old.c new file mode 100644 index 000000000000..e4ff3cb806f6 --- /dev/null +++ b/mpi-serial/tests/ctest_old.c @@ -0,0 +1,181 @@ + +#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]; + int i,j; + MPI_Comm comm2; + int flag; + MPI_Group mygroup; + char pname[MPI_MAX_PROCESSOR_NAME]; + int pnamelen; + + int position, temp; + int errcount = 0; + + 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 isend %d tag %d\n",sbuf[i],tag); + MPI_Isend(&sbuf[2*i],1,MPI_2INT,0,tag,MPI_COMM_WORLD,&sreq[i]); + } + + for (i=0; i < 5; i++) + { + if (sbuf[9-(2*i)] != rbuf[2*i+1] || sbuf[8-2*i] != rbuf[2*i]) + { + errcount++; + printf("Error for COMWORLD send\n"); + printf("buf[%d] = %d, rbuf= %d\n", i, sbuf[9-2*i], rbuf[2*i+1]); + printf("buf[%d] = %d, rbuf= %d\n", i, sbuf[8-2*i], rbuf[2*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]); + + if (rbuf2[i] != sbuf2[i]) + { + errcount++; + printf("Error for COM2 send %d\n", i); + printf("Found %d should be %d\n", rbuf2[i], sbuf2[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); + } + + for (i=0; i<5; i++) + { + if (sbuf[i] != rbuf[i]) + { + errcount++; + printf("Error for pack/send/unpack\n"); + printf("Found %d should be %d\n", rbuf[i], sbuf[i]); + } + } + + MPI_Finalize(); + + + for (i=0; i<5; i++) + { + printf("Time: %f\n",MPI_Wtime()); + sleep(1); + } + + + if (errcount) + printf("Finished with %d errors.\n", errcount); + else + printf("No errors\n"); +} + + + diff --git a/mpi-serial/tests/ftest.F90 b/mpi-serial/tests/ftest.F90 new file mode 100644 index 000000000000..b292b8b73cd9 --- /dev/null +++ b/mpi-serial/tests/ftest.F90 @@ -0,0 +1,680 @@ +#ifdef HAVE_CONFIG_H +#include +#endif + + program test + use mpi + implicit none + integer ierr + integer ec + character*(MPI_MAX_LIBRARY_VERSION_STRING) version + integer vlen + + ec = 0 +#ifdef TEST_INTERNAL + print *, "Using internal tests" +#endif + + call mpi_init(ierr) + + call MPI_GET_LIBRARY_VERSION(version,vlen,ierr) + print *,"MPI Version '",version,"' len=",vlen + + call test_contiguous(ec) + call test_vector(ec) + call test_simple_hvector(ec) + call test_simple_indexed(ec) + call test_simple_bindexed(ec) + call test_simple_hindexed(ec) + call test_complex_indexed(ec) + call test_packed(ec) + call test_multiple(ec) + call test_multiple_indexed(ec) + call test_collectives(ec) + + call mpi_finalize(ierr) + if (ec .eq. 0) then + print *, "PASSED ALL TESTS" + else + print *, "Errors:",ec + end if + stop + end + +!!!!!!!!!!!!!!!!!!! +! Contiguous type. Simplest example. Strings 5 +! integers together and tests their equality after +! a send operation +!!!!!!!!!!!!!!!!!!! + + subroutine test_contiguous(ec) + use mpi + integer ec + integer ierr + integer datatype + integer a(5) + integer b(5) + integer i + data a/1,2,3,4,5/ + data b/5 * 0/ + integer req + + print *, "Test Contiguous of 5 x MPI_INTEGER" + call mpi_type_contiguous(5, mpi_integer, datatype,ierr) + call mpi_type_commit(datatype, ierr) + +#ifdef TEST_INTERNAL + call copy_data2(a,1,datatype,b,1,datatype,ierr) +#else + call mpi_isend(a, 1, datatype, 0, 0, mpi_comm_world, req, ierr) + call mpi_irecv(b, 1, datatype, mpi_any_source, mpi_any_tag, & + mpi_comm_world, req, ierr) +#endif + + do i=1,5 + if (a(i) .ne. b(i)) then + print *,">>>FAILED: mpi_type_contiguous" + ec = ec+1 + return + end if + end do + + end + +!!!!!!!!!!!!!!!!!!!!!!!! +! Vector type. collect a series of indices with +! set stride from an array. +!!!!!!!!!!!!!!!!!!!!!!!! + + subroutine test_vector(ec) + use mpi + integer ec + integer ierr + integer datatype + integer a(10) != (1,2,3,4,5,6,7,8,9,0) + integer b(10) + integer check_index(6) + data a/1,2,3,4,5,6,7,8,9,10/ + data b/10 * 0/ + data check_index/1,2,4,5,7,8/ + integer i + integer req + + print *, "Test vector of MPI_INTEGER" + + call mpi_type_vector(3, 2, 3, mpi_integer, datatype, ierr) + call mpi_type_commit(datatype, ierr) +#ifdef TEST_INTERNAL + call copy_data2(a,1,datatype,b,1,datatype,ierr) +#else + call mpi_isend(a, 1, datatype, 0, 0, mpi_comm_world, req, ierr) + call mpi_irecv(b, 1, datatype, mpi_any_source, mpi_any_tag, & + mpi_comm_world, req, ierr) +#endif + do i=1,6 + if (a(check_index(i)) .ne. b(check_index(i))) then + print *,">>>FAILED: mpi_type_vector" + ec = ec+1 + return + end if + end do + end + +!!!!!!!!!!!!!!!!!!!!! +! Byte-addressed vector. +! values calculated with mpi_type_extent(), +! so basically we are doing the work here in the +! test program instead of in the library +!!!!!!!!!!!!!!!!!!!!! + + subroutine test_simple_hvector(ec) + use mpi + integer ec + integer vector_type + integer (kind=mpi_address_kind) extent + integer i + integer a(10) + integer b(10) + integer index_test(6) + integer ierr + integer req + + data a/1,2,3,4,5,6,7,8,9,10/, b/0,0,0,0,0,0,0,0,0,0/ + data index_test/1,2,5,6,9,10/ + + print *, "Vector type with stride 4 in bytes" + + call mpi_type_extent(mpi_integer, extent, ierr) + call mpi_type_hvector(3, 2, 4 * extent, mpi_integer, & + vector_type, ierr) + call mpi_type_commit(vector_type, ierr) +#ifdef TEST_INTERNAL + call copy_data2(a,1,vector_type, b,1,vector_type, ierr) +#else + call mpi_isend(a, 1, vector_type, 0, 0, mpi_comm_world,req,ierr) + call mpi_irecv(b, 1, vector_type, mpi_any_source, mpi_any_tag, & + mpi_comm_world, req, ierr) +#endif + do i=1,6 + if (a(index_test(i)) .ne. (b(index_test(i)))) then + print *, ">>>FAILED: test_simple_hvector" + ec = ec+1 + return + end if + end do + end subroutine + +!!!!!!!!!!!!!!!!!!!! +! indexed type. test certain indices of an array +!!!!!!!!!!!!!!!!!!!! + + subroutine test_simple_indexed(ec) + use mpi + integer ec + integer i + double complex a(15) + double complex b(15) + integer index_test(6) + integer blens(3) + integer disps(3) + integer indexed_type + integer ierr + integer req + + data a/1,2,3,4,5,6,7,8,9,10,11,12,13,14,15/ + data b/0,0,0,0,0,0,0,0,0,0,0,0,0,0,0/ + data index_test/1,6,7,11,12,13/ + data blens/2,1,3/ + data disps/5,0,10/ + print *, "Indexed type" + + call mpi_type_indexed(3, blens, disps, mpi_double_complex, & + indexed_type, ierr) + call mpi_type_commit(indexed_type, ierr) +#ifdef TEST_INTERNAL + call copy_data2(a,1,indexed_type,b,1,indexed_type,ierr) +#else + call mpi_isend(a, 1, indexed_type,0, 0, mpi_comm_world,req,ierr) + call mpi_irecv(b, 1, indexed_type, mpi_any_source, mpi_any_tag,& + mpi_comm_world, req, ierr) +#endif + + do i=1,6 + if (a(index_test(i)) .ne. b(index_test(i))) then + print *, ">>>FAILED: test_simple_indexed" + ec = ec+1 + return + end if + end do + end subroutine + +!!!!!!!!!!!!!!!! +! Block indexed. All blocks have same length +!!!!!!!!!!!!!!!! + + subroutine test_simple_bindexed(ec) + use mpi + integer ec + integer i + integer disps(3) + integer a(10), b(10) + integer index_test(6) + integer indexed_type + integer ierr + integer req + + data disps/0,4,7/ + data a/1,2,3,4,5,6,7,8,9,10/ + data b/0,0,0,0,0,0,0,0,0,0/ + data index_test/1,2,5,6,8,9/ + print *, "Block indexed type" + + call mpi_type_create_indexed_block(3,2,disps,mpi_integer, & + indexed_type, ierr) + call mpi_type_commit(indexed_type, ierr) +#ifdef TEST_INTERNAL + call copy_data2(a,1,indexed_type, b,1,indexed_type, ierr) +#else + call mpi_isend(a, 1, indexed_type,0, 0, mpi_comm_world,req,ierr) + call mpi_irecv(b, 1, indexed_type,mpi_any_source,mpi_any_tag, & + mpi_comm_world, req, ierr) +#endif + do i=1,6 + if (a(index_test(i)) .ne. b(index_test(i))) then + print *, ">>>FAILED:test_simple_bindexed" + ec = ec+1 + return + end if + end do + end subroutine + +!!!!!!!!!!!!!!!! +! test_simple_hindexed +! test equality of a byte-addressed +! type of integer array +! (disps calculated through mpi_type_extent() +!!!!!!!!!!!!!!! + subroutine test_simple_hindexed(ec) + use mpi + integer ec + integer i + integer a(10), b(10) + integer index_test(6) + integer blens(3) + integer(kind=mpi_address_kind) disps(3) + integer indexed_type + integer(kind=mpi_address_kind) extent + integer ierr + integer req + integer (kind=mpi_address_kind) addr, baddr + + data a/1,2,3,4,5,6,7,8,9,10/ + data b/0,0,0,0,0,0,0,0,0,0/ + data index_test/1,3,4,6,7,8/ + data blens/2,1,3/ + + call mpi_address(a(1), baddr,ierr) + call mpi_address(a(3), addr ,ierr) + disps(1) = addr - baddr + call mpi_address(a(6), addr, ierr) + disps(3) = addr - baddr +! call mpi_type_extent(mpi_integer, extent, ierr) +! disps(1) = 2*extent + disps(2) = 0 +! disps(3) = 5*extent + + + print *, "Byte addressed indexed type" + call mpi_type_hindexed(3,blens,disps, MPI_INTEGER, & + indexed_type,ierr) + call mpi_type_commit(indexed_type, ierr) +#ifdef TEST_INTERNAL + call copy_data2(a,1,indexed_type, b,1,indexed_type, ierr) +#else + call mpi_isend(a, 1, indexed_type,0, 0, mpi_comm_world,req,ierr) + call mpi_irecv(b, 1, indexed_type,mpi_any_source,mpi_any_tag, & + mpi_comm_world,req,ierr) +#endif + do i=1,6 + if (a(index_test(i)) .ne. b(index_test(i))) then + print *, ">>>FAILED: test_simple_hindexed" + ec = ec+1 + return + end if + end do + end subroutine + + subroutine test_complex_indexed(ec) + use mpi + integer ec + integer i + double precision a(72), b(72) + integer disps(3), blens(3) + integer cdisps(2), cblens(2) + integer index_test(8), cindex_test(3) + integer ierr + integer req + integer indexed_type, complex_indexed + + data blens/3,1,4/ + data disps/0,5,8/ + data cindex_test/1,4,5/ + data index_test/1,2,3, 6, 9,10,11,12/ + + data a/1, 2, 3, 4, 5, 6, 7, 8, 9,10,11,12,13,14,15, & + 16,17,18,19,20,21,22,23,24,25,26,27,28,29,30, & + 31,32,33,34,35,36,37,38,39,40,41,42,43,44,45, & + 46,47,48,49,50,51,52,53,54,55,56,57,58,59,60, & + 61,62,63,64,65,66,67,68,69,70,71,72/ + data b/0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, & + 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, & + 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, & + 0,0,0,0,0,0,0,0,0,0,0,0/ + + call mpi_type_indexed(3,blens,disps, MPI_DOUBLE_PRECISION, & + indexed_type, ierr) + call mpi_type_commit(indexed_type, ierr) + + data cblens/1, 2/ + data cdisps/1, 4/ + call mpi_type_indexed(2,cblens,cdisps,indexed_type, & + complex_indexed, ierr) + call mpi_type_commit(complex_indexed, ierr) +#ifdef TEST_INTERNAL + call copy_data2(a,1,complex_indexed,b,1,complex_indexed,ierr) +#else + call mpi_isend(a,1,complex_indexed,0,0,mpi_comm_world,req,ierr) + call mpi_irecv(b,1,complex_indexed,mpi_any_source,mpi_any_tag,& + mpi_comm_world, req, ierr) +#endif + do i=1,3 + do j=1,8 + if (a(index_test(j)+12*cindex_test(i)) .ne. & + b(index_test(j)+12*cindex_test(i))) then + print *, ">>>FAILED: test_complex_indexed" + print *, "index ",index_test(j)+12*cindex_test(i) + print *, "Found:",b(index_test(j)+12*cindex_test(i)) + print *, "Should be:",a(index_test(j)+12*cindex_test(i)) + ec = ec+1 + end if + end do + end do + + call mpi_type_free(complex_indexed, ierr) + call mpi_type_free(indexed_type, ierr) + end subroutine +!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! test_packed() +! Creates a few variable pairs, assigns the first +! of each pair, then packs their values and unpacks +! them to the other set. +!!!!!!!!!!!!!!!!!!!!!!!!!!!! + subroutine test_packed(ec) + use mpi + integer ec + integer size + integer x, y + real f, g + complex c, d + character*5 a, b + character buf(100), rbuf(100) + integer blens(3) + integer(kind=mpi_address_kind) disps(3) + integer pos + integer req + + x = 10 + f = 14.333 + c = (100, 20) + a = "xyzab" + + pos = 0 + data blens/1,2,1/, disps/0,4,8/ + + print *, "Packed type " + + call mpi_pack(x, 1, mpi_integer, buf, 100, pos, 0, ierr) + call mpi_pack(f, 1, mpi_real, buf, 100, pos, 0, ierr) + call mpi_pack(c, 1, mpi_complex, buf, 100, pos, 0, ierr) + call mpi_pack(a, 5, mpi_character, buf, 100, pos, 0, ierr) +#ifdef TEST_INTERNAL + call copy_data2(buf, pos, mpi_packed, rbuf, pos, & + mpi_packed, ierr) +#else + call mpi_isend(buf, pos, mpi_packed,0,0,mpi_comm_world,req,ierr) + call mpi_irecv(rbuf, pos, mpi_packed,mpi_any_source,mpi_any_tag& + ,mpi_comm_world, req, ierr) +#endif + pos = 0; + + call mpi_unpack(rbuf, 100, pos, y, 1, mpi_integer, 0, ierr) + call mpi_unpack(rbuf, 100, pos, g, 1, mpi_real, 0, ierr) + call mpi_unpack(rbuf, 100, pos, d, 1, mpi_complex, 0, ierr) + call mpi_unpack(rbuf, 100, pos, b, 5, mpi_character, & + 0, ierr) + + if (x .ne. y .OR. f .ne. g & + .OR. c .ne. d .OR. a .ne. b) & + then + print *, ">>>FAILED: mpi_pack" + ec = ec+1 + return + end if + + end subroutine + + subroutine test_multiple(ec) + use mpi + integer ec + integer i + complex a(10) + complex b(10) + integer contig_type + integer ierr + integer req + + data a/1,2,3,4,5,6,7,8,9,10/ + data b/0,0,0,0,0,0,0,0,0,0/ + print *, "Contig type send, multiple receive" + + call mpi_type_contiguous(10, mpi_complex, contig_type, ierr) + call mpi_type_commit(contig_type, ierr) +#ifdef TEST_INTERNAL + call copy_data2(a,1,contig_type, b,10, mpi_complex, ierr) +#else + call mpi_isend(a, 1, contig_type,0,0,mpi_comm_world,req,ierr) + call mpi_irecv(b, 10, mpi_complex,mpi_any_source,mpi_any_tag, & + mpi_comm_world,req,ierr) +#endif + + do i=1,10 + if (a(i) .ne. b(i)) then + print *, ">>>FAILED: test_multiple" + ec = ec+1 + return + end if + end do + end subroutine + +!!!!!!!!!!!!!!!!!!!!!!!!! +! Test an indexed send with a multiple receive +!!!!!!!!!!!!!!!!!!!!!!!!! + subroutine test_multiple_indexed(ec) + use mpi + integer ec + integer i,j + complex a(75) + complex b(75) + integer index_test(6) + integer blens(3) + integer disps(3) + integer indexed_type,contig_indexed + integer ierr + integer req + + data a/ 1, 2, 3, 4, 5, 6, 7, 8, 9,10,11,12,13,14,15,& + 16,17,18,19,20,21,22,23,24,25,26,27,28,29,30,& + 31,32,33,34,35,36,37,38,39,40,41,42,43,44,45,& + 46,47,48,49,50,51,52,53,54,55,56,57,58,59,60,& + 61,62,63,64,65,66,67,68,69,70,71,72,73,74,75/ + data b/75*0/ + data index_test/1,6,7,11,12,13/ + data blens/1,2,3/ + data disps/0,5,10/ + print *, "Indexed type send, multiple indexed receive" + + call mpi_type_indexed(3, blens, disps, mpi_complex, & + indexed_type, ierr) + call mpi_type_commit(indexed_type, ierr) + + call mpi_type_contiguous(5, indexed_type, contig_indexed,ierr) + call mpi_type_commit(contig_indexed, ierr) +#ifdef TEST_INTERNAL + call copy_data2(a,1,contig_indexed,b,5,indexed_type,ierr) +#else + call mpi_isend(a, 1, contig_indexed,0,0,mpi_comm_world,req,ierr) + call mpi_irecv(b, 5, indexed_type,mpi_any_source,mpi_any_tag, & + mpi_comm_world,req,ierr) +#endif + do i=0,4 + do j=1,6 + if (a(index_test(j)+(13*i)) .ne. b(index_test(j)+(13*i))) then + print *, ">>>FAILED: test_multiple_indexed" + print *, " Found:",a(index_test(j)+13*i) + print *, " Expected:",b(index_test(j)+13*i) + ec = ec+1 +! return + end if + end do + end do + end subroutine + + subroutine test_collectives(ec) + use mpi + integer ec + integer i + integer a(10) + integer b(10) + integer disps(3) + integer blens(3) + integer itype + integer ierr + integer scount + integer rcount + integer disp + integer index_test(7) + + data scount/1/rcount/1/disp/0/ + data disps/0,5,8/ + data blens/4,2,1/ + data a/1,2,3,4,5,6,7,8,9,10/ + data b/10*0/ + data index_test/1,2,3,4,6,7,9/ + + call mpi_type_indexed(3, blens, disps, MPI_LOGICAL,& + itype, ierr) + call mpi_type_commit(itype, ierr) + + call mpi_bcast(a, scount, itype, 0, & + mpi_comm_world, ierr) + call mpi_gather(a,scount, itype, b, rcount, & + itype, 0, mpi_comm_world, ierr) + print *, "Testing mpi_gather" + do i=1,7 + if (a(index_test(i)) .ne. b(index_test(i))) then + print *, "mpi_gather failed" + ec=ec+1 + end if + end do + do i=1,10 + b(i) = 0 + end do + print *, "Testing mpi_gatherv" + call mpi_gatherv(a, scount, itype, b, rcount, & + disp, itype, 0, mpi_comm_world, ierr) + do i=1,7 + if (a(index_test(i)) .ne. b(index_test(i))) then + print *, "mpi_gatherv failed" + ec=ec+1 + end if + end do + do i=1,10 + b(i) = 0 + end do + print *, "Testing mpi_allgather" + call mpi_allgather(a, scount, itype, b, rcount, & + itype, mpi_comm_world, ierr) + do i=1,7 + if (a(index_test(i)) .ne. b(index_test(i))) then + print *, "mpi_allgather failed" + ec=ec+1 + end if + end do + print *, "Testing mpi_allgatherv" + call mpi_allgatherv(a, scount, itype, b, rcount, & + disp, itype, mpi_comm_world, ierr) + do i=1,7 + if (a(index_test(i)) .ne. b(index_test(i))) then + print *, "mpi_allgatherv failed" + ec=ec+1 + end if + end do + do i=1,10 + b(i) = 0 + end do + print *, "Testing mpi_scatter" + call mpi_scatter(a, scount, itype, b, rcount, & + itype, 0, mpi_comm_world, ierr) + do i=1,7 + if (a(index_test(i)) .ne. b(index_test(i))) then + print *, "mpi_scatter failed" + ec=ec+1 + end if + end do + do i=1,10 + b(i) = 0 + end do + print *, "Testing mpi_scatterv" + call mpi_scatterv(a, scount, disp, itype, b, & + rcount, itype, 0, mpi_comm_world, ierr) + do i=1,7 + if (a(index_test(i)) .ne. b(index_test(i))) then + print *, "mpi_scatterv failed" + ec=ec+1 + end if + end do + do i=1,10 + b(i) = 0 + end do + print *, "Testing mpi_reduce" + call mpi_reduce(a, b, scount, itype, mpi_max, & + 0, mpi_comm_world, ierr) + do i=1,7 + if (a(index_test(i)) .ne. b(index_test(i))) then + print *, "mpi_reduce failed" + ec=ec+1 + end if + end do + do i=1,10 + b(i) = 0 + end do + print *, "Testing mpi_allreduce" + call mpi_allreduce(a, b, scount, itype, mpi_max, & + mpi_comm_world, ierr) + do i=1,7 + if (a(index_test(i)) .ne. b(index_test(i))) then + print *, "mpi_allreduce failed" + ec=ec+1 + end if + end do + do i=1,10 + b(i) = 0 + end do + print *, "Testing mpi_alltoall" + call mpi_alltoall(a, scount, itype, b, rcount, & + itype, mpi_comm_world, ierr) + do i=1,7 + if (a(index_test(i)) .ne. b(index_test(i))) then + print *, "mpi_alltoall failed" + ec=ec+1 + end if + end do + do i=1,10 + b(i) = 0 + end do + print *, "Testing mpi_alltoallv" + call mpi_alltoallv(a, scount, disp, itype, b, & + rcount, disp, itype, mpi_comm_world, ierr) + do i=1,7 + if (a(index_test(i)) .ne. b(index_test(i))) then + print *, "mpi_alltoallv failed" + ec=ec+1 + end if + end do + do i=1,10 + b(i) = 0 + end do + print *, "Testing mpi_reduce_scatter" + call mpi_reduce_scatter(a, b, rcount, itype, & + mpi_max, mpi_comm_world, ierr) + do i=1,7 + if (a(index_test(i)) .ne. b(index_test(i))) then + print *, "mpi_reduce_scatter failed" + ec=ec+1 + end if + end do + do i=1,10 + b(i) = 0 + end do + print *, "Testing mpi_scan" + call mpi_scan(a, b, scount, itype, mpi_max, & + mpi_comm_world, ierr) + + do i=1,7 + if (a(index_test(i)) .ne. b(index_test(i))) then + print *, "mpi_scan failed" + ec=ec+1 + end if + end do + end subroutine + diff --git a/mpi-serial/tests/ftest_internal.F90 b/mpi-serial/tests/ftest_internal.F90 new file mode 100644 index 000000000000..9e1f6a676c63 --- /dev/null +++ b/mpi-serial/tests/ftest_internal.F90 @@ -0,0 +1,328 @@ + program test + use mpi + implicit none + + call test_contiguous() + call test_vector() + call test_simple_hvector() + call test_simple_indexed() + call test_simple_bindexed() + call test_simple_hindexed() + call test_packed() + call test_multiple() + stop + end + +!!!!!!!!!!!!!!!!!!! +! Contiguous type. Simplest example. Strings 5 +! integers together and tests their equality after +! a send operation +!!!!!!!!!!!!!!!!!!! + + subroutine test_contiguous() + use mpi + integer ierr + integer datatype + integer a(5) + integer b(5) + integer i + data a/1,2,3,4,5/ + data b/5 * 0/ + + print *, "Test Contiguous of 5 x MPI_INTEGER" + call mpi_type_contiguous(5, mpi_integer, datatype,ierr) + + call mpi_type_commit(datatype, ierr) + + call print_typemap(datatype,ierr) + call copy_data2(a,1,datatype, b,1,datatype, ierr) + + do i=1,5 + if (a(i) .ne. b(i)) then + print *,">>>FAILED: mpi_type_contiguous" + stop + end if + end do + print *, ">>>PASSED: mpi_type_contiguous" + end + +!!!!!!!!!!!!!!!!!!!!!!!! +! Vector type. collect a series of indices with +! set stride from an array. +!!!!!!!!!!!!!!!!!!!!!!!! + + subroutine test_vector() + use mpi + integer ierr + integer datatype + integer a(10) != (1,2,3,4,5,6,7,8,9,0) + integer b(10) + integer check_index(6) + data a/1,2,3,4,5,6,7,8,9,10/ + data b/10 * 0/ + data check_index/1,2,4,5,7,8/ + integer i + + print *, "Test vector of MPI_INTEGER" + + call mpi_type_vector(3, 2, 3, mpi_integer, datatype, ierr) + call mpi_type_commit(datatype, ierr) + call print_typemap(datatype,ierr) + call copy_data2(a,1,datatype,b,1,datatype,ierr) + + do i=1,6 + if (a(check_index(i)) .ne. b(check_index(i))) then + print *,">>>FAILED: mpi_type_vector" + stop + end if + end do + print *, ">>>PASSED: mpi_type_vector" + end + +!!!!!!!!!!!!!!!!!!!!! +! Byte-addressed vector. +! values calculated with mpi_type_extent(), +! so basically we are doing the work here in the +! test program instead of in the library +!!!!!!!!!!!!!!!!!!!!! + + subroutine test_simple_hvector() + use mpi + integer vector_type + integer (kind=mpi_address_kind) extent + integer i + integer a(10) + integer b(10) + integer index_test(6) + integer ierr + + data a/1,2,3,4,5,6,7,8,9,10/, b/0,0,0,0,0,0,0,0,0,0/ + data index_test/1,2,5,6,9,10/ + + print *, "Vector type of 3 groups of 2 MPI_INTEGER" + print *, "Stride of 4 (in bytes)" + + call mpi_type_extent(mpi_integer, extent, ierr) + call mpi_type_hvector(3, 2, 4 * extent, mpi_integer, & + vector_type, ierr) + call mpi_type_commit(vector_type, ierr) + call print_typemap(vector_type,ierr) + call copy_data2(a,1,vector_type, b,1,vector_type,ierr) + + do i=1,7 + if (a(index_test(i)) .ne. (b(index_test(i)))) then + print *, ">>>FAILED: test_simple_hvector" + stop + end if + end do + print *, ">>>PASSED: test_simple_hvector" + end subroutine + +!!!!!!!!!!!!!!!!!!!! +! indexed type. test certain indices of an array +!!!!!!!!!!!!!!!!!!!! + + subroutine test_simple_indexed() + use mpi + integer i + complex a(15) + complex b(15) + integer index_test(6) + integer blens(3) + integer disps(3) + integer indexed_type + integer ierr + + data a/1,2,3,4,5,6,7,8,9,10,11,12,13,14,15/ + data b/0,0,0,0,0,0,0,0,0,0,0,0,0,0,0/ + data index_test/1,6,7,11,12,13/ + data blens/2,1,3/ + data disps/5,0,10/ + print *, "Indexed type" + + call mpi_type_indexed(3, blens, disps, mpi_complex, & + indexed_type, ierr) + call mpi_type_commit(indexed_type, ierr) + call print_typemap(indexed_type, ierr) + call copy_data2(a,1,indexed_type, b,1,indexed_type,ierr) + + do i=1,6 + if (a(index_test(i)) .ne. b(index_test(i))) then + print *, ">>>FAILED: test_simple_indexed" + stop + end if + end do + print *, ">>>PASSED: test_simple_indexed" + end subroutine + +!!!!!!!!!!!!!!!! +! Block indexed. All blocks have same length +!!!!!!!!!!!!!!!! + + subroutine test_simple_bindexed() + use mpi + integer i + integer disps(3) + integer a(10), b(10) + integer index_test(6) + integer indexed_type + integer ierr + + data disps/0,4,7/ + data a/1,2,3,4,5,6,7,8,9,10/ + data b/0,0,0,0,0,0,0,0,0,0/ + data index_test/1,2,5,6,8,9/ + print *, "Block indexed type" + + call mpi_type_indexed_block(3,2,disps,mpi_integer, & + indexed_type, ierr) + + call mpi_type_commit(indexed_type, ierr) + call print_typemap(indexed_type, ierr) + call copy_data2(a,1,indexed_type, b,1,indexed_type, ierr) + + do i=1,6 + if (a(index_test(i)) .ne. b(index_test(i))) then + print *, ">>>FAILED: test_simple_bindexed" + stop + end if + end do + print *, ">>>PASSED: test_simple_bindexed" + end subroutine + +!!!!!!!!!!!!!!!! +! test_simple_indexed +! test equality of a byte-addressed +! type of integer array +! (disps calculated through mpi_type_extent() +!!!!!!!!!!!!!!! + subroutine test_simple_hindexed() + use mpi + integer i + integer a(10), b(10) + integer index_test(6) + integer blens(3) + integer*8 disps(3) + integer indexed_type + integer*8 extent + integer ierr + + data a/1,2,3,4,5,6,7,8,9,10/ + data b/0,0,0,0,0,0,0,0,0,0/ + data index_test/1,3,4,6,7,8/ + data blens/2,1,3/ + + call mpi_type_extent(mpi_integer, extent, ierr) + disps(1) = 2*extent + disps(2) = 0 + disps(3) = 5*extent + + + print *, "Byte addressed indexed type" + call mpi_type_hindexed(3,blens,disps, MPI_INTEGER, & + indexed_type,ierr) + call mpi_type_commit(indexed_type, ierr) + call print_typemap(indexed_type, ierr) + call copy_data2(a,1,indexed_type, b,1,indexed_type, ierr) + + do i=1,6 + if (a(index_test(i)) .ne. b(index_test(i))) then + print *, ">>>FAILED: test_simple_hindexed" + stop + end if + end do + print *, ">>>PASSED: test_simple_hindexed" + end subroutine + +!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! test_packed() +! Creates a few variable pairs, assigns the first +! of each pair, then packs their values and unpacks +! them to the other set. +!!!!!!!!!!!!!!!!!!!!!!!!!!!! + subroutine test_packed() + use mpi + integer size + integer x, y + real f, g + complex c, d + character*5 a, b + character buf(100), rbuf(100) + integer blens(3) + integer(kind=mpi_address_kind) disps(3) + integer pos + + + x = 10 + f = 14.333 + c = (100, 20) + a = "xyzab" + + pos = 0 + data blens/1,2,1/, disps/0,4,8/ + + print *, "Packed type " + + call mpi_pack(x, 1, mpi_integer, buf, 100, pos, 0, ierr) + call mpi_pack(f, 1, mpi_real, buf, 100, pos, 0, ierr) + call mpi_pack(c, 1, mpi_complex, buf, 100, pos, 0, ierr) + call mpi_pack(a, 5, mpi_character, buf, 100, pos, 0, ierr) + + call copy_data2(buf, pos, mpi_packed, rbuf, pos, & + mpi_packed, ierr) + + pos = 0; + + call mpi_unpack(rbuf, 100, pos, y, 1, mpi_integer, 0, ierr) + call mpi_unpack(rbuf, 100, pos, g, 1, mpi_real, 0, ierr) + call mpi_unpack(rbuf, 100, pos, d, 1, mpi_complex, 0, ierr) + call mpi_unpack(rbuf, 100, pos, b, 5, mpi_character, & + 0, ierr) + + if (x .ne. y .OR. f .ne. g & + .OR. c .ne. d .OR. a .ne. b) & + then + print *, ">>>FAILED: mpi_pack" + stop + end if + + print *, ">>>PASSED: mpi_pack" + + end subroutine + +!!!!!!!!!!!!!!!!!!!!!!!!! +! Test an indexed send with a multiple receive +!!!!!!!!!!!!!!!!!!!!!!!!! + + subroutine test_multiple() + use mpi + integer i + complex a(15) + complex b(15) + integer index_test(6) + integer blens(3) + integer disps(3) + integer indexed_type + integer ierr + + data a/1,2,3,4,5,6,7,8,9,10,11,12,13,14,15/ + data b/0,0,0,0,0,0,0,0,0,0,0,0,0,0,0/ + data index_test/1,6,7,11,12,13/ + data blens/1,2,3/ + data disps/0,5,10/ + print *, "Indexed type" + + call mpi_type_indexed(3, blens, disps, mpi_complex, & + indexed_type, ierr) + call mpi_type_commit(indexed_type, ierr) + call copy_data2(a,1,indexed_type, b,6, mpi_complex, ierr) + + do i=1,6 + if (a(index_test(i)) .ne. b(i)) then + print *, ">>>FAILED: test_multiple" + stop + end if + end do + print *, ">>>PASSED: test_multiple" + end subroutine + diff --git a/mpi-serial/tests/ftest_old.F90 b/mpi-serial/tests/ftest_old.F90 new file mode 100644 index 000000000000..938d4472a94c --- /dev/null +++ b/mpi-serial/tests/ftest_old.F90 @@ -0,0 +1,165 @@ + + 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 + integer errcount + + errcount = 0 + + 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 + + do i=1,5 + if (sbuf(i) .ne. rbuf(i)) then + errcount = errcount+1 + print *, 'error on Send2' + print *, 'found ',sbuf2(i),' should be ',rbuf2(i) + end if + end do + + do i=1,5 + if (sbuf2(i) .ne. rbuf2(i)) then + errcount = errcount+1 + print *, 'error on Send2' + print *, 'found ',sbuf2(i),' should be ',rbuf2(i) + end if + 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) + print *,temp + end do + + do i=1,5 + if (rbuf(i) .ne. sbuf(i)) then + errcount = errcount + 1 + print *,"Error for pack/send/unpack" + print *,"found ",rbuf(i)," should be ",sbuf(i) + end if + end do +! + + + call mpi_finalize(ier) + + do i=1,5 + print *, 'Time=',mpi_wtime() + call sleep(1) + end do + + if (errcount .gt. 0) then + print *,errcount," errors" + else + print *,"No errors" + end if + + end + diff --git a/mpi-serial/time.c b/mpi-serial/time.c new file mode 100644 index 000000000000..6170009e17d8 --- /dev/null +++ b/mpi-serial/time.c @@ -0,0 +1,35 @@ + +#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/mpi-serial/type.c b/mpi-serial/type.c new file mode 100644 index 000000000000..8dd93f274148 --- /dev/null +++ b/mpi-serial/type.c @@ -0,0 +1,846 @@ +/* + * JCY + * 07/2007 + * Derived Datatype functions for mpi-serial + */ + +#include "type.h" +#include "mpiP.h" +#include +#include +#include + +#ifdef HAVE_CONFIG_H +#include +#endif + +/* + * NOTES: All MPI_ prefixed (public) functions operate + * using the integer handle for a datatype. Most of these + * functions are wrapper functions for a different function, + * _not_ prefixed with MPI_. These functions translate the + * handle to a pointer and call the non-MPI_ func. + * + * Fortran bindings use FC_FUNC, as defined in mpiP.h. + */ + + +/* + * Wrapper for mpi_handle_to_ptr in handles.c + * specific for datatype handles, which may be + * predefined negative handles + */ +Datatype* mpi_handle_to_datatype(int handle) +{ + if (handle < 0) + return (Datatype*) &simpletypes[-1-handle]; + else + return (Datatype*) mpi_handle_to_ptr(handle); +} + +/* + * Calculate the epsilon value of typemap + * using the largest element in the typemap + */ + +int calc_padding(Datatype datatype) +{ + long size_max = INT_MIN; + long type_len; + int i; + //find the largest datatype size. The epsilon padding is (probably) based on this. + + for (i = 0; i < datatype->count; i++) + { + type_len = Simpletype_length(datatype->pairs[i].type); + size_max = type_len > size_max ? type_len : size_max; + } + + return size_max; +} + +/* Retrieve size of any simple type + * C sizes use sizeof the literal type + * they represent. Fortran types are those + * as defined in type.h + */ + +int Simpletype_length(Simpletype t) +{ + switch(t) + { + case SIMPLE_CHAR: + return sizeof(char); break; + case SIMPLE_SHORT: + return sizeof(short); break; + case SIMPLE_INT: + return sizeof(int); break; + case SIMPLE_LONG: + return sizeof(long); break; + case SIMPLE_UCHAR: + return sizeof(unsigned char); break; + case SIMPLE_USHORT: + return sizeof(unsigned short); break; + case SIMPLE_UINT: + return sizeof(unsigned int); break; + case SIMPLE_ULONG: + return sizeof(unsigned long); break; + case SIMPLE_FLOAT: + return sizeof(float); break; + case SIMPLE_DOUBLE: + return sizeof(double); break; + case SIMPLE_LDOUBLE: + return sizeof(long double); break; + case SIMPLE_BYTE: + return sizeof(char); break; + case SIMPLE_FINTEGER: + return FSIZE_INTEGER; break; + case SIMPLE_FREAL: + return FSIZE_REAL; break; + case SIMPLE_FDPRECISION: + return FSIZE_DPRECISION; break; + case SIMPLE_FCOMPLEX: + return FSIZE_COMPLEX; break; + case SIMPLE_FDCOMPLEX: + return FSIZE_DCOMPLEX; break; + case SIMPLE_FLOGICAL: + return FSIZE_LOGICAL; break; + case SIMPLE_FCHARACTER: + return FSIZE_CHARACTER; break; + case SIMPLE_FINTEGER1: + return 1; break; + case SIMPLE_FINTEGER2: + return 2; break; + case SIMPLE_FINTEGER4: + return 4; break; + case SIMPLE_FINTEGER8: + return 8; break; + case SIMPLE_FREAL4: + return 4; break; + case SIMPLE_FREAL8: + return 8; break; + case SIMPLE_FREAL16: + return 16; break; + case SIMPLE_FCOMPLEX8: + return 8; break; + case SIMPLE_FCOMPLEX16: + return 16; break; + case SIMPLE_FCOMPLEX32: + return 32; break; + case SIMPLE_LONGLONG: + return sizeof(long long); break; + case SIMPLE_ULONGLONG: + return sizeof(unsigned long long); break; + case SIMPLE_OFFSET: + return sizeof(MPI_Offset); break; + + default: + printf("Invalid simple type\n"); + exit(1); + } +} + +/* + * calculates the lower bound of a datatype using typemap + * (This gives no regard to MPI_LB, but rather uses only displacements) + */ +long calc_lb(Datatype type) +{ + int i; + int min_disp = INT_MAX; + typepair * tp; + + for(i =0; i < type->count; i++) + { + tp = type->pairs+i; + min_disp = tp->disp < min_disp + ? tp->disp + : min_disp; + } + return min_disp; +} + +/* + * Calculate upper bound using typemap + * (Gives no regard to MPI_UB, just calculates + * highest displacement+size of its respective data type) + */ +long calc_ub(Datatype type) +{ + int i; + long max_disp = INT_MIN; + typepair * tp; + + for(i = 0; i < type->count; i++) + { + tp = type->pairs+i; + max_disp = tp->disp + Simpletype_length(tp->type) > max_disp + ? tp->disp + Simpletype_length(tp->type) + : max_disp; + } + + return max_disp; +} + + +/*******************************************************/ +/* MPI_Type_struct is the most general type constructor that + * does the common work other constructors. + * All other type constructors call this function. + */ + +FC_FUNC( mpi_type_struct, MPI_TYPE_STRUCT ) + (int * count, int * blocklens, long * displacements, + int *oldtypes_ptr, int *newtype, int *ierror) +{ + *ierror=MPI_Type_struct(*count, blocklens, displacements, + oldtypes_ptr, newtype); +} + +/* Public function, wrapper for Type_struct that translates handle to + * pointer (see NOTES at top of file) + */ +int MPI_Type_struct(int count, int * blocklens, MPI_Aint * displacements, + MPI_Datatype *oldtypes, MPI_Datatype *newtype) +{ + int i; + Datatype oldtypes_ptr[count]; + Datatype * newtype_ptr; + + for (i = 0; i < count; i++) + { + oldtypes_ptr[i] = *(Datatype*) mpi_handle_to_datatype(oldtypes[i]); + } + + mpi_alloc_handle(newtype, (void**) &newtype_ptr); + + return Type_struct(count, blocklens, displacements, + oldtypes_ptr, newtype_ptr); +} + +int Type_struct(int count, int * blocklens, MPI_Aint * displacements, + Datatype *oldtypes_ptr, Datatype *newtype) +{ + int i, j, k; + Datatype temp, temp2; + int newcount; + char override_lower = 0, //whether to override + override_upper = 0; + MPI_Aint new_lb = LONG_MAX, + new_ub = LONG_MIN, + clb, cub; //calculated lb and ub + int simpletype_count = 0; //total additional blocks for malloc + MPI_Aint tmp_offset; //for contiguous blocks of type + MPI_Aint extent; + + // find the total number of elements in the typemap we need to add. + for (i = 0; i < count; i++) + { + //check for MPI_UB or MPI_LB. These types are special + // cases and will be skipped over + + temp2 = oldtypes_ptr[i]; + if (temp2->pairs[0].type == SIMPLE_LOWER) + { + //found MPI_LB. This is a candidate for the actual lb + if (new_lb > displacements[i]) + new_lb = displacements[i]; + override_lower = 1; + } + else if (temp2->pairs[0].type == SIMPLE_UPPER) + { + //same as above, but ub + if (new_ub < displacements[i]) + new_ub = displacements[i]; + override_upper = 1; + } + else + { + //this is not MPI_LB or MPI_UB + //However it may still have overriding bounds + //Test for these and add its size to the typemap. + + if (temp2->o_lb) + // this type's lb has been overridden. + // ONLY an overriding lb can be the actual lb now. + override_lower = 1; + if (temp2->o_ub) + //same as above, but ub + override_upper = 1; + + simpletype_count += blocklens[i] * oldtypes_ptr[i]->count; + } + } + temp = malloc(sizeof(Typestruct) + + ((simpletype_count-1) * sizeof(typepair))); + + temp->count = simpletype_count; + + i = 0; //old type's index + newcount = 0; //new type's index + + while (i < count) + { + tmp_offset = 0; + + temp2 = oldtypes_ptr[i]; + + //test for previous MPI_LB or MPI_UB in one of the comprising types. + //If found, skip over. + if (!((temp2->pairs[0].type == SIMPLE_LOWER) || + (temp2->pairs[0].type == SIMPLE_UPPER))) + { + for (j = 0; j < blocklens[i]; j++) + { + //Copy the old type's typemap and merge into the new type + //by a "flattening" process + Type_extent((Datatype) oldtypes_ptr[i], &extent); + + tmp_offset = j * extent; + + if (temp2->o_lb && temp2->lb+displacements[i]+tmp_offset < new_lb) + new_lb = temp2->lb+displacements[i]+tmp_offset; + if (temp2->o_ub && temp2->ub+displacements[i]+tmp_offset > new_ub) + { + new_ub = temp2->ub+displacements[i]+tmp_offset; + } + + for (k = 0; k < oldtypes_ptr[i]->count; k++) + { + Copy_type( (typepair*) oldtypes_ptr[i]->pairs+k, + (typepair*) (temp->pairs+newcount)); + + + ((typepair*) temp->pairs+(newcount))->disp += + displacements[i] + tmp_offset; + newcount++; + } + } + } + i++; + } + //type is NOT committed + temp->committed = 0; + + //assign upper and lower bounds here + if (override_lower) + { + //use lowest previous overridden lower bound + temp->o_lb = 1; + temp->lb = new_lb; + } + else + { + //use calculation + temp->lb = calc_lb(temp); + } + + if (override_upper) + { + temp->o_ub = 1; + temp->ub = new_ub; + } + else + { + temp->ub = calc_ub(temp); + } + + *newtype = temp; + temp = MPI_DATATYPE_NULL; + + return MPI_SUCCESS; +} + +/*******************************************************/ +/* MPI_Type_contiguous. Create count copies of a type. + * this creates arrays of the singleton arguments and use them to call + * MPI_Type_struct() + */ + +FC_FUNC( mpi_type_contiguous, MPI_TYPE_CONTIGUOUS ) + (int *count, int *oldtype, int * newtype, int * ierr) +{ + *ierr = MPI_Type_contiguous(*count, *oldtype, newtype); +} + +int MPI_Type_contiguous(int count, MPI_Datatype old, MPI_Datatype * new) +{ + int ret; + Datatype old_ptr = *(Datatype*) mpi_handle_to_datatype(old); + Datatype * new_ptr; + + mpi_alloc_handle(new, (void**) &new_ptr); + + return Type_contiguous(count, old_ptr, new_ptr); +} + +int Type_contiguous(int count, Datatype oldtype, Datatype *newtype) +{ + int i; + int blocklengths[count]; + Datatype oldtypes[count]; + MPI_Aint offsets[count]; + MPI_Aint extent; + + //each copy is strided by the extent of the datatype. + // Calculate that here. + Type_extent(oldtype, &extent); + for (i = 0; i < count; i++) + { + blocklengths[i] = 1; + offsets[i] = extent * i; + oldtypes[i] = oldtype; + } + return Type_struct(count, blocklengths, offsets, oldtypes, newtype); +} + +/*************************/ +/* Type_vector + */ + +FC_FUNC( mpi_type_vector, MPI_TYPE_VECTOR ) + (int * count, int * blocklen, int * stride, + int * oldtype, int * newtype, int * ierr) +{ + *ierr = MPI_Type_vector(*count, *blocklen, *stride, *oldtype, newtype); +} + +int MPI_Type_vector(int count, int blocklen, int stride, + MPI_Datatype oldtype, MPI_Datatype * newtype) +{ + Datatype old_ptr = *(Datatype*) mpi_handle_to_datatype(oldtype); + Datatype * new_ptr; + + mpi_alloc_handle(newtype, (void**) &new_ptr); + + return Type_vector(count, blocklen, stride, old_ptr, new_ptr); +} + + +int Type_vector(int count, int blocklen, int stride, + Datatype oldtype, Datatype *newtype) +{ + MPI_Aint extent; + MPI_Aint bstride; + + Type_extent(oldtype, &extent); + bstride = stride * extent; + + return Type_hvector(count, blocklen, bstride, oldtype, newtype); +} + +/*******************************************************/ + +FC_FUNC( mpi_type_hvector, MPI_TYPE_HVECTOR ) + (int * count, long * blocklen, long * stride, + int * oldtype, int * newtype, int * ierr) +{ + *ierr = MPI_Type_hvector(*count, *blocklen, *stride, *oldtype, newtype); +} + +int MPI_Type_hvector(int count, int blocklen, MPI_Aint stride, + MPI_Datatype oldtype, MPI_Datatype * newtype) +{ + Datatype old_ptr = *(Datatype*) mpi_handle_to_datatype(oldtype); + Datatype * new_ptr; + + mpi_alloc_handle(newtype, (void**) &new_ptr); + return Type_hvector(count, blocklen, stride, old_ptr, new_ptr); +} + +FC_FUNC( mpi_type_create_hvector, MPI_TYPE_CREATE_HVECTOR ) + (int * count, long * blocklen, long * stride, + int * oldtype, int * newtype, int * ierr) +{ + *ierr = MPI_Type_create_hvector(*count, *blocklen, *stride, *oldtype, newtype); +} + +int MPI_Type_create_hvector(int count, int blocklen, MPI_Aint stride, + MPI_Datatype oldtype, MPI_Datatype * newtype) +{ + Datatype old_ptr = *(Datatype*) mpi_handle_to_datatype(oldtype); + Datatype * new_ptr; + + mpi_alloc_handle(newtype, (void**) &new_ptr); + return Type_hvector(count, blocklen, stride, old_ptr, new_ptr); +} + + +int Type_hvector(int count, int blocklen, MPI_Aint stride, + Datatype oldtype, Datatype *newtype) +{ + int i; + int blocklengths[count]; + Datatype oldtypes[count]; + MPI_Aint offsets[count]; + MPI_Aint extent; + + Type_extent(oldtype, &extent); + for (i = 0; i < count; i++) + { + blocklengths[i] = blocklen; + offsets[i] = stride * i; + oldtypes[i] = oldtype; + } + + return Type_struct(count, blocklengths, offsets, oldtypes, newtype); +} + +/*******************************************************/ + +FC_FUNC( mpi_type_indexed, MPI_TYPE_INDEXED ) + (int * count, int * blocklens, int * displacements, + int * oldtype, int * newtype, int * ierr) +{ + *ierr = MPI_Type_indexed(*count, blocklens, displacements, *oldtype, newtype); +} + + +int MPI_Type_indexed(int count, int *blocklens, int *displacements, + MPI_Datatype oldtype, MPI_Datatype * newtype) +{ + Datatype old_ptr = *(Datatype*) mpi_handle_to_datatype(oldtype); + Datatype * new_ptr; + + mpi_alloc_handle(newtype, (void**) &new_ptr); + return Type_indexed(count, blocklens, displacements, old_ptr, new_ptr); +} + +int Type_indexed(int count, int *blocklens, int *displacements, + Datatype oldtype, Datatype *newtype) +{ + int i; + MPI_Aint extent; + MPI_Aint bdisps[count]; + + for (i = 0; i < count; i++) + { + Type_extent(oldtype, &extent); + bdisps[i] = displacements[i] * extent; + } + + return Type_hindexed(count, blocklens, bdisps, oldtype, newtype); +} + +/*******************************************************/ + +FC_FUNC( mpi_type_create_indexed_block, MPI_TYPE_CREATE_INDEXED_BLOCK ) + (int * count, int * blocklen, int * displacements, + int * oldtype, int * newtype, int * ierr) +{ + *ierr = MPI_Type_create_indexed_block(*count, *blocklen, displacements, + *oldtype, newtype); +} + +int MPI_Type_create_indexed_block(int count, int blocklen, int *displacements, + MPI_Datatype oldtype, MPI_Datatype * newtype) +{ + int ret; + Datatype old_ptr = *(Datatype*) mpi_handle_to_datatype(oldtype); + Datatype * new_ptr; + + mpi_alloc_handle(newtype, (void**) &new_ptr); + return Type_create_indexed_block(count, blocklen, displacements, old_ptr, new_ptr); +} + +int Type_create_indexed_block(int count, int blocklen, int *displacements, + Datatype oldtype, Datatype *newtype) +{ + int i; + int blocklens[count]; + + for (i = 0; i < count; i++) + blocklens[i] = blocklen; + + return Type_indexed(count, blocklens, displacements, oldtype, newtype); +} + +/*******************************************************/ + +FC_FUNC( mpi_type_hindexed, MPI_TYPE_HINDEXED ) + (int * count, int * blocklens, MPI_Aint * displacements, + int * oldtype, int * newtype, int * ierr) +{ + *ierr = MPI_Type_hindexed(*count, blocklens, displacements, + *oldtype, newtype); +} + +int MPI_Type_hindexed(int count, int *blocklens, MPI_Aint * disps, + MPI_Datatype oldtype, MPI_Datatype * newtype) +{ + Datatype old_ptr = *(Datatype*) mpi_handle_to_datatype(oldtype); + Datatype * new_ptr; + + mpi_alloc_handle(newtype, (void**) &new_ptr); + return Type_hindexed(count, blocklens, disps, old_ptr, new_ptr); +} + +int Type_hindexed(int count, int *blocklens, MPI_Aint *displacements, + Datatype oldtype, Datatype *newtype) +{ + int i; + Datatype oldtypes[count]; + + for (i = 0; i < count; i++) + { + oldtypes[i] = oldtype; + } + + return Type_struct(count, blocklens, displacements, oldtypes, newtype); +} + + +/*******************************************************/ + +int Type_dup(Datatype oldtype, Datatype *newtype) +{ + int i; + //create a deep copy of given Datatype + newtype = malloc(sizeof(oldtype)); + (*newtype)->committed = oldtype->committed; + (*newtype)->lb = oldtype->lb; + (*newtype)->ub = oldtype->ub; + (*newtype)->o_lb = oldtype->o_lb; + (*newtype)->o_ub = oldtype->o_ub; + + for (i = 0; i < oldtype->count; i++) + { + Copy_type((typepair*) oldtype->pairs + i, + (typepair*) (*newtype)->pairs + i ); + } +} + +/* copy_type: Creates a deep copy of source typepair into dest + */ +int Copy_type(typepair *source, typepair *dest) +{ + dest->type = source->type; + dest->disp = source->disp; +} + +/* MPI_Type_size: Returns the sum of the lengths of each simple + * type that makes up the data type argument + */ +FC_FUNC( mpi_type_size, MPI_TYPE_SIZE )(int * type, int * size, int * ierr) +{ + *ierr=MPI_Type_size(*type, size); +} + +int MPI_Type_size(MPI_Datatype type, int * size) +{ + Datatype type_ptr = *(Datatype*) mpi_handle_to_datatype(type); + return Type_size(type_ptr, size); +} + +int Type_size(Datatype type, int * size) +{ + int i; + *size = 0; + for (i=0; i < type->count; i++) + *size += Simpletype_length(type->pairs[i].type); + + + return MPI_SUCCESS; +} +/* MPI_Type_lb: Returns the lower bound (which may be overridden + * or calculated) + */ +FC_FUNC( mpi_type_lb, MPI_TYPE_LB )(int * type, long * lb, int * ierr) +{ + *ierr = MPI_Type_lb(*type, lb); +} + +int MPI_Type_lb(MPI_Datatype type, MPI_Aint * lb) +{ + Datatype type_ptr = *(Datatype*) mpi_handle_to_datatype(type); + + return Type_lb(type_ptr, lb); +} + +int Type_lb(Datatype type, MPI_Aint * lb) +{ + *lb = type->lb; +} + +/* MPI_Type_ub: Return upper bound (which may be overridden + * or calculated + */ +FC_FUNC( mpi_type_ub, MPI_TYPE_UB )(int * type, long * ub, int * ierr) +{ + *ierr = MPI_Type_ub(*type, ub); +} + +int MPI_Type_ub(MPI_Datatype type, MPI_Aint * ub) +{ + Datatype type_ptr = *(Datatype*) mpi_handle_to_datatype(type); + + return Type_ub(type_ptr, ub); +} + +int Type_ub(Datatype type, MPI_Aint * ub) +{ + *ub = type->ub; +} + +/* MPI_Get_address + * MPI_Address + * Return address of an object + */ +FC_FUNC( mpi_get_address, MPI_ADDRESS )(void * loc, long * address, int * ierr) +{ + *ierr = FGet_address(loc, address); +} + +FC_FUNC( mpi_address, MPI_ADDRESS )(void * loc, long * address, int * ierr) +{ + *address = (long) loc; + *ierr = FGet_address(loc, address); +} + +int FGet_address(void * loc, long * address, int * ierr) +{ + *address = (long) loc; + return MPI_SUCCESS; +} + +int MPI_Address(void * loc, MPI_Aint * address) +{ + return MPI_Get_address(loc, address); +} + +int MPI_Get_address(void * loc, MPI_Aint * address) +{ + *address = (MPI_Aint) loc; + return MPI_SUCCESS; +} + +/* MPI_Type_extent: return ub-lb, plus padding + */ +FC_FUNC( mpi_type_extent, MPI_TYPE_EXTENT)(int * type, long * extent, int * ierr) +{ + *ierr = MPI_Type_extent(*type, extent); +} + +int MPI_Type_extent(MPI_Datatype type, MPI_Aint * extent) +{ + Datatype type_ptr = *(Datatype*) mpi_handle_to_datatype(type); + + return Type_extent(type_ptr, extent); +} + +int Type_extent(Datatype datatype, MPI_Aint * extent) +{ + + if (!(datatype->o_lb || datatype->o_ub)) + { + int epsilon = calc_padding(datatype); + //current epsilon value is based off of largest datatype size + int mod = (datatype->ub - datatype->lb) % epsilon; + if (mod == 0) + epsilon = 0; + else + epsilon = epsilon - mod; + *extent = (datatype->ub - datatype->lb) + epsilon; + } + else + { + *extent = datatype->ub - datatype->lb; + } + + return MPI_SUCCESS; +} + +/* True_extent returns an extent based only on + * calculated upper and lower bound, regardless of any + * override using MPI_LB or MPI_UB + */ +int Type_get_true_extent(Datatype type, MPI_Aint * extent) +{ + long epsilon = calc_padding(type); + long ub = calc_ub(type); + long lb = calc_lb(type); + //current epsilon value is based off of largest datatype size + long mod = (ub - lb) % epsilon; + if (mod == 0) + epsilon = 0; + else + epsilon = epsilon - mod; + *extent = (ub - lb) + epsilon; + + return MPI_SUCCESS; +} + +/***********************/ + +FC_FUNC( mpi_type_commit, MPI_TYPE_COMMIT )(int * datatype, int * ierr) +{ + *ierr = MPI_Type_commit(datatype); +} + +int MPI_Type_commit(MPI_Datatype * datatype) +{ + Datatype type_ptr = *(Datatype*) mpi_handle_to_datatype(*datatype); + (type_ptr)->committed = 1; + + return MPI_SUCCESS; +} + +/**********************/ +FC_FUNC( mpi_type_free, MPI_TYPE_FREE )(int * datatype, int * ierr) +{ + *ierr = MPI_Type_free(datatype); +} + +int MPI_Type_free(MPI_Datatype * datatype) +{ + Datatype type_ptr = *(Datatype*) mpi_handle_to_datatype(*datatype); + free(type_ptr); + type_ptr = MPI_DATATYPE_NULL; + + mpi_free_handle(*datatype); + + return MPI_SUCCESS; +} + +/* Print_typemap is used in test programs only when + * --enable-test-internal is enabled in configure. + */ + +#ifdef TEST_INTERNAL +FC_FUNC( print_typemap, PRINT_TYPEMAP )(int * type, int * ierr) +{ + *ierr = print_typemap(*type); +} + +int print_typemap(MPI_Datatype type) +{ + Datatype type_ptr = *(Datatype*) mpi_handle_to_datatype(type); + + return Pprint_typemap(type_ptr); +} + +int Pprint_typemap(Datatype type) +{ + int i; + MPI_Aint extent; + Type_extent(type, &extent); + + printf("Type with %d type pairs.\n>> lb is %d\n>> ub is %d\n>>" + "Extent is %d\n>>Epsilon based on %d\nTypemap: \n{", + type->count, type->lb, type->ub, extent, calc_padding(type)); + + for (i = 0; i < type->count; i++) + { + printf("(t%d:%d, o%d)", type->pairs[i].type, + Simpletype_length(type->pairs[i].type), + type->pairs[i].disp); + + if (i != type->count-1) + printf(", "); + } + printf("}\n"); + + return MPI_SUCCESS; +} +#endif //TEST_INTERNAL + diff --git a/mpi-serial/type.h b/mpi-serial/type.h new file mode 100644 index 000000000000..cd92b78f1b7d --- /dev/null +++ b/mpi-serial/type.h @@ -0,0 +1,124 @@ +#ifndef TYPE_H +#define TYPE_H + +/* type.h */ +/* defines interface and types used for mpi-serial user-defined datatypes */ + +#include "mpiP.h" + +//for Fortran type sizes +#ifdef HAVE_CONFIG_H +#include +#endif + +//predefined type value used in typemap +typedef int Simpletype; + +typedef struct +{ + long disp; + Simpletype type; +} typepair; + +typedef struct +{ + int count; + long ub; + long lb; + int committed; //type has been committed + int o_lb; //overridden lower/upper bound + int o_ub; // " + /* pairs[] is size 2 because of predefined types + * such as MPI_2INT that have 2 typemap entries + * upon initialization. + */ + typepair pairs[2]; +} Typestruct; + +typedef Typestruct* Datatype; + +//Simpletype constants +#define SIMPLE_CHAR 0 +#define SIMPLE_SHORT 1 +#define SIMPLE_INT 2 +#define SIMPLE_LONG 3 +#define SIMPLE_UCHAR 4 +#define SIMPLE_USHORT 5 +#define SIMPLE_UINT 6 +#define SIMPLE_ULONG 7 +#define SIMPLE_FLOAT 8 +#define SIMPLE_DOUBLE 9 +#define SIMPLE_LDOUBLE 10 +#define SIMPLE_BYTE 11 +#define SIMPLE_LOWER 12 +#define SIMPLE_UPPER 13 +#define SIMPLE_FINTEGER 14 +#define SIMPLE_FREAL 15 +#define SIMPLE_FDPRECISION 16 +#define SIMPLE_FCOMPLEX 17 +#define SIMPLE_FDCOMPLEX 18 +#define SIMPLE_FLOGICAL 19 +#define SIMPLE_FCHARACTER 20 + +#define SIMPLE_FINTEGER1 21 +#define SIMPLE_FINTEGER2 22 +#define SIMPLE_FINTEGER4 23 +#define SIMPLE_FINTEGER8 24 +#define SIMPLE_FINTEGER16 25 + +#define SIMPLE_FREAL4 26 +#define SIMPLE_FREAL8 27 +#define SIMPLE_FREAL16 28 + +#define SIMPLE_FCOMPLEX8 29 +#define SIMPLE_FCOMPLEX16 30 +#define SIMPLE_FCOMPLEX32 31 + +#define SIMPLE_LONGLONG 32 +#define SIMPLE_ULONGLONG 33 + +#define SIMPLE_OFFSET 34 + +//internal type functions +int Simpletype_length(Simpletype s); + +//testing only +int print_typemap(MPI_Datatype in); + + +/* + * Fortran type sizes + * + * If config.h is used and the user has specified + * sizes using --enable-fort-real and --enable-fort-double + * args, they will be used here. Otherwise just take a shot + * in the dark? + * + */ + +#ifdef CONFIG_FORT_REAL +#define FSIZE_REAL CONFIG_FORT_REAL +#else +#define FSIZE_REAL 4 //guess something reasonable +#endif + +#ifdef CONFIG_FORT_DOUBLE +#define FSIZE_DPRECISION CONFIG_FORT_DOUBLE +#else +#define FSIZE_DPRECISION 8 +#endif + +#define FSIZE_INTEGER 4 +#define FSIZE_COMPLEX 2*FSIZE_REAL +#define FSIZE_DCOMPLEX 2*FSIZE_DPRECISION +#define FSIZE_LOGICAL 4 +#define FSIZE_CHARACTER 1 + +const extern Datatype simpletypes[]; +Datatype* mpi_handle_to_datatype(int handle); + +extern int Unpack(void * inbuf, int insize, int * position, void *outbuf, + int outcount, Datatype type, Comm* comm); +extern int Pack(void *inbuf, int incount, Datatype type, + void *outbuf, int outsize, int *position, Comm * comm); +#endif /* TYPE_H */ diff --git a/mpi-serial/type_const.c b/mpi-serial/type_const.c new file mode 100644 index 000000000000..fcb6ed4e46dd --- /dev/null +++ b/mpi-serial/type_const.c @@ -0,0 +1,189 @@ +#include "type.h" + + /* Here are the statically initialized structs for the predefined datatypes. + */ + + //C type structs + Typestruct TSchar = {.count=1, .lb=0, .ub=sizeof(char), + .committed=1, .o_lb=0, .o_ub=0, .pairs[0] = + {.disp = 0, .type = (Simpletype) SIMPLE_CHAR }}; + Typestruct TSshort = {.count=1, .lb=0, .ub=sizeof(short), + .committed=1, .o_lb=0, .o_ub=0, .pairs[0] = + {.disp = 0, .type = (Simpletype) SIMPLE_SHORT }}; + Typestruct TSint = {.count = 1, .lb = 0, .ub=sizeof(int), + .committed=1, .o_lb = 0, .o_ub = 0, .pairs[0]= + {.disp = 0, .type = (Simpletype) SIMPLE_INT }}; + Typestruct TSlong = {.count = 1, .lb = 0, .ub = sizeof(long), + .committed=1, .o_lb = 0, .o_ub = 0, .pairs[0] = + {.disp = 0, .type = (Simpletype) SIMPLE_LONG }}; + Typestruct TSuchar = {.count = 1, .lb = 0, .ub=sizeof(unsigned char), + .committed=1, .o_lb = 0, .o_ub = 0, .pairs[0] = + {.disp = 0, .type = (Simpletype) SIMPLE_UCHAR }}; + Typestruct TSushort = {.count = 1, .lb = 0, .ub=sizeof(unsigned short), + .committed=1, .o_lb = 0, .o_ub = 0, .pairs[0] = + {.disp = 0, .type = (Simpletype) SIMPLE_USHORT }}; + Typestruct TSuint = {.count = 1, .lb = 0, .ub = sizeof(unsigned int), + .committed=1, .o_lb = 0, .o_ub = 0, .pairs[0] = + {.disp = 0, .type = (Simpletype) SIMPLE_UINT }}; + Typestruct TSulong = {.count = 1, .lb = 0, .ub = sizeof(unsigned long), + .committed=1, .o_lb = 0, .o_ub = 0, .pairs[0] = + {.disp = 0, .type = (Simpletype) SIMPLE_ULONG }}; + Typestruct TSfloat = {.count = 1, .lb = 0, .ub = sizeof(float), + .committed=1, .o_lb = 0, .o_ub = 0, .pairs[0] = + {.disp = 0, .type = (Simpletype) SIMPLE_FLOAT }}; + Typestruct TSdouble = {.count = 1, .lb = 0, .ub = sizeof(double), + .committed=1, .o_lb = 0, .o_ub = 0, .pairs[0] = + {.disp = 0, .type = (Simpletype) SIMPLE_DOUBLE }}; + Typestruct TSldouble = {.count = 1, .lb = 0, .ub = sizeof(long double), + .committed=1,.o_lb = 0, .o_ub = 0, .pairs[0] = + {.disp = 0, .type = (Simpletype) SIMPLE_LDOUBLE }}; + + //Cross-language types + Typestruct TSbyte = { .count = 1, .lb = 0, .ub = sizeof(char), .committed = 1, + .o_lb = 0, .o_ub = 0, .pairs[0] = { .disp = 0, .type = (Simpletype) SIMPLE_BYTE } }; + Typestruct TSpacked = { .count = 1, .lb = 0, .ub = sizeof(char), .committed = 1, + .o_lb = 0, .o_ub = 0, .pairs[0] = { .disp = 0, .type = (Simpletype) SIMPLE_BYTE } }; + Typestruct TSlower = { .count = 1, .lb = 0, .ub = 0, .committed = 1, + .o_lb = 0, .o_ub = 0, .pairs[0] = { .disp = 0, .type = (Simpletype) SIMPLE_LOWER } }; + Typestruct TSupper = { .count = 1, .lb = 0, .ub = 0, .committed = 1, + .o_lb = 0, .o_ub = 0, .pairs[0] = { .disp = 0, .type = (Simpletype) SIMPLE_UPPER } }; + + //Fortran type structs + Typestruct TSinteger = { .count = 1, .lb = 0, .ub = FSIZE_INTEGER, .committed = 1, + .o_lb = 0, .o_ub = 0, .pairs[0] = { .disp = 0, .type = (Simpletype) SIMPLE_FINTEGER } }; + Typestruct TSreal = { .count = 1, .lb = 0, .ub = FSIZE_REAL, .committed = 1, + .o_lb = 0, .o_ub = 0, .pairs[0] = { .disp = 0, .type = (Simpletype) SIMPLE_FREAL } }; + Typestruct TSdprecision = { .count = 1, .lb = 0, .ub = FSIZE_DPRECISION, .committed = 1, + .o_lb = 0, .o_ub = 0, .pairs[0] = { .disp = 0, .type = (Simpletype) SIMPLE_FDPRECISION } }; + Typestruct TScomplex = { .count = 1, .lb = 0, .ub = FSIZE_COMPLEX, .committed = 1, + .o_lb = 0, .o_ub = 0, .pairs[0] = { .disp = 0, .type = (Simpletype) SIMPLE_FCOMPLEX } }; + Typestruct TSdcomplex = { .count = 1, .lb = 0, .ub = FSIZE_DCOMPLEX, .committed = 1, + .o_lb = 0, .o_ub = 0, .pairs[0] = { .disp = 0, .type = (Simpletype) SIMPLE_FDCOMPLEX } }; + Typestruct TSlogical = { .count = 1, .lb = 0, .ub = FSIZE_LOGICAL, .committed = 1, + .o_lb = 0, .o_ub = 0, .pairs[0] = { .disp = 0, .type = (Simpletype) SIMPLE_FLOGICAL } }; + Typestruct TScharacter = { .count = 1, .lb = 0, .ub = FSIZE_CHARACTER, .committed = 1, + .o_lb = 0, .o_ub = 0, .pairs[0] = { .disp = 0, .type = (Simpletype) SIMPLE_FCHARACTER } }; + + /*Reduction function types (C) + */ + Typestruct TSfloat_int = { .count = 2, .lb = 0, .ub = sizeof(struct {float a; int b;}), .committed = 1, + .o_lb = 0, .o_ub = 0, .pairs[0] = { .disp = 0, .type = (Simpletype) SIMPLE_FLOAT }, + .pairs[1] = { .disp=sizeof(float), .type = (Simpletype) SIMPLE_INT}}; + Typestruct TSdouble_int = { .count = 2, .lb = 0, .ub = sizeof(struct {double a; int b;}), .committed = 1, + .o_lb = 0, .o_ub = 0, .pairs[0] = { .disp = 0, .type = (Simpletype) SIMPLE_DOUBLE }, + .pairs[1] = { .disp=sizeof(double), .type = (Simpletype) SIMPLE_INT}}; + Typestruct TSlong_int = { .count = 2, .lb = 0, .ub = sizeof(struct {long a; int b;}), .committed = 1, + .o_lb = 0, .o_ub = 0, .pairs[0] = { .disp = 0, .type = (Simpletype) SIMPLE_LONG }, + .pairs[1] = { .disp=sizeof(long), .type = (Simpletype) SIMPLE_INT}}; + Typestruct TS2int = { .count = 2, .lb = 0, .ub = 2*sizeof(int), .committed = 1, + .o_lb = 0, .o_ub = 0, .pairs[0] = { .disp = 0, .type = (Simpletype) SIMPLE_INT }, + .pairs[1] = { .disp=sizeof(int), .type = (Simpletype) SIMPLE_INT}}; + Typestruct TSshort_int = { .count = 2, .lb = 0, .ub = sizeof(struct {short a; int b;}), .committed = 1, + .o_lb = 0, .o_ub = 0, .pairs[0] = { .disp = 0, .type = (Simpletype) SIMPLE_SHORT }, + .pairs[1] = { .disp=sizeof(int), .type = (Simpletype) SIMPLE_INT}}; + Typestruct TSldouble_int = { .count = 2, .lb = 0, .ub = sizeof(struct {long double a; int b;}), .committed = 1, + .o_lb = 0, .o_ub = 0, .pairs[0] = { .disp = 0, .type = (Simpletype) SIMPLE_LDOUBLE }, + .pairs[1] = { .disp=sizeof(long double), .type = (Simpletype) SIMPLE_INT}}; + + /* Reduction function types (Fortran) + */ + Typestruct TS2real = { .count = 2, .lb = 0, .ub = 2*FSIZE_REAL, .committed = 1, + .o_lb = 0, .o_ub = 0, .pairs[0] = { .disp = 0, .type = (Simpletype) SIMPLE_FREAL }, + .pairs[1] = { .disp=FSIZE_REAL, .type = (Simpletype) SIMPLE_FREAL}}; + Typestruct TS2dprecision = { .count = 2, .lb = 0, .ub = 2*FSIZE_DPRECISION, .committed = 1, + .o_lb = 0, .o_ub = 0, .pairs[0] = { .disp = 0, .type = (Simpletype) SIMPLE_FDPRECISION }, + .pairs[1] = { .disp=FSIZE_DPRECISION, .type = (Simpletype) SIMPLE_FDPRECISION}}; + Typestruct TS2integer = { .count = 2, .lb = 0, .ub = 2*FSIZE_INTEGER, .committed = 1, + .o_lb = 0, .o_ub = 0, .pairs[0] = { .disp = 0, .type = (Simpletype) SIMPLE_FINTEGER }, + .pairs[1] = { .disp=FSIZE_INTEGER, .type = (Simpletype) SIMPLE_FINTEGER}}; + + + /* Fortran sized types + */ + + Typestruct TSinteger1 = {.count = 1, .lb = 0, .ub=1, + .committed=1, .o_lb = 0, .o_ub = 0, .pairs[0]= + {.disp = 0, .type = (Simpletype) SIMPLE_FINTEGER1 }}; + + Typestruct TSinteger2 = {.count = 1, .lb = 0, .ub=2, + .committed=1, .o_lb = 0, .o_ub = 0, .pairs[0]= + {.disp = 0, .type = (Simpletype) SIMPLE_FINTEGER2 }}; + + Typestruct TSinteger4 = {.count = 1, .lb = 0, .ub=4, + .committed=1, .o_lb = 0, .o_ub = 0, .pairs[0]= + {.disp = 0, .type = (Simpletype) SIMPLE_FINTEGER4 }}; + + Typestruct TSinteger8 = {.count = 1, .lb = 0, .ub=8, + .committed=1, .o_lb = 0, .o_ub = 0, .pairs[0]= + {.disp = 0, .type = (Simpletype) SIMPLE_FINTEGER8 }}; + + Typestruct TSinteger16 = {.count = 1, .lb = 0, .ub=16, + .committed=1, .o_lb = 0, .o_ub = 0, .pairs[0]= + {.disp = 0, .type = (Simpletype) SIMPLE_FINTEGER16 }}; + + + Typestruct TSreal4 = {.count = 1, .lb = 0, .ub=4, + .committed=1, .o_lb = 0, .o_ub = 0, .pairs[0]= + {.disp = 0, .type = (Simpletype) SIMPLE_FREAL4 }}; + + Typestruct TSreal8 = {.count = 1, .lb = 0, .ub=8, + .committed=1, .o_lb = 0, .o_ub = 0, .pairs[0]= + {.disp = 0, .type = (Simpletype) SIMPLE_FREAL8 }}; + + Typestruct TSreal16 = {.count = 1, .lb = 0, .ub=16, + .committed=1, .o_lb = 0, .o_ub = 0, .pairs[0]= + {.disp = 0, .type = (Simpletype) SIMPLE_FREAL16 }}; + + Typestruct TScomplex8 = {.count = 1, .lb = 0, .ub=8, + .committed=1, .o_lb = 0, .o_ub = 0, .pairs[0]= + {.disp = 0, .type = (Simpletype) SIMPLE_FCOMPLEX8 }}; + + Typestruct TScomplex16 = {.count = 1, .lb = 0, .ub=16, + .committed=1, .o_lb = 0, .o_ub = 0, .pairs[0]= + {.disp = 0, .type = (Simpletype) SIMPLE_FCOMPLEX16 }}; + + Typestruct TScomplex32 = {.count = 1, .lb = 0, .ub=32, + .committed=1, .o_lb = 0, .o_ub = 0, .pairs[0]= + {.disp = 0, .type = (Simpletype) SIMPLE_FCOMPLEX32 }}; + + /* Additions + */ + +Typestruct TSlonglong = {.count = 1, .lb = 0, .ub=sizeof(long long), + .committed=1, .o_lb = 0, .o_ub = 0, .pairs[0]= + {.disp = 0, .type = (Simpletype) SIMPLE_LONGLONG }}; + +Typestruct TSulonglong = {.count = 1, .lb = 0, .ub=sizeof(unsigned long long), + .committed=1, .o_lb = 0, .o_ub = 0, .pairs[0]= + {.disp = 0, .type = (Simpletype) SIMPLE_ULONGLONG }}; + +Typestruct TSoffset = {.count = 1, .lb = 0, .ub=sizeof(MPI_Offset), + .committed=1, .o_lb = 0, .o_ub = 0, .pairs[0]= + {.disp = 0, .type = (Simpletype) SIMPLE_OFFSET }}; + + + + /* RML NOTE: the order and numbering of the elements of simpletypes[] MUST match + * the values for the MPI type constants e.g. MPI_INT + * This should be coded in a better way to avoid human error. + */ + + const Datatype simpletypes[64] = + {&TSchar , &TSshort , &TSint , &TSlong, + &TSuchar , &TSushort , &TSuint , &TSulong, //4 + &TSfloat , &TSdouble , &TSldouble , &TSbyte, //8 + &TSpacked , &TSlower , &TSupper , &TSinteger, //12 + &TSreal , &TSdprecision, &TScomplex , &TSdcomplex, //16 + &TSlogical , &TScharacter , &TS2real , &TS2dprecision,//20 + &TS2integer, &TSfloat_int , &TSdouble_int , &TSlong_int, //24 + &TS2int , &TSshort_int , &TSldouble_int, &TSinteger1, //28 + &TSinteger2, &TSinteger4 , &TSinteger8 , &TSinteger16, //32 + &TSreal4 , &TSreal8 , &TSreal16 , &TScomplex8, //36 + &TScomplex16, &TScomplex32, &TSlonglong , &TSulonglong, //40 + &TSoffset + }; + + + /* optional datatypes (Fortran) MPI_INTEGER1 MPI_INTEGER2 MPI_INTEGER4 MPI_REAL2 MPI_REAL4 MPI_REAL8 + + /* optional datatypes (C) MPI_LONG_LONG_INT */ diff --git a/protex/protex b/protex/protex new file mode 100755 index 000000000000..000708e31063 --- /dev/null +++ b/protex/protex @@ -0,0 +1,879 @@ +#!/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/testsystem/Makefile b/testsystem/Makefile new file mode 100644 index 000000000000..b3614ef25ff5 --- /dev/null +++ b/testsystem/Makefile @@ -0,0 +1,20 @@ + +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/testsystem/testall/.gitignore b/testsystem/testall/.gitignore new file mode 100644 index 000000000000..d675e0fa576f --- /dev/null +++ b/testsystem/testall/.gitignore @@ -0,0 +1,6 @@ +testall +*.clog +fort.* +*.log +*testall.* +*.script diff --git a/testsystem/testall/Makefile b/testsystem/testall/Makefile new file mode 100644 index 000000000000..3c99e0d9cc0c --- /dev/null +++ b/testsystem/testall/Makefile @@ -0,0 +1,60 @@ + +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/testsystem/testall/ReadSparseMatrixAsc.F90 b/testsystem/testall/ReadSparseMatrixAsc.F90 new file mode 100644 index 000000000000..a0ce00128b82 --- /dev/null +++ b/testsystem/testall/ReadSparseMatrixAsc.F90 @@ -0,0 +1,244 @@ +!------------------------------------------------------------------------- +! 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_AttrVect, only : Attrvect_zero => zero + 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) + call AttrVect_zero(sMat%data) + + ! ...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/testsystem/testall/UNTESTED b/testsystem/testall/UNTESTED new file mode 100644 index 000000000000..0840bdbc40e1 --- /dev/null +++ b/testsystem/testall/UNTESTED @@ -0,0 +1,13 @@ +The following routines are untested: + +m_GlobalToLocal +--> GlobalSegMapToNavigator + +m_Merge + +m_Navigator + +m_NBSend + +m_SparseMatrixComms +--> GM_gather diff --git a/testsystem/testall/ccm.F90 b/testsystem/testall/ccm.F90 new file mode 100644 index 000000000000..919de17bf53e --- /dev/null +++ b/testsystem/testall/ccm.F90 @@ -0,0 +1,835 @@ +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! 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/testsystem/testall/convertPOPT.F90 b/testsystem/testall/convertPOPT.F90 new file mode 100644 index 000000000000..52c0098298bd --- /dev/null +++ b/testsystem/testall/convertPOPT.F90 @@ -0,0 +1,454 @@ +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! +! 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/testsystem/testall/convertgauss.F90 b/testsystem/testall/convertgauss.F90 new file mode 100644 index 000000000000..ec4e7996399e --- /dev/null +++ b/testsystem/testall/convertgauss.F90 @@ -0,0 +1,516 @@ +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! +! 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/testsystem/testall/cpl.F90 b/testsystem/testall/cpl.F90 new file mode 100644 index 000000000000..0a1235d9d0f0 --- /dev/null +++ b/testsystem/testall/cpl.F90 @@ -0,0 +1,1270 @@ +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! 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 + if(myProc==0)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/testsystem/testall/job.ut-all.jaguar b/testsystem/testall/job.ut-all.jaguar new file mode 100644 index 000000000000..c61a7432023b --- /dev/null +++ b/testsystem/testall/job.ut-all.jaguar @@ -0,0 +1,23 @@ +#!/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/testsystem/testall/m_ACTEST.F90 b/testsystem/testall/m_ACTEST.F90 new file mode 100644 index 000000000000..01a89ba4ec43 --- /dev/null +++ b/testsystem/testall/m_ACTEST.F90 @@ -0,0 +1,633 @@ +! +! !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/testsystem/testall/m_AVTEST.F90 b/testsystem/testall/m_AVTEST.F90 new file mode 100644 index 000000000000..5632926d821c --- /dev/null +++ b/testsystem/testall/m_AVTEST.F90 @@ -0,0 +1,857 @@ +! +! !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/testsystem/testall/m_GGRIDTEST.F90 b/testsystem/testall/m_GGRIDTEST.F90 new file mode 100644 index 000000000000..df2f8c0889b4 --- /dev/null +++ b/testsystem/testall/m_GGRIDTEST.F90 @@ -0,0 +1,636 @@ +! +! !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/testsystem/testall/m_GMAPTEST.F90 b/testsystem/testall/m_GMAPTEST.F90 new file mode 100644 index 000000000000..032d07723472 --- /dev/null +++ b/testsystem/testall/m_GMAPTEST.F90 @@ -0,0 +1,160 @@ +! +! !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/testsystem/testall/m_GSMAPTEST.F90 b/testsystem/testall/m_GSMAPTEST.F90 new file mode 100644 index 000000000000..55ce3ada9039 --- /dev/null +++ b/testsystem/testall/m_GSMAPTEST.F90 @@ -0,0 +1,377 @@ +! +! !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/testsystem/testall/m_MCTWORLDTEST.F90 b/testsystem/testall/m_MCTWORLDTEST.F90 new file mode 100644 index 000000000000..bf16a337c5c5 --- /dev/null +++ b/testsystem/testall/m_MCTWORLDTEST.F90 @@ -0,0 +1,121 @@ +! +! !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/testsystem/testall/m_ROUTERTEST.F90 b/testsystem/testall/m_ROUTERTEST.F90 new file mode 100644 index 000000000000..2634c6db5315 --- /dev/null +++ b/testsystem/testall/m_ROUTERTEST.F90 @@ -0,0 +1,120 @@ +! +! !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/testsystem/testall/m_SMATTEST.F90 b/testsystem/testall/m_SMATTEST.F90 new file mode 100644 index 000000000000..060a6b5bee43 --- /dev/null +++ b/testsystem/testall/m_SMATTEST.F90 @@ -0,0 +1,627 @@ +! +! !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/testsystem/testall/master.F90 b/testsystem/testall/master.F90 new file mode 100644 index 000000000000..4081f31656a5 --- /dev/null +++ b/testsystem/testall/master.F90 @@ -0,0 +1,39 @@ +!----------------------------------------------------------------------- +! 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/testsystem/testall/mph.F90 b/testsystem/testall/mph.F90 new file mode 100644 index 000000000000..0779705c867e --- /dev/null +++ b/testsystem/testall/mph.F90 @@ -0,0 +1,1068 @@ +!----------------------------------------------------------------------- +! 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/testsystem/testall/pop.F90 b/testsystem/testall/pop.F90 new file mode 100644 index 000000000000..74c8f35e6cb1 --- /dev/null +++ b/testsystem/testall/pop.F90 @@ -0,0 +1,650 @@ +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! 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/testsystem/testall/processors_map.in b/testsystem/testall/processors_map.in new file mode 100644 index 000000000000..dc260c7e40f7 --- /dev/null +++ b/testsystem/testall/processors_map.in @@ -0,0 +1,12 @@ +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/testsystem/testall/script.jag b/testsystem/testall/script.jag new file mode 100644 index 000000000000..d62277c7019a --- /dev/null +++ b/testsystem/testall/script.jag @@ -0,0 +1,18 @@ +#!/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/testsystem/testall/ut_SparseMatrix.rc b/testsystem/testall/ut_SparseMatrix.rc new file mode 100644 index 000000000000..0aaa729738cf --- /dev/null +++ b/testsystem/testall/ut_SparseMatrix.rc @@ -0,0 +1,29 @@ +#------------------------------------------------------------------------- +# 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/testunit/.gitignore b/testunit/.gitignore new file mode 100644 index 000000000000..bebbb2047a51 --- /dev/null +++ b/testunit/.gitignore @@ -0,0 +1,4 @@ +mctTester +AttrVect.log.* +pbs.mct.script +MCTtestunit.o* diff --git a/testunit/AttrVect_Test.F90 b/testunit/AttrVect_Test.F90 new file mode 100644 index 000000000000..764e5b8e47da --- /dev/null +++ b/testunit/AttrVect_Test.F90 @@ -0,0 +1,1907 @@ +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! 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/testunit/Makefile b/testunit/Makefile new file mode 100644 index 000000000000..d337249c6b94 --- /dev/null +++ b/testunit/Makefile @@ -0,0 +1,41 @@ + +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/testunit/master.F90 b/testunit/master.F90 new file mode 100644 index 000000000000..7a222ccba2ae --- /dev/null +++ b/testunit/master.F90 @@ -0,0 +1,101 @@ +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 + From 727881bb1059feeff3737553f0a580c23b97a777 Mon Sep 17 00:00:00 2001 From: Robert Jacob Date: Sun, 21 May 2017 22:15:13 -0500 Subject: [PATCH 3/4] Allocate send/recv buffs always when useswapm The SendBuff and RecvBuff need to be allocated even if the number of sending/receiving procs is 0 when using the swamp commands. --- cime/src/externals/mct/mct/m_Rearranger.F90 | 15 ++++++++++++++- 1 file changed, 14 insertions(+), 1 deletion(-) diff --git a/cime/src/externals/mct/mct/m_Rearranger.F90 b/cime/src/externals/mct/mct/m_Rearranger.F90 index 654c72f1a8d1..2b39a4e9a301 100644 --- a/cime/src/externals/mct/mct/m_Rearranger.F90 +++ b/cime/src/externals/mct/mct/m_Rearranger.F90 @@ -825,7 +825,13 @@ subroutine rearrange_(SourceAVin,TargetAV,InRearranger,Tag,Sum,& endif - + else +! the m_swap call needs these allocated even if +! SendRout%nprocs = 0. + if (useswapm) then + if(numi .ge. 1) allocate(ISendBuf(1),stat=ier) + if(numr .ge. 1) allocate(RSendBuf(1),stat=ier) + endif endif ! IF RECEVING DATA @@ -862,6 +868,13 @@ subroutine rearrange_(SourceAVin,TargetAV,InRearranger,Tag,Sum,& endif + else +! the m_swap call needs these allocated even if +! RecvRout%nprocs = 0. + if (useswapm) then + if(numi .ge. 1) allocate(IRecvBuf(1),stat=ier) + if(numr .ge. 1) allocate(RRecvBuf(1),stat=ier) + endif endif !:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: From 8dd26b0e836f21a0ba5ddcec4d9c4149c1e79d71 Mon Sep 17 00:00:00 2001 From: Robert Jacob Date: Mon, 22 May 2017 19:16:15 -0500 Subject: [PATCH 4/4] Allocate send/recv buffs even if nprocs eq 0 A better fix is to allocate 0 size SendBuff and Recbuff if nprocs to send/receive are 0. --- cime/src/externals/mct/mct/m_Rearranger.F90 | 45 ++------------------- 1 file changed, 4 insertions(+), 41 deletions(-) diff --git a/cime/src/externals/mct/mct/m_Rearranger.F90 b/cime/src/externals/mct/mct/m_Rearranger.F90 index 2b39a4e9a301..d75a4a54a1d4 100644 --- a/cime/src/externals/mct/mct/m_Rearranger.F90 +++ b/cime/src/externals/mct/mct/m_Rearranger.F90 @@ -792,9 +792,6 @@ subroutine rearrange_(SourceAVin,TargetAV,InRearranger,Tag,Sum,& ! ALLOCATE DATA STRUCTURES ! - ! IF SENDING DATA - if(SendRout%nprocs > 0) then - ! IF SENDING INTEGER DATA if(numi .ge. 1) then @@ -825,17 +822,8 @@ subroutine rearrange_(SourceAVin,TargetAV,InRearranger,Tag,Sum,& endif - else -! the m_swap call needs these allocated even if -! SendRout%nprocs = 0. - if (useswapm) then - if(numi .ge. 1) allocate(ISendBuf(1),stat=ier) - if(numr .ge. 1) allocate(RSendBuf(1),stat=ier) - endif - endif ! IF RECEVING DATA - if(RecvRout%nprocs > 0) then ! IF RECEIVING INTEGER DATA if(numi .ge. 1) then @@ -868,15 +856,6 @@ subroutine rearrange_(SourceAVin,TargetAV,InRearranger,Tag,Sum,& endif - else -! the m_swap call needs these allocated even if -! RecvRout%nprocs = 0. - if (useswapm) then - if(numi .ge. 1) allocate(IRecvBuf(1),stat=ier) - if(numr .ge. 1) allocate(RRecvBuf(1),stat=ier) - endif - endif - !:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: ! INVERT PE LIST ! @@ -1346,30 +1325,12 @@ subroutine rearrange_(SourceAVin,TargetAV,InRearranger,Tag,Sum,& ! 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) @@ -1378,14 +1339,16 @@ subroutine rearrange_(SourceAVin,TargetAV,InRearranger,Tag,Sum,& if(numr .ge. 1) then + ! Deallocate the send buffer + deallocate(RSendBuf,stat=ier) + if(ier/=0) call die(myname_,'deallocate(RSendBuf)',ier) + ! 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_