From dc78d15ab3add097f0cb81a0b7117d5922b34d85 Mon Sep 17 00:00:00 2001 From: Gerhard Theurich Date: Thu, 31 Aug 2023 15:25:19 -0700 Subject: [PATCH 01/14] White space clean-up. --- .../Array/include/ESMCI_Array.h | 8 +-- src/Infrastructure/Array/src/ESMCI_Array.C | 72 +++++++++---------- 2 files changed, 40 insertions(+), 40 deletions(-) diff --git a/src/Infrastructure/Array/include/ESMCI_Array.h b/src/Infrastructure/Array/include/ESMCI_Array.h index dede64de5a..395856a305 100644 --- a/src/Infrastructure/Array/include/ESMCI_Array.h +++ b/src/Infrastructure/Array/include/ESMCI_Array.h @@ -63,7 +63,7 @@ namespace ESMCI { template class SparseMatrix; // class definitions - + //TODO: Figure out how to have code use correct SeqIndex structure automatic. //TODO: For now just hard-code the use of one or the other via CPP definition. #define SeqIndexTensor SeqIndex @@ -173,7 +173,7 @@ namespace ESMCI { // larrayList and larrayBaseAddrList hold the PET-local DEs in the first // localDe many entries. Then, up to vasLocalDeCount are the DEs that // are in the same VAS, and up to ssiLocalDeCount are the DEs that are - // in the same SSI. + // in the same SSI. // Without VAS DE sharing, vasLocalDeCount==localDeCount. // Without SSI DE sharing, ssiLocalDeCount==vasLocalDeCount. LocalArray **larrayList; // [ssiLocalDeCount] localDeCount first @@ -324,12 +324,12 @@ namespace ESMCI { private: Array(ESMC_TypeKind_Flag typekind, int rank, LocalArray **larrayList, VM::memhandle *mh, int vasLocalDeCount, int ssiLocalDeCount, - int *localDeToDeMap, DistGrid *distgrid, bool distgridCreator, + int *localDeToDeMap, DistGrid *distgrid, bool distgridCreator, int *exclusiveLBound, int *exclusiveUBound, int *computationalLBound, int *computationalUBound, int *totalLBound, int *totalUBound, int tensorCount, int tensorElementCount, int *undistLBoundArray, int *undistUBoundArray, int *distgridToArrayMapArray, - int *arrayToDistGridMapArray, int *distgridToPackedArrayMapArray, + int *arrayToDistGridMapArray, int *distgridToPackedArrayMapArray, ESMC_IndexFlag indexflagArg, int *rc, VM *vm=NULL); // allow specific VM instead default public: diff --git a/src/Infrastructure/Array/src/ESMCI_Array.C b/src/Infrastructure/Array/src/ESMCI_Array.C index 167ca41dac..b23a1f9599 100644 --- a/src/Infrastructure/Array/src/ESMCI_Array.C +++ b/src/Infrastructure/Array/src/ESMCI_Array.C @@ -204,7 +204,7 @@ Array::Array( } if (ssiLocalDeCount < vasLocalDeCount){ ESMC_LogDefault.MsgFoundError(ESMC_RC_INTNRL_BAD, - "ssiLocalDeCount must not be less than vasLocalDeCount", ESMC_CONTEXT, + "ssiLocalDeCount must not be less than vasLocalDeCount", ESMC_CONTEXT, rc); return; } @@ -213,7 +213,7 @@ Array::Array( localDeToDeMapArg = (int *)delayout->getLocalDeToDeMap(); if (ssiLocalDeCount != localDeCount){ ESMC_LogDefault.MsgFoundError(ESMC_RC_INTNRL_BAD, - "Default localDeToDeMapArg requires ssiLocalDeCount==localDeCount", + "Default localDeToDeMapArg requires ssiLocalDeCount==localDeCount", ESMC_CONTEXT, rc); return; } @@ -1347,9 +1347,9 @@ Array *Array::create( #if 0 { std::stringstream debugmsg; - debugmsg << "Array::create(): DELayout" << delayout << " localDeCount=" - << delayout->getLocalDeCount() << " localDeToDeMap()=" - << delayout->getLocalDeToDeMap() << " : " + debugmsg << "Array::create(): DELayout" << delayout << " localDeCount=" + << delayout->getLocalDeCount() << " localDeToDeMap()=" + << delayout->getLocalDeToDeMap() << " : " << *delayout->getLocalDeToDeMap(); ESMC_LogDefault.Write(debugmsg.str(), ESMC_LOGMSG_DEBUG); } @@ -1811,14 +1811,14 @@ Array *Array::create( } // allocate LocalArray list that holds all PET-local DEs - + // prepare for pinflag specific handling vector larrayListV; int ssiLocalDeCountArg = localDeCount; // default vector localDeToDeMapArgV; int *localDeToDeMapArg = NULL; // default: use map from DELayout VM::memhandle *mh = NULL; // default: no memory sharing - + // branch on pinflag ESMC_Pin_Flag pinflag = ESMF_PIN_DE_TO_PET; // default if (pinflagArg) pinflag = *pinflagArg; @@ -1854,7 +1854,7 @@ Array *Array::create( if (ESMC_LogDefault.MsgFoundError(localrc, ESMCI_ERR_PASSTHRU, ESMC_CONTEXT, rc)) return ESMC_NULL_POINTER; } - }else if (pinflag == ESMF_PIN_DE_TO_SSI || + }else if (pinflag == ESMF_PIN_DE_TO_SSI || pinflag == ESMF_PIN_DE_TO_SSI_CONTIG){ // make DEs accessible from all the PETs that are on the same SSI vector temp_counts(rank); @@ -8647,7 +8647,7 @@ template struct FactorElement{ int partnerDe; #endif #if (SMMSLSQV_OPTION==1 || SMMSLSQV_OPTION==2) - vector partnerDE; //TODO: remove this once + vector partnerDE; //TODO: remove this once // sparseMatMulStoreLinSeqVect.h has been reworked or removed!!!! #endif }; @@ -9398,7 +9398,7 @@ template #endif } #endif - + #ifdef ASMM_STORE_MEMLOG_on VM::logMemInfo(std::string("ASMMStore4.1")); #endif @@ -9430,12 +9430,12 @@ template bool srcTermProcessingExplicitZero = false; if (srcTermProcessingArg && *srcTermProcessingArg==0) srcTermProcessingExplicitZero = true; - + // prepare srcTermProcessingExplicitPositive bool srcTermProcessingExplicitPositive = false; if (srcTermProcessingArg && *srcTermProcessingArg>0) srcTermProcessingExplicitPositive = true; - + // tansform "run distribution" into nb-vectors vector,SeqIndex > > sendnbVector; vector,SeqIndex > > recvnbVector; @@ -9475,7 +9475,7 @@ template #endif } #endif - + #ifdef ASMM_STORE_MEMLOG_on VM::logMemInfo(std::string("ASMMStore4.4")); #endif @@ -10006,11 +10006,11 @@ template int sparseMatMulStoreNbVectors( #endif // force vectors out of scope by swapping with empty vector, to free memory vector,SeqIndex > > ().swap(dstLinSeqVect[j]); - + #ifdef ASMM_STORE_MEMLOG_on VM::logMemInfo(std::string("ASMMStoreNbVectors4.0")); #endif - + #ifdef USE_MALLOC_TRIM { int mtrim = malloc_trim(0); @@ -10021,7 +10021,7 @@ template int sparseMatMulStoreNbVectors( #endif } #endif - + #ifdef ASMM_STORE_MEMLOG_on VM::logMemInfo(std::string("ASMMStoreNbVectors4.1")); #endif @@ -10087,7 +10087,7 @@ template int sparseMatMulStoreNbVectors( { std::stringstream msg; msg << "ASMM_STORE_LOG:" << __LINE__ << - " dstTensorContigLength: " << dstTensorContigLength << + " dstTensorContigLength: " << dstTensorContigLength << " vectorLength: " << vectorLength << " decompSeqIndex: " << decompSeqIndex; ESMC_LogDefault.Write(msg.str(), ESMC_LOGMSG_DEBUG); @@ -10236,7 +10236,7 @@ template int sparseMatMulStoreNbVectors( // garbage collection delete [] recvnbPartnerDeList; delete [] recvnbPartnerDeCount; - + #ifdef ASMM_STORE_TIMING_on VMK::wtime(&t9e); //gjt - profile // printf("gjt - profile for PET %d, j-loop %d:\n" @@ -10260,11 +10260,11 @@ template int sparseMatMulStoreNbVectors( #endif } #endif - + #ifdef ASMM_STORE_MEMLOG_on VM::logMemInfo(std::string("ASMMStoreNbVectors6.0")); #endif - + // determine send pattern for all localDEs on src side for (int j=0; j int sparseMatMulStoreNbVectors( ++iCount; // increment counter } } - + #ifdef ASMM_STORE_MEMLOG_on VM::logMemInfo(std::string("ASMMStoreNbVectors6.1")); #endif @@ -10300,7 +10300,7 @@ template int sparseMatMulStoreNbVectors( ESMC_LogDefault.Write(msg.str(), ESMC_LOGMSG_DEBUG); } #endif - + int *index2Ref2 = new int[localDeFactorCount]; // large enough int *factorIndexRef = new int[localDeFactorCount]; // large enough int *partnerDeRef = new int[localDeFactorCount]; // large enough @@ -10431,11 +10431,11 @@ template int sparseMatMulStoreNbVectors( // force vectors out of scope by swapping with empty vector, to free memory vector,SeqIndex > > ().swap(srcLinSeqVect[j]); - + #ifdef ASMM_STORE_MEMLOG_on VM::logMemInfo(std::string("ASMMStoreNbVectors8.0")); #endif - + #ifdef USE_MALLOC_TRIM { int mtrim = malloc_trim(0); @@ -10446,7 +10446,7 @@ template int sparseMatMulStoreNbVectors( #endif } #endif - + #ifdef ASMM_STORE_MEMLOG_on VM::logMemInfo(std::string("ASMMStoreNbVectors8.1")); #endif @@ -10508,7 +10508,7 @@ template int sparseMatMulStoreNbVectors( { std::stringstream msg; msg << "ASMM_STORE_LOG:" << __LINE__ << - " srcTensorContigLength: " << srcTensorContigLength << + " srcTensorContigLength: " << srcTensorContigLength << " vectorLength: " << vectorLength << " decompSeqIndex: " << decompSeqIndex; ESMC_LogDefault.Write(msg.str(), ESMC_LOGMSG_DEBUG); @@ -10620,7 +10620,7 @@ template int sparseMatMulStoreNbVectors( for (unsigned k=0; k int sparseMatMulStoreNbVectors( sendnbVector[ii].srcInfoTable.swap(srcInfoTable[i]); if (srcTermProcessingExplicitZero){ // the srcInfoTable is no longer needed under this condition - vector,SeqIndex > > + vector,SeqIndex > > ().swap(sendnbVector[ii].srcInfoTable); } sendnbVector[ii].linIndexContigBlockList.swap(linIndexContigBlockList); @@ -10689,9 +10689,9 @@ template int sparseMatMulStoreNbVectors( for (int k=0; k int sparseMatMulStoreEncodeXXE( vectorLength, xxe); if (ESMC_LogDefault.MsgFoundError(localrc, ESMCI_ERR_PASSTHRU, ESMC_CONTEXT, &rc)) return rc; - + #ifdef USE_MALLOC_TRIM { int mtrim = malloc_trim(0); @@ -11403,7 +11403,7 @@ template int sparseMatMulStoreEncodeXXE( #endif } #endif - + #ifdef ASMM_STORE_MEMLOG_on VM::logMemInfo(std::string("ASMMStoreEncodeXXE10.1")); #endif @@ -12058,7 +12058,7 @@ int Array::sparseMatMul( ESMC_LOGMSG_WARN); ESMC_LogDefault.Write("!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!", ESMC_LOGMSG_WARN); - + // check that srcArray's typekind matches if (srcArrayFlag && (xxe->typekind[1] != srcArray->getTypekind())){ ESMC_LogDefault.MsgFoundError(ESMC_RC_ARG_INCOMP, From 5680d0a8bec11928e6de8ecb8a676c6bc6413322 Mon Sep 17 00:00:00 2001 From: Gerhard Theurich Date: Thu, 31 Aug 2023 15:37:09 -0700 Subject: [PATCH 02/14] White space clean-up. --- .../Array/tests/ESMF_ArrayCreateGetUTest.F90 | 194 +++++++++--------- 1 file changed, 97 insertions(+), 97 deletions(-) diff --git a/src/Infrastructure/Array/tests/ESMF_ArrayCreateGetUTest.F90 b/src/Infrastructure/Array/tests/ESMF_ArrayCreateGetUTest.F90 index fd8bfb043f..c67c7762f2 100644 --- a/src/Infrastructure/Array/tests/ESMF_ArrayCreateGetUTest.F90 +++ b/src/Infrastructure/Array/tests/ESMF_ArrayCreateGetUTest.F90 @@ -13,7 +13,7 @@ program ESMF_ArrayCreateGetUTest !------------------------------------------------------------------------------ - + #include "ESMF_Macros.inc" #include "ESMF.h" @@ -87,18 +87,18 @@ program ESMF_ArrayCreateGetUTest !------------------------------------------------------------------------------- ! The unit tests are divided into Sanity and Exhaustive. The Sanity tests are -! always run. When the environment variable, EXHAUSTIVE, is set to ON then +! always run. When the environment variable, EXHAUSTIVE, is set to ON then ! the EXHAUSTIVE and sanity tests both run. If the EXHAUSTIVE variable is set ! to OFF, then only the sanity unit tests. ! Special strings (Non-exhaustive and exhaustive) have been ! added to allow a script to count the number and types of unit tests. -!------------------------------------------------------------------------------- +!------------------------------------------------------------------------------- !------------------------------------------------------------------------ call ESMF_TestStart(ESMF_SRCLINE, rc=rc) ! calls ESMF_Initialize() internally if (rc /= ESMF_SUCCESS) call ESMF_Finalize(endflag=ESMF_END_ABORT) !------------------------------------------------------------------------ - + !------------------------------------------------------------------------ ! preparations call ESMF_VMGetGlobal(vm, rc=rc) @@ -106,7 +106,7 @@ program ESMF_ArrayCreateGetUTest call ESMF_VMGet(vm, localPet=localPet, petCount=petCount, & ssiSharedMemoryEnabledFlag=ssiSharedMemoryEnabled, rc=rc) if (rc /= ESMF_SUCCESS) call ESMF_Finalize(endflag=ESMF_END_ABORT) - + !------------------------------------------------------------------------ ! this unit test requires to be run on exactly 4 PETs if (petCount /= 4) goto 10 @@ -134,7 +134,7 @@ program ESMF_ArrayCreateGetUTest regDecomp=regDecomp, rc=rc) if (rc /= ESMF_SUCCESS) call ESMF_Finalize(endflag=ESMF_END_ABORT) deallocate(regDecomp) - + !------------------------------------------------------------------------ !NEX_UTest_Multi_Proc_Only write(name, *) "Create test Array for IsCreated" @@ -185,7 +185,7 @@ program ESMF_ArrayCreateGetUTest array = ESMF_ArrayCreate(typekind=ESMF_TYPEKIND_R8, distgrid=distgrid, & indexflag=ESMF_INDEX_GLOBAL, name="MyArray", rc=rc) call ESMF_Test((rc.eq.ESMF_SUCCESS), name, failMsg, result, ESMF_SRCLINE) - + !------------------------------------------------------------------------ !NEX_UTest_Multi_Proc_Only write(name, *) "Array equality before assignment Test" @@ -201,7 +201,7 @@ program ESMF_ArrayCreateGetUTest arrayAlias = array arrayBool = (arrayAlias.eq.array) call ESMF_Test(arrayBool, name, failMsg, result, ESMF_SRCLINE) - + !------------------------------------------------------------------------ !NEX_UTest_Multi_Proc_Only write(name, *) "ArrayDestroy Test" @@ -240,7 +240,7 @@ program ESMF_ArrayCreateGetUTest indexflag=ESMF_INDEX_GLOBAL, undistLBound=(/0/), undistUBound=(/2,2/), & name="MyArray", rc=rc) call ESMF_Test((rc.ne.ESMF_SUCCESS), name, failMsg, result, ESMF_SRCLINE) - + !------------------------------------------------------------------------ !NEX_UTest_Multi_Proc_Only write(name, *) "ArrayCreate Allocate 2D ESMF_TYPEKIND_R8 Test" @@ -248,7 +248,7 @@ program ESMF_ArrayCreateGetUTest array = ESMF_ArrayCreate(typekind=ESMF_TYPEKIND_R8, distgrid=distgrid, & indexflag=ESMF_INDEX_GLOBAL, name="MyArray", rc=rc) call ESMF_Test((rc.eq.ESMF_SUCCESS), name, failMsg, result, ESMF_SRCLINE) - + !------------------------------------------------------------------------ !NEX_UTest_Multi_Proc_Only write(name, *) "ArraySet Test" @@ -284,7 +284,7 @@ program ESMF_ArrayCreateGetUTest array = ESMF_ArrayCreate(arrayspec=arrayspec, distgrid=distgrid, & indexflag=ESMF_INDEX_GLOBAL, name="MyArray with ArraySpec", rc=rc) call ESMF_Test((rc.eq.ESMF_SUCCESS), name, failMsg, result, ESMF_SRCLINE) - + !------------------------------------------------------------------------ !NEX_UTest_Multi_Proc_Only write(name, *) "ArrayPrint 2D ESMF_TYPEKIND_R8 Test" @@ -299,26 +299,26 @@ program ESMF_ArrayCreateGetUTest call ESMF_ArrayGet(array, arrayspec=arrayspec2, name=arrayName, rc=rc) print *, "Array name: ", arrayname call ESMF_Test((rc.eq.ESMF_SUCCESS), name, failMsg, result, ESMF_SRCLINE) - + !------------------------------------------------------------------------ !NEX_UTest_Multi_Proc_Only write(name, *) "Verify ArraySpec returned from Array" write(failMsg, *) "Incorrect ArraySpec" call ESMF_Test((arrayspec2==arrayspec), name, failMsg, result, ESMF_SRCLINE) - + !------------------------------------------------------------------------ !NEX_UTest_Multi_Proc_Only write(name, *) "Verify name returned from Array" write(failMsg, *) "Incorrect name" call ESMF_Test((trim(arrayName)=="MyArray with ArraySpec"), name, failMsg, result, ESMF_SRCLINE) - + !------------------------------------------------------------------------ !NEX_UTest_Multi_Proc_Only write(name, *) "ArrayGet Fortran array pointer, 2D ESMF_TYPEKIND_R8 Test" write(failMsg, *) "Did not return ESMF_SUCCESS" call ESMF_ArrayGet(array, farrayPtr=farrayPtr2D, rc=rc) call ESMF_Test((rc.eq.ESMF_SUCCESS), name, failMsg, result, ESMF_SRCLINE) - + !------------------------------------------------------------------------ !NEX_UTest_Multi_Proc_Only write(name, *) "Getting Attribute count from an Array" @@ -331,14 +331,14 @@ program ESMF_ArrayCreateGetUTest write(name, *) "Verify Attribute count from an Array" write(failMsg, *) "Incorrect count" call ESMF_Test((count.eq.0), name, failMsg, result, ESMF_SRCLINE) - + !------------------------------------------------------------------------ !NEX_UTest_Multi_Proc_Only write(name, *) "ArrayCreate from Copy, uninitialized Array Test" write(failMsg, *) "Incorrectly returned ESMF_SUCCESS" arrayCpy = ESMF_ArrayCreate(arrayUnInit, rc=rc) call ESMF_Test((rc /= ESMF_SUCCESS), name, failMsg, result, ESMF_SRCLINE) - + !------------------------------------------------------------------------ !NEX_UTest_Multi_Proc_Only write(name, *) "ArrayCreate from Copy (ALLOC), 2D ESMF_TYPEKIND_R8 Test" @@ -346,7 +346,7 @@ program ESMF_ArrayCreateGetUTest farrayPtr2D = real(localPet+10, ESMF_KIND_R8) ! fill with data to check arrayCpy = ESMF_ArrayCreate(array, datacopyflag=ESMF_DATACOPY_ALLOC, rc=rc) call ESMF_Test((rc.eq.ESMF_SUCCESS), name, failMsg, result, ESMF_SRCLINE) - + !------------------------------------------------------------------------ !NEX_UTest_Multi_Proc_Only write(name, *) "ArrayGet arrayspec from Array Copy (ALLOC) Test" @@ -354,20 +354,20 @@ program ESMF_ArrayCreateGetUTest call ESMF_ArrayGet(arrayCpy, arrayspec=arrayspec2, name=arrayName, rc=rc) print *, "Array name: ", arrayname call ESMF_Test((rc.eq.ESMF_SUCCESS), name, failMsg, result, ESMF_SRCLINE) - + !------------------------------------------------------------------------ !NEX_UTest_Multi_Proc_Only write(name, *) "Verify ArraySpec returned from Array (ALLOC) Copy" write(failMsg, *) "Incorrect ArraySpec" call ESMF_Test((arrayspec2==arrayspec), name, failMsg, result, ESMF_SRCLINE) - + !------------------------------------------------------------------------ !NEX_UTest_Multi_Proc_Only write(name, *) "ArrayGet Fortran array pointer, from Array Copy (ALLOC) Test" write(failMsg, *) "Did not return ESMF_SUCCESS" call ESMF_ArrayGet(arrayCpy, farrayPtr=farrayPtr2DCpy, rc=rc) call ESMF_Test((rc.eq.ESMF_SUCCESS), name, failMsg, result, ESMF_SRCLINE) - + !------------------------------------------------------------------------ !NEX_UTest_Multi_Proc_Only write(name, *) "Verify Array vs Array Copy (ALLOC) no data copy" @@ -408,14 +408,14 @@ program ESMF_ArrayCreateGetUTest write(failMsg, *) "Did not return ESMF_SUCCESS" call ESMF_ArrayDestroy(array, rc=rc) call ESMF_Test((rc.eq.ESMF_SUCCESS), name, failMsg, result, ESMF_SRCLINE) - + !------------------------------------------------------------------------ !NEX_UTest_Multi_Proc_Only write(name, *) "ArrayPrint from Copy (ALLOC) after original destroy, 2D ESMF_TYPEKIND_R8 Test" write(failMsg, *) "Did not return ESMF_SUCCESS" call ESMF_ArrayPrint(arrayCpy, rc=rc) call ESMF_Test((rc.eq.ESMF_SUCCESS), name, failMsg, result, ESMF_SRCLINE) - + !------------------------------------------------------------------------ !NEX_UTest_Multi_Proc_Only write(name, *) "ArrayDestroy of Copy (ALLOC) Test" @@ -430,14 +430,14 @@ program ESMF_ArrayCreateGetUTest array = ESMF_ArrayCreate(arrayspec=arrayspec, distgrid=distgrid, & indexflag=ESMF_INDEX_GLOBAL, name="MyArray with ArraySpec", rc=rc) call ESMF_Test((rc.eq.ESMF_SUCCESS), name, failMsg, result, ESMF_SRCLINE) - + !------------------------------------------------------------------------ !NEX_UTest_Multi_Proc_Only write(name, *) "ArrayGet Fortran array pointer, 2D ESMF_TYPEKIND_R8 Test" write(failMsg, *) "Did not return ESMF_SUCCESS" call ESMF_ArrayGet(array, farrayPtr=farrayPtr2D, rc=rc) call ESMF_Test((rc.eq.ESMF_SUCCESS), name, failMsg, result, ESMF_SRCLINE) - + !------------------------------------------------------------------------ !NEX_UTest_Multi_Proc_Only write(name, *) "ArrayCreate from Copy (VALUE), 2D ESMF_TYPEKIND_R8 Test" @@ -453,7 +453,7 @@ program ESMF_ArrayCreateGetUTest call ESMF_ArrayGet(arrayCpy, isESMFAllocated=isESMFAllocated, rc=rc) print *, "Array is allocated internally: ", isESMFAllocated call ESMF_Test(isESMFAllocated, name, failMsg, result, ESMF_SRCLINE) - + !------------------------------------------------------------------------ !NEX_UTest_Multi_Proc_Only write(name, *) "ArrayGet arrayspec from Array Copy (VALUE) Test" @@ -461,20 +461,20 @@ program ESMF_ArrayCreateGetUTest call ESMF_ArrayGet(arrayCpy, arrayspec=arrayspec2, name=arrayName, rc=rc) print *, "Array name: ", arrayname call ESMF_Test((rc.eq.ESMF_SUCCESS), name, failMsg, result, ESMF_SRCLINE) - + !------------------------------------------------------------------------ !NEX_UTest_Multi_Proc_Only write(name, *) "Verify ArraySpec returned from Array (VALUE) Copy" write(failMsg, *) "Incorrect ArraySpec" call ESMF_Test((arrayspec2==arrayspec), name, failMsg, result, ESMF_SRCLINE) - + !------------------------------------------------------------------------ !NEX_UTest_Multi_Proc_Only write(name, *) "ArrayGet Fortran array pointer, from Array Copy (VALUE) Test" write(failMsg, *) "Did not return ESMF_SUCCESS" call ESMF_ArrayGet(arrayCpy, farrayPtr=farrayPtr2DCpy, rc=rc) call ESMF_Test((rc.eq.ESMF_SUCCESS), name, failMsg, result, ESMF_SRCLINE) - + !------------------------------------------------------------------------ !NEX_UTest_Multi_Proc_Only write(name, *) "Verify Array vs Array Copy (VALUE) data copy" @@ -515,7 +515,7 @@ program ESMF_ArrayCreateGetUTest write(failMsg, *) "Did not return ESMF_SUCCESS" call ESMF_ArrayDestroy(array, rc=rc) call ESMF_Test((rc.eq.ESMF_SUCCESS), name, failMsg, result, ESMF_SRCLINE) - + !------------------------------------------------------------------------ !NEX_UTest_Multi_Proc_Only write(name, *) "ArrayDestroy of Copy (VALUE) Test" @@ -631,7 +631,7 @@ program ESMF_ArrayCreateGetUTest array = ESMF_ArrayCreate(farrayPtr=farrayPtr3D, distgrid=distgrid, & name="MyArray", rc=rc) call ESMF_Test((rc.eq.ESMF_SUCCESS), name, failMsg, result, ESMF_SRCLINE) - + !------------------------------------------------------------------------ !NEX_UTest_Multi_Proc_Only write(name, *) "ArrayPrint for ArrayCreate from Ptr Test" @@ -645,7 +645,7 @@ program ESMF_ArrayCreateGetUTest write(failMsg, *) "Did not return ESMF_SUCCESS" call ESMF_ArrayGet(array, farrayPtr=farrayPtr3Dx, rc=rc) call ESMF_Test((rc.eq.ESMF_SUCCESS), name, failMsg, result, ESMF_SRCLINE) - + !------------------------------------------------------------------------ !NEX_UTest_Multi_Proc_Only write(name, *) "Deallocate returned pointer Test" @@ -668,7 +668,7 @@ program ESMF_ArrayCreateGetUTest array = ESMF_ArrayCreate(farray=farrayPtr3D, distgrid=distgrid, & indexflag=ESMF_INDEX_GLOBAL, name="MyArray", rc=rc) call ESMF_Test((rc.eq.ESMF_SUCCESS), name, failMsg, result, ESMF_SRCLINE) - + !------------------------------------------------------------------------ !NEX_UTest_Multi_Proc_Only write(name, *) "ArrayDestroy Test" @@ -686,7 +686,7 @@ program ESMF_ArrayCreateGetUTest array = ESMF_ArrayCreate(farray=farrayPtr3D, distgrid=distgrid, & indexflag=ESMF_INDEX_GLOBAL, name="MyArray", datacopyflag=ESMF_DATACOPY_VALUE, rc=rc) call ESMF_Test((rc.eq.ESMF_SUCCESS), name, failMsg, result, ESMF_SRCLINE) - + !------------------------------------------------------------------------ !NEX_UTest_Multi_Proc_Only write(name, *) "ArrayDestroy Test" @@ -704,7 +704,7 @@ program ESMF_ArrayCreateGetUTest array = ESMF_ArrayCreate(farrayPtr=farrayPtr3D, distgrid=distgrid, & name="MyArray", datacopyflag=ESMF_DATACOPY_VALUE, rc=rc) call ESMF_Test((rc.eq.ESMF_SUCCESS), name, failMsg, result, ESMF_SRCLINE) - + !------------------------------------------------------------------------ !NEX_UTest_Multi_Proc_Only write(name, *) "ArrayDestroy Test" @@ -723,7 +723,7 @@ program ESMF_ArrayCreateGetUTest distgridToArrayMap=(/2,1/), computationalLWidth=(/0,5/), & indexflag=ESMF_INDEX_GLOBAL, name="MyArray", rc=rc) call ESMF_Test((rc.eq.ESMF_SUCCESS), name, failMsg, result, ESMF_SRCLINE) - + !------------------------------------------------------------------------ !NEX_UTest_Multi_Proc_Only write(name, *) "ArrayDestroy Test" @@ -740,7 +740,7 @@ program ESMF_ArrayCreateGetUTest indexflag=ESMF_INDEX_GLOBAL, computationalLWidth=(/-1,-1/), & computationalUWidth=(/-2,-3/), name="MyArray Negative", rc=rc) call ESMF_Test((rc.eq.ESMF_SUCCESS), name, failMsg, result, ESMF_SRCLINE) - + !------------------------------------------------------------------------ !NEX_UTest_Multi_Proc_Only write(name, *) "ArrayPrint 2D ESMF_TYPEKIND_R8 w/ computational widths Test" @@ -754,7 +754,7 @@ program ESMF_ArrayCreateGetUTest write(failMsg, *) "Did not return ESMF_SUCCESS" call ESMF_ArrayDestroy(array, rc=rc) call ESMF_Test((rc.eq.ESMF_SUCCESS), name, failMsg, result, ESMF_SRCLINE) - + !------------------------------------------------------------------------ !NEX_UTest_Multi_Proc_Only write(name, *) "ArrayCreate Allocate 2D ESMF_TYPEKIND_R8 w/ computationalEdge widths Test" @@ -763,7 +763,7 @@ program ESMF_ArrayCreateGetUTest indexflag=ESMF_INDEX_GLOBAL, computationalEdgeLWidth=(/0,-1/), & computationalEdgeUWidth=(/-2,+1/), name="MyArray Negative Edge", rc=rc) call ESMF_Test((rc.eq.ESMF_SUCCESS), name, failMsg, result, ESMF_SRCLINE) - + !------------------------------------------------------------------------ !NEX_UTest_Multi_Proc_Only write(name, *) "ArrayPrint 2D ESMF_TYPEKIND_R8 w/ computationalEdge widths Test" @@ -802,7 +802,7 @@ program ESMF_ArrayCreateGetUTest write(failMsg, *) "Did not return ESMF_SUCCESS" call ESMF_ArrayDestroy(array, rc=rc) call ESMF_Test((rc.eq.ESMF_SUCCESS), name, failMsg, result, ESMF_SRCLINE) - + !------------------------------------------------------------------------ !NEX_UTest_Multi_Proc_Only write(name, *) "ArrayCreate Allocate 2D ESMF_TYPEKIND_R8 w/ computationalEdge and total widths Test" @@ -812,7 +812,7 @@ program ESMF_ArrayCreateGetUTest computationalEdgeUWidth=(/-2,+1/), totalLWidth=(/1,2/), totalUWidth=(/3,4/),& name="MyArray Negative Edge", rc=rc) call ESMF_Test((rc.eq.ESMF_SUCCESS), name, failMsg, result, ESMF_SRCLINE) - + !------------------------------------------------------------------------ !NEX_UTest_Multi_Proc_Only write(name, *) "ArrayPrint 2D ESMF_TYPEKIND_R8 w/ computationalEdge and total widths Test" @@ -861,7 +861,7 @@ program ESMF_ArrayCreateGetUTest call ESMF_Test((totalLBound(1,1)==8.and.totalLBound(2,1)==11.and.& totalUBound(1,1)==18.and.totalUBound(2,1)==27), & name, failMsg, result, ESMF_SRCLINE) - endif + endif deallocate(totalLBound, totalUBound) !------------------------------------------------------------------------ @@ -870,7 +870,7 @@ program ESMF_ArrayCreateGetUTest write(failMsg, *) "Did not return ESMF_SUCCESS" call ESMF_ArrayDestroy(array, rc=rc) call ESMF_Test((rc.eq.ESMF_SUCCESS), name, failMsg, result, ESMF_SRCLINE) - + !------------------------------------------------------------------------ !NEX_UTest_Multi_Proc_Only write(name, *) "Create test Array with ESMF_PIN_DE_TO_PET" @@ -886,7 +886,7 @@ program ESMF_ArrayCreateGetUTest write(failMsg, *) "Did not return ESMF_SUCCESS" call ESMF_ArrayGet(array, farrayPtr=farrayPtr2D, rc=rc) call ESMF_Test((rc.eq.ESMF_SUCCESS), name, failMsg, result, ESMF_SRCLINE) - + write (msg,*) "Local Array lbounds=", lbound(farrayPtr2D) call ESMF_LogWrite(msg, ESMF_LOGMSG_INFO, rc=rc) if (rc /= ESMF_SUCCESS) call ESMF_Finalize(endflag=ESMF_END_ABORT) @@ -950,7 +950,7 @@ program ESMF_ArrayCreateGetUTest endif allocate(localDeToDeMap(ssiLocalDeCount)) allocate(localArrayList(ssiLocalDeCount)) - + !------------------------------------------------------------------------ !NEX_UTest_Multi_Proc_Only write(name, *) "ArrayGet localDeToDeMap ESMF_PIN_DE_TO_SSI Test" @@ -966,14 +966,14 @@ program ESMF_ArrayCreateGetUTest write(failMsg, *) "Did not return the correct RC" call ESMF_Test((rc.eq.ESMF_RC_OBJ_NOT_CREATED), name, failMsg, result, ESMF_SRCLINE) endif - + !------------------------------------------------------------------------ ! initialize the data on this PETs first localDE if (ssiSharedMemoryEnabled) then farrayPtr2D(:,:) = localDeToDeMap(1) endif !------------------------------------------------------------------------ - + !------------------------------------------------------------------------ !NEX_UTest_Multi_Proc_Only write(name, *) "ArraySync() for ESMF_PIN_DE_TO_SSI Test" @@ -985,7 +985,7 @@ program ESMF_ArrayCreateGetUTest write(failMsg, *) "Did not return the correct RC" call ESMF_Test((rc.eq.ESMF_RC_OBJ_NOT_CREATED), name, failMsg, result, ESMF_SRCLINE) endif - + !------------------------------------------------------------------------ !NEX_UTest_Multi_Proc_Only write(name, *) "LocalArrayGet Fortran array pointer for last ssiLocalDe for ESMF_PIN_DE_TO_SSI Test" @@ -1027,7 +1027,7 @@ program ESMF_ArrayCreateGetUTest call ESMF_ArraySync(array, rc=rc) ! prevent race condition with below if (rc /= ESMF_SUCCESS) call ESMF_Finalize(endflag=ESMF_END_ABORT) - + deallocate(localDeToDeMap) deallocate(localArrayList) @@ -1078,7 +1078,7 @@ program ESMF_ArrayCreateGetUTest endif allocate(localDeToDeMap(ssiLocalDeCount)) allocate(localArrayList(ssiLocalDeCount)) - + !------------------------------------------------------------------------ !NEX_UTest_Multi_Proc_Only write(name, *) "ArrayGet localDeToDeMap ESMF_PIN_DE_TO_SSI arrayCpy Test" @@ -1094,14 +1094,14 @@ program ESMF_ArrayCreateGetUTest write(failMsg, *) "Did not return the correct RC" call ESMF_Test((rc.eq.ESMF_RC_OBJ_NOT_CREATED), name, failMsg, result, ESMF_SRCLINE) endif - + !------------------------------------------------------------------------ ! initialize the data on this PETs first localDE if (ssiSharedMemoryEnabled) then farrayPtr2D(:,:) = localDeToDeMap(1) * 10 endif !------------------------------------------------------------------------ - + !------------------------------------------------------------------------ !NEX_UTest_Multi_Proc_Only write(name, *) "ArraySync() for ESMF_PIN_DE_TO_SSI arrayCpy Test" @@ -1113,7 +1113,7 @@ program ESMF_ArrayCreateGetUTest write(failMsg, *) "Did not return the correct RC" call ESMF_Test((rc.eq.ESMF_RC_OBJ_NOT_CREATED), name, failMsg, result, ESMF_SRCLINE) endif - + !------------------------------------------------------------------------ !NEX_UTest_Multi_Proc_Only write(name, *) "LocalArrayGet Fortran array pointer for last ssiLocalDe for ESMF_PIN_DE_TO_SSI arrayCpy Test" @@ -1155,7 +1155,7 @@ program ESMF_ArrayCreateGetUTest call ESMF_ArraySync(arrayCpy, rc=rc) ! prevent race condition with below if (rc /= ESMF_SUCCESS) call ESMF_Finalize(endflag=ESMF_END_ABORT) - + deallocate(localDeToDeMap) deallocate(localArrayList) @@ -1210,7 +1210,7 @@ program ESMF_ArrayCreateGetUTest endif allocate(localDeToDeMap(ssiLocalDeCount)) allocate(localArrayList(ssiLocalDeCount)) - + !------------------------------------------------------------------------ !NEX_UTest_Multi_Proc_Only write(name, *) "ArrayGet localDeToDeMap ESMF_PIN_DE_TO_SSI arrayCpy Test" @@ -1226,7 +1226,7 @@ program ESMF_ArrayCreateGetUTest write(failMsg, *) "Did not return the correct RC" call ESMF_Test((rc.eq.ESMF_RC_OBJ_NOT_CREATED), name, failMsg, result, ESMF_SRCLINE) endif - + !------------------------------------------------------------------------ !NEX_UTest_Multi_Proc_Only write(name, *) "Test data in LocalArray for last ssiLocalDe for ESMF_PIN_DE_TO_SSI arrayCpy Test" @@ -1254,7 +1254,7 @@ program ESMF_ArrayCreateGetUTest call ESMF_ArraySync(arrayCpy, rc=rc) ! prevent race condition with below if (rc /= ESMF_SUCCESS) call ESMF_Finalize(endflag=ESMF_END_ABORT) - + deallocate(localDeToDeMap) deallocate(localArrayList) @@ -1269,7 +1269,7 @@ program ESMF_ArrayCreateGetUTest write(failMsg, *) "Did not return the correct RC" call ESMF_Test((rc.eq.ESMF_RC_OBJ_NOT_CREATED), name, failMsg, result, ESMF_SRCLINE) endif - + !------------------------------------------------------------------------ !NEX_UTest_Multi_Proc_Only write(name, *) "ArrayDestroy Test for arrayCpy with ESMF_PIN_DE_TO_SSI w/ DELayout" @@ -1295,15 +1295,15 @@ program ESMF_ArrayCreateGetUTest endif !------------------------------------------------------------------------ - ! cleanup + ! cleanup call ESMF_DistGridDestroy(distgrid, rc=rc) if (rc /= ESMF_SUCCESS) call ESMF_Finalize(endflag=ESMF_END_ABORT) - + !------------------------------------------------------------------------ ! preparations distgrid = ESMF_DistGridCreate(minIndex=(/1/), maxIndex=(/40/), rc=rc) if (rc /= ESMF_SUCCESS) call ESMF_Finalize(endflag=ESMF_END_ABORT) - + !------------------------------------------------------------------------ !NEX_UTest_Multi_Proc_Only write(name, *) "ArrayCreate AssmdShape 1D ESMF_TYPEKIND_R8 Test" @@ -1311,21 +1311,21 @@ program ESMF_ArrayCreateGetUTest array = ESMF_ArrayCreate(farray=farray1D, distgrid=distgrid, & indexflag=ESMF_INDEX_DELOCAL, rc=rc) call ESMF_Test((rc.eq.ESMF_SUCCESS), name, failMsg, result, ESMF_SRCLINE) - + !------------------------------------------------------------------------ !NEX_UTest_Multi_Proc_Only write(name, *) "ArrayGet Fortran array pointer, 1D ESMF_TYPEKIND_R8 Test" write(failMsg, *) "Did not return ESMF_SUCCESS" call ESMF_ArrayGet(array, farrayPtr=farrayPtr1D, rc=rc) call ESMF_Test((rc.eq.ESMF_SUCCESS), name, failMsg, result, ESMF_SRCLINE) - + !------------------------------------------------------------------------ !NEX_UTest_Multi_Proc_Only write(name, *) "ArrayGet w/ incompatible Fortran array pointer, 1D ESMF_TYPEKIND_R8 Test" write(failMsg, *) "Did return ESMF_SUCCESS" call ESMF_ArrayGet(array, farrayPtr=farrayPtr2D, rc=rc) call ESMF_Test((rc.ne.ESMF_SUCCESS), name, failMsg, result, ESMF_SRCLINE) - + !------------------------------------------------------------------------ !NEX_UTest_Multi_Proc_Only write(name, *) "ArrayPrint AssmdShape 1D ESMF_TYPEKIND_R8 Test" @@ -1339,7 +1339,7 @@ program ESMF_ArrayCreateGetUTest write(failMsg, *) "Did not return ESMF_SUCCESS" call ESMF_ArrayDestroy(array, rc=rc) call ESMF_Test((rc.eq.ESMF_SUCCESS), name, failMsg, result, ESMF_SRCLINE) - + !------------------------------------------------------------------------ !NEX_UTest_Multi_Proc_Only write(name, *) "ArrayCreate AssmdShape 1D ESMF_TYPEKIND_R8 w/ negative computationalEdge widths Test" @@ -1348,7 +1348,7 @@ program ESMF_ArrayCreateGetUTest indexflag=ESMF_INDEX_DELOCAL, computationalEdgeLWidth=(/-1/), & computationalEdgeUWidth=(/-1/), rc=rc) call ESMF_Test((rc.eq.ESMF_SUCCESS), name, failMsg, result, ESMF_SRCLINE) - + !------------------------------------------------------------------------ !NEX_UTest_Multi_Proc_Only write(name, *) "ArrayPrint AssmdShape 1D ESMF_TYPEKIND_R8 w/ negative computationalEdge widths Test" @@ -1362,18 +1362,18 @@ program ESMF_ArrayCreateGetUTest write(failMsg, *) "Did not return ESMF_SUCCESS" call ESMF_ArrayDestroy(array, rc=rc) call ESMF_Test((rc.eq.ESMF_SUCCESS), name, failMsg, result, ESMF_SRCLINE) - + !------------------------------------------------------------------------ - ! cleanup + ! cleanup call ESMF_DistGridDestroy(distgrid, rc=rc) if (rc /= ESMF_SUCCESS) call ESMF_Finalize(endflag=ESMF_END_ABORT) - + !------------------------------------------------------------------------ ! preparations distgrid = ESMF_DistGridCreate(minIndex=(/1,1/), maxIndex=(/40,10/), & regDecomp=(/petCount,1/), rc=rc) if (rc /= ESMF_SUCCESS) call ESMF_Finalize(endflag=ESMF_END_ABORT) - + !------------------------------------------------------------------------ !NEX_UTest_Multi_Proc_Only write(name, *) "ArrayCreate AssmdShape 2D ESMF_TYPEKIND_R8 Test" @@ -1381,39 +1381,39 @@ program ESMF_ArrayCreateGetUTest array = ESMF_ArrayCreate(farray=farray2D, distgrid=distgrid, & indexflag=ESMF_INDEX_DELOCAL, rc=rc) call ESMF_Test((rc.eq.ESMF_SUCCESS), name, failMsg, result, ESMF_SRCLINE) - + !------------------------------------------------------------------------ !NEX_UTest_Multi_Proc_Only write(name, *) "ArrayGet Fortran array pointer, 2D ESMF_TYPEKIND_R8 Test" write(failMsg, *) "Did not return ESMF_SUCCESS" call ESMF_ArrayGet(array, farrayPtr=farrayPtr2D, rc=rc) call ESMF_Test((rc.eq.ESMF_SUCCESS), name, failMsg, result, ESMF_SRCLINE) - + !------------------------------------------------------------------------ !NEX_UTest_Multi_Proc_Only write(name, *) "ArrayGet w/ incompatible Fortran array pointer, 2D ESMF_TYPEKIND_R8 Test" write(failMsg, *) "Did return ESMF_SUCCESS" call ESMF_ArrayGet(array, farrayPtr=farrayPtr3D, rc=rc) call ESMF_Test((rc.ne.ESMF_SUCCESS), name, failMsg, result, ESMF_SRCLINE) - + !------------------------------------------------------------------------ !NEX_UTest_Multi_Proc_Only write(name, *) "ArrayDestroy Test" write(failMsg, *) "Did not return ESMF_SUCCESS" call ESMF_ArrayDestroy(array, rc=rc) call ESMF_Test((rc.eq.ESMF_SUCCESS), name, failMsg, result, ESMF_SRCLINE) - + !------------------------------------------------------------------------ - ! cleanup + ! cleanup call ESMF_DistGridDestroy(distgrid, rc=rc) if (rc /= ESMF_SUCCESS) call ESMF_Finalize(endflag=ESMF_END_ABORT) - + !------------------------------------------------------------------------ ! preparations distgrid = ESMF_DistGridCreate(minIndex=(/1,1,1/), maxIndex=(/40,10,10/), & regDecomp=(/petCount,1,1/), rc=rc) if (rc /= ESMF_SUCCESS) call ESMF_Finalize(endflag=ESMF_END_ABORT) - + !------------------------------------------------------------------------ !NEX_UTest_Multi_Proc_Only write(name, *) "ArrayCreate AssmdShape 3D ESMF_TYPEKIND_R4 Test" @@ -1421,32 +1421,32 @@ program ESMF_ArrayCreateGetUTest array = ESMF_ArrayCreate(farray=farray3D, distgrid=distgrid, & indexflag=ESMF_INDEX_DELOCAL, rc=rc) call ESMF_Test((rc.eq.ESMF_SUCCESS), name, failMsg, result, ESMF_SRCLINE) - + !------------------------------------------------------------------------ !NEX_UTest_Multi_Proc_Only write(name, *) "ArrayGet Fortran array pointer, 3D ESMF_TYPEKIND_R4 Test" write(failMsg, *) "Did not return ESMF_SUCCESS" call ESMF_ArrayGet(array, farrayPtr=farrayPtr3D, rc=rc) call ESMF_Test((rc.eq.ESMF_SUCCESS), name, failMsg, result, ESMF_SRCLINE) - + !------------------------------------------------------------------------ !NEX_UTest_Multi_Proc_Only write(name, *) "ArrayDestroy Test" write(failMsg, *) "Did not return ESMF_SUCCESS" call ESMF_ArrayDestroy(array, rc=rc) call ESMF_Test((rc.eq.ESMF_SUCCESS), name, failMsg, result, ESMF_SRCLINE) - + !------------------------------------------------------------------------ - ! cleanup + ! cleanup call ESMF_DistGridDestroy(distgrid, rc=rc) if (rc /= ESMF_SUCCESS) call ESMF_Finalize(endflag=ESMF_END_ABORT) - + !------------------------------------------------------------------------ ! preparations distgrid = ESMF_DistGridCreate(minIndex=(/1,1,1,1/), & maxIndex=(/40,10,10,10/), regDecomp=(/petCount,1,1,1/), rc=rc) if (rc /= ESMF_SUCCESS) call ESMF_Finalize(endflag=ESMF_END_ABORT) - + !------------------------------------------------------------------------ !NEX_UTest_Multi_Proc_Only write(name, *) "ArrayCreate AssmdShape 4D ESMF_TYPEKIND_I4 Test" @@ -1454,14 +1454,14 @@ program ESMF_ArrayCreateGetUTest array = ESMF_ArrayCreate(farray=farray4D, distgrid=distgrid, & indexflag=ESMF_INDEX_DELOCAL, rc=rc) call ESMF_Test((rc.eq.ESMF_SUCCESS), name, failMsg, result, ESMF_SRCLINE) - + !------------------------------------------------------------------------ !NEX_UTest_Multi_Proc_Only write(name, *) "ArrayGet Fortran array pointer, 4D ESMF_TYPEKIND_I4 Test" write(failMsg, *) "Did not return ESMF_SUCCESS" call ESMF_ArrayGet(array, farrayPtr=farrayPtr4D, rc=rc) call ESMF_Test((rc.eq.ESMF_SUCCESS), name, failMsg, result, ESMF_SRCLINE) - + !------------------------------------------------------------------------ !NEX_UTest_Multi_Proc_Only write(name, *) "ArrayDestroy Test" @@ -1470,10 +1470,10 @@ program ESMF_ArrayCreateGetUTest call ESMF_Test((rc.eq.ESMF_SUCCESS), name, failMsg, result, ESMF_SRCLINE) !------------------------------------------------------------------------ - ! cleanup + ! cleanup call ESMF_DistGridDestroy(distgrid, rc=rc) if (rc /= ESMF_SUCCESS) call ESMF_Finalize(endflag=ESMF_END_ABORT) - + !------------------------------------------------------------------------ ! prepare a 2D DistGrid distgrid = ESMF_DistGridCreate(minIndex=(/1,1/), maxIndex=(/15,23/), & @@ -1488,7 +1488,7 @@ program ESMF_ArrayCreateGetUTest call ESMF_DistGridGet(distgrid, minIndexPDe=minIndexPDe, & maxIndexPDe=maxIndexPDe, rc=rc) if (rc /= ESMF_SUCCESS) call ESMF_Finalize(endflag=ESMF_END_ABORT) - + do de=0, deCount-1 write (msg,*) "DistGrid DE=",de," minIndexPDe=", minIndexPDe(:,de), & " maxIndexPDe=", maxIndexPDe(:,de) @@ -1497,7 +1497,7 @@ program ESMF_ArrayCreateGetUTest enddo deallocate(minIndexPDe, maxIndexPDe) - + !------------------------------------------------------------------------ ! prepare a 2D DistGrid with with extra edge elements distgrid = ESMF_DistGridCreate(distgrid, & @@ -1512,7 +1512,7 @@ program ESMF_ArrayCreateGetUTest call ESMF_DistGridGet(distgrid, minIndexPDe=minIndexPDe, & maxIndexPDe=maxIndexPDe, rc=rc) if (rc /= ESMF_SUCCESS) call ESMF_Finalize(endflag=ESMF_END_ABORT) - + do de=0, deCount-1 write (msg,*) "DistGrid2 DE=",de," minIndexPDe=", minIndexPDe(:,de), & " maxIndexPDe=", maxIndexPDe(:,de) @@ -1540,7 +1540,7 @@ program ESMF_ArrayCreateGetUTest call ESMF_ArrayGet(array, exclusiveLBound=exclusiveLBound, & exclusiveUBound=exclusiveUBound, localDeToDeMap=localDeToDeMap, rc=rc) if (rc /= ESMF_SUCCESS) call ESMF_Finalize(endflag=ESMF_END_ABORT) - + do lde=0, localDeCount-1 de = localDeToDeMap(lde) write (msg,*) "Array DE=",de," exclusiveLBound=", exclusiveLBound(:,lde), & @@ -1560,7 +1560,7 @@ program ESMF_ArrayCreateGetUTest call ESMF_Test((rc.eq.ESMF_SUCCESS), name, failMsg, result, ESMF_SRCLINE) !------------------------------------------------------------------------ - ! cleanup + ! cleanup call ESMF_DistGridDestroy(distgrid, rc=rc) if (rc /= ESMF_SUCCESS) call ESMF_Finalize(endflag=ESMF_END_ABORT) @@ -1591,7 +1591,7 @@ program ESMF_ArrayCreateGetUTest write(failMsg, *) "Did not return ESMF_SUCCESS" call ESMF_ArrayDestroy(array, rc=rc) call ESMF_Test((rc.eq.ESMF_SUCCESS), name, failMsg, result, ESMF_SRCLINE) - + !------------------------------------------------------------------------ ! prepare Fortran allocations on each PET to match DistGrid if (localPet==0) then @@ -1616,7 +1616,7 @@ program ESMF_ArrayCreateGetUTest call ESMF_Test((rc.eq.ESMF_SUCCESS), name, failMsg, result, ESMF_SRCLINE) !------------------------------------------------------------------------ - ! cleanup + ! cleanup deallocate(farrayPtr1D) call ESMF_DistGridDestroy(distgrid, rc=rc) if (rc /= ESMF_SUCCESS) call ESMF_Finalize(endflag=ESMF_END_ABORT) @@ -1634,7 +1634,7 @@ program ESMF_ArrayCreateGetUTest else allocate(farrayPtr1D(0)) endif - + !------------------------------------------------------------------------ !NEX_UTest_Multi_Proc_Only write(name, *) "Create Array on 4 DE DistGrid with only DE 0 elements, with Fortran allocation" @@ -1651,11 +1651,11 @@ program ESMF_ArrayCreateGetUTest call ESMF_Test((rc.eq.ESMF_SUCCESS), name, failMsg, result, ESMF_SRCLINE) !------------------------------------------------------------------------ - ! cleanup + ! cleanup deallocate(farrayPtr1D) call ESMF_DistGridDestroy(distgrid, rc=rc) if (rc /= ESMF_SUCCESS) call ESMF_Finalize(endflag=ESMF_END_ABORT) - + 10 continue !------------------------------------------------------------------------ call ESMF_TestEnd(ESMF_SRCLINE) ! calls ESMF_Finalize() internally From 39f6d9759239e43255b10f8f8ca2557df0cbf7e2 Mon Sep 17 00:00:00 2001 From: Gerhard Theurich Date: Fri, 1 Sep 2023 13:59:20 -0700 Subject: [PATCH 03/14] Cleanup, improvements, and starting to add testing of ESMF_PIN_DE_TO_SSI with undistributed dim. --- .../Array/tests/ESMF_ArrayCreateGetUTest.F90 | 238 ++++++++++++++++-- 1 file changed, 222 insertions(+), 16 deletions(-) diff --git a/src/Infrastructure/Array/tests/ESMF_ArrayCreateGetUTest.F90 b/src/Infrastructure/Array/tests/ESMF_ArrayCreateGetUTest.F90 index c67c7762f2..b42cc1e33f 100644 --- a/src/Infrastructure/Array/tests/ESMF_ArrayCreateGetUTest.F90 +++ b/src/Infrastructure/Array/tests/ESMF_ArrayCreateGetUTest.F90 @@ -53,7 +53,7 @@ program ESMF_ArrayCreateGetUTest !LOCAL VARIABLES: type(ESMF_VM):: vm - integer:: i,j + integer:: i,j,k, next integer:: petCount, localPet, deCount, de, localDeCount, lde, ssiLocalDeCount integer, allocatable :: regDecomp(:) type(ESMF_ArraySpec) :: arrayspec, arrayspec2 @@ -61,12 +61,14 @@ program ESMF_ArrayCreateGetUTest type(ESMF_Array):: array, arrayAlias, arrayCpy, arrayUnInit type(ESMF_DELayout):: delayout type(ESMF_DistGrid):: distgrid, distgrid2 + real(ESMF_KIND_R8) :: diffR8 real(ESMF_KIND_R8) :: farray1D(10) real(ESMF_KIND_R8) :: farray2D(10,10) real(ESMF_KIND_R4) :: farray3D(10,10,10) integer(ESMF_KIND_I4) :: farray4D(10,10,10,10) real(ESMF_KIND_R8), pointer :: farrayPtr1D(:) real(ESMF_KIND_R8), pointer :: farrayPtr2D(:,:), farrayPtr2DCpy(:,:) + real(ESMF_KIND_R8), pointer :: farrayPtr3DR8(:,:,:) real(ESMF_KIND_R4), pointer :: farrayPtr3D(:,:,:) real(ESMF_KIND_R4), pointer :: farrayPtr3Dx(:,:,:) integer(ESMF_KIND_I4), pointer :: farrayPtr4D(:,:,:,:) @@ -970,7 +972,13 @@ program ESMF_ArrayCreateGetUTest !------------------------------------------------------------------------ ! initialize the data on this PETs first localDE if (ssiSharedMemoryEnabled) then - farrayPtr2D(:,:) = localDeToDeMap(1) + do j=lbound(farrayPtr2D,2), ubound(farrayPtr2D,2) + do i=lbound(farrayPtr2D,1), ubound(farrayPtr2D,1) + farrayPtr2D(i,j) = real(localDeToDeMap(1)+5,ESMF_KIND_R8) & + * sin(real(i,ESMF_KIND_R8)) & + * sin(real(j,ESMF_KIND_R8)) + enddo + enddo endif !------------------------------------------------------------------------ @@ -988,9 +996,11 @@ program ESMF_ArrayCreateGetUTest !------------------------------------------------------------------------ !NEX_UTest_Multi_Proc_Only - write(name, *) "LocalArrayGet Fortran array pointer for last ssiLocalDe for ESMF_PIN_DE_TO_SSI Test" + write(name, *) "LocalArrayGet Fortran array pointer for next ssiLocalDe for ESMF_PIN_DE_TO_SSI Test" write(failMsg, *) "Did not return ESMF_SUCCESS" - call ESMF_LocalArrayGet(localArrayList(ssiLocalDeCount), & + next = localPet + 2 + if (next > ssiLocalDeCount) next = 1 + call ESMF_LocalArrayGet(localArrayList(next), & farrayPtr=farrayPtr2D, rc=rc) if (ssiSharedMemoryEnabled) then call ESMF_Test((rc.eq.ESMF_SUCCESS), name, failMsg, result, ESMF_SRCLINE) @@ -1007,7 +1017,7 @@ program ESMF_ArrayCreateGetUTest !------------------------------------------------------------------------ !NEX_UTest_Multi_Proc_Only - write(name, *) "Test data in LocalArray for last ssiLocalDe for ESMF_PIN_DE_TO_SSI Test" + write(name, *) "Validate data in LocalArray for next ssiLocalDe for ESMF_PIN_DE_TO_SSI Test" write(failMsg, *) "Data not correct" dataCorrect = .true. ! initialize if (ssiSharedMemoryEnabled) then @@ -1016,8 +1026,16 @@ program ESMF_ArrayCreateGetUTest write (msg,*) "data(",i,",",j,")=", farrayPtr2D(i,j) call ESMF_LogWrite(msg, ESMF_LOGMSG_INFO, rc=rc) if (rc /= ESMF_SUCCESS) call ESMF_Finalize(endflag=ESMF_END_ABORT) - if (abs(farrayPtr2D(i,j)-real(localDeToDeMap(ssiLocalDeCount),ESMF_KIND_R8))& - > 1.d-10) dataCorrect=.false. + diffR8 = farrayPtr2D(i,j) - & + real(localDeToDeMap(next)+5,ESMF_KIND_R8) & + * sin(real(i,ESMF_KIND_R8)) & + * sin(real(j,ESMF_KIND_R8)) + if (abs(diffR8) > 1.d-10) then + dataCorrect=.false. + write (msg,*) "diffR8=", diffR8 + call ESMF_LogWrite(msg, ESMF_LOGMSG_INFO, rc=rc) + if (rc /= ESMF_SUCCESS) call ESMF_Finalize(endflag=ESMF_END_ABORT) + endif enddo enddo else @@ -1098,7 +1116,13 @@ program ESMF_ArrayCreateGetUTest !------------------------------------------------------------------------ ! initialize the data on this PETs first localDE if (ssiSharedMemoryEnabled) then - farrayPtr2D(:,:) = localDeToDeMap(1) * 10 + do j=lbound(farrayPtr2D,2), ubound(farrayPtr2D,2) + do i=lbound(farrayPtr2D,1), ubound(farrayPtr2D,1) + farrayPtr2D(i,j) = real(10*(localDeToDeMap(1)+5),ESMF_KIND_R8) & + * sin(real(i,ESMF_KIND_R8)) & + * sin(real(j,ESMF_KIND_R8)) + enddo + enddo endif !------------------------------------------------------------------------ @@ -1116,9 +1140,11 @@ program ESMF_ArrayCreateGetUTest !------------------------------------------------------------------------ !NEX_UTest_Multi_Proc_Only - write(name, *) "LocalArrayGet Fortran array pointer for last ssiLocalDe for ESMF_PIN_DE_TO_SSI arrayCpy Test" + write(name, *) "LocalArrayGet Fortran array pointer for next ssiLocalDe for ESMF_PIN_DE_TO_SSI arrayCpy Test" write(failMsg, *) "Did not return ESMF_SUCCESS" - call ESMF_LocalArrayGet(localArrayList(ssiLocalDeCount), & + next = localPet + 2 + if (next > ssiLocalDeCount) next = 1 + call ESMF_LocalArrayGet(localArrayList(next), & farrayPtr=farrayPtr2D, rc=rc) if (ssiSharedMemoryEnabled) then call ESMF_Test((rc.eq.ESMF_SUCCESS), name, failMsg, result, ESMF_SRCLINE) @@ -1135,7 +1161,7 @@ program ESMF_ArrayCreateGetUTest !------------------------------------------------------------------------ !NEX_UTest_Multi_Proc_Only - write(name, *) "Test data in LocalArray for last ssiLocalDe for ESMF_PIN_DE_TO_SSI arrayCpy Test" + write(name, *) "Validate data in LocalArray for next ssiLocalDe for ESMF_PIN_DE_TO_SSI arrayCpy Test" write(failMsg, *) "Data not correct" dataCorrect = .true. ! initialize if (ssiSharedMemoryEnabled) then @@ -1144,8 +1170,16 @@ program ESMF_ArrayCreateGetUTest write (msg,*) "data(",i,",",j,")=", farrayPtr2D(i,j) call ESMF_LogWrite(msg, ESMF_LOGMSG_INFO, rc=rc) if (rc /= ESMF_SUCCESS) call ESMF_Finalize(endflag=ESMF_END_ABORT) - if (abs(farrayPtr2D(i,j)-real(10*localDeToDeMap(ssiLocalDeCount),ESMF_KIND_R8))& - > 1.d-10) dataCorrect=.false. + diffR8 = farrayPtr2D(i,j) - & + real(10*(localDeToDeMap(next)+5),ESMF_KIND_R8) & + * sin(real(i,ESMF_KIND_R8)) & + * sin(real(j,ESMF_KIND_R8)) + if (abs(diffR8) > 1.d-10) then + dataCorrect=.false. + write (msg,*) "diffR8=", diffR8 + call ESMF_LogWrite(msg, ESMF_LOGMSG_INFO, rc=rc) + if (rc /= ESMF_SUCCESS) call ESMF_Finalize(endflag=ESMF_END_ABORT) + endif enddo enddo else @@ -1229,7 +1263,7 @@ program ESMF_ArrayCreateGetUTest !------------------------------------------------------------------------ !NEX_UTest_Multi_Proc_Only - write(name, *) "Test data in LocalArray for last ssiLocalDe for ESMF_PIN_DE_TO_SSI arrayCpy Test" + write(name, *) "Validate data in LocalArray for all DEs for ESMF_PIN_DE_TO_SSI arrayCpy Test" write(failMsg, *) "Data not correct" dataCorrect = .true. ! initialize if (ssiSharedMemoryEnabled) then @@ -1242,8 +1276,16 @@ program ESMF_ArrayCreateGetUTest " data(",i,",",j,")=", farrayPtr2D(i,j) call ESMF_LogWrite(msg, ESMF_LOGMSG_INFO, rc=rc) if (rc /= ESMF_SUCCESS) call ESMF_Finalize(endflag=ESMF_END_ABORT) - if (abs(farrayPtr2D(i,j)-real(10*localDeToDeMap(lde),ESMF_KIND_R8))& - > 1.d-10) dataCorrect=.false. + diffR8 = farrayPtr2D(i,j) - & + real(10*(localDeToDeMap(lde)+5),ESMF_KIND_R8) & + * sin(real(i,ESMF_KIND_R8)) & + * sin(real(j,ESMF_KIND_R8)) + if (abs(diffR8) > 1.d-10) then + dataCorrect=.false. + write (msg,*) "diffR8=", diffR8 + call ESMF_LogWrite(msg, ESMF_LOGMSG_INFO, rc=rc) + if (rc /= ESMF_SUCCESS) call ESMF_Finalize(endflag=ESMF_END_ABORT) + endif enddo enddo enddo @@ -1294,6 +1336,170 @@ program ESMF_ArrayCreateGetUTest call ESMF_Test((rc.eq.ESMF_RC_OBJ_NOT_CREATED), name, failMsg, result, ESMF_SRCLINE) endif +!--- new stuff begin ---- + + !------------------------------------------------------------------------ + !NEX_UTest_Multi_Proc_Only + write(name, *) "Create test 2D+1 Array with ESMF_PIN_DE_TO_SSI" + write(failMsg, *) "Did not return ESMF_SUCCESS" + array = ESMF_ArrayCreate(typekind=ESMF_TYPEKIND_R8, distgrid=distgrid, & + indexflag=ESMF_INDEX_GLOBAL, pinflag=ESMF_PIN_DE_TO_SSI, name="MyArray", & + undistLBound=[1], undistUBound=[3], rc=rc) + if (ssiSharedMemoryEnabled) then + call ESMF_Test((rc.eq.ESMF_SUCCESS), name, failMsg, result, ESMF_SRCLINE) + else + write(failMsg, *) "Did not return the correct RC" + call ESMF_Test((rc.eq.ESMC_RC_INTNRL_BAD), name, failMsg, result, ESMF_SRCLINE) + endif + + !------------------------------------------------------------------------ + !NEX_UTest_Multi_Proc_Only + write(name, *) "ArrayGet Fortran array pointer for ESMF_PIN_DE_TO_SSI 2D+1 Test" + write(failMsg, *) "Did not return ESMF_SUCCESS" + call ESMF_ArrayGet(array, farrayPtr=farrayPtr3DR8, rc=rc) + if (ssiSharedMemoryEnabled) then + call ESMF_Test((rc.eq.ESMF_SUCCESS), name, failMsg, result, ESMF_SRCLINE) + write (msg,*) "Local Array lbounds=", lbound(farrayPtr3DR8) + call ESMF_LogWrite(msg, ESMF_LOGMSG_INFO, rc=rc) + if (rc /= ESMF_SUCCESS) call ESMF_Finalize(endflag=ESMF_END_ABORT) + write (msg,*) "Local Array ubounds=", ubound(farrayPtr3DR8) + call ESMF_LogWrite(msg, ESMF_LOGMSG_INFO, rc=rc) + if (rc /= ESMF_SUCCESS) call ESMF_Finalize(endflag=ESMF_END_ABORT) + else + write(failMsg, *) "Did not return the correct RC" + call ESMF_Test((rc.eq.ESMF_RC_OBJ_NOT_CREATED), name, failMsg, result, ESMF_SRCLINE) + endif + + !------------------------------------------------------------------------ + !NEX_UTest_Multi_Proc_Only + write(name, *) "ArrayGet ssiLocalDeCount ESMF_PIN_DE_TO_SSI 2D+1 Test" + write(failMsg, *) "Did not return ESMF_SUCCESS" + call ESMF_ArrayGet(array, ssiLocalDeCount=ssiLocalDeCount, rc=rc) + if (ssiSharedMemoryEnabled) then + call ESMF_Test((rc.eq.ESMF_SUCCESS), name, failMsg, result, ESMF_SRCLINE) + write (msg,*) "ssiLocalDeCount=", ssiLocalDeCount + call ESMF_LogWrite(msg, ESMF_LOGMSG_INFO, rc=rc) + if (rc /= ESMF_SUCCESS) call ESMF_Finalize(endflag=ESMF_END_ABORT) + else + ssiLocalDeCount=1 + write(failMsg, *) "Did not return the correct RC" + call ESMF_Test((rc.eq.ESMF_RC_OBJ_NOT_CREATED), name, failMsg, result, ESMF_SRCLINE) + endif + allocate(localDeToDeMap(ssiLocalDeCount)) + allocate(localArrayList(ssiLocalDeCount)) + + !------------------------------------------------------------------------ + !NEX_UTest_Multi_Proc_Only + write(name, *) "ArrayGet localDeToDeMap ESMF_PIN_DE_TO_SSI 2D+1 Test" + write(failMsg, *) "Did not return ESMF_SUCCESS" + call ESMF_ArrayGet(array, localDeToDeMap=localDeToDeMap, & + localarrayList=localArrayList, rc=rc) + if (ssiSharedMemoryEnabled) then + call ESMF_Test((rc.eq.ESMF_SUCCESS), name, failMsg, result, ESMF_SRCLINE) + write (msg,*) "localDeToDeMap=", localDeToDeMap + call ESMF_LogWrite(msg, ESMF_LOGMSG_INFO, rc=rc) + if (rc /= ESMF_SUCCESS) call ESMF_Finalize(endflag=ESMF_END_ABORT) + else + write(failMsg, *) "Did not return the correct RC" + call ESMF_Test((rc.eq.ESMF_RC_OBJ_NOT_CREATED), name, failMsg, result, ESMF_SRCLINE) + endif + + !------------------------------------------------------------------------ + ! initialize the data on this PETs first localDE + if (ssiSharedMemoryEnabled) then + do k=lbound(farrayPtr3DR8,3), ubound(farrayPtr3DR8,3) + do j=lbound(farrayPtr3DR8,2), ubound(farrayPtr3DR8,2) + do i=lbound(farrayPtr3DR8,1), ubound(farrayPtr3DR8,1) + farrayPtr3DR8(i,j,k) = real(localDeToDeMap(1)+5,ESMF_KIND_R8) & + * sin(real(i,ESMF_KIND_R8)) & + * sin(real(j,ESMF_KIND_R8)) & + * sin(real(k,ESMF_KIND_R8)) + enddo + enddo + enddo + endif + !------------------------------------------------------------------------ + + !------------------------------------------------------------------------ + !NEX_UTest_Multi_Proc_Only + write(name, *) "ArraySync() for ESMF_PIN_DE_TO_SSI 2D+1 Test" + write(failMsg, *) "Did not return ESMF_SUCCESS" + call ESMF_ArraySync(array, rc=rc) + if (ssiSharedMemoryEnabled) then + call ESMF_Test((rc.eq.ESMF_SUCCESS), name, failMsg, result, ESMF_SRCLINE) + else + write(failMsg, *) "Did not return the correct RC" + call ESMF_Test((rc.eq.ESMF_RC_OBJ_NOT_CREATED), name, failMsg, result, ESMF_SRCLINE) + endif + + !------------------------------------------------------------------------ + !NEX_UTest_Multi_Proc_Only + write(name, *) "LocalArrayGet Fortran array pointer for next ssiLocalDe for ESMF_PIN_DE_TO_SSI 2D+1 Test" + write(failMsg, *) "Did not return ESMF_SUCCESS" + next = localPet + 2 + if (next > ssiLocalDeCount) next = 1 + call ESMF_LocalArrayGet(localArrayList(next), & + farrayPtr=farrayPtr3DR8, rc=rc) + if (ssiSharedMemoryEnabled) then + call ESMF_Test((rc.eq.ESMF_SUCCESS), name, failMsg, result, ESMF_SRCLINE) + write (msg,*) "Local Array lbounds=", lbound(farrayPtr3DR8) + call ESMF_LogWrite(msg, ESMF_LOGMSG_INFO, rc=rc) + if (rc /= ESMF_SUCCESS) call ESMF_Finalize(endflag=ESMF_END_ABORT) + write (msg,*) "Local Array ubounds=", ubound(farrayPtr3DR8) + call ESMF_LogWrite(msg, ESMF_LOGMSG_INFO, rc=rc) + if (rc /= ESMF_SUCCESS) call ESMF_Finalize(endflag=ESMF_END_ABORT) + else + write(failMsg, *) "Did not return the correct RC" + call ESMF_Test((rc.eq.ESMF_RC_OBJ_NOT_CREATED), name, failMsg, result, ESMF_SRCLINE) + endif + + !------------------------------------------------------------------------ + !NEX_UTest_Multi_Proc_Only + write(name, *) "Validate data in LocalArray for next ssiLocalDe for ESMF_PIN_DE_TO_SSI 2D+1 Test" + write(failMsg, *) "Data not correct" + dataCorrect = .true. ! initialize + if (ssiSharedMemoryEnabled) then + do k=lbound(farrayPtr3DR8,3), ubound(farrayPtr3DR8,3) + do j=lbound(farrayPtr3DR8,2), ubound(farrayPtr3DR8,2) + do i=lbound(farrayPtr3DR8,1), ubound(farrayPtr3DR8,1) + write (msg,*) "data(",i,",",j,",",k,")=", farrayPtr3DR8(i,j,k) + call ESMF_LogWrite(msg, ESMF_LOGMSG_INFO, rc=rc) + if (rc /= ESMF_SUCCESS) call ESMF_Finalize(endflag=ESMF_END_ABORT) + diffR8 = farrayPtr3DR8(i,j,k) - & + real(localDeToDeMap(next)+5,ESMF_KIND_R8) & + * sin(real(i,ESMF_KIND_R8)) & + * sin(real(j,ESMF_KIND_R8)) & + * sin(real(k,ESMF_KIND_R8)) + if (abs(diffR8) > 1.d-10) then + dataCorrect=.false. + write (msg,*) "diffR8=", diffR8 + call ESMF_LogWrite(msg, ESMF_LOGMSG_INFO, rc=rc) + if (rc /= ESMF_SUCCESS) call ESMF_Finalize(endflag=ESMF_END_ABORT) + endif + enddo + enddo + enddo + else + ! dummy test + endif + call ESMF_Test((dataCorrect), name, failMsg, result, ESMF_SRCLINE) + + call ESMF_ArraySync(array, rc=rc) ! prevent race condition with below + if (rc /= ESMF_SUCCESS) call ESMF_Finalize(endflag=ESMF_END_ABORT) + + deallocate(localDeToDeMap) + deallocate(localArrayList) + + + + + + + + + +!--- new stuff end ---- + !------------------------------------------------------------------------ ! cleanup call ESMF_DistGridDestroy(distgrid, rc=rc) From 0bbb15c91b51ee2f324e921dddaf092eb817b435 Mon Sep 17 00:00:00 2001 From: Gerhard Theurich Date: Fri, 1 Sep 2023 14:08:22 -0700 Subject: [PATCH 04/14] Code standardization. --- .../Array/interface/ESMF_ArrayCreate.cppF90 | 24 +++++++++---------- 1 file changed, 12 insertions(+), 12 deletions(-) diff --git a/src/Infrastructure/Array/interface/ESMF_ArrayCreate.cppF90 b/src/Infrastructure/Array/interface/ESMF_ArrayCreate.cppF90 index 1c3589169e..d5f853a971 100644 --- a/src/Infrastructure/Array/interface/ESMF_ArrayCreate.cppF90 +++ b/src/Infrastructure/Array/interface/ESMF_ArrayCreate.cppF90 @@ -139,7 +139,7 @@ module ESMF_ArrayCreateMod module procedure ESMF_ArrayCreateAllocateAS module procedure ESMF_ArrayCreateAllocateASArb module procedure ESMF_ArrayCreateAllocateASArbI8 - module procedure ESMF_ArrayCreateCopy + module procedure ESMF_ArrayCreateFromArray ! !DESCRIPTION: ! This interface provides a single entry point for the various @@ -3862,16 +3862,16 @@ TypeKindRankDeclarationMacro(ArrayCreateAsmdSpArbI8) ! -------------------------- ESMF-public method ------------------------------- ^undef ESMF_METHOD -^define ESMF_METHOD "ESMF_ArrayCreateCopy()" +^define ESMF_METHOD "ESMF_ArrayCreateFromArray()" !BOP -! !IROUTINE: ESMF_ArrayCreate - Create Array object as copy of existing Array object +! !IROUTINE: ESMF_ArrayCreate - Create Array object from an existing Array object ! !INTERFACE: ! Private name; call using ESMF_ArrayCreate() - function ESMF_ArrayCreateCopy(array, keywordEnforcer, datacopyflag, delayout, rc) + function ESMF_ArrayCreateFromArray(array, keywordEnforcer, datacopyflag, delayout, rc) ! ! !RETURN VALUE: - type(ESMF_Array) :: ESMF_ArrayCreateCopy + type(ESMF_Array) :: ESMF_ArrayCreateFromArray ! ! !ARGUMENTS: type(ESMF_Array), intent(in) :: array @@ -3886,14 +3886,14 @@ TypeKindRankDeclarationMacro(ArrayCreateAsmdSpArbI8) ! \item\apiStatusModifiedSinceVersion{5.2.0r} ! \begin{description} ! \item[8.1.0] Added argument {\tt datacopyflag} to select between different -! copy options.\newline +! data copy options.\newline ! Added argument {\tt delayout} to create Array with different localDe -> DE ! mapping. This is identical to a change in DE -> PET mapping. ! \end{description} ! \end{itemize} ! ! !DESCRIPTION: -! Create an {\tt ESMF\_Array} object as the copy of an existing Array. +! Create an {\tt ESMF\_Array} object from an existing Array. ! ! The return value is the newly created {\tt ESMF\_Array} object. ! @@ -3925,11 +3925,11 @@ TypeKindRankDeclarationMacro(ArrayCreateAsmdSpArbI8) ! Mark this Array object as invalid arrayOut%this = ESMF_NULL_POINTER - ESMF_ArrayCreateCopy = arrayOut + ESMF_ArrayCreateFromArray = arrayOut ESMF_INIT_CHECK_DEEP_SHORT(ESMF_ArrayGetInit, array, rc) - ! Set copy/ref behavior + ! Set data copy/ref behavior datacopyflag_opt = ESMF_DATACOPY_VALUE ! default if (present(datacopyflag)) datacopyflag_opt = datacopyflag @@ -3940,15 +3940,15 @@ TypeKindRankDeclarationMacro(ArrayCreateAsmdSpArbI8) ESMF_CONTEXT, rcToReturn=rc)) return ! Set return value - ESMF_ArrayCreateCopy = arrayOut + ESMF_ArrayCreateFromArray = arrayOut ! Set init code - ESMF_INIT_SET_CREATED(ESMF_ArrayCreateCopy) + ESMF_INIT_SET_CREATED(ESMF_ArrayCreateFromArray) ! Return successfully if (present(rc)) rc = ESMF_SUCCESS - end function ESMF_ArrayCreateCopy + end function ESMF_ArrayCreateFromArray !------------------------------------------------------------------------------ From feacfb264ea7a3344cdf87935134edf8c58c3d68 Mon Sep 17 00:00:00 2001 From: Gerhard Theurich Date: Tue, 5 Sep 2023 10:47:44 -0700 Subject: [PATCH 05/14] Add `trailingUndistSlice` argument to ArrayCreate(fromArray) to support array slicing. --- .../Array/interface/ESMF_ArrayCreate.cppF90 | 28 ++++++++++++++++--- 1 file changed, 24 insertions(+), 4 deletions(-) diff --git a/src/Infrastructure/Array/interface/ESMF_ArrayCreate.cppF90 b/src/Infrastructure/Array/interface/ESMF_ArrayCreate.cppF90 index d5f853a971..e76bb69182 100644 --- a/src/Infrastructure/Array/interface/ESMF_ArrayCreate.cppF90 +++ b/src/Infrastructure/Array/interface/ESMF_ArrayCreate.cppF90 @@ -3868,7 +3868,8 @@ TypeKindRankDeclarationMacro(ArrayCreateAsmdSpArbI8) ! !INTERFACE: ! Private name; call using ESMF_ArrayCreate() - function ESMF_ArrayCreateFromArray(array, keywordEnforcer, datacopyflag, delayout, rc) + function ESMF_ArrayCreateFromArray(array, keywordEnforcer, datacopyflag, delayout, & + trailingUndistSlice, rc) ! ! !RETURN VALUE: type(ESMF_Array) :: ESMF_ArrayCreateFromArray @@ -3878,6 +3879,7 @@ TypeKindRankDeclarationMacro(ArrayCreateAsmdSpArbI8) type(ESMF_KeywordEnforcer), optional:: keywordEnforcer ! must use keywords below type(ESMF_DataCopy_Flag), intent(in), optional :: datacopyflag type(ESMF_DELayout), intent(in), optional :: delayout + integer, intent(in), optional :: trailingUndistSlice(:) integer, intent(out), optional :: rc ! ! !STATUS: @@ -3889,6 +3891,8 @@ TypeKindRankDeclarationMacro(ArrayCreateAsmdSpArbI8) ! data copy options.\newline ! Added argument {\tt delayout} to create Array with different localDe -> DE ! mapping. This is identical to a change in DE -> PET mapping. +! \item[8.6.0] Added argument {\tt trailingUndistSlice} to all arrays created +! by reference to slice along traling undistributed dimensions. ! \end{description} ! \end{itemize} ! @@ -3909,6 +3913,10 @@ TypeKindRankDeclarationMacro(ArrayCreateAsmdSpArbI8) ! \item[{[delayout]}] ! If present, override the DELayout of the incoming {\tt distgrid}. ! By default use the DELayout defined in {\tt distgrid}. +! \item[{[trailingUndistSlice]}] +! If present, the returned Array references the data of the slice of the +! {\tt array} argument, at the specified trailing undistributed dimension +! tuple. ! \item[{[rc]}] ! Return code; equals {\tt ESMF\_SUCCESS} if there are no errors. ! \end{description} @@ -3917,7 +3925,8 @@ TypeKindRankDeclarationMacro(ArrayCreateAsmdSpArbI8) !------------------------------------------------------------------------------ integer :: localrc ! local return code type(ESMF_Array) :: arrayOut ! opaque pointer to new C++ Array - type(ESMF_DataCopy_Flag):: datacopyflag_opt ! helper variable + type(ESMF_DataCopy_Flag):: datacopyflag_opt ! helper variable + type(ESMF_InterArray) :: trailingUndistSliceArg ! helper variable ! Initialize return code; assume failure until success is certain localrc = ESMF_RC_NOT_IMPL @@ -3933,9 +3942,20 @@ TypeKindRankDeclarationMacro(ArrayCreateAsmdSpArbI8) datacopyflag_opt = ESMF_DATACOPY_VALUE ! default if (present(datacopyflag)) datacopyflag_opt = datacopyflag + ! Deal with (optional) array arguments + trailingUndistSliceArg = ESMF_InterArrayCreate( & + farray1D=trailingUndistSlice, rc=localrc) + if (ESMF_LogFoundError(localrc, ESMF_ERR_PASSTHRU, & + ESMF_CONTEXT, rcToReturn=rc)) return + ! Call into the C++ interface - call c_ESMC_ArrayCreateCopy(array, arrayOut, datacopyflag_opt, delayout, & - localrc) + call c_ESMC_ArrayCreateFromArray(array, arrayOut, datacopyflag_opt, & + delayout, trailingUndistSliceArg, localrc) + if (ESMF_LogFoundError(localrc, ESMF_ERR_PASSTHRU, & + ESMF_CONTEXT, rcToReturn=rc)) return + + ! Garbage collection + call ESMF_InterArrayDestroy(trailingUndistSliceArg, rc=localrc) if (ESMF_LogFoundError(localrc, ESMF_ERR_PASSTHRU, & ESMF_CONTEXT, rcToReturn=rc)) return From e8af5b1425e02cc3f74dec4cfac1c07d5b5292ea Mon Sep 17 00:00:00 2001 From: Gerhard Theurich Date: Tue, 5 Sep 2023 12:06:58 -0700 Subject: [PATCH 06/14] Improve API doc of new argument `trailingUndistSlice`. --- .../Array/interface/ESMF_ArrayCreate.cppF90 | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/src/Infrastructure/Array/interface/ESMF_ArrayCreate.cppF90 b/src/Infrastructure/Array/interface/ESMF_ArrayCreate.cppF90 index e76bb69182..4ad1e4e3e9 100644 --- a/src/Infrastructure/Array/interface/ESMF_ArrayCreate.cppF90 +++ b/src/Infrastructure/Array/interface/ESMF_ArrayCreate.cppF90 @@ -3891,8 +3891,8 @@ TypeKindRankDeclarationMacro(ArrayCreateAsmdSpArbI8) ! data copy options.\newline ! Added argument {\tt delayout} to create Array with different localDe -> DE ! mapping. This is identical to a change in DE -> PET mapping. -! \item[8.6.0] Added argument {\tt trailingUndistSlice} to all arrays created -! by reference to slice along traling undistributed dimensions. +! \item[8.6.0] Added argument {\tt trailingUndistSlice} to allow slicing of +! arrays created by reference. ! \end{description} ! \end{itemize} ! @@ -3914,9 +3914,9 @@ TypeKindRankDeclarationMacro(ArrayCreateAsmdSpArbI8) ! If present, override the DELayout of the incoming {\tt distgrid}. ! By default use the DELayout defined in {\tt distgrid}. ! \item[{[trailingUndistSlice]}] -! If present, the returned Array references the data of the slice of the -! {\tt array} argument, at the specified trailing undistributed dimension -! tuple. +! If present, the returned Array references the data of the array slice +! as defined by the specified tuple, applied to the right most +! trailing undistributed dimensions. ! \item[{[rc]}] ! Return code; equals {\tt ESMF\_SUCCESS} if there are no errors. ! \end{description} From 1b87a33980be4fc0cfb3c88cc24a79cea94a9f24 Mon Sep 17 00:00:00 2001 From: Gerhard Theurich Date: Tue, 5 Sep 2023 15:51:45 -0700 Subject: [PATCH 07/14] Keep track of Fortran pointers even when ownership is not transferred. Track ownership transfer within the object separately, only used during Destroy(). --- .../Util/interface/ESMF_F90Interface.F90 | 216 +++++++++--------- 1 file changed, 105 insertions(+), 111 deletions(-) diff --git a/src/Infrastructure/Util/interface/ESMF_F90Interface.F90 b/src/Infrastructure/Util/interface/ESMF_F90Interface.F90 index 54e40815c3..397437ce1d 100644 --- a/src/Infrastructure/Util/interface/ESMF_F90Interface.F90 +++ b/src/Infrastructure/Util/interface/ESMF_F90Interface.F90 @@ -1,10 +1,10 @@ ! $Id$ ! ! Earth System Modeling Framework -! Copyright (c) 2002-2023, University Corporation for Atmospheric Research, -! Massachusetts Institute of Technology, Geophysical Fluid Dynamics -! Laboratory, University of Michigan, National Centers for Environmental -! Prediction, Los Alamos National Laboratory, Argonne National Laboratory, +! Copyright (c) 2002-2023, University Corporation for Atmospheric Research, +! Massachusetts Institute of Technology, Geophysical Fluid Dynamics +! Laboratory, University of Michigan, National Centers for Environmental +! Prediction, Los Alamos National Laboratory, Argonne National Laboratory, ! NASA Goddard Space Flight Center. ! Licensed under the University of Illinois-NCSA License. ! @@ -30,12 +30,12 @@ module ESMF_F90InterfaceMod !------------------------------------------------------------------------------ ! !PRIVATE TYPES: private - + public ESMF_InterArray public ESMF_InterArrayCreate public ESMF_InterArrayGet public ESMF_InterArrayDestroy - + !------------------------------------------------------------------------------ ! ESMF_InterArray: ! Handling of [optional] integer arrays on the Fortran-to-C++ interface. @@ -66,12 +66,13 @@ module ESMF_F90InterfaceMod real(ESMF_KIND_R8), pointer :: farray1DR8(:) ! Fortran reference real(ESMF_KIND_R8), pointer :: farray2DR8(:,:) ! Fortran reference real(ESMF_KIND_R8), pointer :: farray3DR8(:,:,:) ! Fortran reference + logical :: owner ! flag need for deallocation during Destroy() end type !============================================================================== -! +! ! INTERFACE BLOCKS ! !============================================================================== @@ -87,9 +88,9 @@ module ESMF_F90InterfaceMod ! module procedure ESMF_InterArrayCreateTrg module procedure ESMF_InterArrayCreatePtr - -! !DESCRIPTION: -!EOPI + +! !DESCRIPTION: +!EOPI end interface !============================================================================== @@ -125,7 +126,7 @@ recursive function ESMF_InterArrayCreateTrg(farray1D, farray2D, farray3D, & real(ESMF_KIND_R8), target, intent(in), optional :: farray2DR8(:,:) real(ESMF_KIND_R8), target, intent(in), optional :: farray3DR8(:,:,:) integer, intent(out), optional :: rc -! +! ! !RETURN VALUE: type(ESMF_InterArray) :: InterArrayCreateTrg ! @@ -170,17 +171,16 @@ recursive function ESMF_InterArrayCreateTrg(farray1D, farray2D, farray3D, & real(ESMF_KIND_R8), pointer :: farray2DR8Ptr(:,:) real(ESMF_KIND_R8), pointer :: farray3DR8Ptr(:,:,:) - ! initialize return code; assume routine not implemented localrc = ESMF_RC_NOT_IMPL if (present(rc)) rc = ESMF_RC_NOT_IMPL - + ! mark this InterArray as invalid call c_ESMC_InterArraySetInvalid(array, localrc) InterArrayCreateTrg = array if (ESMF_LogFoundError(localrc, ESMF_ERR_PASSTHRU, & ESMF_CONTEXT, rcToReturn=rc)) return - + ! initialize nullify(farray1DPtr) nullify(farray2DPtr) @@ -192,8 +192,6 @@ recursive function ESMF_InterArrayCreateTrg(farray1D, farray2D, farray3D, & nullify(farray2DR8Ptr) nullify(farray3DR8Ptr) - - ! set references if (present(farray1D)) farray1DPtr => farray1D if (present(farray2D)) farray2DPtr => farray2D if (present(farray3D)) farray3DPtr => farray3D @@ -203,7 +201,7 @@ recursive function ESMF_InterArrayCreateTrg(farray1D, farray2D, farray3D, & if (present(farray1DR8)) farray1DR8Ptr => farray1DR8 if (present(farray2DR8)) farray2DR8Ptr => farray2DR8 if (present(farray3DR8)) farray3DR8Ptr => farray3DR8 - + ! create InterArray object array = ESMF_InterArrayCreate(farray1DPtr, farray2DPtr, farray3DPtr, & farray1DI8Ptr, farray2DI8Ptr, farray3DI8Ptr, & @@ -211,13 +209,13 @@ recursive function ESMF_InterArrayCreateTrg(farray1D, farray2D, farray3D, & transferOwnership=.false., rc=localrc) if (ESMF_LogFoundError(localrc, ESMF_ERR_PASSTHRU, & ESMF_CONTEXT, rcToReturn=rc)) return - + ! set return value InterArrayCreateTrg = array - + ! return successfully if (present(rc)) rc = ESMF_SUCCESS - + end function ESMF_InterArrayCreateTrg !------------------------------------------------------------------------------ @@ -247,14 +245,14 @@ recursive function ESMF_InterArrayCreatePtr(farray1D, farray2D, farray3D, & real(ESMF_KIND_R8), pointer, optional :: farray3DR8(:,:,:) logical, intent(in) :: transferOwnership integer, intent(out), optional :: rc -! +! ! !RETURN VALUE: type(ESMF_InterArray) :: InterArrayCreatePtr ! ! !DESCRIPTION: -! Create an {\tt ESMF\_InterArray} from Fortran array. The +! Create an {\tt ESMF\_InterArray} from Fortran array. The ! {\tt transferOwnership} allows ownership of the Fortran array to be -! transferred to the InterArray object. InterArrayDestroy() will call +! transferred to the InterArray object. InterArrayDestroy() will call ! deallocate() for Fortran arrays whose ownership was transferred. ! ! The arguments are: @@ -292,17 +290,17 @@ recursive function ESMF_InterArrayCreatePtr(farray1D, farray2D, farray3D, & integer :: checkCount integer(ESMF_KIND_I8) :: dummyI8 real(ESMF_KIND_R8) :: dummyR8 - + ! initialize return code; assume routine not implemented localrc = ESMF_RC_NOT_IMPL if (present(rc)) rc = ESMF_RC_NOT_IMPL - + ! mark this InterArray as invalid call c_ESMC_InterArraySetInvalid(array, localrc) InterArrayCreatePtr = array if (ESMF_LogFoundError(localrc, ESMF_ERR_PASSTHRU, & ESMF_CONTEXT, rcToReturn=rc)) return - + ! initialize Fortran array references nullify(array%farray1D) nullify(array%farray2D) @@ -313,7 +311,7 @@ recursive function ESMF_InterArrayCreatePtr(farray1D, farray2D, farray3D, & nullify(array%farray1DR8) nullify(array%farray2DR8) nullify(array%farray3DR8) - + ! check that only one of the array arguments is present checkCount = 0 ! reset if (present(farray1D)) then @@ -350,11 +348,13 @@ recursive function ESMF_InterArrayCreatePtr(farray1D, farray2D, farray3D, & return endif + ! set owner flag + array%owner = transferOwnership + ! call into the C++ interface, depending on whether or not farray is present if (present(farray1D)) then if (associated(farray1D)) then - if (transferOwnership) & - array%farray1D => farray1D + array%farray1D => farray1D allocate(len(1)) len = shape(farray1D) if (all(len .ne. 0)) then @@ -371,8 +371,7 @@ recursive function ESMF_InterArrayCreatePtr(farray1D, farray2D, farray3D, & endif if (present(farray2D)) then if (associated(farray2D)) then - if (transferOwnership) & - array%farray2D => farray2D + array%farray2D => farray2D allocate(len(2)) len = shape(farray2D) if (all(len .ne. 0)) then @@ -389,8 +388,7 @@ recursive function ESMF_InterArrayCreatePtr(farray1D, farray2D, farray3D, & endif if (present(farray3D)) then if (associated(farray3D)) then - if (transferOwnership) & - array%farray3D => farray3D + array%farray3D => farray3D allocate(len(3)) len = shape(farray3D) if (all(len .ne. 0)) then @@ -407,8 +405,7 @@ recursive function ESMF_InterArrayCreatePtr(farray1D, farray2D, farray3D, & endif if (present(farray1DI8)) then if (associated(farray1DI8)) then - if (transferOwnership) & - array%farray1DI8 => farray1DI8 + array%farray1DI8 => farray1DI8 allocate(len(1)) len = shape(farray1DI8) if (all(len .ne. 0)) then @@ -425,8 +422,7 @@ recursive function ESMF_InterArrayCreatePtr(farray1D, farray2D, farray3D, & endif if (present(farray2DI8)) then if (associated(farray2DI8)) then - if (transferOwnership) & - array%farray2DI8 => farray2DI8 + array%farray2DI8 => farray2DI8 allocate(len(2)) len = shape(farray2DI8) if (all(len .ne. 0)) then @@ -444,8 +440,7 @@ recursive function ESMF_InterArrayCreatePtr(farray1D, farray2D, farray3D, & endif if (present(farray3DI8)) then if (associated(farray3DI8)) then - if (transferOwnership) & - array%farray3DI8 => farray3DI8 + array%farray3DI8 => farray3DI8 allocate(len(3)) len = shape(farray3DI8) if (all(len .ne. 0)) then @@ -464,8 +459,7 @@ recursive function ESMF_InterArrayCreatePtr(farray1D, farray2D, farray3D, & if (present(farray1DR8)) then if (associated(farray1DR8)) then - if (transferOwnership) & - array%farray1DR8 => farray1DR8 + array%farray1DR8 => farray1DR8 allocate(len(1)) len = shape(farray1DR8) if (all(len .ne. 0)) then @@ -482,8 +476,7 @@ recursive function ESMF_InterArrayCreatePtr(farray1D, farray2D, farray3D, & endif if (present(farray2DR8)) then if (associated(farray2DR8)) then - if (transferOwnership) & - array%farray2DR8 => farray2DR8 + array%farray2DR8 => farray2DR8 allocate(len(2)) len = shape(farray2DR8) if (all(len .ne. 0)) then @@ -501,8 +494,7 @@ recursive function ESMF_InterArrayCreatePtr(farray1D, farray2D, farray3D, & endif if (present(farray3DR8)) then if (associated(farray3DR8)) then - if (transferOwnership) & - array%farray3DR8 => farray3DR8 + array%farray3DR8 => farray3DR8 allocate(len(3)) len = shape(farray3DR8) if (all(len .ne. 0)) then @@ -518,13 +510,13 @@ recursive function ESMF_InterArrayCreatePtr(farray1D, farray2D, farray3D, & deallocate(len) endif endif - + ! set return value InterArrayCreatePtr = array - + ! return successfully if (present(rc)) rc = ESMF_SUCCESS - + end function ESMF_InterArrayCreatePtr !------------------------------------------------------------------------------ @@ -551,7 +543,7 @@ recursive subroutine ESMF_InterArrayGet(array, farray1D, farray2D, farray3D, & real(ESMF_KIND_R8), pointer, optional :: farray2DR8(:,:) real(ESMF_KIND_R8), pointer, optional :: farray3DR8(:,:,:) integer, intent(out), optional :: rc -! +! ! ! !DESCRIPTION: ! Get pointer out of an {\tt ESMF\_InterArray} object. @@ -586,11 +578,11 @@ recursive subroutine ESMF_InterArrayGet(array, farray1D, farray2D, farray3D, & !------------------------------------------------------------------------------ integer :: localrc ! local return code integer :: stat ! Fortran return code - + ! initialize return code; assume routine not implemented localrc = ESMF_RC_NOT_IMPL if (present(rc)) rc = ESMF_RC_NOT_IMPL - + if (present(farray1D)) farray1D => array%farray1D if (present(farray2D)) farray2D => array%farray2D if (present(farray3D)) farray3D => array%farray3D @@ -603,7 +595,7 @@ recursive subroutine ESMF_InterArrayGet(array, farray1D, farray2D, farray3D, & ! return successfully if (present(rc)) rc = ESMF_SUCCESS - + end subroutine ESMF_InterArrayGet !------------------------------------------------------------------------------ @@ -620,7 +612,7 @@ recursive subroutine ESMF_InterArrayDestroy(array, rc) ! !ARGUMENTS: type(ESMF_InterArray), intent(inout) :: array integer, intent(out), optional :: rc -! +! ! ! !DESCRIPTION: ! Destroy an {\tt ESMF\_InterArray} object. Deallocate Fortran arrays @@ -638,71 +630,73 @@ recursive subroutine ESMF_InterArrayDestroy(array, rc) !------------------------------------------------------------------------------ integer :: localrc ! local return code integer :: stat ! Fortran return code - + ! initialize return code; assume routine not implemented localrc = ESMF_RC_NOT_IMPL if (present(rc)) rc = ESMF_RC_NOT_IMPL - - ! deallocate Fortran arrays whose ownership was transferred - if (associated(array%farray1D)) then - deallocate(array%farray1D, stat=stat) - if (ESMF_LogFoundDeallocError(stat, msg="deallocating array%farray1D", & - ESMF_CONTEXT)) & - return ! bail out - endif - if (associated(array%farray2D)) then - deallocate(array%farray2D, stat=stat) - if (ESMF_LogFoundDeallocError(stat, msg="deallocating array%farray2D", & - ESMF_CONTEXT)) & - return ! bail out - endif - if (associated(array%farray3D)) then - deallocate(array%farray3D, stat=stat) - if (ESMF_LogFoundDeallocError(stat, msg="deallocating array%farray3D", & - ESMF_CONTEXT)) & - return ! bail out - endif - if (associated(array%farray1DI8)) then - deallocate(array%farray1DI8, stat=stat) - if (ESMF_LogFoundDeallocError(stat, msg="deallocating array%farray1DI8", & - ESMF_CONTEXT)) & - return ! bail out - endif - if (associated(array%farray2DI8)) then - deallocate(array%farray2DI8, stat=stat) - if (ESMF_LogFoundDeallocError(stat, msg="deallocating array%farray2DI8", & - ESMF_CONTEXT)) & - return ! bail out - endif - if (associated(array%farray3DI8)) then - deallocate(array%farray3DI8, stat=stat) - if (ESMF_LogFoundDeallocError(stat, msg="deallocating array%farray3DI8", & - ESMF_CONTEXT)) & - return ! bail out - endif - if (associated(array%farray1DR8)) then - deallocate(array%farray1DR8, stat=stat) - if (ESMF_LogFoundDeallocError(stat, msg="deallocating array%farray1DR8", & - ESMF_CONTEXT)) & - return ! bail out - endif - if (associated(array%farray2DR8)) then - deallocate(array%farray2DR8, stat=stat) - if (ESMF_LogFoundDeallocError(stat, msg="deallocating array%farray2DR8", & - ESMF_CONTEXT)) & - return ! bail out - endif - if (associated(array%farray3DR8)) then - deallocate(array%farray3DR8, stat=stat) - if (ESMF_LogFoundDeallocError(stat, msg="deallocating array%farray3DR8", & - ESMF_CONTEXT)) & - return ! bail out + ! deallocate Fortran arrays if ownership was transferred + if (array%owner) then + if (associated(array%farray1D)) then + deallocate(array%farray1D, stat=stat) + if (ESMF_LogFoundDeallocError(stat, msg="deallocating array%farray1D", & + ESMF_CONTEXT)) & + return ! bail out + endif + if (associated(array%farray2D)) then + deallocate(array%farray2D, stat=stat) + if (ESMF_LogFoundDeallocError(stat, msg="deallocating array%farray2D", & + ESMF_CONTEXT)) & + return ! bail out + endif + if (associated(array%farray3D)) then + deallocate(array%farray3D, stat=stat) + if (ESMF_LogFoundDeallocError(stat, msg="deallocating array%farray3D", & + ESMF_CONTEXT)) & + return ! bail out + endif + if (associated(array%farray1DI8)) then + deallocate(array%farray1DI8, stat=stat) + if (ESMF_LogFoundDeallocError(stat, msg="deallocating array%farray1DI8", & + ESMF_CONTEXT)) & + return ! bail out + endif + if (associated(array%farray2DI8)) then + deallocate(array%farray2DI8, stat=stat) + if (ESMF_LogFoundDeallocError(stat, msg="deallocating array%farray2DI8", & + ESMF_CONTEXT)) & + return ! bail out + endif + if (associated(array%farray3DI8)) then + deallocate(array%farray3DI8, stat=stat) + if (ESMF_LogFoundDeallocError(stat, msg="deallocating array%farray3DI8", & + ESMF_CONTEXT)) & + return ! bail out + endif + + if (associated(array%farray1DR8)) then + deallocate(array%farray1DR8, stat=stat) + if (ESMF_LogFoundDeallocError(stat, msg="deallocating array%farray1DR8", & + ESMF_CONTEXT)) & + return ! bail out + endif + if (associated(array%farray2DR8)) then + deallocate(array%farray2DR8, stat=stat) + if (ESMF_LogFoundDeallocError(stat, msg="deallocating array%farray2DR8", & + ESMF_CONTEXT)) & + return ! bail out + endif + if (associated(array%farray3DR8)) then + deallocate(array%farray3DR8, stat=stat) + if (ESMF_LogFoundDeallocError(stat, msg="deallocating array%farray3DR8", & + ESMF_CONTEXT)) & + return ! bail out + endif endif - + ! return successfully if (present(rc)) rc = ESMF_SUCCESS - + end subroutine ESMF_InterArrayDestroy !------------------------------------------------------------------------------ From 96f95c383d957983472aea0994119406b9048f1b Mon Sep 17 00:00:00 2001 From: Gerhard Theurich Date: Tue, 5 Sep 2023 15:54:52 -0700 Subject: [PATCH 08/14] White space clean-up. --- .../Util/include/ESMCI_F90Interface.h | 12 ++++---- .../Util/interface/ESMCI_F90Interface_F.C | 28 +++++++++---------- .../Util/src/ESMCI_F90Interface.C | 18 ++++++------ 3 files changed, 29 insertions(+), 29 deletions(-) diff --git a/src/Infrastructure/Util/include/ESMCI_F90Interface.h b/src/Infrastructure/Util/include/ESMCI_F90Interface.h index ef3774940a..3b3552118c 100644 --- a/src/Infrastructure/Util/include/ESMCI_F90Interface.h +++ b/src/Infrastructure/Util/include/ESMCI_F90Interface.h @@ -80,7 +80,7 @@ namespace ESMCI { void set(std::vector &arrayArg); void set(T *arrayArg, int dimArg, const int *lenArg); }; - + // implementation of a present() method to detect present/absent optional template bool present(InterArray *ptr); @@ -113,7 +113,7 @@ namespace ESMCI { extent[i]=0; } - template InterArray::InterArray(T *arrayArg, + template InterArray::InterArray(T *arrayArg, int dimArg, const int *lenArg){ // constructor array = arrayArg; @@ -131,7 +131,7 @@ namespace ESMCI { for (int i=dimCount; i<7; i++) extent[i]=0; } - + template void InterArray::set(void){ // set NULL array = NULL; @@ -158,7 +158,7 @@ namespace ESMCI { extent[i]=0; } - template void InterArray::set(T *arrayArg, int dimArg, + template void InterArray::set(T *arrayArg, int dimArg, const int *lenArg){ // set array = arrayArg; @@ -168,11 +168,11 @@ namespace ESMCI { for (int i=dimCount; i<7; i++) extent[i]=0; } - + template bool present(InterArray *ptr){ return ( (ptr != NULL) && (ptr->array != NULL) ); } - + } // namespace ESMCI diff --git a/src/Infrastructure/Util/interface/ESMCI_F90Interface_F.C b/src/Infrastructure/Util/interface/ESMCI_F90Interface_F.C index 2c3db3249a..285067aec7 100644 --- a/src/Infrastructure/Util/interface/ESMCI_F90Interface_F.C +++ b/src/Infrastructure/Util/interface/ESMCI_F90Interface_F.C @@ -1,10 +1,10 @@ // $Id$ // // Earth System Modeling Framework -// Copyright (c) 2002-2023, University Corporation for Atmospheric Research, -// Massachusetts Institute of Technology, Geophysical Fluid Dynamics -// Laboratory, University of Michigan, National Centers for Environmental -// Prediction, Los Alamos National Laboratory, Argonne National Laboratory, +// Copyright (c) 2002-2023, University Corporation for Atmospheric Research, +// Massachusetts Institute of Technology, Geophysical Fluid Dynamics +// Laboratory, University of Michigan, National Centers for Environmental +// Prediction, Los Alamos National Laboratory, Argonne National Laboratory, // NASA Goddard Space Flight Center. // Licensed under the University of Illinois-NCSA License. // @@ -23,7 +23,7 @@ extern "C" { // ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ // ESMC_InterArray interfaces // ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - + void FTN_X(c_esmc_interarraysetinvalid)(ESMCI::InterArray *array, int *rc){ #undef ESMC_METHOD @@ -32,7 +32,7 @@ extern "C" { *rc = ESMF_SUCCESS; } - void FTN_X(c_esmc_interarraycreate1d)(ESMCI::InterArray *array, + void FTN_X(c_esmc_interarraycreate1d)(ESMCI::InterArray *array, int *farray, int *len, int *rc){ #undef ESMC_METHOD #define ESMC_METHOD "c_esmc_interarraycreate1d()" @@ -40,7 +40,7 @@ extern "C" { *rc = ESMF_SUCCESS; } - void FTN_X(c_esmc_interarraycreate2d)(ESMCI::InterArray *array, + void FTN_X(c_esmc_interarraycreate2d)(ESMCI::InterArray *array, int *farray, int *len, int *rc){ #undef ESMC_METHOD #define ESMC_METHOD "c_esmc_interarraycreate2d()" @@ -48,7 +48,7 @@ extern "C" { *rc = ESMF_SUCCESS; } - void FTN_X(c_esmc_interarraycreate3d)(ESMCI::InterArray *array, + void FTN_X(c_esmc_interarraycreate3d)(ESMCI::InterArray *array, int *farray, int *len, int *rc){ #undef ESMC_METHOD #define ESMC_METHOD "c_esmc_interarraycreate3d()" @@ -64,7 +64,7 @@ extern "C" { *rc = ESMF_SUCCESS; } - void FTN_X(c_esmc_interarraycreate1di8)(ESMCI::InterArray *array, + void FTN_X(c_esmc_interarraycreate1di8)(ESMCI::InterArray *array, ESMC_I8 *farray, int *len, int *rc){ #undef ESMC_METHOD #define ESMC_METHOD "c_esmc_interarraycreate1di8()" @@ -72,7 +72,7 @@ extern "C" { *rc = ESMF_SUCCESS; } - void FTN_X(c_esmc_interarraycreate2di8)(ESMCI::InterArray *array, + void FTN_X(c_esmc_interarraycreate2di8)(ESMCI::InterArray *array, ESMC_I8 *farray, int *len, int *rc){ #undef ESMC_METHOD #define ESMC_METHOD "c_esmc_interarraycreate2di8()" @@ -80,7 +80,7 @@ extern "C" { *rc = ESMF_SUCCESS; } - void FTN_X(c_esmc_interarraycreate3di8)(ESMCI::InterArray *array, + void FTN_X(c_esmc_interarraycreate3di8)(ESMCI::InterArray *array, ESMC_I8 *farray, int *len, int *rc){ #undef ESMC_METHOD #define ESMC_METHOD "c_esmc_interarraycreate3di8()" @@ -89,7 +89,7 @@ extern "C" { } - void FTN_X(c_esmc_interarraycreate1dr8)(ESMCI::InterArray *array, + void FTN_X(c_esmc_interarraycreate1dr8)(ESMCI::InterArray *array, ESMC_R8 *farray, int *len, int *rc){ #undef ESMC_METHOD #define ESMC_METHOD "c_esmc_interarraycreate1dr8()" @@ -97,7 +97,7 @@ extern "C" { *rc = ESMF_SUCCESS; } - void FTN_X(c_esmc_interarraycreate2dr8)(ESMCI::InterArray *array, + void FTN_X(c_esmc_interarraycreate2dr8)(ESMCI::InterArray *array, ESMC_R8 *farray, int *len, int *rc){ #undef ESMC_METHOD #define ESMC_METHOD "c_esmc_interarraycreate2dr8()" @@ -105,7 +105,7 @@ extern "C" { *rc = ESMF_SUCCESS; } - void FTN_X(c_esmc_interarraycreate3dr8)(ESMCI::InterArray *array, + void FTN_X(c_esmc_interarraycreate3dr8)(ESMCI::InterArray *array, ESMC_R8 *farray, int *len, int *rc){ #undef ESMC_METHOD #define ESMC_METHOD "c_esmc_interarraycreate3dr8()" diff --git a/src/Infrastructure/Util/src/ESMCI_F90Interface.C b/src/Infrastructure/Util/src/ESMCI_F90Interface.C index 2181af47c7..9591adf902 100644 --- a/src/Infrastructure/Util/src/ESMCI_F90Interface.C +++ b/src/Infrastructure/Util/src/ESMCI_F90Interface.C @@ -1,10 +1,10 @@ // $Id$ // // Earth System Modeling Framework -// Copyright (c) 2002-2023, University Corporation for Atmospheric Research, -// Massachusetts Institute of Technology, Geophysical Fluid Dynamics -// Laboratory, University of Michigan, National Centers for Environmental -// Prediction, Los Alamos National Laboratory, Argonne National Laboratory, +// Copyright (c) 2002-2023, University Corporation for Atmospheric Research, +// Massachusetts Institute of Technology, Geophysical Fluid Dynamics +// Laboratory, University of Michigan, National Centers for Environmental +// Prediction, Los Alamos National Laboratory, Argonne National Laboratory, // NASA Goddard Space Flight Center. // Licensed under the University of Illinois-NCSA License. // @@ -29,7 +29,7 @@ extern "C" { //============================================================================== namespace ESMCI { - + F90ClassHolder::F90ClassHolder(void **udtPtr){ // constructor that stores a user derived type (UDT) inside F90ClassHolder #undef ESMC_METHOD @@ -38,14 +38,14 @@ namespace ESMCI { FTN_X(f_esmf_fortranudtpointersize)(&udtSize); if ((int)sizeof(ESMCI::F90ClassHolder) < udtSize){ int localrc = ESMC_RC_NOT_IMPL; - ESMC_LogDefault.MsgFoundError(ESMC_RC_INTNRL_BAD, + ESMC_LogDefault.MsgFoundError(ESMC_RC_INTNRL_BAD, "- hardcoded ESMCI::F90ClassHolder size smaller than UDT size" " determined at runtime", ESMC_CONTEXT, &localrc); throw localrc; // bail out with exception } - FTN_X(f_esmf_fortranudtpointercopy)((void *)this, (void *)udtPtr); + FTN_X(f_esmf_fortranudtpointercopy)((void *)this, (void *)udtPtr); } - + int F90ClassHolder::castToFortranUDT(void **udtPtr){ int rc=ESMC_RC_NOT_IMPL; FTN_X(f_esmf_fortranudtpointercopy)((void *)udtPtr, (void *)this); @@ -53,5 +53,5 @@ namespace ESMCI { rc = ESMF_SUCCESS; return rc; } - + } // namespace ESMCI From a97cb0807d4b57abd0b274b8cfe1a5308d8372ae Mon Sep 17 00:00:00 2001 From: Gerhard Theurich Date: Wed, 6 Sep 2023 14:29:27 -0700 Subject: [PATCH 09/14] Correct intent(). --- src/Infrastructure/Util/interface/ESMF_F90Interface.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Infrastructure/Util/interface/ESMF_F90Interface.F90 b/src/Infrastructure/Util/interface/ESMF_F90Interface.F90 index 397437ce1d..9c1d2c4f5c 100644 --- a/src/Infrastructure/Util/interface/ESMF_F90Interface.F90 +++ b/src/Infrastructure/Util/interface/ESMF_F90Interface.F90 @@ -532,7 +532,7 @@ recursive subroutine ESMF_InterArrayGet(array, farray1D, farray2D, farray3D, & farray1DI8, farray2DI8, farray3DI8, farray1DR8, farray2DR8, farray3DR8, rc) ! ! !ARGUMENTS: - type(ESMF_InterArray), intent(inout) :: array + type(ESMF_InterArray), intent(in) :: array integer, pointer, optional :: farray1D(:) integer, pointer, optional :: farray2D(:,:) integer, pointer, optional :: farray3D(:,:,:) From da50b6ed1bda77c734bc125056e07d2d5633cb02 Mon Sep 17 00:00:00 2001 From: Gerhard Theurich Date: Wed, 6 Sep 2023 14:30:22 -0700 Subject: [PATCH 10/14] Add testing of new Array Slicing feature. Also some general clean-up and improved testing. --- .../Array/tests/ESMF_ArrayCreateGetUTest.F90 | 617 ++++++++++++++++-- 1 file changed, 562 insertions(+), 55 deletions(-) diff --git a/src/Infrastructure/Array/tests/ESMF_ArrayCreateGetUTest.F90 b/src/Infrastructure/Array/tests/ESMF_ArrayCreateGetUTest.F90 index b42cc1e33f..f4574f80f2 100644 --- a/src/Infrastructure/Array/tests/ESMF_ArrayCreateGetUTest.F90 +++ b/src/Infrastructure/Array/tests/ESMF_ArrayCreateGetUTest.F90 @@ -53,12 +53,12 @@ program ESMF_ArrayCreateGetUTest !LOCAL VARIABLES: type(ESMF_VM):: vm - integer:: i,j,k, next + integer:: i,j,k, next, rank integer:: petCount, localPet, deCount, de, localDeCount, lde, ssiLocalDeCount integer, allocatable :: regDecomp(:) type(ESMF_ArraySpec) :: arrayspec, arrayspec2 type(ESMF_LocalArray), allocatable :: localArrayList(:) - type(ESMF_Array):: array, arrayAlias, arrayCpy, arrayUnInit + type(ESMF_Array):: array, arrayAlias, arrayDup, arrayUnInit type(ESMF_DELayout):: delayout type(ESMF_DistGrid):: distgrid, distgrid2 real(ESMF_KIND_R8) :: diffR8 @@ -78,7 +78,7 @@ program ESMF_ArrayCreateGetUTest integer, allocatable:: computationalLWidth(:,:), computationalUWidth(:,:) integer, allocatable:: minIndexPDe(:,:), maxIndexPDe(:,:) integer, allocatable:: exclusiveLBound(:,:), exclusiveUBound(:,:) - integer, allocatable:: localDeToDeMap(:) + integer, allocatable:: localDeToDeMap(:), arrayToDistGridMap(:) logical:: arrayBool logical:: isCreated logical:: dataCorrect @@ -338,7 +338,7 @@ program ESMF_ArrayCreateGetUTest !NEX_UTest_Multi_Proc_Only write(name, *) "ArrayCreate from Copy, uninitialized Array Test" write(failMsg, *) "Incorrectly returned ESMF_SUCCESS" - arrayCpy = ESMF_ArrayCreate(arrayUnInit, rc=rc) + arrayDup = ESMF_ArrayCreate(arrayUnInit, rc=rc) call ESMF_Test((rc /= ESMF_SUCCESS), name, failMsg, result, ESMF_SRCLINE) !------------------------------------------------------------------------ @@ -346,14 +346,14 @@ program ESMF_ArrayCreateGetUTest write(name, *) "ArrayCreate from Copy (ALLOC), 2D ESMF_TYPEKIND_R8 Test" write(failMsg, *) "Did not return ESMF_SUCCESS" farrayPtr2D = real(localPet+10, ESMF_KIND_R8) ! fill with data to check - arrayCpy = ESMF_ArrayCreate(array, datacopyflag=ESMF_DATACOPY_ALLOC, rc=rc) + arrayDup = ESMF_ArrayCreate(array, datacopyflag=ESMF_DATACOPY_ALLOC, rc=rc) call ESMF_Test((rc.eq.ESMF_SUCCESS), name, failMsg, result, ESMF_SRCLINE) !------------------------------------------------------------------------ !NEX_UTest_Multi_Proc_Only write(name, *) "ArrayGet arrayspec from Array Copy (ALLOC) Test" write(failMsg, *) "Did not return ESMF_SUCCESS" - call ESMF_ArrayGet(arrayCpy, arrayspec=arrayspec2, name=arrayName, rc=rc) + call ESMF_ArrayGet(arrayDup, arrayspec=arrayspec2, name=arrayName, rc=rc) print *, "Array name: ", arrayname call ESMF_Test((rc.eq.ESMF_SUCCESS), name, failMsg, result, ESMF_SRCLINE) @@ -367,7 +367,7 @@ program ESMF_ArrayCreateGetUTest !NEX_UTest_Multi_Proc_Only write(name, *) "ArrayGet Fortran array pointer, from Array Copy (ALLOC) Test" write(failMsg, *) "Did not return ESMF_SUCCESS" - call ESMF_ArrayGet(arrayCpy, farrayPtr=farrayPtr2DCpy, rc=rc) + call ESMF_ArrayGet(arrayDup, farrayPtr=farrayPtr2DCpy, rc=rc) call ESMF_Test((rc.eq.ESMF_SUCCESS), name, failMsg, result, ESMF_SRCLINE) !------------------------------------------------------------------------ @@ -415,14 +415,14 @@ program ESMF_ArrayCreateGetUTest !NEX_UTest_Multi_Proc_Only write(name, *) "ArrayPrint from Copy (ALLOC) after original destroy, 2D ESMF_TYPEKIND_R8 Test" write(failMsg, *) "Did not return ESMF_SUCCESS" - call ESMF_ArrayPrint(arrayCpy, rc=rc) + call ESMF_ArrayPrint(arrayDup, rc=rc) call ESMF_Test((rc.eq.ESMF_SUCCESS), name, failMsg, result, ESMF_SRCLINE) !------------------------------------------------------------------------ !NEX_UTest_Multi_Proc_Only write(name, *) "ArrayDestroy of Copy (ALLOC) Test" write(failMsg, *) "Did not return ESMF_SUCCESS" - call ESMF_ArrayDestroy(arrayCpy, rc=rc) + call ESMF_ArrayDestroy(arrayDup, rc=rc) call ESMF_Test((rc.eq.ESMF_SUCCESS), name, failMsg, result, ESMF_SRCLINE) !------------------------------------------------------------------------ @@ -445,14 +445,14 @@ program ESMF_ArrayCreateGetUTest write(name, *) "ArrayCreate from Copy (VALUE), 2D ESMF_TYPEKIND_R8 Test" write(failMsg, *) "Did not return ESMF_SUCCESS" farrayPtr2D = real(localPet+20, ESMF_KIND_R8) ! fill with data to check - arrayCpy = ESMF_ArrayCreate(array, datacopyflag=ESMF_DATACOPY_VALUE, rc=rc) + arrayDup = ESMF_ArrayCreate(array, datacopyflag=ESMF_DATACOPY_VALUE, rc=rc) call ESMF_Test((rc.eq.ESMF_SUCCESS), name, failMsg, result, ESMF_SRCLINE) !------------------------------------------------------------------------ !NEX_UTest_Multi_Proc_Only write(name, *) "ArrayGet isESMFAllocated from Array Copy (VALUE) Test" write(failMsg, *) "Did not return .true." - call ESMF_ArrayGet(arrayCpy, isESMFAllocated=isESMFAllocated, rc=rc) + call ESMF_ArrayGet(arrayDup, isESMFAllocated=isESMFAllocated, rc=rc) print *, "Array is allocated internally: ", isESMFAllocated call ESMF_Test(isESMFAllocated, name, failMsg, result, ESMF_SRCLINE) @@ -460,7 +460,7 @@ program ESMF_ArrayCreateGetUTest !NEX_UTest_Multi_Proc_Only write(name, *) "ArrayGet arrayspec from Array Copy (VALUE) Test" write(failMsg, *) "Did not return ESMF_SUCCESS" - call ESMF_ArrayGet(arrayCpy, arrayspec=arrayspec2, name=arrayName, rc=rc) + call ESMF_ArrayGet(arrayDup, arrayspec=arrayspec2, name=arrayName, rc=rc) print *, "Array name: ", arrayname call ESMF_Test((rc.eq.ESMF_SUCCESS), name, failMsg, result, ESMF_SRCLINE) @@ -474,7 +474,7 @@ program ESMF_ArrayCreateGetUTest !NEX_UTest_Multi_Proc_Only write(name, *) "ArrayGet Fortran array pointer, from Array Copy (VALUE) Test" write(failMsg, *) "Did not return ESMF_SUCCESS" - call ESMF_ArrayGet(arrayCpy, farrayPtr=farrayPtr2DCpy, rc=rc) + call ESMF_ArrayGet(arrayDup, farrayPtr=farrayPtr2DCpy, rc=rc) call ESMF_Test((rc.eq.ESMF_SUCCESS), name, failMsg, result, ESMF_SRCLINE) !------------------------------------------------------------------------ @@ -522,7 +522,7 @@ program ESMF_ArrayCreateGetUTest !NEX_UTest_Multi_Proc_Only write(name, *) "ArrayDestroy of Copy (VALUE) Test" write(failMsg, *) "Did not return ESMF_SUCCESS" - call ESMF_ArrayDestroy(arrayCpy, rc=rc) + call ESMF_ArrayDestroy(arrayDup, rc=rc) call ESMF_Test((rc.eq.ESMF_SUCCESS), name, failMsg, result, ESMF_SRCLINE) !------------------------------------------------------------------------ @@ -545,14 +545,14 @@ program ESMF_ArrayCreateGetUTest write(name, *) "ArrayCreate from Copy (REF), 2D ESMF_TYPEKIND_R8 Test" write(failMsg, *) "Did not return ESMF_SUCCESS" farrayPtr2D = real(localPet+30, ESMF_KIND_R8) ! fill with data to check - arrayCpy = ESMF_ArrayCreate(array, datacopyflag=ESMF_DATACOPY_REFERENCE, rc=rc) + arrayDup = ESMF_ArrayCreate(array, datacopyflag=ESMF_DATACOPY_REFERENCE, rc=rc) call ESMF_Test((rc.eq.ESMF_SUCCESS), name, failMsg, result, ESMF_SRCLINE) !------------------------------------------------------------------------ !NEX_UTest_Multi_Proc_Only write(name, *) "ArrayGet isESMFAllocated from Array Copy (REF) Test" write(failMsg, *) "Did not return .false." - call ESMF_ArrayGet(arrayCpy, isESMFAllocated=isESMFAllocated, rc=rc) + call ESMF_ArrayGet(arrayDup, isESMFAllocated=isESMFAllocated, rc=rc) print *, "Array is allocated internally: ", isESMFAllocated call ESMF_Test(.not.isESMFAllocated, name, failMsg, result, ESMF_SRCLINE) @@ -560,7 +560,7 @@ program ESMF_ArrayCreateGetUTest !NEX_UTest_Multi_Proc_Only write(name, *) "ArrayGet arrayspec from Array Copy (REF) Test" write(failMsg, *) "Did not return ESMF_SUCCESS" - call ESMF_ArrayGet(arrayCpy, arrayspec=arrayspec2, name=arrayName, rc=rc) + call ESMF_ArrayGet(arrayDup, arrayspec=arrayspec2, name=arrayName, rc=rc) print *, "Array name: ", arrayname call ESMF_Test((rc.eq.ESMF_SUCCESS), name, failMsg, result, ESMF_SRCLINE) @@ -574,7 +574,7 @@ program ESMF_ArrayCreateGetUTest !NEX_UTest_Multi_Proc_Only write(name, *) "ArrayGet Fortran array pointer, from Array Copy (REF) Test" write(failMsg, *) "Did not return ESMF_SUCCESS" - call ESMF_ArrayGet(arrayCpy, farrayPtr=farrayPtr2DCpy, rc=rc) + call ESMF_ArrayGet(arrayDup, farrayPtr=farrayPtr2DCpy, rc=rc) call ESMF_Test((rc.eq.ESMF_SUCCESS), name, failMsg, result, ESMF_SRCLINE) !------------------------------------------------------------------------ @@ -622,7 +622,7 @@ program ESMF_ArrayCreateGetUTest !NEX_UTest_Multi_Proc_Only write(name, *) "ArrayDestroy of Copy Test" write(failMsg, *) "Did not return ESMF_SUCCESS" - call ESMF_ArrayDestroy(arrayCpy, rc=rc) + call ESMF_ArrayDestroy(arrayDup, rc=rc) call ESMF_Test((rc.eq.ESMF_SUCCESS), name, failMsg, result, ESMF_SRCLINE) !------------------------------------------------------------------------ @@ -955,7 +955,7 @@ program ESMF_ArrayCreateGetUTest !------------------------------------------------------------------------ !NEX_UTest_Multi_Proc_Only - write(name, *) "ArrayGet localDeToDeMap ESMF_PIN_DE_TO_SSI Test" + write(name, *) "ArrayGet localDeToDeMap, etc. ESMF_PIN_DE_TO_SSI Test" write(failMsg, *) "Did not return ESMF_SUCCESS" call ESMF_ArrayGet(array, localDeToDeMap=localDeToDeMap, & localarrayList=localArrayList, rc=rc) @@ -1004,6 +1004,9 @@ program ESMF_ArrayCreateGetUTest farrayPtr=farrayPtr2D, rc=rc) if (ssiSharedMemoryEnabled) then call ESMF_Test((rc.eq.ESMF_SUCCESS), name, failMsg, result, ESMF_SRCLINE) + write (msg,*) "localDeToDeMap(next)=", localDeToDeMap(next) + call ESMF_LogWrite(msg, ESMF_LOGMSG_INFO, rc=rc) + if (rc /= ESMF_SUCCESS) call ESMF_Finalize(endflag=ESMF_END_ABORT) write (msg,*) "Local Array lbounds=", lbound(farrayPtr2D) call ESMF_LogWrite(msg, ESMF_LOGMSG_INFO, rc=rc) if (rc /= ESMF_SUCCESS) call ESMF_Finalize(endflag=ESMF_END_ABORT) @@ -1053,7 +1056,7 @@ program ESMF_ArrayCreateGetUTest !NEX_UTest_Multi_Proc_Only write(name, *) "ArrayCreate from Copy (REF), ESMF_PIN_DE_TO_SSI Test" write(failMsg, *) "Did not return ESMF_SUCCESS" - arrayCpy = ESMF_ArrayCreate(array, datacopyflag=ESMF_DATACOPY_REFERENCE, rc=rc) + arrayDup = ESMF_ArrayCreate(array, datacopyflag=ESMF_DATACOPY_REFERENCE, rc=rc) if (ssiSharedMemoryEnabled) then call ESMF_Test((rc.eq.ESMF_SUCCESS), name, failMsg, result, ESMF_SRCLINE) else @@ -1063,9 +1066,9 @@ program ESMF_ArrayCreateGetUTest !------------------------------------------------------------------------ !NEX_UTest_Multi_Proc_Only - write(name, *) "ArrayGet Fortran array pointer for ESMF_PIN_DE_TO_SSI arrayCpy Test" + write(name, *) "ArrayGet Fortran array pointer for ESMF_PIN_DE_TO_SSI arrayDup Test" write(failMsg, *) "Did not return ESMF_SUCCESS" - call ESMF_ArrayGet(arrayCpy, farrayPtr=farrayPtr2D, rc=rc) + call ESMF_ArrayGet(arrayDup, farrayPtr=farrayPtr2D, rc=rc) if (ssiSharedMemoryEnabled) then call ESMF_Test((rc.eq.ESMF_SUCCESS), name, failMsg, result, ESMF_SRCLINE) write (msg,*) "Local Array lbounds=", lbound(farrayPtr2D) @@ -1081,9 +1084,9 @@ program ESMF_ArrayCreateGetUTest !------------------------------------------------------------------------ !NEX_UTest_Multi_Proc_Only - write(name, *) "ArrayGet ssiLocalDeCount ESMF_PIN_DE_TO_SSI arrayCpy Test" + write(name, *) "ArrayGet ssiLocalDeCount ESMF_PIN_DE_TO_SSI arrayDup Test" write(failMsg, *) "Did not return ESMF_SUCCESS" - call ESMF_ArrayGet(arrayCpy, ssiLocalDeCount=ssiLocalDeCount, rc=rc) + call ESMF_ArrayGet(arrayDup, ssiLocalDeCount=ssiLocalDeCount, rc=rc) if (ssiSharedMemoryEnabled) then call ESMF_Test((rc.eq.ESMF_SUCCESS), name, failMsg, result, ESMF_SRCLINE) write (msg,*) "ssiLocalDeCount=", ssiLocalDeCount @@ -1099,9 +1102,9 @@ program ESMF_ArrayCreateGetUTest !------------------------------------------------------------------------ !NEX_UTest_Multi_Proc_Only - write(name, *) "ArrayGet localDeToDeMap ESMF_PIN_DE_TO_SSI arrayCpy Test" + write(name, *) "ArrayGet localDeToDeMap, etc. ESMF_PIN_DE_TO_SSI arrayDup Test" write(failMsg, *) "Did not return ESMF_SUCCESS" - call ESMF_ArrayGet(arrayCpy, localDeToDeMap=localDeToDeMap, & + call ESMF_ArrayGet(arrayDup, localDeToDeMap=localDeToDeMap, & localarrayList=localArrayList, rc=rc) if (ssiSharedMemoryEnabled) then call ESMF_Test((rc.eq.ESMF_SUCCESS), name, failMsg, result, ESMF_SRCLINE) @@ -1128,9 +1131,9 @@ program ESMF_ArrayCreateGetUTest !------------------------------------------------------------------------ !NEX_UTest_Multi_Proc_Only - write(name, *) "ArraySync() for ESMF_PIN_DE_TO_SSI arrayCpy Test" + write(name, *) "ArraySync() for ESMF_PIN_DE_TO_SSI arrayDup Test" write(failMsg, *) "Did not return ESMF_SUCCESS" - call ESMF_ArraySync(arrayCpy, rc=rc) + call ESMF_ArraySync(arrayDup, rc=rc) if (ssiSharedMemoryEnabled) then call ESMF_Test((rc.eq.ESMF_SUCCESS), name, failMsg, result, ESMF_SRCLINE) else @@ -1140,7 +1143,7 @@ program ESMF_ArrayCreateGetUTest !------------------------------------------------------------------------ !NEX_UTest_Multi_Proc_Only - write(name, *) "LocalArrayGet Fortran array pointer for next ssiLocalDe for ESMF_PIN_DE_TO_SSI arrayCpy Test" + write(name, *) "LocalArrayGet Fortran array pointer for next ssiLocalDe for ESMF_PIN_DE_TO_SSI arrayDup Test" write(failMsg, *) "Did not return ESMF_SUCCESS" next = localPet + 2 if (next > ssiLocalDeCount) next = 1 @@ -1148,6 +1151,8 @@ program ESMF_ArrayCreateGetUTest farrayPtr=farrayPtr2D, rc=rc) if (ssiSharedMemoryEnabled) then call ESMF_Test((rc.eq.ESMF_SUCCESS), name, failMsg, result, ESMF_SRCLINE) + write (msg,*) "localDeToDeMap(next)=", localDeToDeMap(next) + call ESMF_LogWrite(msg, ESMF_LOGMSG_INFO, rc=rc) write (msg,*) "Local Array lbounds=", lbound(farrayPtr2D) call ESMF_LogWrite(msg, ESMF_LOGMSG_INFO, rc=rc) if (rc /= ESMF_SUCCESS) call ESMF_Finalize(endflag=ESMF_END_ABORT) @@ -1161,7 +1166,7 @@ program ESMF_ArrayCreateGetUTest !------------------------------------------------------------------------ !NEX_UTest_Multi_Proc_Only - write(name, *) "Validate data in LocalArray for next ssiLocalDe for ESMF_PIN_DE_TO_SSI arrayCpy Test" + write(name, *) "Validate data in LocalArray for next ssiLocalDe for ESMF_PIN_DE_TO_SSI arrayDup Test" write(failMsg, *) "Data not correct" dataCorrect = .true. ! initialize if (ssiSharedMemoryEnabled) then @@ -1187,7 +1192,7 @@ program ESMF_ArrayCreateGetUTest endif call ESMF_Test((dataCorrect), name, failMsg, result, ESMF_SRCLINE) - call ESMF_ArraySync(arrayCpy, rc=rc) ! prevent race condition with below + call ESMF_ArraySync(arrayDup, rc=rc) ! prevent race condition with below if (rc /= ESMF_SUCCESS) call ESMF_Finalize(endflag=ESMF_END_ABORT) deallocate(localDeToDeMap) @@ -1195,9 +1200,9 @@ program ESMF_ArrayCreateGetUTest !------------------------------------------------------------------------ !NEX_UTest_Multi_Proc_Only - write(name, *) "ArrayDestroy Test for arrayCpy with ESMF_PIN_DE_TO_SSI" + write(name, *) "ArrayDestroy Test for arrayDup with ESMF_PIN_DE_TO_SSI" write(failMsg, *) "Did not return ESMF_SUCCESS" - call ESMF_ArrayDestroy(arrayCpy, rc=rc) + call ESMF_ArrayDestroy(arrayDup, rc=rc) if (ssiSharedMemoryEnabled) then call ESMF_Test((rc.eq.ESMF_SUCCESS), name, failMsg, result, ESMF_SRCLINE) else @@ -1211,7 +1216,7 @@ program ESMF_ArrayCreateGetUTest write(failMsg, *) "Did not return ESMF_SUCCESS" delayout = ESMF_DELayoutCreate((/0,0,2,2/), rc=rc) if (rc /= ESMF_SUCCESS) call ESMF_Finalize(endflag=ESMF_END_ABORT) - arrayCpy = ESMF_ArrayCreate(array, datacopyflag=ESMF_DATACOPY_REFERENCE, & + arrayDup = ESMF_ArrayCreate(array, datacopyflag=ESMF_DATACOPY_REFERENCE, & delayout=delayout, rc=rc) if (ssiSharedMemoryEnabled) then call ESMF_Test((rc.eq.ESMF_SUCCESS), name, failMsg, result, ESMF_SRCLINE) @@ -1224,14 +1229,14 @@ program ESMF_ArrayCreateGetUTest !NEX_UTest_Multi_Proc_Only write(name, *) "ArrayPrint from Copy (REF), ESMF_PIN_DE_TO_SSI w/ DELayout Test" write(failMsg, *) "Did not return ESMF_SUCCESS" - call ESMF_ArrayPrint(arrayCpy, rc=rc) + call ESMF_ArrayPrint(arrayDup, rc=rc) call ESMF_Test((rc.eq.ESMF_SUCCESS), name, failMsg, result, ESMF_SRCLINE) !------------------------------------------------------------------------ !NEX_UTest_Multi_Proc_Only - write(name, *) "ArrayGet ssiLocalDeCount ESMF_PIN_DE_TO_SSI arrayCpy Test" + write(name, *) "ArrayGet ssiLocalDeCount ESMF_PIN_DE_TO_SSI arrayDup Test" write(failMsg, *) "Did not return ESMF_SUCCESS" - call ESMF_ArrayGet(arrayCpy, ssiLocalDeCount=ssiLocalDeCount, rc=rc) + call ESMF_ArrayGet(arrayDup, ssiLocalDeCount=ssiLocalDeCount, rc=rc) if (ssiSharedMemoryEnabled) then call ESMF_Test((rc.eq.ESMF_SUCCESS), name, failMsg, result, ESMF_SRCLINE) write (msg,*) "ssiLocalDeCount=", ssiLocalDeCount @@ -1247,9 +1252,9 @@ program ESMF_ArrayCreateGetUTest !------------------------------------------------------------------------ !NEX_UTest_Multi_Proc_Only - write(name, *) "ArrayGet localDeToDeMap ESMF_PIN_DE_TO_SSI arrayCpy Test" + write(name, *) "ArrayGet localDeToDeMap, etc. ESMF_PIN_DE_TO_SSI arrayDup Test" write(failMsg, *) "Did not return ESMF_SUCCESS" - call ESMF_ArrayGet(arrayCpy, localDeToDeMap=localDeToDeMap, & + call ESMF_ArrayGet(arrayDup, localDeToDeMap=localDeToDeMap, & localarrayList=localArrayList, rc=rc) if (ssiSharedMemoryEnabled) then call ESMF_Test((rc.eq.ESMF_SUCCESS), name, failMsg, result, ESMF_SRCLINE) @@ -1263,7 +1268,7 @@ program ESMF_ArrayCreateGetUTest !------------------------------------------------------------------------ !NEX_UTest_Multi_Proc_Only - write(name, *) "Validate data in LocalArray for all DEs for ESMF_PIN_DE_TO_SSI arrayCpy Test" + write(name, *) "Validate data in LocalArray for all DEs for ESMF_PIN_DE_TO_SSI arrayDup Test" write(failMsg, *) "Data not correct" dataCorrect = .true. ! initialize if (ssiSharedMemoryEnabled) then @@ -1294,7 +1299,7 @@ program ESMF_ArrayCreateGetUTest endif call ESMF_Test((dataCorrect), name, failMsg, result, ESMF_SRCLINE) - call ESMF_ArraySync(arrayCpy, rc=rc) ! prevent race condition with below + call ESMF_ArraySync(arrayDup, rc=rc) ! prevent race condition with below if (rc /= ESMF_SUCCESS) call ESMF_Finalize(endflag=ESMF_END_ABORT) deallocate(localDeToDeMap) @@ -1302,9 +1307,9 @@ program ESMF_ArrayCreateGetUTest !------------------------------------------------------------------------ !NEX_UTest_Multi_Proc_Only - write(name, *) "ArraySync() for ESMF_PIN_DE_TO_SSI arrayCpy Test" + write(name, *) "ArraySync() for ESMF_PIN_DE_TO_SSI arrayDup Test" write(failMsg, *) "Did not return ESMF_SUCCESS" - call ESMF_ArraySync(arrayCpy, rc=rc) + call ESMF_ArraySync(arrayDup, rc=rc) if (ssiSharedMemoryEnabled) then call ESMF_Test((rc.eq.ESMF_SUCCESS), name, failMsg, result, ESMF_SRCLINE) else @@ -1314,9 +1319,9 @@ program ESMF_ArrayCreateGetUTest !------------------------------------------------------------------------ !NEX_UTest_Multi_Proc_Only - write(name, *) "ArrayDestroy Test for arrayCpy with ESMF_PIN_DE_TO_SSI w/ DELayout" + write(name, *) "ArrayDestroy Test for arrayDup with ESMF_PIN_DE_TO_SSI w/ DELayout" write(failMsg, *) "Did not return ESMF_SUCCESS" - call ESMF_ArrayDestroy(arrayCpy, rc=rc) + call ESMF_ArrayDestroy(arrayDup, rc=rc) if (ssiSharedMemoryEnabled) then call ESMF_Test((rc.eq.ESMF_SUCCESS), name, failMsg, result, ESMF_SRCLINE) else @@ -1336,8 +1341,6 @@ program ESMF_ArrayCreateGetUTest call ESMF_Test((rc.eq.ESMF_RC_OBJ_NOT_CREATED), name, failMsg, result, ESMF_SRCLINE) endif -!--- new stuff begin ---- - !------------------------------------------------------------------------ !NEX_UTest_Multi_Proc_Only write(name, *) "Create test 2D+1 Array with ESMF_PIN_DE_TO_SSI" @@ -1372,9 +1375,9 @@ program ESMF_ArrayCreateGetUTest !------------------------------------------------------------------------ !NEX_UTest_Multi_Proc_Only - write(name, *) "ArrayGet ssiLocalDeCount ESMF_PIN_DE_TO_SSI 2D+1 Test" + write(name, *) "ArrayGet rank, ssiLocalDeCount ESMF_PIN_DE_TO_SSI 2D+1 Test" write(failMsg, *) "Did not return ESMF_SUCCESS" - call ESMF_ArrayGet(array, ssiLocalDeCount=ssiLocalDeCount, rc=rc) + call ESMF_ArrayGet(array, rank=rank, ssiLocalDeCount=ssiLocalDeCount, rc=rc) if (ssiSharedMemoryEnabled) then call ESMF_Test((rc.eq.ESMF_SUCCESS), name, failMsg, result, ESMF_SRCLINE) write (msg,*) "ssiLocalDeCount=", ssiLocalDeCount @@ -1382,23 +1385,42 @@ program ESMF_ArrayCreateGetUTest if (rc /= ESMF_SUCCESS) call ESMF_Finalize(endflag=ESMF_END_ABORT) else ssiLocalDeCount=1 + rank=1 write(failMsg, *) "Did not return the correct RC" call ESMF_Test((rc.eq.ESMF_RC_OBJ_NOT_CREATED), name, failMsg, result, ESMF_SRCLINE) endif allocate(localDeToDeMap(ssiLocalDeCount)) allocate(localArrayList(ssiLocalDeCount)) + allocate(arrayToDistGridMap(rank)) + + !------------------------------------------------------------------------ + !NEX_UTest_Multi_Proc_Only + write(name, *) "Validate rank for ESMF_PIN_DE_TO_SSI 2D+1 Test" + write(failMsg, *) "Rank is wrong" + if (ssiSharedMemoryEnabled) then + call ESMF_Test((rank==3), name, failMsg, result, ESMF_SRCLINE) + write (msg,*) "rank=", rank + call ESMF_LogWrite(msg, ESMF_LOGMSG_INFO, rc=rc) + if (rc /= ESMF_SUCCESS) call ESMF_Finalize(endflag=ESMF_END_ABORT) + else + ! dummy test call + call ESMF_Test((.true.), name, failMsg, result, ESMF_SRCLINE) + endif !------------------------------------------------------------------------ !NEX_UTest_Multi_Proc_Only - write(name, *) "ArrayGet localDeToDeMap ESMF_PIN_DE_TO_SSI 2D+1 Test" + write(name, *) "ArrayGet localDeToDeMap, etc. ESMF_PIN_DE_TO_SSI 2D+1 Test" write(failMsg, *) "Did not return ESMF_SUCCESS" call ESMF_ArrayGet(array, localDeToDeMap=localDeToDeMap, & - localarrayList=localArrayList, rc=rc) + localarrayList=localArrayList, arrayToDistGridMap=arrayToDistGridMap, rc=rc) if (ssiSharedMemoryEnabled) then call ESMF_Test((rc.eq.ESMF_SUCCESS), name, failMsg, result, ESMF_SRCLINE) write (msg,*) "localDeToDeMap=", localDeToDeMap call ESMF_LogWrite(msg, ESMF_LOGMSG_INFO, rc=rc) if (rc /= ESMF_SUCCESS) call ESMF_Finalize(endflag=ESMF_END_ABORT) + write (msg,*) "arrayToDistGridMap=", arrayToDistGridMap + call ESMF_LogWrite(msg, ESMF_LOGMSG_INFO, rc=rc) + if (rc /= ESMF_SUCCESS) call ESMF_Finalize(endflag=ESMF_END_ABORT) else write(failMsg, *) "Did not return the correct RC" call ESMF_Test((rc.eq.ESMF_RC_OBJ_NOT_CREATED), name, failMsg, result, ESMF_SRCLINE) @@ -1434,7 +1456,8 @@ program ESMF_ArrayCreateGetUTest !------------------------------------------------------------------------ !NEX_UTest_Multi_Proc_Only - write(name, *) "LocalArrayGet Fortran array pointer for next ssiLocalDe for ESMF_PIN_DE_TO_SSI 2D+1 Test" + write(name, *) "LocalArrayGet Fortran array pointer for next ssiLocalDe "//& + "for ESMF_PIN_DE_TO_SSI 2D+1 Test" write(failMsg, *) "Did not return ESMF_SUCCESS" next = localPet + 2 if (next > ssiLocalDeCount) next = 1 @@ -1442,6 +1465,8 @@ program ESMF_ArrayCreateGetUTest farrayPtr=farrayPtr3DR8, rc=rc) if (ssiSharedMemoryEnabled) then call ESMF_Test((rc.eq.ESMF_SUCCESS), name, failMsg, result, ESMF_SRCLINE) + write (msg,*) "localDeToDeMap(next)=", localDeToDeMap(next) + call ESMF_LogWrite(msg, ESMF_LOGMSG_INFO, rc=rc) write (msg,*) "Local Array lbounds=", lbound(farrayPtr3DR8) call ESMF_LogWrite(msg, ESMF_LOGMSG_INFO, rc=rc) if (rc /= ESMF_SUCCESS) call ESMF_Finalize(endflag=ESMF_END_ABORT) @@ -1455,7 +1480,8 @@ program ESMF_ArrayCreateGetUTest !------------------------------------------------------------------------ !NEX_UTest_Multi_Proc_Only - write(name, *) "Validate data in LocalArray for next ssiLocalDe for ESMF_PIN_DE_TO_SSI 2D+1 Test" + write(name, *) "Validate data in LocalArray for next ssiLocalDe for "//& + "ESMF_PIN_DE_TO_SSI 2D+1 Test" write(failMsg, *) "Data not correct" dataCorrect = .true. ! initialize if (ssiSharedMemoryEnabled) then @@ -1489,16 +1515,497 @@ program ESMF_ArrayCreateGetUTest deallocate(localDeToDeMap) deallocate(localArrayList) + deallocate(arrayToDistGridMap) + + !------------------------------------------------------------------------ + !NEX_UTest_Multi_Proc_Only + write(name, *) "ArrayCreate from Copy (REF), ESMF_PIN_DE_TO_SSI "//& + "2D+1->2D Slice at k=1 Test" + write(failMsg, *) "Did not return ESMF_SUCCESS" + arrayDup = ESMF_ArrayCreate(array, datacopyflag=ESMF_DATACOPY_REFERENCE, & + trailingUndistSlice=[1], rc=rc) ! create a slice + if (ssiSharedMemoryEnabled) then + call ESMF_Test((rc.eq.ESMF_SUCCESS), name, failMsg, result, ESMF_SRCLINE) + else + write(failMsg, *) "Did not return the correct RC" + call ESMF_Test((rc.eq.ESMF_RC_OBJ_NOT_CREATED), name, failMsg, result, ESMF_SRCLINE) + endif + + !------------------------------------------------------------------------ + !NEX_UTest_Multi_Proc_Only + write(name, *) "ArrayGet Fortran array pointer for ESMF_PIN_DE_TO_SSI "// & + "arrayDup 2D+1->2D Slice at k=1 Test" + write(failMsg, *) "Did not return ESMF_SUCCESS" + call ESMF_ArrayGet(arrayDup, farrayPtr=farrayPtr2D, rc=rc) + if (ssiSharedMemoryEnabled) then + call ESMF_Test((rc.eq.ESMF_SUCCESS), name, failMsg, result, ESMF_SRCLINE) + write (msg,*) "Local Array lbounds=", lbound(farrayPtr2D) + call ESMF_LogWrite(msg, ESMF_LOGMSG_INFO, rc=rc) + if (rc /= ESMF_SUCCESS) call ESMF_Finalize(endflag=ESMF_END_ABORT) + write (msg,*) "Local Array ubounds=", ubound(farrayPtr2D) + call ESMF_LogWrite(msg, ESMF_LOGMSG_INFO, rc=rc) + if (rc /= ESMF_SUCCESS) call ESMF_Finalize(endflag=ESMF_END_ABORT) + else + write(failMsg, *) "Did not return the correct RC" + call ESMF_Test((rc.eq.ESMF_RC_OBJ_NOT_CREATED), name, failMsg, result, ESMF_SRCLINE) + endif + + !------------------------------------------------------------------------ + !NEX_UTest_Multi_Proc_Only + write(name, *) "ArrayGet rank, ssiLocalDeCount ESMF_PIN_DE_TO_SSI "//& + "arrayDup 2D+1->2D Slice at k=1 Test" + write(failMsg, *) "Did not return ESMF_SUCCESS" + call ESMF_ArrayGet(arrayDup, rank=rank, ssiLocalDeCount=ssiLocalDeCount, & + rc=rc) + if (ssiSharedMemoryEnabled) then + call ESMF_Test((rc.eq.ESMF_SUCCESS), name, failMsg, result, ESMF_SRCLINE) + write (msg,*) "ssiLocalDeCount=", ssiLocalDeCount + call ESMF_LogWrite(msg, ESMF_LOGMSG_INFO, rc=rc) + if (rc /= ESMF_SUCCESS) call ESMF_Finalize(endflag=ESMF_END_ABORT) + else + ssiLocalDeCount=1 + rank=1 + write(failMsg, *) "Did not return the correct RC" + call ESMF_Test((rc.eq.ESMF_RC_OBJ_NOT_CREATED), name, failMsg, result, ESMF_SRCLINE) + endif + allocate(localDeToDeMap(ssiLocalDeCount)) + allocate(localArrayList(ssiLocalDeCount)) + allocate(arrayToDistGridMap(rank)) + + !------------------------------------------------------------------------ + !NEX_UTest_Multi_Proc_Only + write(name, *) "Validate rank for ESMF_PIN_DE_TO_SSI arrayDup 2D+1->2D "//& + "Slice at k=1 Test" + write(failMsg, *) "Rank is wrong" + if (ssiSharedMemoryEnabled) then + call ESMF_Test((rank==2), name, failMsg, result, ESMF_SRCLINE) + write (msg,*) "rank=", rank + call ESMF_LogWrite(msg, ESMF_LOGMSG_INFO, rc=rc) + if (rc /= ESMF_SUCCESS) call ESMF_Finalize(endflag=ESMF_END_ABORT) + else + ! dummy test call + call ESMF_Test((.true.), name, failMsg, result, ESMF_SRCLINE) + endif + + !------------------------------------------------------------------------ + !NEX_UTest_Multi_Proc_Only + write(name, *) "ArrayGet localDeToDeMap, etc. ESMF_PIN_DE_TO_SSI arrayDup "//& + "2D+1->2D Slice at k=1 Test" + write(failMsg, *) "Did not return ESMF_SUCCESS" + call ESMF_ArrayGet(arrayDup, localDeToDeMap=localDeToDeMap, & + localarrayList=localArrayList, arrayToDistGridMap=arrayToDistGridMap, rc=rc) + if (ssiSharedMemoryEnabled) then + call ESMF_Test((rc.eq.ESMF_SUCCESS), name, failMsg, result, ESMF_SRCLINE) + write (msg,*) "localDeToDeMap=", localDeToDeMap + call ESMF_LogWrite(msg, ESMF_LOGMSG_INFO, rc=rc) + if (rc /= ESMF_SUCCESS) call ESMF_Finalize(endflag=ESMF_END_ABORT) + write (msg,*) "arrayToDistGridMap=", arrayToDistGridMap + call ESMF_LogWrite(msg, ESMF_LOGMSG_INFO, rc=rc) + if (rc /= ESMF_SUCCESS) call ESMF_Finalize(endflag=ESMF_END_ABORT) + else + write(failMsg, *) "Did not return the correct RC" + call ESMF_Test((rc.eq.ESMF_RC_OBJ_NOT_CREATED), name, failMsg, result, ESMF_SRCLINE) + endif + + !------------------------------------------------------------------------ + !NEX_UTest_Multi_Proc_Only + write(name, *) "Validate data in LocalArray for all DEs for "//& + "ESMF_PIN_DE_TO_SSI arrayDup 2D+1->2D Slice at k=1 Test" + write(failMsg, *) "Data not correct" + dataCorrect = .true. ! initialize + if (ssiSharedMemoryEnabled) then + k=1 + do lde=1, ssiLocalDeCount + call ESMF_LocalArrayGet(localArrayList(lde), farrayPtr=farrayPtr2D, rc=rc) + if (rc /= ESMF_SUCCESS) call ESMF_Finalize(endflag=ESMF_END_ABORT) + do j=lbound(farrayPtr2D,2), ubound(farrayPtr2D,2) + do i=lbound(farrayPtr2D,1), ubound(farrayPtr2D,1) + write (msg,*) "localDE=",lde-1," DE=", localDeToDeMap(lde), & + " data(",i,",",j,")=", farrayPtr2D(i,j) + call ESMF_LogWrite(msg, ESMF_LOGMSG_INFO, rc=rc) + if (rc /= ESMF_SUCCESS) call ESMF_Finalize(endflag=ESMF_END_ABORT) + diffR8 = farrayPtr2D(i,j) - & + real(localDeToDeMap(lde)+5,ESMF_KIND_R8) & + * sin(real(i,ESMF_KIND_R8)) & + * sin(real(j,ESMF_KIND_R8)) & + * sin(real(k,ESMF_KIND_R8)) + if (abs(diffR8) > 1.d-10) then + dataCorrect=.false. + write (msg,*) "diffR8=", diffR8 + call ESMF_LogWrite(msg, ESMF_LOGMSG_INFO, rc=rc) + if (rc /= ESMF_SUCCESS) call ESMF_Finalize(endflag=ESMF_END_ABORT) + endif + enddo + enddo + enddo + else + ! dummy test + endif + call ESMF_Test((dataCorrect), name, failMsg, result, ESMF_SRCLINE) + + call ESMF_ArraySync(arrayDup, rc=rc) ! prevent race condition with below + if (rc /= ESMF_SUCCESS) call ESMF_Finalize(endflag=ESMF_END_ABORT) + + deallocate(localDeToDeMap) + deallocate(localArrayList) + deallocate(arrayToDistGridMap) + + !------------------------------------------------------------------------ + !NEX_UTest_Multi_Proc_Only + write(name, *) "ArraySync() for ESMF_PIN_DE_TO_SSI arrayDup "//& + "2D+1->2D Slice at k=1 Test" + write(failMsg, *) "Did not return ESMF_SUCCESS" + call ESMF_ArraySync(arrayDup, rc=rc) + if (ssiSharedMemoryEnabled) then + call ESMF_Test((rc.eq.ESMF_SUCCESS), name, failMsg, result, ESMF_SRCLINE) + else + write(failMsg, *) "Did not return the correct RC" + call ESMF_Test((rc.eq.ESMF_RC_OBJ_NOT_CREATED), name, failMsg, result, ESMF_SRCLINE) + endif + + !------------------------------------------------------------------------ + !NEX_UTest_Multi_Proc_Only + write(name, *) "ArrayDestroy Test for arrayDup with ESMF_PIN_DE_TO_SSI "//& + "2D+1->2D Slice at k=1 Test" + write(failMsg, *) "Did not return ESMF_SUCCESS" + call ESMF_ArrayDestroy(arrayDup, rc=rc) + if (ssiSharedMemoryEnabled) then + call ESMF_Test((rc.eq.ESMF_SUCCESS), name, failMsg, result, ESMF_SRCLINE) + else + write(failMsg, *) "Did not return the correct RC" + call ESMF_Test((rc.eq.ESMF_RC_OBJ_NOT_CREATED), name, failMsg, result, ESMF_SRCLINE) + endif + + !------------------------------------------------------------------------ + !NEX_UTest_Multi_Proc_Only + write(name, *) "ArrayCreate from Copy (REF), ESMF_PIN_DE_TO_SSI "//& + "2D+1->2D Slice at k=2 Test" + write(failMsg, *) "Did not return ESMF_SUCCESS" + arrayDup = ESMF_ArrayCreate(array, datacopyflag=ESMF_DATACOPY_REFERENCE, & + trailingUndistSlice=[2], rc=rc) ! create a slice + if (ssiSharedMemoryEnabled) then + call ESMF_Test((rc.eq.ESMF_SUCCESS), name, failMsg, result, ESMF_SRCLINE) + else + write(failMsg, *) "Did not return the correct RC" + call ESMF_Test((rc.eq.ESMF_RC_OBJ_NOT_CREATED), name, failMsg, result, ESMF_SRCLINE) + endif + + !------------------------------------------------------------------------ + !NEX_UTest_Multi_Proc_Only + write(name, *) "ArrayGet Fortran array pointer for ESMF_PIN_DE_TO_SSI "// & + "arrayDup 2D+1->2D Slice at k=2 Test" + write(failMsg, *) "Did not return ESMF_SUCCESS" + call ESMF_ArrayGet(arrayDup, farrayPtr=farrayPtr2D, rc=rc) + if (ssiSharedMemoryEnabled) then + call ESMF_Test((rc.eq.ESMF_SUCCESS), name, failMsg, result, ESMF_SRCLINE) + write (msg,*) "Local Array lbounds=", lbound(farrayPtr2D) + call ESMF_LogWrite(msg, ESMF_LOGMSG_INFO, rc=rc) + if (rc /= ESMF_SUCCESS) call ESMF_Finalize(endflag=ESMF_END_ABORT) + write (msg,*) "Local Array ubounds=", ubound(farrayPtr2D) + call ESMF_LogWrite(msg, ESMF_LOGMSG_INFO, rc=rc) + if (rc /= ESMF_SUCCESS) call ESMF_Finalize(endflag=ESMF_END_ABORT) + else + write(failMsg, *) "Did not return the correct RC" + call ESMF_Test((rc.eq.ESMF_RC_OBJ_NOT_CREATED), name, failMsg, result, ESMF_SRCLINE) + endif + + !------------------------------------------------------------------------ + !NEX_UTest_Multi_Proc_Only + write(name, *) "ArrayGet rank, ssiLocalDeCount ESMF_PIN_DE_TO_SSI "//& + "arrayDup 2D+1->2D Slice at k=2 Test" + write(failMsg, *) "Did not return ESMF_SUCCESS" + call ESMF_ArrayGet(arrayDup, rank=rank, ssiLocalDeCount=ssiLocalDeCount, & + rc=rc) + if (ssiSharedMemoryEnabled) then + call ESMF_Test((rc.eq.ESMF_SUCCESS), name, failMsg, result, ESMF_SRCLINE) + write (msg,*) "ssiLocalDeCount=", ssiLocalDeCount + call ESMF_LogWrite(msg, ESMF_LOGMSG_INFO, rc=rc) + if (rc /= ESMF_SUCCESS) call ESMF_Finalize(endflag=ESMF_END_ABORT) + else + ssiLocalDeCount=1 + rank=1 + write(failMsg, *) "Did not return the correct RC" + call ESMF_Test((rc.eq.ESMF_RC_OBJ_NOT_CREATED), name, failMsg, result, ESMF_SRCLINE) + endif + allocate(localDeToDeMap(ssiLocalDeCount)) + allocate(localArrayList(ssiLocalDeCount)) + allocate(arrayToDistGridMap(rank)) + + !------------------------------------------------------------------------ + !NEX_UTest_Multi_Proc_Only + write(name, *) "Validate rank for ESMF_PIN_DE_TO_SSI arrayDup 2D+1->2D "//& + "Slice at k=2 Test" + write(failMsg, *) "Rank is wrong" + if (ssiSharedMemoryEnabled) then + call ESMF_Test((rank==2), name, failMsg, result, ESMF_SRCLINE) + write (msg,*) "rank=", rank + call ESMF_LogWrite(msg, ESMF_LOGMSG_INFO, rc=rc) + if (rc /= ESMF_SUCCESS) call ESMF_Finalize(endflag=ESMF_END_ABORT) + else + ! dummy test call + call ESMF_Test((.true.), name, failMsg, result, ESMF_SRCLINE) + endif + + !------------------------------------------------------------------------ + !NEX_UTest_Multi_Proc_Only + write(name, *) "ArrayGet localDeToDeMap, etc. ESMF_PIN_DE_TO_SSI arrayDup "//& + "2D+1->2D Slice at k=2 Test" + write(failMsg, *) "Did not return ESMF_SUCCESS" + call ESMF_ArrayGet(arrayDup, localDeToDeMap=localDeToDeMap, & + localarrayList=localArrayList, arrayToDistGridMap=arrayToDistGridMap, rc=rc) + if (ssiSharedMemoryEnabled) then + call ESMF_Test((rc.eq.ESMF_SUCCESS), name, failMsg, result, ESMF_SRCLINE) + write (msg,*) "localDeToDeMap=", localDeToDeMap + call ESMF_LogWrite(msg, ESMF_LOGMSG_INFO, rc=rc) + if (rc /= ESMF_SUCCESS) call ESMF_Finalize(endflag=ESMF_END_ABORT) + write (msg,*) "arrayToDistGridMap=", arrayToDistGridMap + call ESMF_LogWrite(msg, ESMF_LOGMSG_INFO, rc=rc) + if (rc /= ESMF_SUCCESS) call ESMF_Finalize(endflag=ESMF_END_ABORT) + else + write(failMsg, *) "Did not return the correct RC" + call ESMF_Test((rc.eq.ESMF_RC_OBJ_NOT_CREATED), name, failMsg, result, ESMF_SRCLINE) + endif + + !------------------------------------------------------------------------ + !NEX_UTest_Multi_Proc_Only + write(name, *) "Validate data in LocalArray for all DEs for "//& + "ESMF_PIN_DE_TO_SSI arrayDup 2D+1->2D Slice at k=2 Test" + write(failMsg, *) "Data not correct" + dataCorrect = .true. ! initialize + if (ssiSharedMemoryEnabled) then + k=2 + do lde=1, ssiLocalDeCount + call ESMF_LocalArrayGet(localArrayList(lde), farrayPtr=farrayPtr2D, rc=rc) + if (rc /= ESMF_SUCCESS) call ESMF_Finalize(endflag=ESMF_END_ABORT) + do j=lbound(farrayPtr2D,2), ubound(farrayPtr2D,2) + do i=lbound(farrayPtr2D,1), ubound(farrayPtr2D,1) + write (msg,*) "localDE=",lde-1," DE=", localDeToDeMap(lde), & + " data(",i,",",j,")=", farrayPtr2D(i,j) + call ESMF_LogWrite(msg, ESMF_LOGMSG_INFO, rc=rc) + if (rc /= ESMF_SUCCESS) call ESMF_Finalize(endflag=ESMF_END_ABORT) + diffR8 = farrayPtr2D(i,j) - & + real(localDeToDeMap(lde)+5,ESMF_KIND_R8) & + * sin(real(i,ESMF_KIND_R8)) & + * sin(real(j,ESMF_KIND_R8)) & + * sin(real(k,ESMF_KIND_R8)) + if (abs(diffR8) > 1.d-10) then + dataCorrect=.false. + write (msg,*) "diffR8=", diffR8 + call ESMF_LogWrite(msg, ESMF_LOGMSG_INFO, rc=rc) + if (rc /= ESMF_SUCCESS) call ESMF_Finalize(endflag=ESMF_END_ABORT) + endif + enddo + enddo + enddo + else + ! dummy test + endif + call ESMF_Test((dataCorrect), name, failMsg, result, ESMF_SRCLINE) + + call ESMF_ArraySync(arrayDup, rc=rc) ! prevent race condition with below + if (rc /= ESMF_SUCCESS) call ESMF_Finalize(endflag=ESMF_END_ABORT) + + deallocate(localDeToDeMap) + deallocate(localArrayList) + deallocate(arrayToDistGridMap) + !------------------------------------------------------------------------ + !NEX_UTest_Multi_Proc_Only + write(name, *) "ArraySync() for ESMF_PIN_DE_TO_SSI arrayDup "//& + "2D+1->2D Slice at k=2 Test" + write(failMsg, *) "Did not return ESMF_SUCCESS" + call ESMF_ArraySync(arrayDup, rc=rc) + if (ssiSharedMemoryEnabled) then + call ESMF_Test((rc.eq.ESMF_SUCCESS), name, failMsg, result, ESMF_SRCLINE) + else + write(failMsg, *) "Did not return the correct RC" + call ESMF_Test((rc.eq.ESMF_RC_OBJ_NOT_CREATED), name, failMsg, result, ESMF_SRCLINE) + endif + !------------------------------------------------------------------------ + !NEX_UTest_Multi_Proc_Only + write(name, *) "ArrayDestroy Test for arrayDup with ESMF_PIN_DE_TO_SSI "//& + "2D+1->2D Slice at k=2 Test" + write(failMsg, *) "Did not return ESMF_SUCCESS" + call ESMF_ArrayDestroy(arrayDup, rc=rc) + if (ssiSharedMemoryEnabled) then + call ESMF_Test((rc.eq.ESMF_SUCCESS), name, failMsg, result, ESMF_SRCLINE) + else + write(failMsg, *) "Did not return the correct RC" + call ESMF_Test((rc.eq.ESMF_RC_OBJ_NOT_CREATED), name, failMsg, result, ESMF_SRCLINE) + endif + !------------------------------------------------------------------------ + !NEX_UTest_Multi_Proc_Only + write(name, *) "ArrayCreate from Copy (value), ESMF_PIN_DE_TO_SSI "//& + "2D+1->2D Slice at k=3 Test" + write(failMsg, *) "Did not return ESMF_SUCCESS" + arrayDup = ESMF_ArrayCreate(array, datacopyflag=ESMF_DATACOPY_VALUE, & + trailingUndistSlice=[3], rc=rc) ! create a slice + if (ssiSharedMemoryEnabled) then + call ESMF_Test((rc.eq.ESMF_SUCCESS), name, failMsg, result, ESMF_SRCLINE) + else + write(failMsg, *) "Did not return the correct RC" + call ESMF_Test((rc.eq.ESMF_RC_OBJ_NOT_CREATED), name, failMsg, result, ESMF_SRCLINE) + endif + !------------------------------------------------------------------------ + !NEX_UTest_Multi_Proc_Only + write(name, *) "ArrayGet Fortran array pointer for ESMF_PIN_DE_TO_SSI "// & + "arrayDup 2D+1->2D Slice at k=3 Test" + write(failMsg, *) "Did not return ESMF_SUCCESS" + call ESMF_ArrayGet(arrayDup, farrayPtr=farrayPtr2D, rc=rc) + if (ssiSharedMemoryEnabled) then + call ESMF_Test((rc.eq.ESMF_SUCCESS), name, failMsg, result, ESMF_SRCLINE) + write (msg,*) "Local Array lbounds=", lbound(farrayPtr2D) + call ESMF_LogWrite(msg, ESMF_LOGMSG_INFO, rc=rc) + if (rc /= ESMF_SUCCESS) call ESMF_Finalize(endflag=ESMF_END_ABORT) + write (msg,*) "Local Array ubounds=", ubound(farrayPtr2D) + call ESMF_LogWrite(msg, ESMF_LOGMSG_INFO, rc=rc) + if (rc /= ESMF_SUCCESS) call ESMF_Finalize(endflag=ESMF_END_ABORT) + else + write(failMsg, *) "Did not return the correct RC" + call ESMF_Test((rc.eq.ESMF_RC_OBJ_NOT_CREATED), name, failMsg, result, ESMF_SRCLINE) + endif + !------------------------------------------------------------------------ + !NEX_UTest_Multi_Proc_Only + write(name, *) "ArrayGet rank, ssiLocalDeCount ESMF_PIN_DE_TO_SSI "//& + "arrayDup 2D+1->2D Slice at k=3 Test" + write(failMsg, *) "Did not return ESMF_SUCCESS" + call ESMF_ArrayGet(arrayDup, rank=rank, ssiLocalDeCount=ssiLocalDeCount, & + rc=rc) + if (ssiSharedMemoryEnabled) then + call ESMF_Test((rc.eq.ESMF_SUCCESS), name, failMsg, result, ESMF_SRCLINE) + write (msg,*) "ssiLocalDeCount=", ssiLocalDeCount + call ESMF_LogWrite(msg, ESMF_LOGMSG_INFO, rc=rc) + if (rc /= ESMF_SUCCESS) call ESMF_Finalize(endflag=ESMF_END_ABORT) + else + ssiLocalDeCount=1 + rank=1 + write(failMsg, *) "Did not return the correct RC" + call ESMF_Test((rc.eq.ESMF_RC_OBJ_NOT_CREATED), name, failMsg, result, ESMF_SRCLINE) + endif + allocate(localDeToDeMap(ssiLocalDeCount)) + allocate(localArrayList(ssiLocalDeCount)) + allocate(arrayToDistGridMap(rank)) + !------------------------------------------------------------------------ + !NEX_UTest_Multi_Proc_Only + write(name, *) "Validate rank for ESMF_PIN_DE_TO_SSI arrayDup 2D+1->2D "//& + "Slice at k=3 Test" + write(failMsg, *) "Rank is wrong" + if (ssiSharedMemoryEnabled) then + call ESMF_Test((rank==2), name, failMsg, result, ESMF_SRCLINE) + write (msg,*) "rank=", rank + call ESMF_LogWrite(msg, ESMF_LOGMSG_INFO, rc=rc) + if (rc /= ESMF_SUCCESS) call ESMF_Finalize(endflag=ESMF_END_ABORT) + else + ! dummy test call + call ESMF_Test((.true.), name, failMsg, result, ESMF_SRCLINE) + endif + !------------------------------------------------------------------------ + !NEX_UTest_Multi_Proc_Only + write(name, *) "ArrayGet localDeToDeMap, etc. ESMF_PIN_DE_TO_SSI arrayDup "//& + "2D+1->2D Slice at k=3 Test" + write(failMsg, *) "Did not return ESMF_SUCCESS" + call ESMF_ArrayGet(arrayDup, localDeToDeMap=localDeToDeMap, & + localarrayList=localArrayList, arrayToDistGridMap=arrayToDistGridMap, rc=rc) + if (ssiSharedMemoryEnabled) then + call ESMF_Test((rc.eq.ESMF_SUCCESS), name, failMsg, result, ESMF_SRCLINE) + write (msg,*) "localDeToDeMap=", localDeToDeMap + call ESMF_LogWrite(msg, ESMF_LOGMSG_INFO, rc=rc) + if (rc /= ESMF_SUCCESS) call ESMF_Finalize(endflag=ESMF_END_ABORT) + write (msg,*) "arrayToDistGridMap=", arrayToDistGridMap + call ESMF_LogWrite(msg, ESMF_LOGMSG_INFO, rc=rc) + if (rc /= ESMF_SUCCESS) call ESMF_Finalize(endflag=ESMF_END_ABORT) + else + write(failMsg, *) "Did not return the correct RC" + call ESMF_Test((rc.eq.ESMF_RC_OBJ_NOT_CREATED), name, failMsg, result, ESMF_SRCLINE) + endif + !------------------------------------------------------------------------ + !NEX_UTest_Multi_Proc_Only + write(name, *) "Validate data in LocalArray for all DEs for "//& + "ESMF_PIN_DE_TO_SSI arrayDup 2D+1->2D Slice at k=3 Test" + write(failMsg, *) "Data not correct" + dataCorrect = .true. ! initialize + if (ssiSharedMemoryEnabled) then + k=3 + do lde=1, ssiLocalDeCount + call ESMF_LocalArrayGet(localArrayList(lde), farrayPtr=farrayPtr2D, rc=rc) + if (rc /= ESMF_SUCCESS) call ESMF_Finalize(endflag=ESMF_END_ABORT) + do j=lbound(farrayPtr2D,2), ubound(farrayPtr2D,2) + do i=lbound(farrayPtr2D,1), ubound(farrayPtr2D,1) + write (msg,*) "localDE=",lde-1," DE=", localDeToDeMap(lde), & + " data(",i,",",j,")=", farrayPtr2D(i,j) + call ESMF_LogWrite(msg, ESMF_LOGMSG_INFO, rc=rc) + if (rc /= ESMF_SUCCESS) call ESMF_Finalize(endflag=ESMF_END_ABORT) + diffR8 = farrayPtr2D(i,j) - & + real(localDeToDeMap(lde)+5,ESMF_KIND_R8) & + * sin(real(i,ESMF_KIND_R8)) & + * sin(real(j,ESMF_KIND_R8)) & + * sin(real(k,ESMF_KIND_R8)) + if (abs(diffR8) > 1.d-10) then + dataCorrect=.false. + write (msg,*) "diffR8=", diffR8 + call ESMF_LogWrite(msg, ESMF_LOGMSG_INFO, rc=rc) + if (rc /= ESMF_SUCCESS) call ESMF_Finalize(endflag=ESMF_END_ABORT) + endif + enddo + enddo + enddo + else + ! dummy test + endif + call ESMF_Test((dataCorrect), name, failMsg, result, ESMF_SRCLINE) -!--- new stuff end ---- + call ESMF_ArraySync(arrayDup, rc=rc) ! prevent race condition with below + if (rc /= ESMF_SUCCESS) call ESMF_Finalize(endflag=ESMF_END_ABORT) + + deallocate(localDeToDeMap) + deallocate(localArrayList) + deallocate(arrayToDistGridMap) + + !------------------------------------------------------------------------ + !NEX_UTest_Multi_Proc_Only + write(name, *) "ArraySync() for ESMF_PIN_DE_TO_SSI arrayDup "//& + "2D+1->2D Slice at k=3 Test" + write(failMsg, *) "Did not return ESMF_SUCCESS" + call ESMF_ArraySync(arrayDup, rc=rc) + if (ssiSharedMemoryEnabled) then + call ESMF_Test((rc.eq.ESMF_SUCCESS), name, failMsg, result, ESMF_SRCLINE) + else + write(failMsg, *) "Did not return the correct RC" + call ESMF_Test((rc.eq.ESMF_RC_OBJ_NOT_CREATED), name, failMsg, result, ESMF_SRCLINE) + endif + + !------------------------------------------------------------------------ + !NEX_UTest_Multi_Proc_Only + write(name, *) "ArrayDestroy Test for arrayDup with ESMF_PIN_DE_TO_SSI "//& + "2D+1->2D Slice at k=3 Test" + write(failMsg, *) "Did not return ESMF_SUCCESS" + call ESMF_ArrayDestroy(arrayDup, rc=rc) + if (ssiSharedMemoryEnabled) then + call ESMF_Test((rc.eq.ESMF_SUCCESS), name, failMsg, result, ESMF_SRCLINE) + else + write(failMsg, *) "Did not return the correct RC" + call ESMF_Test((rc.eq.ESMF_RC_OBJ_NOT_CREATED), name, failMsg, result, ESMF_SRCLINE) + endif + + !------------------------------------------------------------------------ + !NEX_UTest_Multi_Proc_Only + write(name, *) "ArrayDestroy Test for array with ESMF_PIN_DE_TO_SSI "//& + "2D+1->2D Slice Test" + write(failMsg, *) "Did not return ESMF_SUCCESS" + call ESMF_ArrayDestroy(array, rc=rc) + if (ssiSharedMemoryEnabled) then + call ESMF_Test((rc.eq.ESMF_SUCCESS), name, failMsg, result, ESMF_SRCLINE) + else + write(failMsg, *) "Did not return the correct RC" + call ESMF_Test((rc.eq.ESMF_RC_OBJ_NOT_CREATED), name, failMsg, result, ESMF_SRCLINE) + endif !------------------------------------------------------------------------ ! cleanup From 31405757471c22737965537948bf0148485645e1 Mon Sep 17 00:00:00 2001 From: Gerhard Theurich Date: Wed, 6 Sep 2023 14:30:59 -0700 Subject: [PATCH 11/14] Implement general Array Slicing feature as per request from NASA. Still need to fully overload the internal implementation, but at this stage all of the wiring is hooked up, and unit testing runs cleanly. --- .../Array/include/ESMCI_Array.h | 3 +- .../Array/interface/ESMCI_Array_F.C | 10 +- src/Infrastructure/Array/src/ESMCI_Array.C | 70 ++++++-- .../LocalArray/include/ESMCI_LocalArray.h | 3 + .../interface/ESMF_LocalArrayCreate.cppF90 | 159 ++++++++++++++++++ .../interface/ESMF_LocalArray_C.F90 | 24 +++ .../LocalArray/src/ESMCI_LocalArray.C | 71 +++++++- 7 files changed, 312 insertions(+), 28 deletions(-) diff --git a/src/Infrastructure/Array/include/ESMCI_Array.h b/src/Infrastructure/Array/include/ESMCI_Array.h index 395856a305..0c9b1b0a1c 100644 --- a/src/Infrastructure/Array/include/ESMCI_Array.h +++ b/src/Infrastructure/Array/include/ESMCI_Array.h @@ -363,7 +363,8 @@ namespace ESMCI { InterArray *undistLBoundArg, InterArray *undistUBoundArg, int *rc, VM *vm=NULL); static Array *create(Array *array, DataCopyFlag copyflag, - DELayout *delayout=NULL, int rmLeadingTensors=0, int *rc=NULL); + DELayout *delayout=NULL, InterArray *trailingTensorSlice=NULL, + int rmLeadingTensors=0, int *rc=NULL); static Array *create(Array *array, bool rmTensorFlag, int *rc=NULL); static int destroy(Array **array, bool noGarbage=false); // data copy() diff --git a/src/Infrastructure/Array/interface/ESMCI_Array_F.C b/src/Infrastructure/Array/interface/ESMCI_Array_F.C index dcdc0a33c0..c249ec0411 100644 --- a/src/Infrastructure/Array/interface/ESMCI_Array_F.C +++ b/src/Infrastructure/Array/interface/ESMCI_Array_F.C @@ -157,11 +157,12 @@ extern "C" { ESMC_NOT_PRESENT_FILTER(rc))) return; } - void FTN_X(c_esmc_arraycreatecopy)(ESMCI::Array **ptr, + void FTN_X(c_esmc_arraycreatefromarray)(ESMCI::Array **ptr, ESMCI::Array **arrayOut, ESMCI::DataCopyFlag *copyflag, - ESMCI::DELayout **delayout, int *rc){ + ESMCI::DELayout **delayout, ESMCI::InterArray *trailingUndistSlice, + int *rc){ #undef ESMC_METHOD -#define ESMC_METHOD "c_esmc_arraycreatecopy()" +#define ESMC_METHOD "c_esmc_arraycreatefromarray()" // Initialize return code; assume routine not implemented if (rc!=NULL) *rc = ESMC_RC_NOT_IMPL; int localrc = ESMC_RC_NOT_IMPL; @@ -169,7 +170,8 @@ extern "C" { if (ESMC_NOT_PRESENT_FILTER(delayout) != ESMC_NULL_POINTER) delayout_opt = *delayout; // call into C++ - *arrayOut = ESMCI::Array::create(*ptr, *copyflag, delayout_opt, 0, &localrc); + *arrayOut = ESMCI::Array::create(*ptr, *copyflag, delayout_opt, + trailingUndistSlice, 0, &localrc); if (ESMC_LogDefault.MsgFoundError(localrc, ESMCI_ERR_PASSTHRU, ESMC_CONTEXT, ESMC_NOT_PRESENT_FILTER(rc))) return; } diff --git a/src/Infrastructure/Array/src/ESMCI_Array.C b/src/Infrastructure/Array/src/ESMCI_Array.C index b23a1f9599..25e5bd141a 100644 --- a/src/Infrastructure/Array/src/ESMCI_Array.C +++ b/src/Infrastructure/Array/src/ESMCI_Array.C @@ -2104,11 +2104,12 @@ Array *Array::create( // // !ARGUMENTS: // - Array *arrayIn, // (in) Array to copy - DataCopyFlag copyflag, // (in) - DELayout *delayout, // (in) - int rmLeadingTensors, // (in) leading tensors to remove - int *rc // (out) return code + Array *arrayIn, // (in) Array to copy + DataCopyFlag copyflag, // (in) + DELayout *delayout, // (in) + InterArray *trailingTensorSlice, // (in) trailing tensor slice + int rmLeadingTensors, // (in) leading tensors to remove + int *rc // (out) return code ){ // // !DESCRIPTION: @@ -2136,14 +2137,24 @@ Array *Array::create( ESMC_LogDefault.MsgAllocError("for new ESMCI::Array.", ESMC_CONTEXT, rc); return NULL; } + //TODO: sanity check requested tensor handling (leading and trailing) + int rmTrailingTensors = 0; + if (present(trailingTensorSlice)){ + if (trailingTensorSlice->dimCount != 1){ + ESMC_LogDefault.MsgFoundError(ESMC_RC_ARG_RANK, + "trailingTensorSlice array must be of rank 1", ESMC_CONTEXT, rc); + } + rmTrailingTensors = trailingTensorSlice->extent[0]; + } // copy all scalar members and reference members ESMC_TypeKind_Flag typekind = arrayOut->typekind = arrayIn->typekind; int rank = - arrayOut->rank = arrayIn->rank - rmLeadingTensors; + arrayOut->rank = arrayIn->rank - rmLeadingTensors - rmTrailingTensors; arrayOut->indexflag = arrayIn->indexflag; int tensorCount = - arrayOut->tensorCount = arrayIn->tensorCount - rmLeadingTensors; + arrayOut->tensorCount = arrayIn->tensorCount + - rmLeadingTensors - rmTrailingTensors; arrayOut->vasLocalDeCount = arrayIn->vasLocalDeCount; if (copyflag == DATACOPY_REFERENCE){ // sharing reference means also sharing memhandle @@ -2207,10 +2218,9 @@ Array *Array::create( if (arrayOut->tensorElementCount==0) arrayOut->tensorElementCount=1; // copy the PET-local LocalArray pointers arrayOut->larrayList = new LocalArray*[ssiLocalDeCount]; - int *i2jMap = NULL; + vector i2jMap(ssiLocalDeCount); if (rmLeadingTensors==0){ // use the src larrayList as a template for the new larrayList - i2jMap = new int[ssiLocalDeCount]; for (int i=0; ilarrayList[i] = - LocalArray::create(arrayIn->larrayList[j], copyflag, NULL, NULL, - &localrc); - if (ESMC_LogDefault.MsgFoundError(localrc, - ESMCI_ERR_PASSTHRU, ESMC_CONTEXT, rc)){ - arrayOut->ESMC_BaseSetStatus(ESMF_STATUS_INVALID); // mark invalid - return ESMC_NULL_POINTER; + if (present(trailingTensorSlice)){ + arrayOut->larrayList[i] = LocalArray::create(arrayIn->larrayList[j], + trailingTensorSlice, &localrc); + if (ESMC_LogDefault.MsgFoundError(localrc, + ESMCI_ERR_PASSTHRU, ESMC_CONTEXT, rc)){ + arrayOut->ESMC_BaseSetStatus(ESMF_STATUS_INVALID); // mark invalid + return ESMC_NULL_POINTER; + } + if (copyflag != DATACOPY_REFERENCE){ + // create tha appropriate copy + ESMCI::LocalArray *larray = arrayOut->larrayList[i]; + arrayOut->larrayList[i] = LocalArray::create(larray, + copyflag, NULL, NULL, &localrc); + if (ESMC_LogDefault.MsgFoundError(localrc, + ESMCI_ERR_PASSTHRU, ESMC_CONTEXT, rc)){ + arrayOut->ESMC_BaseSetStatus(ESMF_STATUS_INVALID); // mark invalid + return ESMC_NULL_POINTER; + } + localrc = ESMCI::LocalArray::destroy(larray); + if (ESMC_LogDefault.MsgFoundError(localrc, + ESMCI_ERR_PASSTHRU, ESMC_CONTEXT, rc)){ + arrayOut->ESMC_BaseSetStatus(ESMF_STATUS_INVALID); // mark invalid + return ESMC_NULL_POINTER; + } + } + }else{ + arrayOut->larrayList[i] = LocalArray::create(arrayIn->larrayList[j], + copyflag, NULL, NULL, &localrc); + if (ESMC_LogDefault.MsgFoundError(localrc, + ESMCI_ERR_PASSTHRU, ESMC_CONTEXT, rc)){ + arrayOut->ESMC_BaseSetStatus(ESMF_STATUS_INVALID); // mark invalid + return ESMC_NULL_POINTER; + } } } }else{ @@ -2350,8 +2386,6 @@ Array *Array::create( arrayOut->vmAux = arrayIn->vmAux; // simple copy arrayOut->ioRH = NULL; // invalidate - if (i2jMap) delete [] i2jMap; - }catch(int catchrc){ // catch standard ESMF return code ESMC_LogDefault.MsgFoundError(catchrc, ESMCI_ERR_PASSTHRU, ESMC_CONTEXT, diff --git a/src/Infrastructure/LocalArray/include/ESMCI_LocalArray.h b/src/Infrastructure/LocalArray/include/ESMCI_LocalArray.h index 07a0866961..90c23ed3ec 100644 --- a/src/Infrastructure/LocalArray/include/ESMCI_LocalArray.h +++ b/src/Infrastructure/LocalArray/include/ESMCI_LocalArray.h @@ -35,6 +35,7 @@ #include "ESMCI_Util.h" #include "ESMCI_Macros.h" +#include "ESMCI_F90Interface.h" //------------------------------------------------------------------------- @@ -118,6 +119,8 @@ namespace ESMCI { DataCopyFlag docopy = DATACOPY_REFERENCE, int *rc = NULL); static LocalArray *create(const LocalArray *larrayIn, DataCopyFlag copyflag, const int *lbounds, const int *ubounds, int *rc); + static LocalArray *create(const LocalArray *larrayIn, + InterArray *trailingTensorSlice, int *rc); static int destroy(LocalArray *array); // standard methods diff --git a/src/Infrastructure/LocalArray/interface/ESMF_LocalArrayCreate.cppF90 b/src/Infrastructure/LocalArray/interface/ESMF_LocalArrayCreate.cppF90 index 2041ce3125..77e577a9cf 100644 --- a/src/Infrastructure/LocalArray/interface/ESMF_LocalArrayCreate.cppF90 +++ b/src/Infrastructure/LocalArray/interface/ESMF_LocalArrayCreate.cppF90 @@ -52,6 +52,7 @@ module ESMF_LocalArrayCreateMod use ESMF_BaseMod ! ESMF base class use ESMF_LogErrMod ! ESMF error handling use ESMF_IOUtilMod + use ESMF_F90InterfaceMod use ESMF_ArraySpecMod use ESMF_LocalArrayWrapperTypeMod ! contains the LAWrapper derived type @@ -137,6 +138,7 @@ module ESMF_LocalArrayCreateMod public ESMF_LocalArrayCopyF90Ptr public ESMF_LocalArrayAdjust + public ESMF_LocalArraySlice public ESMF_LocalArrayValidate public ESMF_LocalArrayPrint @@ -3603,6 +3605,163 @@ TypeKindRankDeclarationMacro(LocalArrayAdjust) TypeKindRankDeclarationMacro(LocalArrayAdjustShape) +!------------------------------------------------------------------------------ +^undef ESMF_METHOD +^define ESMF_METHOD "ESMF_LocalArraySlice" +!BOPI +! !IROUTINE: ESMF_LocalArraySlice - Slice array on trailing dims +! +! !INTERFACE: + subroutine ESMF_LocalArraySlice(array, trailingTensorSlice, rankIn, rankOut, rc) +! +! !ARGUMENTS: + type(ESMF_LocalArray), intent(inout) :: array + type(ESMF_InterArray), intent(in) :: trailingTensorSlice + integer, intent(in) :: rankIn, rankOut + integer, intent(out), optional :: rc + +! +! !DESCRIPTION: +! Slice the {\tt ESMF\_LocalArray} object. +! +!EOPI +!------------------------------------------------------------------------------ + ! Local vars + integer :: localrc ! local return code + integer :: localtk, count + type(ESMF_TypeKind_Flag) :: typekind + integer, pointer :: slice(:) + + localrc = ESMF_RC_NOT_IMPL + + ! Access information from array + call c_ESMC_LocalArrayGetTypeKind(array, typekind, localrc) + if (ESMF_LogFoundError(localrc, & + ESMF_ERR_PASSTHRU, & + ESMF_CONTEXT, rcToReturn=rc)) return + + ! Access information from trailingTensorSlice + call ESMF_InterArrayGet(trailingTensorSlice, farray1D=slice, rc=localrc) + if (ESMF_LogFoundError(localrc, & + ESMF_ERR_PASSTHRU, & + ESMF_CONTEXT, rcToReturn=rc)) return + count = size(slice) +print *, "count: ", count +print *, "slice: ", slice + + ! Call a T/K/R specific interface in order to create the proper + ! type of F90 pointer, then slice the F90 pointer. + + localtk = typekind%dkind + + !! calling routines generated from macros by the preprocessor + + select case (localtk) + case (ESMF_TYPEKIND_R8%dkind) + select case(rankIn) + case (1) + case (2) + case (3) + select case(rankOut) + case (1) + case (2) + call ESMF_LocalArraySlice3D2DR8(array, slice, rc=localrc) + if (ESMF_LogFoundError(localrc, & + ESMF_ERR_PASSTHRU, & + ESMF_CONTEXT, rcToReturn=rc)) return + case default + if (ESMF_LogFoundError(ESMF_RC_ARG_BAD, & + msg="Unsupported rankIn/rankOut combination", & + ESMF_CONTEXT, rcToReturn=rc)) return + end select + case (4) +^ifndef ESMF_NO_GREATER_THAN_4D + case (5) + case (6) + case (7) +^endif + case default + if (ESMF_LogFoundError(ESMF_RC_ARG_BAD, & + msg="Unsupported rankIn", & + ESMF_CONTEXT, rcToReturn=rc)) return + end select + case default + if (ESMF_LogFoundError(ESMF_RC_ARG_BAD, & + msg="Unsupported typekind", & + ESMF_CONTEXT, rcToReturn=rc)) return + end select + + ! Set init code + ESMF_INIT_SET_CREATED(array) + + ! Return successfully + if (present(rc)) rc = ESMF_SUCCESS + + end subroutine ESMF_LocalArraySlice +!------------------------------------------------------------------------------ + + + subroutine ESMF_LocalArraySlice3D2DR8(array, slice, rc) + type(ESMF_LocalArray), intent(inout) :: array + integer, pointer :: slice(:) + integer, intent(out), optional :: rc + + integer :: localrc, rankOut + type (ESMF_LAWrap3Dr8) :: wrapIn + type (ESMF_LAWrap2Dr8) :: wrapOut + real (ESMF_KIND_r8), dimension(:,:,:), pointer :: farrayPtrIn + real (ESMF_KIND_r8), dimension(:,:), pointer :: farrayPtrOut + + call ESMF_LogWrite("Hi There from ESMF_LocalArraySlice3D2DR8", & + ESMF_LOGMSG_DEBUG, rc=rc) + + call c_ESMC_LocalArrayGetFPtr(array, wrapIn, localrc) + if (ESMF_LogFoundError(localrc, & + ESMF_ERR_PASSTHRU, & + ESMF_CONTEXT, rcToReturn=rc)) return + +print *, "lbound(wrapIn%ptr3Dr8):", lbound(wrapIn%ptr3Dr8) +print *, "ubound(wrapIn%ptr3Dr8):", ubound(wrapIn%ptr3Dr8) + +#if 0 + + ! slicing!!! + wrapOut%ptr2Dr8 => wrapIn%ptr3Dr8(:,:,slice(1)) +! wrapOut%ptr2Dr8 => wrapIn%ptr3Dr8(:,:,1) + +!print *, "wrapOut%ptr2Dr8(1,1)=", wrapOut%ptr2Dr8(1,1) + + rankOut = 2 ! must set now so SetFPtr works correctly + call c_ESMC_LocalArraySetRank(array, rankOut, localrc) + if (ESMF_LogFoundError(localrc, & + ESMF_ERR_PASSTHRU, & + ESMF_CONTEXT, rcToReturn=rc)) return + + call c_ESMC_LocalArraySetFPtr(array, wrapOut, localrc) + if (ESMF_LogFoundError(localrc, & + ESMF_ERR_PASSTHRU, & + ESMF_CONTEXT, rcToReturn=rc)) return +#else + + farrayPtrOut(lbound(wrapIn%ptr3Dr8,1):,lbound(wrapIn%ptr3Dr8,2):) => wrapIn%ptr3Dr8(:,:,slice(1)) +! farrayPtrOut => wrapIn%ptr3Dr8(:,:,slice(1)) + +print *, "lbound(farrayPtrOut):", lbound(farrayPtrOut) +print *, "ubound(farrayPtrOut):", ubound(farrayPtrOut) + + array = ESMF_LocalArrayCreate(farrayPtrOut, rc=localrc) + if (ESMF_LogFoundError(localrc, & + ESMF_ERR_PASSTHRU, & + ESMF_CONTEXT, rcToReturn=rc)) return + +#endif + + ! Return successfully + if (present(rc)) rc = ESMF_SUCCESS + + end subroutine ESMF_LocalArraySlice3D2DR8 + + !------------------------------------------------------------------------------ ^undef ESMF_METHOD ^define ESMF_METHOD "ESMF_LocalArrayValidate" diff --git a/src/Infrastructure/LocalArray/interface/ESMF_LocalArray_C.F90 b/src/Infrastructure/LocalArray/interface/ESMF_LocalArray_C.F90 index 1744890726..e7a96527cb 100644 --- a/src/Infrastructure/LocalArray/interface/ESMF_LocalArray_C.F90 +++ b/src/Infrastructure/LocalArray/interface/ESMF_LocalArray_C.F90 @@ -108,6 +108,30 @@ subroutine f_esmf_localarrayadjust(array, rank, typekind, counts, & end subroutine f_esmf_localarrayadjust +#undef ESMF_METHOD +#define ESMF_METHOD "f_esmf_localarrayslice" +subroutine f_esmf_localarrayslice(array, trailingTensorSlice, rankIn, rankOut, rc) + use ESMF_UtilTypesMod ! ESMF base class + use ESMF_BaseMod ! ESMF base class + use ESMF_LogErrMod ! ESMF error logging + use ESMF_LocalArrayMod + use ESMF_F90InterfaceMod + + implicit none + + type(ESMF_LocalArray) :: array + type(ESMF_InterArray) :: trailingTensorSlice + integer :: rankIn, rankOut + integer :: rc + + call ESMF_LocalArraySlice(array, trailingTensorSlice, rankIn, rankOut, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, & + ESMF_ERR_PASSTHRU, & + ESMF_CONTEXT)) return + +end subroutine f_esmf_localarrayslice + + #undef ESMF_METHOD #define ESMF_METHOD "f_esmf_localarraycopyf90ptr" subroutine f_esmf_localarraycopyf90ptr(arrayInArg, arrayOutArg, datacopyflag, rc) diff --git a/src/Infrastructure/LocalArray/src/ESMCI_LocalArray.C b/src/Infrastructure/LocalArray/src/ESMCI_LocalArray.C index e490d8c02f..2ce61a201c 100644 --- a/src/Infrastructure/LocalArray/src/ESMCI_LocalArray.C +++ b/src/Infrastructure/LocalArray/src/ESMCI_LocalArray.C @@ -52,19 +52,22 @@ extern "C" { void FTN_X(f_esmf_localarrayf90allocate)(ESMCI::LocalArray**, int *, ESMC_TypeKind_Flag*, int *, int *, int *, int *); - + void FTN_X(f_esmf_localarrayf90deallocate)(ESMCI::LocalArray**, int*, ESMC_TypeKind_Flag *, int *); - + void FTN_X(f_esmf_localarrayadjust)(ESMCI::LocalArray**, int *, ESMC_TypeKind_Flag*, const int *, const int *, const int *, int *); - void FTN_X(f_esmf_localarraycopyf90ptr)(const ESMCI::LocalArray** laIn, + void FTN_X(f_esmf_localarrayslice)(ESMCI::LocalArray**, + ESMCI::InterArray *, int *, int *, int *); + + void FTN_X(f_esmf_localarraycopyf90ptr)(const ESMCI::LocalArray** laIn, ESMCI::LocalArray** laOut, ESMCI::DataCopyFlag *copyflag, int *rc); - + void FTN_X(f_esmf_localarrayctof90)(ESMCI::LocalArray**, void *, int *, ESMC_TypeKind_Flag*, int *, int *, int *, int *); - + #ifndef ESMF_NO_INTEGER_1_BYTE void FTN_X(f_esmf_fortrantkrptrcopy1di1)(void *dst, void *src); void FTN_X(f_esmf_fortrantkrptrcopy2di1)(void *dst, void *src); @@ -599,6 +602,64 @@ LocalArray *LocalArray::create( //----------------------------------------------------------------------------- +//----------------------------------------------------------------------------- +#undef ESMC_METHOD +#define ESMC_METHOD "ESMCI::LocalArray::create()" +//BOPI +// !IROUTINE: ESMCI::LocalArray::create - create ESMCI::LocalArray as slice from existing object by reference +// +// !INTERFACE: +LocalArray *LocalArray::create( +// +// !RETURN VALUE: +// pointer to newly allocated ESMCI::LocalArray object +// +// !ARGUMENTS: + const LocalArray *larrayIn, // incoming object + InterArray *trailingTensorSlice, // trailing tensor slice tuple + int *rc){ // return code +// +// !DESCRIPTION: +// Return slice of {\tt larrayIn} by reference +// +//EOPI +//----------------------------------------------------------------------------- + // initialize return code; assume routine not implemented + if (rc != NULL) *rc = ESMC_RC_NOT_IMPL; + int localrc = ESMC_RC_NOT_IMPL; + + // allocate memory for new LocalArray object + LocalArray *larrayOut; + try{ + larrayOut = new LocalArray; + }catch(...){ + // allocation error + ESMC_LogDefault.AllocError(ESMC_CONTEXT, rc); + return ESMC_NULL_POINTER; + } + // copy the LocalArray members, including the _reference_ to its data alloc. + *larrayOut = *larrayIn; + + // mark this copy not to be responsible for deallocation + larrayOut->dealloc = false; + + // determine rankIn and rankOut + int rankIn = larrayIn->rank; + int rankOut = rankIn - trailingTensorSlice->extent[0]; + + // create new larrayOut with adjusted Fortran dope vector to reflect slicing + FTN_X(f_esmf_localarrayslice)(&larrayOut, trailingTensorSlice, + &rankIn, &rankOut, &localrc); + if (ESMC_LogDefault.MsgFoundError(localrc, ESMCI_ERR_PASSTHRU, + ESMC_CONTEXT, rc)) return NULL; + + // return successfully + if (rc) *rc = ESMF_SUCCESS; + return larrayOut; +} +//----------------------------------------------------------------------------- + + //----------------------------------------------------------------------------- #undef ESMC_METHOD #define ESMC_METHOD "ESMCI::LocalArray::destroy()" From 0a1a58a813edeecc1ce1e4fc749a8b95e2379d11 Mon Sep 17 00:00:00 2001 From: Gerhard Theurich Date: Thu, 7 Sep 2023 11:11:41 -0700 Subject: [PATCH 12/14] Macro clean-up. Removal of unused PIO_TKR preprocessor logic. --- .../interface/ESMF_LocalArrayCreate.cppF90 | 34 +++++------ .../include/ESMF_TypeKindRankMacros.hcppF90 | 60 +------------------ 2 files changed, 19 insertions(+), 75 deletions(-) diff --git a/src/Infrastructure/LocalArray/interface/ESMF_LocalArrayCreate.cppF90 b/src/Infrastructure/LocalArray/interface/ESMF_LocalArrayCreate.cppF90 index 77e577a9cf..9779c3635c 100644 --- a/src/Infrastructure/LocalArray/interface/ESMF_LocalArrayCreate.cppF90 +++ b/src/Infrastructure/LocalArray/interface/ESMF_LocalArrayCreate.cppF90 @@ -911,7 +911,7 @@ end function !EOP @\ !---------------------------------------------------------------------------- @\ -#define LocalArrCreateByPtrMacro(mname, mtypekind, mrank, mdim, mlen, mrng, mloc) \ +#define LocalArrCreateByPtrMacro(mtypename, mtypekind, mrank, mdim, mlen, mrng, mloc) \ !---------------------------------------------------------------------------- @\ ^undef ESMF_METHOD @\ !define ESMF_METHOD "ESMF_LocalArrCreateByPtr##mrank##D##mtypekind" @\ @@ -921,7 +921,7 @@ end function @\ type(ESMF_LocalArray) :: ESMF_LocalArrCreateByPtr##mrank##D##mtypekind @\ @\ - mname (ESMF_KIND_##mtypekind), dimension(mdim), pointer :: farrayPtr @\ + mtypename (ESMF_KIND_##mtypekind), dimension(mdim), pointer :: farrayPtr @\ type(ESMF_KeywordEnforcer), optional:: keywordEnforcer ! must use keywords below @\ type(ESMF_DataCopy_Flag), intent(in), optional :: datacopyflag @\ integer, dimension(:), intent(in), optional :: totalCount @\ @@ -1636,7 +1636,7 @@ TypeKindRankDeclarationMacro(LocalArrCreateByPtr) !---------------------------------------------------------------------------- @\ @\ -#define LocalArrConstrF90PtrMacro(mname, mtypekind, mrank, mdim, mlen, mrng, mloc) \ +#define LocalArrConstrF90PtrMacro(mtypename, mtypekind, mrank, mdim, mlen, mrng, mloc) \ !---------------------------------------------------------------------------- @\ ^undef ESMF_METHOD @\ !define ESMF_METHOD "ESMF_LocalArrConstrF90Ptr##mrank##D##mtypekind" @\ @@ -1647,7 +1647,7 @@ TypeKindRankDeclarationMacro(LocalArrCreateByPtr) @\ type(ESMF_LocalArray), intent(inout) :: array @\ integer, dimension(:), intent(in) :: totalCount @\ - mname (ESMF_KIND_##mtypekind), dimension(mdim), pointer, optional :: farrayPtr @\ + mtypename (ESMF_KIND_##mtypekind), dimension(mdim), pointer, optional :: farrayPtr @\ type(ESMF_DataCopy_Flag), intent(in), optional :: datacopyflag @\ integer, dimension(:), intent(in), optional :: totalLBound @\ integer, dimension(:), intent(in), optional :: totalUBound @\ @@ -1660,7 +1660,7 @@ TypeKindRankDeclarationMacro(LocalArrCreateByPtr) type(ESMF_Logical) :: do_dealloc ! dealloc flag for SetInternal call @\ @\ type (ESMF_LAWrap##mrank##D##mtypekind) :: wrap ! to pass f90 ptr to C++ @\ - mname (ESMF_KIND_##mtypekind), dimension(mdim), pointer :: newp @\ + mtypename (ESMF_KIND_##mtypekind), dimension(mdim), pointer :: newp @\ integer, dimension(ESMF_MAXDIM) :: lb, ub @\ integer, dimension(ESMF_MAXDIM) :: offsets @\ @\ @@ -2258,7 +2258,7 @@ TypeKindRankDeclarationMacro(LocalArrConstrF90Ptr) !---------------------------------------------------------------------------- @\ @\ -#define LocalArrCToF90PtrMacro(mname, mtypekind, mrank, mdim, mlen, mrng, mloc) \ +#define LocalArrCToF90PtrMacro(mtypename, mtypekind, mrank, mdim, mlen, mrng, mloc) \ !---------------------------------------------------------------------------- @\ ^undef ESMF_METHOD @\ !define ESMF_METHOD "ESMF_LocalArrCToF90Ptr##mrank##D##mtypekind" @\ @@ -2277,7 +2277,7 @@ TypeKindRankDeclarationMacro(LocalArrConstrF90Ptr) @\ ! Local variables @\ integer :: localrc ! local return code @\ - mname (ESMF_KIND_##mtypekind), dimension(mdim), pointer :: farrayPtr @\ + mtypename (ESMF_KIND_##mtypekind), dimension(mdim), pointer :: farrayPtr @\ character(len=160) :: msgString @\ integer, dimension(mrank) :: totalLBoundLocal @\ integer, dimension(mrank) :: totalUBoundLocal @\ @@ -2327,10 +2327,10 @@ TypeKindRankDeclarationMacro(LocalArrCToF90Ptr) !------------------------------------------------------------------------------ -#define LocalArrayVarMacro(mname, mtypekind, mrank, mdim) \ +#define LocalArrayVarMacro(mtypename, mtypekind, mrank, mdim) \ type(ESMF_LAWrap##mrank##D##mtypekind) :: l##mrank##D##mtypekind -#define AllocDeallocateMacro(mname, mtypekind, mrank, mdim, mlen, mrng, mloc) \ +#define AllocDeallocateMacro(mtypename, mtypekind, mrank, mdim, mlen, mrng, mloc) \ call c_ESMC_LocalArrayGetFPtr(array, l##mrank##D##mtypekind, localrc) @\ if (ESMF_LogFoundError(localrc, & @\ ESMF_ERR_PASSTHRU, & @\ @@ -2978,7 +2978,7 @@ AllocDeallocateMacro(real, R8, 7, COL7, LEN7, RNG7, LOC7) !---------------------------------------------------------------------------- @\ @\ -#define LocalArrayCopyMacro(mname, mtypekind, mrank, mdim, mlen, mrng, mloc) \ +#define LocalArrayCopyMacro(mtypename, mtypekind, mrank, mdim, mlen, mrng, mloc) \ !---------------------------------------------------------------------------- @\ ^undef ESMF_METHOD @\ !define ESMF_METHOD "ESMF_LocalArrayCopy##mrank##D##mtypekind" @\ @@ -2998,7 +2998,7 @@ AllocDeallocateMacro(real, R8, 7, COL7, LEN7, RNG7, LOC7) type (ESMF_LAWrap##mrank##D##mtypekind) :: wrapOut ! for passing f90 ptr to C++ @\ @\ integer :: lb(mrank), ub(mrank) ! size info for the array @\ - mname (ESMF_KIND_##mtypekind), dimension(mdim), pointer :: lp ! local copy @\ + mtypename (ESMF_KIND_##mtypekind), dimension(mdim), pointer :: lp ! local copy @\ @\ ! initialize return code; assume routine not implemented @\ localrc = ESMF_RC_NOT_IMPL @\ @@ -3468,7 +3468,7 @@ TypeKindRankDeclarationMacro(LocalArrayCopy) !---------------------------------------------------------------------------- @\ @\ -#define LocalArrayAdjustMacro(mname, mtypekind, mrank, mdim, mlen, mrng, mloc) \ +#define LocalArrayAdjustMacro(mtypename, mtypekind, mrank, mdim, mlen, mrng, mloc) \ !---------------------------------------------------------------------------- @\ ^undef ESMF_METHOD @\ !define ESMF_METHOD "ESMF_LocalArrayAdjust##mrank##D##mtypekind" @\ @@ -3487,7 +3487,7 @@ TypeKindRankDeclarationMacro(LocalArrayCopy) integer :: localrc ! local return code @\ @\ type (ESMF_LAWrap##mrank##D##mtypekind) :: wrap ! to pass f90 ptr to C++ @\ - mname (ESMF_KIND_##mtypekind), dimension(mdim), pointer :: farrayPtr @\ + mtypename (ESMF_KIND_##mtypekind), dimension(mdim), pointer :: farrayPtr @\ @\ ! Initialize return code; assume routine not implemented @\ localrc = ESMF_RC_NOT_IMPL @\ @@ -3532,7 +3532,7 @@ TypeKindRankDeclarationMacro(LocalArrayAdjust) ! integer, dimension(:), intent(in) :: totalCount @\ ! integer, dimension(:), intent(in), optional :: lb @\ ! integer, dimension(:), intent(in), optional :: ub @\ -! mname (ESMF_KIND_##mtypekind), dimension(mdim), target :: fshape(mrng) @\ +! mtypename (ESMF_KIND_##mtypekind), dimension(mdim), target :: fshape(mrng) @\ ! integer, intent(out), optional :: rc @\ ! @\ ! !DESCRIPTION: @\ @@ -3550,7 +3550,7 @@ TypeKindRankDeclarationMacro(LocalArrayAdjust) !---------------------------------------------------------------------------- @\ @\ -#define LocalArrayAdjustShapeMacro(mname, mtypekind, mrank, mdim, mlen, mrng, mloc) \ +#define LocalArrayAdjustShapeMacro(mtypename, mtypekind, mrank, mdim, mlen, mrng, mloc) \ !---------------------------------------------------------------------------- @\ ^undef ESMF_METHOD @\ !define ESMF_METHOD "ESMF_LocalArrayAdjustShape##mrank##D##mtypekind" @\ @@ -3563,14 +3563,14 @@ TypeKindRankDeclarationMacro(LocalArrayAdjust) integer, dimension(:), intent(in) :: totalCount @\ integer, dimension(:), intent(in) :: lb @\ integer, dimension(:), intent(in) :: ub @\ - mname (ESMF_KIND_##mtypekind), dimension(mdim), target :: fshape(mrng) @\ + mtypename (ESMF_KIND_##mtypekind), dimension(mdim), target :: fshape(mrng) @\ integer, intent(out), optional :: rc @\ @\ ! Local variables @\ integer :: localrc ! local return code @\ @\ type (ESMF_LAWrap##mrank##D##mtypekind) :: wrap ! to pass f90 ptr to C++ @\ - mname (ESMF_KIND_##mtypekind), dimension(mdim), pointer :: farrayPtr @\ + mtypename (ESMF_KIND_##mtypekind), dimension(mdim), pointer :: farrayPtr @\ @\ ! Initialize return code; assume routine not implemented @\ localrc = ESMF_RC_NOT_IMPL @\ diff --git a/src/Infrastructure/Util/include/ESMF_TypeKindRankMacros.hcppF90 b/src/Infrastructure/Util/include/ESMF_TypeKindRankMacros.hcppF90 index baaaeff0df..b276ec723b 100644 --- a/src/Infrastructure/Util/include/ESMF_TypeKindRankMacros.hcppF90 +++ b/src/Infrastructure/Util/include/ESMF_TypeKindRankMacros.hcppF90 @@ -105,7 +105,6 @@ #define TypeKindRankInterfaceMacro(funcname) \ !------------------------------------------------------------------------------ @\ ! @\ -^ifndef PIO_TKR @\ ^ifndef ESMF_NO_INTEGER_1_BYTE @\ module procedure ESMF_##funcname##1DI1 @\ module procedure ESMF_##funcname##2DI1 @\ @@ -127,40 +126,28 @@ module procedure ESMF_##funcname##6DI2 @\ module procedure ESMF_##funcname##7DI2 @\ ^endif @\ -^endif @\ ^endif @\ module procedure ESMF_##funcname##1DI4 @\ -^ifndef PIO_TKR @\ module procedure ESMF_##funcname##1DI8 @\ -^endif @\ module procedure ESMF_##funcname##1DR4 @\ module procedure ESMF_##funcname##1DR8 @\ module procedure ESMF_##funcname##2DI4 @\ -^ifndef PIO_TKR @\ module procedure ESMF_##funcname##2DI8 @\ -^endif @\ module procedure ESMF_##funcname##2DR4 @\ module procedure ESMF_##funcname##2DR8 @\ module procedure ESMF_##funcname##3DI4 @\ -^ifndef PIO_TKR @\ module procedure ESMF_##funcname##3DI8 @\ -^endif @\ module procedure ESMF_##funcname##3DR4 @\ module procedure ESMF_##funcname##3DR8 @\ module procedure ESMF_##funcname##4DI4 @\ -^ifndef PIO_TKR @\ module procedure ESMF_##funcname##4DI8 @\ -^endif @\ module procedure ESMF_##funcname##4DR4 @\ module procedure ESMF_##funcname##4DR8 @\ ^ifndef ESMF_NO_GREATER_THAN_4D @\ module procedure ESMF_##funcname##5DI4 @\ -^ifndef PIO_TKR @\ module procedure ESMF_##funcname##5DI8 @\ -^endif @\ module procedure ESMF_##funcname##5DR4 @\ module procedure ESMF_##funcname##5DR8 @\ -^ifndef PIO_TKR @\ module procedure ESMF_##funcname##6DI4 @\ module procedure ESMF_##funcname##6DI8 @\ module procedure ESMF_##funcname##6DR4 @\ @@ -170,7 +157,6 @@ module procedure ESMF_##funcname##7DR4 @\ module procedure ESMF_##funcname##7DR8 @\ ^endif @\ -^endif @\ ! < end macro - do not edit directly > @\ !------------------------------------------------------------------------------ @\ @@ -188,7 +174,6 @@ #define TypeKindRankPublicMacro(funcname) \ !------------------------------------------------------------------------------ @\ ! @\ -^ifndef PIO_TKR @\ ^ifndef ESMF_NO_INTEGER_1_BYTE @\ public ESMF_##funcname##1DI1 @\ public ESMF_##funcname##2DI1 @\ @@ -210,40 +195,28 @@ public ESMF_##funcname##6DI2 @\ public ESMF_##funcname##7DI2 @\ ^endif @\ -^endif @\ ^endif @\ public ESMF_##funcname##1DI4 @\ -^ifndef PIO_TKR @\ public ESMF_##funcname##1DI8 @\ -^endif @\ public ESMF_##funcname##1DR4 @\ public ESMF_##funcname##1DR8 @\ public ESMF_##funcname##2DI4 @\ -^ifndef PIO_TKR @\ public ESMF_##funcname##2DI8 @\ -^endif @\ public ESMF_##funcname##2DR4 @\ public ESMF_##funcname##2DR8 @\ public ESMF_##funcname##3DI4 @\ -^ifndef PIO_TKR @\ public ESMF_##funcname##3DI8 @\ -^endif @\ public ESMF_##funcname##3DR4 @\ public ESMF_##funcname##3DR8 @\ public ESMF_##funcname##4DI4 @\ -^ifndef PIO_TKR @\ public ESMF_##funcname##4DI8 @\ -^endif @\ public ESMF_##funcname##4DR4 @\ public ESMF_##funcname##4DR8 @\ ^ifndef ESMF_NO_GREATER_THAN_4D @\ public ESMF_##funcname##5DI4 @\ -^ifndef PIO_TKR @\ public ESMF_##funcname##5DI8 @\ -^endif @\ public ESMF_##funcname##5DR4 @\ public ESMF_##funcname##5DR8 @\ -^ifndef PIO_TKR @\ public ESMF_##funcname##6DI4 @\ public ESMF_##funcname##6DI8 @\ public ESMF_##funcname##6DR4 @\ @@ -253,7 +226,6 @@ public ESMF_##funcname##7DR4 @\ public ESMF_##funcname##7DR8 @\ ^endif @\ -^endif @\ ! < end macro - do not edit directly > @\ !------------------------------------------------------------------------------ @\ @@ -268,7 +240,7 @@ ! where the following other macros are defined elsewhere by the user: ! #define fredDoc() ... ! which contains generic protex documentation only, no code, plus: -! #define fredMacro(name, typekind, rank, col, len, rng, loc) ... +! #define fredMacro(typename, typekind, rank, col, len, rng, loc) ... ! which contains the actual code for the function, with no protex documentation. !------------------------------------------------------------------------------ #endif @@ -280,7 +252,6 @@ !! < start of macros which become actual subroutine bodies after expansion > @\ @\ funcname##Doc() @\ -^ifndef PIO_TKR @\ ^ifndef ESMF_NO_INTEGER_1_BYTE @\ funcname##Macro(integer, i1, 1, COL1, LEN1, RNG1, LOC1) @\ funcname##Macro(integer, i1, 2, COL2, LEN2, RNG2, LOC2) @\ @@ -303,39 +274,27 @@ funcname##Macro(integer, i2, 6, COL6, LEN6, RNG6, LOC6) @\ funcname##Macro(integer, i2, 7, COL7, LEN7, RNG7, LOC7) @\ ^endif @\ ^endif @\ -^endif @\ funcname##Macro(integer, i4, 1, COL1, LEN1, RNG1, LOC1) @\ -^ifndef PIO_TKR @\ funcname##Macro(integer, i8, 1, COL1, LEN1, RNG1, LOC1) @\ -^endif @\ funcname##Macro(real, r4, 1, COL1, LEN1, RNG1, LOC1) @\ funcname##Macro(real, r8, 1, COL1, LEN1, RNG1, LOC1) @\ funcname##Macro(integer, i4, 2, COL2, LEN2, RNG2, LOC2) @\ -^ifndef PIO_TKR @\ funcname##Macro(integer, i8, 2, COL2, LEN2, RNG2, LOC2) @\ -^endif @\ funcname##Macro(real, r4, 2, COL2, LEN2, RNG2, LOC2) @\ funcname##Macro(real, r8, 2, COL2, LEN2, RNG2, LOC2) @\ funcname##Macro(integer, i4, 3, COL3, LEN3, RNG3, LOC3) @\ -^ifndef PIO_TKR @\ funcname##Macro(integer, i8, 3, COL3, LEN3, RNG3, LOC3) @\ -^endif @\ funcname##Macro(real, r4, 3, COL3, LEN3, RNG3, LOC3) @\ funcname##Macro(real, r8, 3, COL3, LEN3, RNG3, LOC3) @\ funcname##Macro(integer, i4, 4, COL4, LEN4, RNG4, LOC4) @\ -^ifndef PIO_TKR @\ funcname##Macro(integer, i8, 4, COL4, LEN4, RNG4, LOC4) @\ -^endif @\ funcname##Macro(real, r4, 4, COL4, LEN4, RNG4, LOC4) @\ funcname##Macro(real, r8, 4, COL4, LEN4, RNG4, LOC4) @\ ^ifndef ESMF_NO_GREATER_THAN_4D @\ funcname##Macro(integer, i4, 5, COL5, LEN5, RNG5, LOC5) @\ -^ifndef PIO_TKR @\ funcname##Macro(integer, i8, 5, COL5, LEN5, RNG5, LOC5) @\ -^endif @\ funcname##Macro(real, r4, 5, COL5, LEN5, RNG5, LOC5) @\ funcname##Macro(real, r8, 5, COL5, LEN5, RNG5, LOC5) @\ -^ifndef PIO_TKR @\ funcname##Macro(integer, i4, 6, COL6, LEN6, RNG6, LOC6) @\ funcname##Macro(integer, i8, 6, COL6, LEN6, RNG6, LOC6) @\ funcname##Macro(real, r4, 6, COL6, LEN6, RNG6, LOC6) @\ @@ -344,7 +303,6 @@ funcname##Macro(integer, i4, 7, COL7, LEN7, RNG7, LOC7) @\ funcname##Macro(integer, i8, 7, COL7, LEN7, RNG7, LOC7) @\ funcname##Macro(real, r4, 7, COL7, LEN7, RNG7, LOC7) @\ funcname##Macro(real, r8, 7, COL7, LEN7, RNG7, LOC7) @\ -^endif @\ ^endif @\ @\ ! < end macro - do not edit directly > @\ @@ -359,7 +317,7 @@ funcname##Macro(real, r8, 7, COL7, LEN7, RNG7, LOC7) @\ ! AllTypesMacro(fred) ! ! where the following macro is defined elsewhere by the user: -! #define fredMacro(name, typekind, rank, col) ... +! #define fredMacro(typename, typekind, rank, col) ... ! Expected use is to invoke an instance of code for each type, e.g. for ! local variable declarations: ! type (fred##rank##typekind) :: localvar##rank##typekind(col) @@ -369,7 +327,6 @@ funcname##Macro(real, r8, 7, COL7, LEN7, RNG7, LOC7) @\ #define AllTypesMacro(fname) \ @\ ^ifndef ESMF_NO_INTEGER_1_BYTE @\ -^ifndef PIO_TKR @\ fname##Macro(integer, I1, 1, COL1) @\ fname##Macro(integer, I1, 2, COL2) @\ fname##Macro(integer, I1, 3, COL3) @\ @@ -380,9 +337,7 @@ funcname##Macro(real, r8, 7, COL7, LEN7, RNG7, LOC7) @\ fname##Macro(integer, I1, 7, COL7) @\ ^endif @\ ^endif @\ -^endif @\ ^ifndef ESMF_NO_INTEGER_2_BYTE @\ -^ifndef PIO_TKR @\ fname##Macro(integer, I2, 1, COL1) @\ fname##Macro(integer, I2, 2, COL2) @\ fname##Macro(integer, I2, 3, COL3) @\ @@ -392,33 +347,24 @@ funcname##Macro(real, r8, 7, COL7, LEN7, RNG7, LOC7) @\ fname##Macro(integer, I2, 6, COL6) @\ fname##Macro(integer, I2, 7, COL7) @\ ^endif @\ -^endif @\ ^endif @\ fname##Macro(integer, I4, 1, COL1) @\ -^ifndef PIO_TKR @\ fname##Macro(integer, I8, 1, COL1) @\ -^endif @\ fname##Macro(real, R4, 1, COL1) @\ fname##Macro(real, R8, 1, COL1) @\ @\ fname##Macro(integer, I4, 2, COL2) @\ -^ifndef PIO_TKR @\ fname##Macro(integer, I8, 2, COL2) @\ -^endif @\ fname##Macro(real, R4, 2, COL2) @\ fname##Macro(real, R8, 2, COL2) @\ @\ fname##Macro(integer, I4, 3, COL3) @\ -^ifndef PIO_TKR @\ fname##Macro(integer, I8, 3, COL3) @\ -^endif @\ fname##Macro(real, R4, 3, COL3) @\ fname##Macro(real, R8, 3, COL3) @\ @\ fname##Macro(integer, I4, 4, COL4) @\ -^ifndef PIO_TKR @\ fname##Macro(integer, I8, 4, COL4) @\ -^endif @\ fname##Macro(real, R4, 4, COL4) @\ fname##Macro(real, R8, 4, COL4) @\ @\ @@ -431,7 +377,6 @@ funcname##Macro(real, r8, 7, COL7, LEN7, RNG7, LOC7) @\ fname##Macro(real, R4, 5, COL5) @\ fname##Macro(real, R8, 5, COL5) @\ @\ -^ifndef PIO_TKR @\ @\ fname##Macro(integer, I4, 6, COL6) @\ fname##Macro(integer, I8, 6, COL6) @\ @@ -443,7 +388,6 @@ funcname##Macro(real, r8, 7, COL7, LEN7, RNG7, LOC7) @\ fname##Macro(real, R4, 7, COL7) @\ fname##Macro(real, R8, 7, COL7) @\ @\ -^endif @\ @\ ^endif @\ @\ From 7ae12760a840bfdd36067bb7cb27eca46f596971 Mon Sep 17 00:00:00 2001 From: Gerhard Theurich Date: Thu, 7 Sep 2023 15:00:16 -0700 Subject: [PATCH 13/14] Implement full T/K/R overloading of Array Slicing feature. Add R4 array 2D2D+2 -> 2D+1 slicing test. --- .../Array/tests/ESMF_ArrayCreateGetUTest.F90 | 363 +++++- .../interface/ESMF_LocalArrayCreate.cppF90 | 1039 ++++++++++++++++- .../include/ESMF_TypeKindRankMacros.hcppF90 | 187 +++ 3 files changed, 1527 insertions(+), 62 deletions(-) diff --git a/src/Infrastructure/Array/tests/ESMF_ArrayCreateGetUTest.F90 b/src/Infrastructure/Array/tests/ESMF_ArrayCreateGetUTest.F90 index f4574f80f2..8e03816204 100644 --- a/src/Infrastructure/Array/tests/ESMF_ArrayCreateGetUTest.F90 +++ b/src/Infrastructure/Array/tests/ESMF_ArrayCreateGetUTest.F90 @@ -53,7 +53,7 @@ program ESMF_ArrayCreateGetUTest !LOCAL VARIABLES: type(ESMF_VM):: vm - integer:: i,j,k, next, rank + integer:: i,j,k,l, next, rank integer:: petCount, localPet, deCount, de, localDeCount, lde, ssiLocalDeCount integer, allocatable :: regDecomp(:) type(ESMF_ArraySpec) :: arrayspec, arrayspec2 @@ -62,6 +62,7 @@ program ESMF_ArrayCreateGetUTest type(ESMF_DELayout):: delayout type(ESMF_DistGrid):: distgrid, distgrid2 real(ESMF_KIND_R8) :: diffR8 + real(ESMF_KIND_R4) :: diffR4 real(ESMF_KIND_R8) :: farray1D(10) real(ESMF_KIND_R8) :: farray2D(10,10) real(ESMF_KIND_R4) :: farray3D(10,10,10) @@ -72,6 +73,7 @@ program ESMF_ArrayCreateGetUTest real(ESMF_KIND_R4), pointer :: farrayPtr3D(:,:,:) real(ESMF_KIND_R4), pointer :: farrayPtr3Dx(:,:,:) integer(ESMF_KIND_I4), pointer :: farrayPtr4D(:,:,:,:) + real(ESMF_KIND_R4), pointer :: farrayPtr4DR4(:,:,:,:) character (len=80) :: arrayName integer, allocatable:: totalLWidth(:,:), totalUWidth(:,:) integer, allocatable:: totalLBound(:,:), totalUBound(:,:) @@ -1997,7 +1999,364 @@ program ESMF_ArrayCreateGetUTest !------------------------------------------------------------------------ !NEX_UTest_Multi_Proc_Only write(name, *) "ArrayDestroy Test for array with ESMF_PIN_DE_TO_SSI "//& - "2D+1->2D Slice Test" + "2D+1 Test" + write(failMsg, *) "Did not return ESMF_SUCCESS" + call ESMF_ArrayDestroy(array, rc=rc) + if (ssiSharedMemoryEnabled) then + call ESMF_Test((rc.eq.ESMF_SUCCESS), name, failMsg, result, ESMF_SRCLINE) + else + write(failMsg, *) "Did not return the correct RC" + call ESMF_Test((rc.eq.ESMF_RC_OBJ_NOT_CREATED), name, failMsg, result, ESMF_SRCLINE) + endif + + !------------------------------------------------------------------------ + !NEX_UTest_Multi_Proc_Only + write(name, *) "Create test 2D+2 Array with ESMF_PIN_DE_TO_SSI" + write(failMsg, *) "Did not return ESMF_SUCCESS" + array = ESMF_ArrayCreate(typekind=ESMF_TYPEKIND_R4, distgrid=distgrid, & + indexflag=ESMF_INDEX_GLOBAL, pinflag=ESMF_PIN_DE_TO_SSI, name="MyArray", & + undistLBound=[1,1], undistUBound=[3,4], rc=rc) + if (ssiSharedMemoryEnabled) then + call ESMF_Test((rc.eq.ESMF_SUCCESS), name, failMsg, result, ESMF_SRCLINE) + else + write(failMsg, *) "Did not return the correct RC" + call ESMF_Test((rc.eq.ESMC_RC_INTNRL_BAD), name, failMsg, result, ESMF_SRCLINE) + endif + + !------------------------------------------------------------------------ + !NEX_UTest_Multi_Proc_Only + write(name, *) "ArrayGet Fortran array pointer for ESMF_PIN_DE_TO_SSI 2D+2 Test" + write(failMsg, *) "Did not return ESMF_SUCCESS" + call ESMF_ArrayGet(array, farrayPtr=farrayPtr4DR4, rc=rc) + if (ssiSharedMemoryEnabled) then + call ESMF_Test((rc.eq.ESMF_SUCCESS), name, failMsg, result, ESMF_SRCLINE) + write (msg,*) "Local Array lbounds=", lbound(farrayPtr4DR4) + call ESMF_LogWrite(msg, ESMF_LOGMSG_INFO, rc=rc) + if (rc /= ESMF_SUCCESS) call ESMF_Finalize(endflag=ESMF_END_ABORT) + write (msg,*) "Local Array ubounds=", ubound(farrayPtr4DR4) + call ESMF_LogWrite(msg, ESMF_LOGMSG_INFO, rc=rc) + if (rc /= ESMF_SUCCESS) call ESMF_Finalize(endflag=ESMF_END_ABORT) + else + write(failMsg, *) "Did not return the correct RC" + call ESMF_Test((rc.eq.ESMF_RC_OBJ_NOT_CREATED), name, failMsg, result, ESMF_SRCLINE) + endif + + !------------------------------------------------------------------------ + !NEX_UTest_Multi_Proc_Only + write(name, *) "ArrayGet rank, ssiLocalDeCount ESMF_PIN_DE_TO_SSI 2D+2 Test" + write(failMsg, *) "Did not return ESMF_SUCCESS" + call ESMF_ArrayGet(array, rank=rank, ssiLocalDeCount=ssiLocalDeCount, rc=rc) + if (ssiSharedMemoryEnabled) then + call ESMF_Test((rc.eq.ESMF_SUCCESS), name, failMsg, result, ESMF_SRCLINE) + write (msg,*) "ssiLocalDeCount=", ssiLocalDeCount + call ESMF_LogWrite(msg, ESMF_LOGMSG_INFO, rc=rc) + if (rc /= ESMF_SUCCESS) call ESMF_Finalize(endflag=ESMF_END_ABORT) + else + ssiLocalDeCount=1 + rank=1 + write(failMsg, *) "Did not return the correct RC" + call ESMF_Test((rc.eq.ESMF_RC_OBJ_NOT_CREATED), name, failMsg, result, ESMF_SRCLINE) + endif + allocate(localDeToDeMap(ssiLocalDeCount)) + allocate(localArrayList(ssiLocalDeCount)) + allocate(arrayToDistGridMap(rank)) + + !------------------------------------------------------------------------ + !NEX_UTest_Multi_Proc_Only + write(name, *) "Validate rank for ESMF_PIN_DE_TO_SSI 2D+2 Test" + write(failMsg, *) "Rank is wrong" + if (ssiSharedMemoryEnabled) then + call ESMF_Test((rank==4), name, failMsg, result, ESMF_SRCLINE) + write (msg,*) "rank=", rank + call ESMF_LogWrite(msg, ESMF_LOGMSG_INFO, rc=rc) + if (rc /= ESMF_SUCCESS) call ESMF_Finalize(endflag=ESMF_END_ABORT) + else + ! dummy test call + call ESMF_Test((.true.), name, failMsg, result, ESMF_SRCLINE) + endif + + !------------------------------------------------------------------------ + !NEX_UTest_Multi_Proc_Only + write(name, *) "ArrayGet localDeToDeMap, etc. ESMF_PIN_DE_TO_SSI 2D+2 Test" + write(failMsg, *) "Did not return ESMF_SUCCESS" + call ESMF_ArrayGet(array, localDeToDeMap=localDeToDeMap, & + localarrayList=localArrayList, arrayToDistGridMap=arrayToDistGridMap, rc=rc) + if (ssiSharedMemoryEnabled) then + call ESMF_Test((rc.eq.ESMF_SUCCESS), name, failMsg, result, ESMF_SRCLINE) + write (msg,*) "localDeToDeMap=", localDeToDeMap + call ESMF_LogWrite(msg, ESMF_LOGMSG_INFO, rc=rc) + if (rc /= ESMF_SUCCESS) call ESMF_Finalize(endflag=ESMF_END_ABORT) + write (msg,*) "arrayToDistGridMap=", arrayToDistGridMap + call ESMF_LogWrite(msg, ESMF_LOGMSG_INFO, rc=rc) + if (rc /= ESMF_SUCCESS) call ESMF_Finalize(endflag=ESMF_END_ABORT) + else + write(failMsg, *) "Did not return the correct RC" + call ESMF_Test((rc.eq.ESMF_RC_OBJ_NOT_CREATED), name, failMsg, result, ESMF_SRCLINE) + endif + + !------------------------------------------------------------------------ + ! initialize the data on this PETs first localDE + if (ssiSharedMemoryEnabled) then + do l=lbound(farrayPtr4DR4,4), ubound(farrayPtr4DR4,4) + do k=lbound(farrayPtr4DR4,3), ubound(farrayPtr4DR4,3) + do j=lbound(farrayPtr4DR4,2), ubound(farrayPtr4DR4,2) + do i=lbound(farrayPtr4DR4,1), ubound(farrayPtr4DR4,1) + farrayPtr4DR4(i,j,k,l) = real(localDeToDeMap(1)+5,ESMF_KIND_R4) & + * sin(real(i,ESMF_KIND_R4)) & + * sin(real(j,ESMF_KIND_R4)) & + * sin(real(k,ESMF_KIND_R4)) & + * sin(real(l,ESMF_KIND_R4)) + enddo + enddo + enddo + enddo + endif + !------------------------------------------------------------------------ + + !------------------------------------------------------------------------ + !NEX_UTest_Multi_Proc_Only + write(name, *) "ArraySync() for ESMF_PIN_DE_TO_SSI 2D+2 Test" + write(failMsg, *) "Did not return ESMF_SUCCESS" + call ESMF_ArraySync(array, rc=rc) + if (ssiSharedMemoryEnabled) then + call ESMF_Test((rc.eq.ESMF_SUCCESS), name, failMsg, result, ESMF_SRCLINE) + else + write(failMsg, *) "Did not return the correct RC" + call ESMF_Test((rc.eq.ESMF_RC_OBJ_NOT_CREATED), name, failMsg, result, ESMF_SRCLINE) + endif + + !------------------------------------------------------------------------ + !NEX_UTest_Multi_Proc_Only + write(name, *) "LocalArrayGet Fortran array pointer for next ssiLocalDe "//& + "for ESMF_PIN_DE_TO_SSI 2D+2 Test" + write(failMsg, *) "Did not return ESMF_SUCCESS" + next = localPet + 2 + if (next > ssiLocalDeCount) next = 1 + call ESMF_LocalArrayGet(localArrayList(next), & + farrayPtr=farrayPtr4DR4, rc=rc) + if (ssiSharedMemoryEnabled) then + call ESMF_Test((rc.eq.ESMF_SUCCESS), name, failMsg, result, ESMF_SRCLINE) + write (msg,*) "localDeToDeMap(next)=", localDeToDeMap(next) + call ESMF_LogWrite(msg, ESMF_LOGMSG_INFO, rc=rc) + write (msg,*) "Local Array lbounds=", lbound(farrayPtr4DR4) + call ESMF_LogWrite(msg, ESMF_LOGMSG_INFO, rc=rc) + if (rc /= ESMF_SUCCESS) call ESMF_Finalize(endflag=ESMF_END_ABORT) + write (msg,*) "Local Array ubounds=", ubound(farrayPtr4DR4) + call ESMF_LogWrite(msg, ESMF_LOGMSG_INFO, rc=rc) + if (rc /= ESMF_SUCCESS) call ESMF_Finalize(endflag=ESMF_END_ABORT) + else + write(failMsg, *) "Did not return the correct RC" + call ESMF_Test((rc.eq.ESMF_RC_OBJ_NOT_CREATED), name, failMsg, result, ESMF_SRCLINE) + endif + + !------------------------------------------------------------------------ + !NEX_UTest_Multi_Proc_Only + write(name, *) "Validate data in LocalArray for next ssiLocalDe for "//& + "ESMF_PIN_DE_TO_SSI 2D+2 Test" + write(failMsg, *) "Data not correct" + dataCorrect = .true. ! initialize + if (ssiSharedMemoryEnabled) then + do l=lbound(farrayPtr4DR4,4), ubound(farrayPtr4DR4,4) + do k=lbound(farrayPtr4DR4,3), ubound(farrayPtr4DR4,3) + do j=lbound(farrayPtr4DR4,2), ubound(farrayPtr4DR4,2) + do i=lbound(farrayPtr4DR4,1), ubound(farrayPtr4DR4,1) + write (msg,*) "data(",i,",",j,",",k,",",l,")=", farrayPtr4DR4(i,j,k,l) + call ESMF_LogWrite(msg, ESMF_LOGMSG_INFO, rc=rc) + if (rc /= ESMF_SUCCESS) call ESMF_Finalize(endflag=ESMF_END_ABORT) + diffR4 = farrayPtr4DR4(i,j,k,l) - & + real(localDeToDeMap(next)+5,ESMF_KIND_R4) & + * sin(real(i,ESMF_KIND_R4)) & + * sin(real(j,ESMF_KIND_R4)) & + * sin(real(k,ESMF_KIND_R4)) & + * sin(real(l,ESMF_KIND_R4)) + if (abs(diffR4) > 1.d-6) then + dataCorrect=.false. + write (msg,*) "diffR4=", diffR4 + call ESMF_LogWrite(msg, ESMF_LOGMSG_INFO, rc=rc) + if (rc /= ESMF_SUCCESS) call ESMF_Finalize(endflag=ESMF_END_ABORT) + endif + enddo + enddo + enddo + enddo + else + ! dummy test + endif + call ESMF_Test((dataCorrect), name, failMsg, result, ESMF_SRCLINE) + + call ESMF_ArraySync(array, rc=rc) ! prevent race condition with below + if (rc /= ESMF_SUCCESS) call ESMF_Finalize(endflag=ESMF_END_ABORT) + + deallocate(localDeToDeMap) + deallocate(localArrayList) + deallocate(arrayToDistGridMap) + + !------------------------------------------------------------------------ + !NEX_UTest_Multi_Proc_Only + write(name, *) "ArrayCreate from Copy (REF), ESMF_PIN_DE_TO_SSI "//& + "2D+2->2D+1 Slice at l=1 Test" + write(failMsg, *) "Did not return ESMF_SUCCESS" + arrayDup = ESMF_ArrayCreate(array, datacopyflag=ESMF_DATACOPY_REFERENCE, & + trailingUndistSlice=[1], rc=rc) ! create a slice + if (ssiSharedMemoryEnabled) then + call ESMF_Test((rc.eq.ESMF_SUCCESS), name, failMsg, result, ESMF_SRCLINE) + else + write(failMsg, *) "Did not return the correct RC" + call ESMF_Test((rc.eq.ESMF_RC_OBJ_NOT_CREATED), name, failMsg, result, ESMF_SRCLINE) + endif + + !------------------------------------------------------------------------ + !NEX_UTest_Multi_Proc_Only + write(name, *) "ArrayGet Fortran array pointer for ESMF_PIN_DE_TO_SSI "// & + "arrayDup 2D+2->2D+1 Slice at l=1 Test" + write(failMsg, *) "Did not return ESMF_SUCCESS" + call ESMF_ArrayGet(arrayDup, farrayPtr=farrayPtr3D, rc=rc) + if (ssiSharedMemoryEnabled) then + call ESMF_Test((rc.eq.ESMF_SUCCESS), name, failMsg, result, ESMF_SRCLINE) + write (msg,*) "Local Array lbounds=", lbound(farrayPtr3D) + call ESMF_LogWrite(msg, ESMF_LOGMSG_INFO, rc=rc) + if (rc /= ESMF_SUCCESS) call ESMF_Finalize(endflag=ESMF_END_ABORT) + write (msg,*) "Local Array ubounds=", ubound(farrayPtr3D) + call ESMF_LogWrite(msg, ESMF_LOGMSG_INFO, rc=rc) + if (rc /= ESMF_SUCCESS) call ESMF_Finalize(endflag=ESMF_END_ABORT) + else + write(failMsg, *) "Did not return the correct RC" + call ESMF_Test((rc.eq.ESMF_RC_OBJ_NOT_CREATED), name, failMsg, result, ESMF_SRCLINE) + endif + + !------------------------------------------------------------------------ + !NEX_UTest_Multi_Proc_Only + write(name, *) "ArrayGet rank, ssiLocalDeCount ESMF_PIN_DE_TO_SSI "//& + "arrayDup 2D+2->2D+1 Slice at l=1 Test" + write(failMsg, *) "Did not return ESMF_SUCCESS" + call ESMF_ArrayGet(arrayDup, rank=rank, ssiLocalDeCount=ssiLocalDeCount, & + rc=rc) + if (ssiSharedMemoryEnabled) then + call ESMF_Test((rc.eq.ESMF_SUCCESS), name, failMsg, result, ESMF_SRCLINE) + write (msg,*) "ssiLocalDeCount=", ssiLocalDeCount + call ESMF_LogWrite(msg, ESMF_LOGMSG_INFO, rc=rc) + if (rc /= ESMF_SUCCESS) call ESMF_Finalize(endflag=ESMF_END_ABORT) + else + ssiLocalDeCount=1 + rank=1 + write(failMsg, *) "Did not return the correct RC" + call ESMF_Test((rc.eq.ESMF_RC_OBJ_NOT_CREATED), name, failMsg, result, ESMF_SRCLINE) + endif + allocate(localDeToDeMap(ssiLocalDeCount)) + allocate(localArrayList(ssiLocalDeCount)) + allocate(arrayToDistGridMap(rank)) + + !------------------------------------------------------------------------ + !NEX_UTest_Multi_Proc_Only + write(name, *) "Validate rank for ESMF_PIN_DE_TO_SSI arrayDup 2D+2->2D+1 "//& + "Slice at l=1 Test" + write(failMsg, *) "Rank is wrong" + if (ssiSharedMemoryEnabled) then + call ESMF_Test((rank==3), name, failMsg, result, ESMF_SRCLINE) + write (msg,*) "rank=", rank + call ESMF_LogWrite(msg, ESMF_LOGMSG_INFO, rc=rc) + if (rc /= ESMF_SUCCESS) call ESMF_Finalize(endflag=ESMF_END_ABORT) + else + ! dummy test call + call ESMF_Test((.true.), name, failMsg, result, ESMF_SRCLINE) + endif + + !------------------------------------------------------------------------ + !NEX_UTest_Multi_Proc_Only + write(name, *) "ArrayGet localDeToDeMap, etc. ESMF_PIN_DE_TO_SSI arrayDup "//& + "2D+2->2D+1 Slice at l=1 Test" + write(failMsg, *) "Did not return ESMF_SUCCESS" + call ESMF_ArrayGet(arrayDup, localDeToDeMap=localDeToDeMap, & + localarrayList=localArrayList, arrayToDistGridMap=arrayToDistGridMap, rc=rc) + if (ssiSharedMemoryEnabled) then + call ESMF_Test((rc.eq.ESMF_SUCCESS), name, failMsg, result, ESMF_SRCLINE) + write (msg,*) "localDeToDeMap=", localDeToDeMap + call ESMF_LogWrite(msg, ESMF_LOGMSG_INFO, rc=rc) + if (rc /= ESMF_SUCCESS) call ESMF_Finalize(endflag=ESMF_END_ABORT) + write (msg,*) "arrayToDistGridMap=", arrayToDistGridMap + call ESMF_LogWrite(msg, ESMF_LOGMSG_INFO, rc=rc) + if (rc /= ESMF_SUCCESS) call ESMF_Finalize(endflag=ESMF_END_ABORT) + else + write(failMsg, *) "Did not return the correct RC" + call ESMF_Test((rc.eq.ESMF_RC_OBJ_NOT_CREATED), name, failMsg, result, ESMF_SRCLINE) + endif + + !------------------------------------------------------------------------ + !NEX_UTest_Multi_Proc_Only + write(name, *) "Validate data in LocalArray for all DEs for "//& + "ESMF_PIN_DE_TO_SSI arrayDup 2D+2->2D+1 Slice at l=1 Test" + write(failMsg, *) "Data not correct" + dataCorrect = .true. ! initialize + if (ssiSharedMemoryEnabled) then + l=1 + do lde=1, ssiLocalDeCount + call ESMF_LocalArrayGet(localArrayList(lde), farrayPtr=farrayPtr3D, rc=rc) + if (rc /= ESMF_SUCCESS) call ESMF_Finalize(endflag=ESMF_END_ABORT) + do k=lbound(farrayPtr3D,3), ubound(farrayPtr3D,3) + do j=lbound(farrayPtr3D,2), ubound(farrayPtr3D,2) + do i=lbound(farrayPtr3D,1), ubound(farrayPtr3D,1) + write (msg,*) "localDE=",lde-1," DE=", localDeToDeMap(lde), & + " data(",i,",",j,",",k,")=", farrayPtr3D(i,j,k) + call ESMF_LogWrite(msg, ESMF_LOGMSG_INFO, rc=rc) + if (rc /= ESMF_SUCCESS) call ESMF_Finalize(endflag=ESMF_END_ABORT) + diffR4 = farrayPtr3D(i,j,k) - & + real(localDeToDeMap(lde)+5,ESMF_KIND_R4) & + * sin(real(i,ESMF_KIND_R4)) & + * sin(real(j,ESMF_KIND_R4)) & + * sin(real(k,ESMF_KIND_R4)) & + * sin(real(l,ESMF_KIND_R4)) + if (abs(diffR4) > 1.d-10) then + dataCorrect=.false. + write (msg,*) "diffR4=", diffR4 + call ESMF_LogWrite(msg, ESMF_LOGMSG_INFO, rc=rc) + if (rc /= ESMF_SUCCESS) call ESMF_Finalize(endflag=ESMF_END_ABORT) + endif + enddo + enddo + enddo + enddo + else + ! dummy test + endif + call ESMF_Test((dataCorrect), name, failMsg, result, ESMF_SRCLINE) + + call ESMF_ArraySync(arrayDup, rc=rc) ! prevent race condition with below + if (rc /= ESMF_SUCCESS) call ESMF_Finalize(endflag=ESMF_END_ABORT) + + deallocate(localDeToDeMap) + deallocate(localArrayList) + deallocate(arrayToDistGridMap) + + !------------------------------------------------------------------------ + !NEX_UTest_Multi_Proc_Only + write(name, *) "ArraySync() for ESMF_PIN_DE_TO_SSI arrayDup "//& + "2D+2->2D+1 Slice at l=1 Test" + write(failMsg, *) "Did not return ESMF_SUCCESS" + call ESMF_ArraySync(arrayDup, rc=rc) + if (ssiSharedMemoryEnabled) then + call ESMF_Test((rc.eq.ESMF_SUCCESS), name, failMsg, result, ESMF_SRCLINE) + else + write(failMsg, *) "Did not return the correct RC" + call ESMF_Test((rc.eq.ESMF_RC_OBJ_NOT_CREATED), name, failMsg, result, ESMF_SRCLINE) + endif + + !------------------------------------------------------------------------ + !NEX_UTest_Multi_Proc_Only + write(name, *) "ArrayDestroy Test for arrayDup with ESMF_PIN_DE_TO_SSI "//& + "2D+2->2D+1 Slice at l=1 Test" + write(failMsg, *) "Did not return ESMF_SUCCESS" + call ESMF_ArrayDestroy(arrayDup, rc=rc) + if (ssiSharedMemoryEnabled) then + call ESMF_Test((rc.eq.ESMF_SUCCESS), name, failMsg, result, ESMF_SRCLINE) + else + write(failMsg, *) "Did not return the correct RC" + call ESMF_Test((rc.eq.ESMF_RC_OBJ_NOT_CREATED), name, failMsg, result, ESMF_SRCLINE) + endif + + !------------------------------------------------------------------------ + !NEX_UTest_Multi_Proc_Only + write(name, *) "ArrayDestroy Test for array with ESMF_PIN_DE_TO_SSI "//& + "2D+2 Test" write(failMsg, *) "Did not return ESMF_SUCCESS" call ESMF_ArrayDestroy(array, rc=rc) if (ssiSharedMemoryEnabled) then diff --git a/src/Infrastructure/LocalArray/interface/ESMF_LocalArrayCreate.cppF90 b/src/Infrastructure/LocalArray/interface/ESMF_LocalArrayCreate.cppF90 index 9779c3635c..941171e6b9 100644 --- a/src/Infrastructure/LocalArray/interface/ESMF_LocalArrayCreate.cppF90 +++ b/src/Infrastructure/LocalArray/interface/ESMF_LocalArrayCreate.cppF90 @@ -3646,8 +3646,6 @@ TypeKindRankDeclarationMacro(LocalArrayAdjustShape) ESMF_ERR_PASSTHRU, & ESMF_CONTEXT, rcToReturn=rc)) return count = size(slice) -print *, "count: ", count -print *, "slice: ", slice ! Call a T/K/R specific interface in order to create the proper ! type of F90 pointer, then slice the F90 pointer. @@ -3657,13 +3655,811 @@ print *, "slice: ", slice !! calling routines generated from macros by the preprocessor select case (localtk) +^ifndef ESMF_NO_INTEGER_1_BYTE + case (ESMF_TYPEKIND_I1%dkind) + select case(rankIn) + case (2) + select case(rankOut) + case (1) + call ESMF_LocalArraySlice2D1DI1(array, slice, rc=localrc) + if (ESMF_LogFoundError(localrc, & + ESMF_ERR_PASSTHRU, & + ESMF_CONTEXT, rcToReturn=rc)) return + case default + if (ESMF_LogFoundError(ESMF_RC_ARG_BAD, & + msg="Unsupported rankIn/rankOut combination", & + ESMF_CONTEXT, rcToReturn=rc)) return + end select + case (3) + select case(rankOut) + case (1) + call ESMF_LocalArraySlice3D1DI1(array, slice, rc=localrc) + if (ESMF_LogFoundError(localrc, & + ESMF_ERR_PASSTHRU, & + ESMF_CONTEXT, rcToReturn=rc)) return + case (2) + call ESMF_LocalArraySlice3D2DI1(array, slice, rc=localrc) + if (ESMF_LogFoundError(localrc, & + ESMF_ERR_PASSTHRU, & + ESMF_CONTEXT, rcToReturn=rc)) return + case default + if (ESMF_LogFoundError(ESMF_RC_ARG_BAD, & + msg="Unsupported rankIn/rankOut combination", & + ESMF_CONTEXT, rcToReturn=rc)) return + end select + case (4) + select case(rankOut) + case (1) + call ESMF_LocalArraySlice4D1DI1(array, slice, rc=localrc) + if (ESMF_LogFoundError(localrc, & + ESMF_ERR_PASSTHRU, & + ESMF_CONTEXT, rcToReturn=rc)) return + case (2) + call ESMF_LocalArraySlice4D2DI1(array, slice, rc=localrc) + if (ESMF_LogFoundError(localrc, & + ESMF_ERR_PASSTHRU, & + ESMF_CONTEXT, rcToReturn=rc)) return + case (3) + call ESMF_LocalArraySlice4D3DI1(array, slice, rc=localrc) + if (ESMF_LogFoundError(localrc, & + ESMF_ERR_PASSTHRU, & + ESMF_CONTEXT, rcToReturn=rc)) return + case default + if (ESMF_LogFoundError(ESMF_RC_ARG_BAD, & + msg="Unsupported rankIn/rankOut combination", & + ESMF_CONTEXT, rcToReturn=rc)) return + end select +^ifndef ESMF_NO_GREATER_THAN_4D + case (5) + select case(rankOut) + case (1) + call ESMF_LocalArraySlice5D1DI1(array, slice, rc=localrc) + if (ESMF_LogFoundError(localrc, & + ESMF_ERR_PASSTHRU, & + ESMF_CONTEXT, rcToReturn=rc)) return + case (2) + call ESMF_LocalArraySlice5D2DI1(array, slice, rc=localrc) + if (ESMF_LogFoundError(localrc, & + ESMF_ERR_PASSTHRU, & + ESMF_CONTEXT, rcToReturn=rc)) return + case (3) + call ESMF_LocalArraySlice5D3DI1(array, slice, rc=localrc) + if (ESMF_LogFoundError(localrc, & + ESMF_ERR_PASSTHRU, & + ESMF_CONTEXT, rcToReturn=rc)) return + case (4) + call ESMF_LocalArraySlice5D4DI1(array, slice, rc=localrc) + if (ESMF_LogFoundError(localrc, & + ESMF_ERR_PASSTHRU, & + ESMF_CONTEXT, rcToReturn=rc)) return + case default + if (ESMF_LogFoundError(ESMF_RC_ARG_BAD, & + msg="Unsupported rankIn/rankOut combination", & + ESMF_CONTEXT, rcToReturn=rc)) return + end select + case (6) + select case(rankOut) + case (1) + call ESMF_LocalArraySlice6D1DI1(array, slice, rc=localrc) + if (ESMF_LogFoundError(localrc, & + ESMF_ERR_PASSTHRU, & + ESMF_CONTEXT, rcToReturn=rc)) return + case (2) + call ESMF_LocalArraySlice6D2DI1(array, slice, rc=localrc) + if (ESMF_LogFoundError(localrc, & + ESMF_ERR_PASSTHRU, & + ESMF_CONTEXT, rcToReturn=rc)) return + case (3) + call ESMF_LocalArraySlice6D3DI1(array, slice, rc=localrc) + if (ESMF_LogFoundError(localrc, & + ESMF_ERR_PASSTHRU, & + ESMF_CONTEXT, rcToReturn=rc)) return + case (4) + call ESMF_LocalArraySlice6D4DI1(array, slice, rc=localrc) + if (ESMF_LogFoundError(localrc, & + ESMF_ERR_PASSTHRU, & + ESMF_CONTEXT, rcToReturn=rc)) return + case (5) + call ESMF_LocalArraySlice6D5DI1(array, slice, rc=localrc) + if (ESMF_LogFoundError(localrc, & + ESMF_ERR_PASSTHRU, & + ESMF_CONTEXT, rcToReturn=rc)) return + case default + if (ESMF_LogFoundError(ESMF_RC_ARG_BAD, & + msg="Unsupported rankIn/rankOut combination", & + ESMF_CONTEXT, rcToReturn=rc)) return + end select + case (7) + select case(rankOut) + case (1) + call ESMF_LocalArraySlice7D1DI1(array, slice, rc=localrc) + if (ESMF_LogFoundError(localrc, & + ESMF_ERR_PASSTHRU, & + ESMF_CONTEXT, rcToReturn=rc)) return + case (2) + call ESMF_LocalArraySlice7D2DI1(array, slice, rc=localrc) + if (ESMF_LogFoundError(localrc, & + ESMF_ERR_PASSTHRU, & + ESMF_CONTEXT, rcToReturn=rc)) return + case (3) + call ESMF_LocalArraySlice7D3DI1(array, slice, rc=localrc) + if (ESMF_LogFoundError(localrc, & + ESMF_ERR_PASSTHRU, & + ESMF_CONTEXT, rcToReturn=rc)) return + case (4) + call ESMF_LocalArraySlice7D4DI1(array, slice, rc=localrc) + if (ESMF_LogFoundError(localrc, & + ESMF_ERR_PASSTHRU, & + ESMF_CONTEXT, rcToReturn=rc)) return + case (5) + call ESMF_LocalArraySlice7D5DI1(array, slice, rc=localrc) + if (ESMF_LogFoundError(localrc, & + ESMF_ERR_PASSTHRU, & + ESMF_CONTEXT, rcToReturn=rc)) return + case (6) + call ESMF_LocalArraySlice7D6DI1(array, slice, rc=localrc) + if (ESMF_LogFoundError(localrc, & + ESMF_ERR_PASSTHRU, & + ESMF_CONTEXT, rcToReturn=rc)) return + case default + if (ESMF_LogFoundError(ESMF_RC_ARG_BAD, & + msg="Unsupported rankIn/rankOut combination", & + ESMF_CONTEXT, rcToReturn=rc)) return + end select +^endif + case default + if (ESMF_LogFoundError(ESMF_RC_ARG_BAD, & + msg="Unsupported rankIn", & + ESMF_CONTEXT, rcToReturn=rc)) return + end select +^endif +^ifndef ESMF_NO_INTEGER_2_BYTE + case (ESMF_TYPEKIND_I2%dkind) + select case(rankIn) + case (2) + select case(rankOut) + case (1) + call ESMF_LocalArraySlice2D1DI2(array, slice, rc=localrc) + if (ESMF_LogFoundError(localrc, & + ESMF_ERR_PASSTHRU, & + ESMF_CONTEXT, rcToReturn=rc)) return + case default + if (ESMF_LogFoundError(ESMF_RC_ARG_BAD, & + msg="Unsupported rankIn/rankOut combination", & + ESMF_CONTEXT, rcToReturn=rc)) return + end select + case (3) + select case(rankOut) + case (1) + call ESMF_LocalArraySlice3D1DI2(array, slice, rc=localrc) + if (ESMF_LogFoundError(localrc, & + ESMF_ERR_PASSTHRU, & + ESMF_CONTEXT, rcToReturn=rc)) return + case (2) + call ESMF_LocalArraySlice3D2DI2(array, slice, rc=localrc) + if (ESMF_LogFoundError(localrc, & + ESMF_ERR_PASSTHRU, & + ESMF_CONTEXT, rcToReturn=rc)) return + case default + if (ESMF_LogFoundError(ESMF_RC_ARG_BAD, & + msg="Unsupported rankIn/rankOut combination", & + ESMF_CONTEXT, rcToReturn=rc)) return + end select + case (4) + select case(rankOut) + case (1) + call ESMF_LocalArraySlice4D1DI2(array, slice, rc=localrc) + if (ESMF_LogFoundError(localrc, & + ESMF_ERR_PASSTHRU, & + ESMF_CONTEXT, rcToReturn=rc)) return + case (2) + call ESMF_LocalArraySlice4D2DI2(array, slice, rc=localrc) + if (ESMF_LogFoundError(localrc, & + ESMF_ERR_PASSTHRU, & + ESMF_CONTEXT, rcToReturn=rc)) return + case (3) + call ESMF_LocalArraySlice4D3DI2(array, slice, rc=localrc) + if (ESMF_LogFoundError(localrc, & + ESMF_ERR_PASSTHRU, & + ESMF_CONTEXT, rcToReturn=rc)) return + case default + if (ESMF_LogFoundError(ESMF_RC_ARG_BAD, & + msg="Unsupported rankIn/rankOut combination", & + ESMF_CONTEXT, rcToReturn=rc)) return + end select +^ifndef ESMF_NO_GREATER_THAN_4D + case (5) + select case(rankOut) + case (1) + call ESMF_LocalArraySlice5D1DI2(array, slice, rc=localrc) + if (ESMF_LogFoundError(localrc, & + ESMF_ERR_PASSTHRU, & + ESMF_CONTEXT, rcToReturn=rc)) return + case (2) + call ESMF_LocalArraySlice5D2DI2(array, slice, rc=localrc) + if (ESMF_LogFoundError(localrc, & + ESMF_ERR_PASSTHRU, & + ESMF_CONTEXT, rcToReturn=rc)) return + case (3) + call ESMF_LocalArraySlice5D3DI2(array, slice, rc=localrc) + if (ESMF_LogFoundError(localrc, & + ESMF_ERR_PASSTHRU, & + ESMF_CONTEXT, rcToReturn=rc)) return + case (4) + call ESMF_LocalArraySlice5D4DI2(array, slice, rc=localrc) + if (ESMF_LogFoundError(localrc, & + ESMF_ERR_PASSTHRU, & + ESMF_CONTEXT, rcToReturn=rc)) return + case default + if (ESMF_LogFoundError(ESMF_RC_ARG_BAD, & + msg="Unsupported rankIn/rankOut combination", & + ESMF_CONTEXT, rcToReturn=rc)) return + end select + case (6) + select case(rankOut) + case (1) + call ESMF_LocalArraySlice6D1DI2(array, slice, rc=localrc) + if (ESMF_LogFoundError(localrc, & + ESMF_ERR_PASSTHRU, & + ESMF_CONTEXT, rcToReturn=rc)) return + case (2) + call ESMF_LocalArraySlice6D2DI2(array, slice, rc=localrc) + if (ESMF_LogFoundError(localrc, & + ESMF_ERR_PASSTHRU, & + ESMF_CONTEXT, rcToReturn=rc)) return + case (3) + call ESMF_LocalArraySlice6D3DI2(array, slice, rc=localrc) + if (ESMF_LogFoundError(localrc, & + ESMF_ERR_PASSTHRU, & + ESMF_CONTEXT, rcToReturn=rc)) return + case (4) + call ESMF_LocalArraySlice6D4DI2(array, slice, rc=localrc) + if (ESMF_LogFoundError(localrc, & + ESMF_ERR_PASSTHRU, & + ESMF_CONTEXT, rcToReturn=rc)) return + case (5) + call ESMF_LocalArraySlice6D5DI2(array, slice, rc=localrc) + if (ESMF_LogFoundError(localrc, & + ESMF_ERR_PASSTHRU, & + ESMF_CONTEXT, rcToReturn=rc)) return + case default + if (ESMF_LogFoundError(ESMF_RC_ARG_BAD, & + msg="Unsupported rankIn/rankOut combination", & + ESMF_CONTEXT, rcToReturn=rc)) return + end select + case (7) + select case(rankOut) + case (1) + call ESMF_LocalArraySlice7D1DI2(array, slice, rc=localrc) + if (ESMF_LogFoundError(localrc, & + ESMF_ERR_PASSTHRU, & + ESMF_CONTEXT, rcToReturn=rc)) return + case (2) + call ESMF_LocalArraySlice7D2DI2(array, slice, rc=localrc) + if (ESMF_LogFoundError(localrc, & + ESMF_ERR_PASSTHRU, & + ESMF_CONTEXT, rcToReturn=rc)) return + case (3) + call ESMF_LocalArraySlice7D3DI2(array, slice, rc=localrc) + if (ESMF_LogFoundError(localrc, & + ESMF_ERR_PASSTHRU, & + ESMF_CONTEXT, rcToReturn=rc)) return + case (4) + call ESMF_LocalArraySlice7D4DI2(array, slice, rc=localrc) + if (ESMF_LogFoundError(localrc, & + ESMF_ERR_PASSTHRU, & + ESMF_CONTEXT, rcToReturn=rc)) return + case (5) + call ESMF_LocalArraySlice7D5DI2(array, slice, rc=localrc) + if (ESMF_LogFoundError(localrc, & + ESMF_ERR_PASSTHRU, & + ESMF_CONTEXT, rcToReturn=rc)) return + case (6) + call ESMF_LocalArraySlice7D6DI2(array, slice, rc=localrc) + if (ESMF_LogFoundError(localrc, & + ESMF_ERR_PASSTHRU, & + ESMF_CONTEXT, rcToReturn=rc)) return + case default + if (ESMF_LogFoundError(ESMF_RC_ARG_BAD, & + msg="Unsupported rankIn/rankOut combination", & + ESMF_CONTEXT, rcToReturn=rc)) return + end select +^endif + case default + if (ESMF_LogFoundError(ESMF_RC_ARG_BAD, & + msg="Unsupported rankIn", & + ESMF_CONTEXT, rcToReturn=rc)) return + end select +^endif + case (ESMF_TYPEKIND_I4%dkind) + select case(rankIn) + case (2) + select case(rankOut) + case (1) + call ESMF_LocalArraySlice2D1DI4(array, slice, rc=localrc) + if (ESMF_LogFoundError(localrc, & + ESMF_ERR_PASSTHRU, & + ESMF_CONTEXT, rcToReturn=rc)) return + case default + if (ESMF_LogFoundError(ESMF_RC_ARG_BAD, & + msg="Unsupported rankIn/rankOut combination", & + ESMF_CONTEXT, rcToReturn=rc)) return + end select + case (3) + select case(rankOut) + case (1) + call ESMF_LocalArraySlice3D1DI4(array, slice, rc=localrc) + if (ESMF_LogFoundError(localrc, & + ESMF_ERR_PASSTHRU, & + ESMF_CONTEXT, rcToReturn=rc)) return + case (2) + call ESMF_LocalArraySlice3D2DI4(array, slice, rc=localrc) + if (ESMF_LogFoundError(localrc, & + ESMF_ERR_PASSTHRU, & + ESMF_CONTEXT, rcToReturn=rc)) return + case default + if (ESMF_LogFoundError(ESMF_RC_ARG_BAD, & + msg="Unsupported rankIn/rankOut combination", & + ESMF_CONTEXT, rcToReturn=rc)) return + end select + case (4) + select case(rankOut) + case (1) + call ESMF_LocalArraySlice4D1DI4(array, slice, rc=localrc) + if (ESMF_LogFoundError(localrc, & + ESMF_ERR_PASSTHRU, & + ESMF_CONTEXT, rcToReturn=rc)) return + case (2) + call ESMF_LocalArraySlice4D2DI4(array, slice, rc=localrc) + if (ESMF_LogFoundError(localrc, & + ESMF_ERR_PASSTHRU, & + ESMF_CONTEXT, rcToReturn=rc)) return + case (3) + call ESMF_LocalArraySlice4D3DI4(array, slice, rc=localrc) + if (ESMF_LogFoundError(localrc, & + ESMF_ERR_PASSTHRU, & + ESMF_CONTEXT, rcToReturn=rc)) return + case default + if (ESMF_LogFoundError(ESMF_RC_ARG_BAD, & + msg="Unsupported rankIn/rankOut combination", & + ESMF_CONTEXT, rcToReturn=rc)) return + end select +^ifndef ESMF_NO_GREATER_THAN_4D + case (5) + select case(rankOut) + case (1) + call ESMF_LocalArraySlice5D1DI4(array, slice, rc=localrc) + if (ESMF_LogFoundError(localrc, & + ESMF_ERR_PASSTHRU, & + ESMF_CONTEXT, rcToReturn=rc)) return + case (2) + call ESMF_LocalArraySlice5D2DI4(array, slice, rc=localrc) + if (ESMF_LogFoundError(localrc, & + ESMF_ERR_PASSTHRU, & + ESMF_CONTEXT, rcToReturn=rc)) return + case (3) + call ESMF_LocalArraySlice5D3DI4(array, slice, rc=localrc) + if (ESMF_LogFoundError(localrc, & + ESMF_ERR_PASSTHRU, & + ESMF_CONTEXT, rcToReturn=rc)) return + case (4) + call ESMF_LocalArraySlice5D4DI4(array, slice, rc=localrc) + if (ESMF_LogFoundError(localrc, & + ESMF_ERR_PASSTHRU, & + ESMF_CONTEXT, rcToReturn=rc)) return + case default + if (ESMF_LogFoundError(ESMF_RC_ARG_BAD, & + msg="Unsupported rankIn/rankOut combination", & + ESMF_CONTEXT, rcToReturn=rc)) return + end select + case (6) + select case(rankOut) + case (1) + call ESMF_LocalArraySlice6D1DI4(array, slice, rc=localrc) + if (ESMF_LogFoundError(localrc, & + ESMF_ERR_PASSTHRU, & + ESMF_CONTEXT, rcToReturn=rc)) return + case (2) + call ESMF_LocalArraySlice6D2DI4(array, slice, rc=localrc) + if (ESMF_LogFoundError(localrc, & + ESMF_ERR_PASSTHRU, & + ESMF_CONTEXT, rcToReturn=rc)) return + case (3) + call ESMF_LocalArraySlice6D3DI4(array, slice, rc=localrc) + if (ESMF_LogFoundError(localrc, & + ESMF_ERR_PASSTHRU, & + ESMF_CONTEXT, rcToReturn=rc)) return + case (4) + call ESMF_LocalArraySlice6D4DI4(array, slice, rc=localrc) + if (ESMF_LogFoundError(localrc, & + ESMF_ERR_PASSTHRU, & + ESMF_CONTEXT, rcToReturn=rc)) return + case (5) + call ESMF_LocalArraySlice6D5DI4(array, slice, rc=localrc) + if (ESMF_LogFoundError(localrc, & + ESMF_ERR_PASSTHRU, & + ESMF_CONTEXT, rcToReturn=rc)) return + case default + if (ESMF_LogFoundError(ESMF_RC_ARG_BAD, & + msg="Unsupported rankIn/rankOut combination", & + ESMF_CONTEXT, rcToReturn=rc)) return + end select + case (7) + select case(rankOut) + case (1) + call ESMF_LocalArraySlice7D1DI4(array, slice, rc=localrc) + if (ESMF_LogFoundError(localrc, & + ESMF_ERR_PASSTHRU, & + ESMF_CONTEXT, rcToReturn=rc)) return + case (2) + call ESMF_LocalArraySlice7D2DI4(array, slice, rc=localrc) + if (ESMF_LogFoundError(localrc, & + ESMF_ERR_PASSTHRU, & + ESMF_CONTEXT, rcToReturn=rc)) return + case (3) + call ESMF_LocalArraySlice7D3DI4(array, slice, rc=localrc) + if (ESMF_LogFoundError(localrc, & + ESMF_ERR_PASSTHRU, & + ESMF_CONTEXT, rcToReturn=rc)) return + case (4) + call ESMF_LocalArraySlice7D4DI4(array, slice, rc=localrc) + if (ESMF_LogFoundError(localrc, & + ESMF_ERR_PASSTHRU, & + ESMF_CONTEXT, rcToReturn=rc)) return + case (5) + call ESMF_LocalArraySlice7D5DI4(array, slice, rc=localrc) + if (ESMF_LogFoundError(localrc, & + ESMF_ERR_PASSTHRU, & + ESMF_CONTEXT, rcToReturn=rc)) return + case (6) + call ESMF_LocalArraySlice7D6DI4(array, slice, rc=localrc) + if (ESMF_LogFoundError(localrc, & + ESMF_ERR_PASSTHRU, & + ESMF_CONTEXT, rcToReturn=rc)) return + case default + if (ESMF_LogFoundError(ESMF_RC_ARG_BAD, & + msg="Unsupported rankIn/rankOut combination", & + ESMF_CONTEXT, rcToReturn=rc)) return + end select +^endif + case default + if (ESMF_LogFoundError(ESMF_RC_ARG_BAD, & + msg="Unsupported rankIn", & + ESMF_CONTEXT, rcToReturn=rc)) return + end select + case (ESMF_TYPEKIND_I8%dkind) + select case(rankIn) + case (2) + select case(rankOut) + case (1) + call ESMF_LocalArraySlice2D1DI8(array, slice, rc=localrc) + if (ESMF_LogFoundError(localrc, & + ESMF_ERR_PASSTHRU, & + ESMF_CONTEXT, rcToReturn=rc)) return + case default + if (ESMF_LogFoundError(ESMF_RC_ARG_BAD, & + msg="Unsupported rankIn/rankOut combination", & + ESMF_CONTEXT, rcToReturn=rc)) return + end select + case (3) + select case(rankOut) + case (1) + call ESMF_LocalArraySlice3D1DI8(array, slice, rc=localrc) + if (ESMF_LogFoundError(localrc, & + ESMF_ERR_PASSTHRU, & + ESMF_CONTEXT, rcToReturn=rc)) return + case (2) + call ESMF_LocalArraySlice3D2DI8(array, slice, rc=localrc) + if (ESMF_LogFoundError(localrc, & + ESMF_ERR_PASSTHRU, & + ESMF_CONTEXT, rcToReturn=rc)) return + case default + if (ESMF_LogFoundError(ESMF_RC_ARG_BAD, & + msg="Unsupported rankIn/rankOut combination", & + ESMF_CONTEXT, rcToReturn=rc)) return + end select + case (4) + select case(rankOut) + case (1) + call ESMF_LocalArraySlice4D1DI8(array, slice, rc=localrc) + if (ESMF_LogFoundError(localrc, & + ESMF_ERR_PASSTHRU, & + ESMF_CONTEXT, rcToReturn=rc)) return + case (2) + call ESMF_LocalArraySlice4D2DI8(array, slice, rc=localrc) + if (ESMF_LogFoundError(localrc, & + ESMF_ERR_PASSTHRU, & + ESMF_CONTEXT, rcToReturn=rc)) return + case (3) + call ESMF_LocalArraySlice4D3DI8(array, slice, rc=localrc) + if (ESMF_LogFoundError(localrc, & + ESMF_ERR_PASSTHRU, & + ESMF_CONTEXT, rcToReturn=rc)) return + case default + if (ESMF_LogFoundError(ESMF_RC_ARG_BAD, & + msg="Unsupported rankIn/rankOut combination", & + ESMF_CONTEXT, rcToReturn=rc)) return + end select +^ifndef ESMF_NO_GREATER_THAN_4D + case (5) + select case(rankOut) + case (1) + call ESMF_LocalArraySlice5D1DI8(array, slice, rc=localrc) + if (ESMF_LogFoundError(localrc, & + ESMF_ERR_PASSTHRU, & + ESMF_CONTEXT, rcToReturn=rc)) return + case (2) + call ESMF_LocalArraySlice5D2DI8(array, slice, rc=localrc) + if (ESMF_LogFoundError(localrc, & + ESMF_ERR_PASSTHRU, & + ESMF_CONTEXT, rcToReturn=rc)) return + case (3) + call ESMF_LocalArraySlice5D3DI8(array, slice, rc=localrc) + if (ESMF_LogFoundError(localrc, & + ESMF_ERR_PASSTHRU, & + ESMF_CONTEXT, rcToReturn=rc)) return + case (4) + call ESMF_LocalArraySlice5D4DI8(array, slice, rc=localrc) + if (ESMF_LogFoundError(localrc, & + ESMF_ERR_PASSTHRU, & + ESMF_CONTEXT, rcToReturn=rc)) return + case default + if (ESMF_LogFoundError(ESMF_RC_ARG_BAD, & + msg="Unsupported rankIn/rankOut combination", & + ESMF_CONTEXT, rcToReturn=rc)) return + end select + case (6) + select case(rankOut) + case (1) + call ESMF_LocalArraySlice6D1DI8(array, slice, rc=localrc) + if (ESMF_LogFoundError(localrc, & + ESMF_ERR_PASSTHRU, & + ESMF_CONTEXT, rcToReturn=rc)) return + case (2) + call ESMF_LocalArraySlice6D2DI8(array, slice, rc=localrc) + if (ESMF_LogFoundError(localrc, & + ESMF_ERR_PASSTHRU, & + ESMF_CONTEXT, rcToReturn=rc)) return + case (3) + call ESMF_LocalArraySlice6D3DI8(array, slice, rc=localrc) + if (ESMF_LogFoundError(localrc, & + ESMF_ERR_PASSTHRU, & + ESMF_CONTEXT, rcToReturn=rc)) return + case (4) + call ESMF_LocalArraySlice6D4DI8(array, slice, rc=localrc) + if (ESMF_LogFoundError(localrc, & + ESMF_ERR_PASSTHRU, & + ESMF_CONTEXT, rcToReturn=rc)) return + case (5) + call ESMF_LocalArraySlice6D5DI8(array, slice, rc=localrc) + if (ESMF_LogFoundError(localrc, & + ESMF_ERR_PASSTHRU, & + ESMF_CONTEXT, rcToReturn=rc)) return + case default + if (ESMF_LogFoundError(ESMF_RC_ARG_BAD, & + msg="Unsupported rankIn/rankOut combination", & + ESMF_CONTEXT, rcToReturn=rc)) return + end select + case (7) + select case(rankOut) + case (1) + call ESMF_LocalArraySlice7D1DI8(array, slice, rc=localrc) + if (ESMF_LogFoundError(localrc, & + ESMF_ERR_PASSTHRU, & + ESMF_CONTEXT, rcToReturn=rc)) return + case (2) + call ESMF_LocalArraySlice7D2DI8(array, slice, rc=localrc) + if (ESMF_LogFoundError(localrc, & + ESMF_ERR_PASSTHRU, & + ESMF_CONTEXT, rcToReturn=rc)) return + case (3) + call ESMF_LocalArraySlice7D3DI8(array, slice, rc=localrc) + if (ESMF_LogFoundError(localrc, & + ESMF_ERR_PASSTHRU, & + ESMF_CONTEXT, rcToReturn=rc)) return + case (4) + call ESMF_LocalArraySlice7D4DI8(array, slice, rc=localrc) + if (ESMF_LogFoundError(localrc, & + ESMF_ERR_PASSTHRU, & + ESMF_CONTEXT, rcToReturn=rc)) return + case (5) + call ESMF_LocalArraySlice7D5DI8(array, slice, rc=localrc) + if (ESMF_LogFoundError(localrc, & + ESMF_ERR_PASSTHRU, & + ESMF_CONTEXT, rcToReturn=rc)) return + case (6) + call ESMF_LocalArraySlice7D6DI8(array, slice, rc=localrc) + if (ESMF_LogFoundError(localrc, & + ESMF_ERR_PASSTHRU, & + ESMF_CONTEXT, rcToReturn=rc)) return + case default + if (ESMF_LogFoundError(ESMF_RC_ARG_BAD, & + msg="Unsupported rankIn/rankOut combination", & + ESMF_CONTEXT, rcToReturn=rc)) return + end select +^endif + case default + if (ESMF_LogFoundError(ESMF_RC_ARG_BAD, & + msg="Unsupported rankIn", & + ESMF_CONTEXT, rcToReturn=rc)) return + end select + case (ESMF_TYPEKIND_R4%dkind) + select case(rankIn) + case (2) + select case(rankOut) + case (1) + call ESMF_LocalArraySlice2D1DR4(array, slice, rc=localrc) + if (ESMF_LogFoundError(localrc, & + ESMF_ERR_PASSTHRU, & + ESMF_CONTEXT, rcToReturn=rc)) return + case default + if (ESMF_LogFoundError(ESMF_RC_ARG_BAD, & + msg="Unsupported rankIn/rankOut combination", & + ESMF_CONTEXT, rcToReturn=rc)) return + end select + case (3) + select case(rankOut) + case (1) + call ESMF_LocalArraySlice3D1DR4(array, slice, rc=localrc) + if (ESMF_LogFoundError(localrc, & + ESMF_ERR_PASSTHRU, & + ESMF_CONTEXT, rcToReturn=rc)) return + case (2) + call ESMF_LocalArraySlice3D2DR4(array, slice, rc=localrc) + if (ESMF_LogFoundError(localrc, & + ESMF_ERR_PASSTHRU, & + ESMF_CONTEXT, rcToReturn=rc)) return + case default + if (ESMF_LogFoundError(ESMF_RC_ARG_BAD, & + msg="Unsupported rankIn/rankOut combination", & + ESMF_CONTEXT, rcToReturn=rc)) return + end select + case (4) + select case(rankOut) + case (1) + call ESMF_LocalArraySlice4D1DR4(array, slice, rc=localrc) + if (ESMF_LogFoundError(localrc, & + ESMF_ERR_PASSTHRU, & + ESMF_CONTEXT, rcToReturn=rc)) return + case (2) + call ESMF_LocalArraySlice4D2DR4(array, slice, rc=localrc) + if (ESMF_LogFoundError(localrc, & + ESMF_ERR_PASSTHRU, & + ESMF_CONTEXT, rcToReturn=rc)) return + case (3) + call ESMF_LocalArraySlice4D3DR4(array, slice, rc=localrc) + if (ESMF_LogFoundError(localrc, & + ESMF_ERR_PASSTHRU, & + ESMF_CONTEXT, rcToReturn=rc)) return + case default + if (ESMF_LogFoundError(ESMF_RC_ARG_BAD, & + msg="Unsupported rankIn/rankOut combination", & + ESMF_CONTEXT, rcToReturn=rc)) return + end select +^ifndef ESMF_NO_GREATER_THAN_4D + case (5) + select case(rankOut) + case (1) + call ESMF_LocalArraySlice5D1DR4(array, slice, rc=localrc) + if (ESMF_LogFoundError(localrc, & + ESMF_ERR_PASSTHRU, & + ESMF_CONTEXT, rcToReturn=rc)) return + case (2) + call ESMF_LocalArraySlice5D2DR4(array, slice, rc=localrc) + if (ESMF_LogFoundError(localrc, & + ESMF_ERR_PASSTHRU, & + ESMF_CONTEXT, rcToReturn=rc)) return + case (3) + call ESMF_LocalArraySlice5D3DR4(array, slice, rc=localrc) + if (ESMF_LogFoundError(localrc, & + ESMF_ERR_PASSTHRU, & + ESMF_CONTEXT, rcToReturn=rc)) return + case (4) + call ESMF_LocalArraySlice5D4DR4(array, slice, rc=localrc) + if (ESMF_LogFoundError(localrc, & + ESMF_ERR_PASSTHRU, & + ESMF_CONTEXT, rcToReturn=rc)) return + case default + if (ESMF_LogFoundError(ESMF_RC_ARG_BAD, & + msg="Unsupported rankIn/rankOut combination", & + ESMF_CONTEXT, rcToReturn=rc)) return + end select + case (6) + select case(rankOut) + case (1) + call ESMF_LocalArraySlice6D1DR4(array, slice, rc=localrc) + if (ESMF_LogFoundError(localrc, & + ESMF_ERR_PASSTHRU, & + ESMF_CONTEXT, rcToReturn=rc)) return + case (2) + call ESMF_LocalArraySlice6D2DR4(array, slice, rc=localrc) + if (ESMF_LogFoundError(localrc, & + ESMF_ERR_PASSTHRU, & + ESMF_CONTEXT, rcToReturn=rc)) return + case (3) + call ESMF_LocalArraySlice6D3DR4(array, slice, rc=localrc) + if (ESMF_LogFoundError(localrc, & + ESMF_ERR_PASSTHRU, & + ESMF_CONTEXT, rcToReturn=rc)) return + case (4) + call ESMF_LocalArraySlice6D4DR4(array, slice, rc=localrc) + if (ESMF_LogFoundError(localrc, & + ESMF_ERR_PASSTHRU, & + ESMF_CONTEXT, rcToReturn=rc)) return + case (5) + call ESMF_LocalArraySlice6D5DR4(array, slice, rc=localrc) + if (ESMF_LogFoundError(localrc, & + ESMF_ERR_PASSTHRU, & + ESMF_CONTEXT, rcToReturn=rc)) return + case default + if (ESMF_LogFoundError(ESMF_RC_ARG_BAD, & + msg="Unsupported rankIn/rankOut combination", & + ESMF_CONTEXT, rcToReturn=rc)) return + end select + case (7) + select case(rankOut) + case (1) + call ESMF_LocalArraySlice7D1DR4(array, slice, rc=localrc) + if (ESMF_LogFoundError(localrc, & + ESMF_ERR_PASSTHRU, & + ESMF_CONTEXT, rcToReturn=rc)) return + case (2) + call ESMF_LocalArraySlice7D2DR4(array, slice, rc=localrc) + if (ESMF_LogFoundError(localrc, & + ESMF_ERR_PASSTHRU, & + ESMF_CONTEXT, rcToReturn=rc)) return + case (3) + call ESMF_LocalArraySlice7D3DR4(array, slice, rc=localrc) + if (ESMF_LogFoundError(localrc, & + ESMF_ERR_PASSTHRU, & + ESMF_CONTEXT, rcToReturn=rc)) return + case (4) + call ESMF_LocalArraySlice7D4DR4(array, slice, rc=localrc) + if (ESMF_LogFoundError(localrc, & + ESMF_ERR_PASSTHRU, & + ESMF_CONTEXT, rcToReturn=rc)) return + case (5) + call ESMF_LocalArraySlice7D5DR4(array, slice, rc=localrc) + if (ESMF_LogFoundError(localrc, & + ESMF_ERR_PASSTHRU, & + ESMF_CONTEXT, rcToReturn=rc)) return + case (6) + call ESMF_LocalArraySlice7D6DR4(array, slice, rc=localrc) + if (ESMF_LogFoundError(localrc, & + ESMF_ERR_PASSTHRU, & + ESMF_CONTEXT, rcToReturn=rc)) return + case default + if (ESMF_LogFoundError(ESMF_RC_ARG_BAD, & + msg="Unsupported rankIn/rankOut combination", & + ESMF_CONTEXT, rcToReturn=rc)) return + end select +^endif + case default + if (ESMF_LogFoundError(ESMF_RC_ARG_BAD, & + msg="Unsupported rankIn", & + ESMF_CONTEXT, rcToReturn=rc)) return + end select case (ESMF_TYPEKIND_R8%dkind) select case(rankIn) - case (1) case (2) + select case(rankOut) + case (1) + call ESMF_LocalArraySlice2D1DR8(array, slice, rc=localrc) + if (ESMF_LogFoundError(localrc, & + ESMF_ERR_PASSTHRU, & + ESMF_CONTEXT, rcToReturn=rc)) return + case default + if (ESMF_LogFoundError(ESMF_RC_ARG_BAD, & + msg="Unsupported rankIn/rankOut combination", & + ESMF_CONTEXT, rcToReturn=rc)) return + end select case (3) select case(rankOut) case (1) + call ESMF_LocalArraySlice3D1DR8(array, slice, rc=localrc) + if (ESMF_LogFoundError(localrc, & + ESMF_ERR_PASSTHRU, & + ESMF_CONTEXT, rcToReturn=rc)) return case (2) call ESMF_LocalArraySlice3D2DR8(array, slice, rc=localrc) if (ESMF_LogFoundError(localrc, & @@ -3675,10 +4471,124 @@ print *, "slice: ", slice ESMF_CONTEXT, rcToReturn=rc)) return end select case (4) + select case(rankOut) + case (1) + call ESMF_LocalArraySlice4D1DR8(array, slice, rc=localrc) + if (ESMF_LogFoundError(localrc, & + ESMF_ERR_PASSTHRU, & + ESMF_CONTEXT, rcToReturn=rc)) return + case (2) + call ESMF_LocalArraySlice4D2DR8(array, slice, rc=localrc) + if (ESMF_LogFoundError(localrc, & + ESMF_ERR_PASSTHRU, & + ESMF_CONTEXT, rcToReturn=rc)) return + case (3) + call ESMF_LocalArraySlice4D3DR8(array, slice, rc=localrc) + if (ESMF_LogFoundError(localrc, & + ESMF_ERR_PASSTHRU, & + ESMF_CONTEXT, rcToReturn=rc)) return + case default + if (ESMF_LogFoundError(ESMF_RC_ARG_BAD, & + msg="Unsupported rankIn/rankOut combination", & + ESMF_CONTEXT, rcToReturn=rc)) return + end select ^ifndef ESMF_NO_GREATER_THAN_4D case (5) + select case(rankOut) + case (1) + call ESMF_LocalArraySlice5D1DR8(array, slice, rc=localrc) + if (ESMF_LogFoundError(localrc, & + ESMF_ERR_PASSTHRU, & + ESMF_CONTEXT, rcToReturn=rc)) return + case (2) + call ESMF_LocalArraySlice5D2DR8(array, slice, rc=localrc) + if (ESMF_LogFoundError(localrc, & + ESMF_ERR_PASSTHRU, & + ESMF_CONTEXT, rcToReturn=rc)) return + case (3) + call ESMF_LocalArraySlice5D3DR8(array, slice, rc=localrc) + if (ESMF_LogFoundError(localrc, & + ESMF_ERR_PASSTHRU, & + ESMF_CONTEXT, rcToReturn=rc)) return + case (4) + call ESMF_LocalArraySlice5D4DR8(array, slice, rc=localrc) + if (ESMF_LogFoundError(localrc, & + ESMF_ERR_PASSTHRU, & + ESMF_CONTEXT, rcToReturn=rc)) return + case default + if (ESMF_LogFoundError(ESMF_RC_ARG_BAD, & + msg="Unsupported rankIn/rankOut combination", & + ESMF_CONTEXT, rcToReturn=rc)) return + end select case (6) + select case(rankOut) + case (1) + call ESMF_LocalArraySlice6D1DR8(array, slice, rc=localrc) + if (ESMF_LogFoundError(localrc, & + ESMF_ERR_PASSTHRU, & + ESMF_CONTEXT, rcToReturn=rc)) return + case (2) + call ESMF_LocalArraySlice6D2DR8(array, slice, rc=localrc) + if (ESMF_LogFoundError(localrc, & + ESMF_ERR_PASSTHRU, & + ESMF_CONTEXT, rcToReturn=rc)) return + case (3) + call ESMF_LocalArraySlice6D3DR8(array, slice, rc=localrc) + if (ESMF_LogFoundError(localrc, & + ESMF_ERR_PASSTHRU, & + ESMF_CONTEXT, rcToReturn=rc)) return + case (4) + call ESMF_LocalArraySlice6D4DR8(array, slice, rc=localrc) + if (ESMF_LogFoundError(localrc, & + ESMF_ERR_PASSTHRU, & + ESMF_CONTEXT, rcToReturn=rc)) return + case (5) + call ESMF_LocalArraySlice6D5DR8(array, slice, rc=localrc) + if (ESMF_LogFoundError(localrc, & + ESMF_ERR_PASSTHRU, & + ESMF_CONTEXT, rcToReturn=rc)) return + case default + if (ESMF_LogFoundError(ESMF_RC_ARG_BAD, & + msg="Unsupported rankIn/rankOut combination", & + ESMF_CONTEXT, rcToReturn=rc)) return + end select case (7) + select case(rankOut) + case (1) + call ESMF_LocalArraySlice7D1DR8(array, slice, rc=localrc) + if (ESMF_LogFoundError(localrc, & + ESMF_ERR_PASSTHRU, & + ESMF_CONTEXT, rcToReturn=rc)) return + case (2) + call ESMF_LocalArraySlice7D2DR8(array, slice, rc=localrc) + if (ESMF_LogFoundError(localrc, & + ESMF_ERR_PASSTHRU, & + ESMF_CONTEXT, rcToReturn=rc)) return + case (3) + call ESMF_LocalArraySlice7D3DR8(array, slice, rc=localrc) + if (ESMF_LogFoundError(localrc, & + ESMF_ERR_PASSTHRU, & + ESMF_CONTEXT, rcToReturn=rc)) return + case (4) + call ESMF_LocalArraySlice7D4DR8(array, slice, rc=localrc) + if (ESMF_LogFoundError(localrc, & + ESMF_ERR_PASSTHRU, & + ESMF_CONTEXT, rcToReturn=rc)) return + case (5) + call ESMF_LocalArraySlice7D5DR8(array, slice, rc=localrc) + if (ESMF_LogFoundError(localrc, & + ESMF_ERR_PASSTHRU, & + ESMF_CONTEXT, rcToReturn=rc)) return + case (6) + call ESMF_LocalArraySlice7D6DR8(array, slice, rc=localrc) + if (ESMF_LogFoundError(localrc, & + ESMF_ERR_PASSTHRU, & + ESMF_CONTEXT, rcToReturn=rc)) return + case default + if (ESMF_LogFoundError(ESMF_RC_ARG_BAD, & + msg="Unsupported rankIn/rankOut combination", & + ESMF_CONTEXT, rcToReturn=rc)) return + end select ^endif case default if (ESMF_LogFoundError(ESMF_RC_ARG_BAD, & @@ -3701,65 +4611,74 @@ print *, "slice: ", slice !------------------------------------------------------------------------------ - subroutine ESMF_LocalArraySlice3D2DR8(array, slice, rc) - type(ESMF_LocalArray), intent(inout) :: array - integer, pointer :: slice(:) - integer, intent(out), optional :: rc - - integer :: localrc, rankOut - type (ESMF_LAWrap3Dr8) :: wrapIn - type (ESMF_LAWrap2Dr8) :: wrapOut - real (ESMF_KIND_r8), dimension(:,:,:), pointer :: farrayPtrIn - real (ESMF_KIND_r8), dimension(:,:), pointer :: farrayPtrOut - - call ESMF_LogWrite("Hi There from ESMF_LocalArraySlice3D2DR8", & - ESMF_LOGMSG_DEBUG, rc=rc) - - call c_ESMC_LocalArrayGetFPtr(array, wrapIn, localrc) - if (ESMF_LogFoundError(localrc, & - ESMF_ERR_PASSTHRU, & - ESMF_CONTEXT, rcToReturn=rc)) return - -print *, "lbound(wrapIn%ptr3Dr8):", lbound(wrapIn%ptr3Dr8) -print *, "ubound(wrapIn%ptr3Dr8):", ubound(wrapIn%ptr3Dr8) - -#if 0 - - ! slicing!!! - wrapOut%ptr2Dr8 => wrapIn%ptr3Dr8(:,:,slice(1)) -! wrapOut%ptr2Dr8 => wrapIn%ptr3Dr8(:,:,1) - -!print *, "wrapOut%ptr2Dr8(1,1)=", wrapOut%ptr2Dr8(1,1) - - rankOut = 2 ! must set now so SetFPtr works correctly - call c_ESMC_LocalArraySetRank(array, rankOut, localrc) - if (ESMF_LogFoundError(localrc, & - ESMF_ERR_PASSTHRU, & - ESMF_CONTEXT, rcToReturn=rc)) return - - call c_ESMC_LocalArraySetFPtr(array, wrapOut, localrc) - if (ESMF_LogFoundError(localrc, & - ESMF_ERR_PASSTHRU, & - ESMF_CONTEXT, rcToReturn=rc)) return -#else - - farrayPtrOut(lbound(wrapIn%ptr3Dr8,1):,lbound(wrapIn%ptr3Dr8,2):) => wrapIn%ptr3Dr8(:,:,slice(1)) -! farrayPtrOut => wrapIn%ptr3Dr8(:,:,slice(1)) - -print *, "lbound(farrayPtrOut):", lbound(farrayPtrOut) -print *, "ubound(farrayPtrOut):", ubound(farrayPtrOut) - - array = ESMF_LocalArrayCreate(farrayPtrOut, rc=localrc) - if (ESMF_LogFoundError(localrc, & - ESMF_ERR_PASSTHRU, & - ESMF_CONTEXT, rcToReturn=rc)) return - -#endif +#define LocalArraySliceDoc() \ +!---------------------------------------------------------------------------- @\ +!BOPI @\ +! !IROUTINE: ESMF_LocalArraySlice - Array Slicing @\ +! @\ +! !INTERFACE: @\ +! recursive subroutine ESMF_LocalArraySlice(array,&@\ +! slice, rc) @\ +! @\ +! !ARGUMENTS: @\ +! type(ESMF_LocalArray), intent(inout) :: array @\ +! integer, pointer :: slice(:) @\ +! integer, intent(out), optional :: rc @\ +! @\ +! !DESCRIPTION: @\ +! Array Slicing. @\ +!EOPI @\ +!---------------------------------------------------------------------------- @\ + @\ - ! Return successfully - if (present(rc)) rc = ESMF_SUCCESS +#define LocalArraySliceMacro(mtypename, mtypekind, mranka, mdima, mlena, mrnga, mlbca, mrankb, mdimb, mlenb, mrngb, mlbcb, mslc) \ +!---------------------------------------------------------------------------- @\ +^undef ESMF_METHOD @\ +!define ESMF_METHOD "ESMF_LocalArraySlice##mrank##D##mtypekind" @\ +^define ESMF_METHOD "ESMF_LocalArraySlice" @\ + @\ + recursive subroutine ESMF_LocalArraySlice##mranka##D##mrankb##D##mtypekind(array, &@\ + slice, rc) @\ + @\ + type(ESMF_LocalArray), intent(inout) :: array @\ + integer, pointer :: slice(:) @\ + integer, intent(out), optional :: rc @\ + @\ + ! Local variables @\ + integer :: localrc ! local return code @\ + integer :: lb(mranka), ub(mranka) ! bounds of the incoming array @\ + @\ + type (ESMF_LAWrap##mranka##D##mtypekind) :: wrapIn @\ + mtypename (ESMF_KIND_##mtypekind), dimension(mdimb), pointer :: farrayPtrOut @\ + @\ + ! Initialize return code; assume routine not implemented @\ + localrc = ESMF_RC_NOT_IMPL @\ + if (present(rc)) rc = ESMF_RC_NOT_IMPL @\ + @\ + call c_ESMC_LocalArrayGetFPtr(array, wrapIn, localrc) @\ + if (ESMF_LogFoundError(localrc, & @\ + ESMF_ERR_PASSTHRU, & @\ + ESMF_CONTEXT, rcToReturn=rc)) return @\ + @\ + lb = lbound(wrapIn%ptr##mranka##D##mtypekind) @\ + ub = ubound(wrapIn%ptr##mranka##D##mtypekind) @\ + @\ + farrayPtrOut(mlbcb) & @\ + => wrapIn%ptr##mranka##D##mtypekind(mdimb,mslc) @\ + @\ + array = ESMF_LocalArrayCreate(farrayPtrOut, rc=localrc) @\ + if (ESMF_LogFoundError(localrc, & @\ + ESMF_ERR_PASSTHRU, & @\ + ESMF_CONTEXT, rcToReturn=rc)) return @\ + @\ + ! return successfully @\ + if (present(rc)) rc = ESMF_SUCCESS @\ + @\ + end subroutine ESMF_LocalArraySlice##mranka##D##mrankb##D##mtypekind @\ + @\ +!---------------------------------------------------------------------------- @\ - end subroutine ESMF_LocalArraySlice3D2DR8 +TypeKindRankCrossRankTridiagDeclarationMacro(LocalArraySlice) !------------------------------------------------------------------------------ diff --git a/src/Infrastructure/Util/include/ESMF_TypeKindRankMacros.hcppF90 b/src/Infrastructure/Util/include/ESMF_TypeKindRankMacros.hcppF90 index b276ec723b..62a2ec7539 100644 --- a/src/Infrastructure/Util/include/ESMF_TypeKindRankMacros.hcppF90 +++ b/src/Infrastructure/Util/include/ESMF_TypeKindRankMacros.hcppF90 @@ -88,6 +88,21 @@ #define LOC6 lb(1),lb(2),lb(3),lb(4),lb(5),lb(6) #define LOC7 lb(1),lb(2),lb(3),lb(4),lb(5),lb(6),lb(7) +#define LBC1 lb(1): +#define LBC2 lb(1):,lb(2): +#define LBC3 lb(1):,lb(2):,lb(3): +#define LBC4 lb(1):,lb(2):,lb(3):,lb(4): +#define LBC5 lb(1):,lb(2):,lb(3):,lb(4):,lb(5): +#define LBC6 lb(1):,lb(2):,lb(3):,lb(4):,lb(5):,lb(6): +#define LBC7 lb(1):,lb(2):,lb(3):,lb(4):,lb(5):,lb(6):,lb(7): + +#define SLC1 slice(1) +#define SLC2 slice(1),slice(2) +#define SLC3 slice(1),slice(2),slice(3) +#define SLC4 slice(1),slice(2),slice(3),slice(4) +#define SLC5 slice(1),slice(2),slice(3),slice(4),slice(5) +#define SLC6 slice(1),slice(2),slice(3),slice(4),slice(5),slice(6) +#define SLC7 slice(1),slice(2),slice(3),slice(4),slice(5),slice(6),slice(7) #if 0 !------------------------------------------------------------------------------ @@ -309,6 +324,178 @@ funcname##Macro(real, r8, 7, COL7, LEN7, RNG7, LOC7) @\ !------------------------------------------------------------------------------ @\ +#if 0 +!------------------------------------------------------------------------------ +! Expand a string into each of the cross-product T/K/R x R procedures. +! Assumes one macro which contains only the general protex documentation, +! and the rest do NOT contain protex. Expected use: +! +! TypeKindRankCrossRankTridiagDeclarationMacro(fred) +! +! where the following other macros are defined elsewhere by the user: +! #define fredDoc() ... +! which contains generic protex documentation only, no code, plus: +! #define fredMacro(typename, typekind, rankA, colA, lenA, rngA, locA, rankB, colB, lenB, rngB, locB) ... +! which contains the actual code for the function, with no protex documentation. +! +! The B rank expansion is done in tridiagonal fashion, only up to A rank - 1. +!------------------------------------------------------------------------------ +#endif + +#define TypeKindRankCrossRankTridiagDeclarationMacro(funcname) \ +!------------------------------------------------------------------------------ @\ +! @\ + @\ +!! < start of macros which become actual subroutine bodies after expansion > @\ + @\ +funcname##Doc() @\ +^ifndef ESMF_NO_INTEGER_1_BYTE @\ +funcname##Macro(integer, i1, 2, COL2, LEN2, RNG2, LBC2, 1, COL1, LEN1, RNG1, LBC1, SLC1) @\ +funcname##Macro(integer, i1, 3, COL3, LEN3, RNG3, LBC3, 1, COL1, LEN1, RNG1, LBC1, SLC2) @\ +funcname##Macro(integer, i1, 3, COL3, LEN3, RNG3, LBC3, 2, COL2, LEN2, RNG2, LBC2, SLC1) @\ +funcname##Macro(integer, i1, 4, COL4, LEN4, RNG4, LBC4, 1, COL1, LEN1, RNG1, LBC1, SLC3) @\ +funcname##Macro(integer, i1, 4, COL4, LEN4, RNG4, LBC4, 2, COL2, LEN2, RNG2, LBC2, SLC2) @\ +funcname##Macro(integer, i1, 4, COL4, LEN4, RNG4, LBC4, 3, COL3, LEN3, RNG3, LBC3, SLC1) @\ +^ifndef ESMF_NO_GREATER_THAN_4D @\ +funcname##Macro(integer, i1, 5, COL5, LEN5, RNG5, LBC5, 1, COL1, LEN1, RNG1, LBC1, SLC4) @\ +funcname##Macro(integer, i1, 5, COL5, LEN5, RNG5, LBC5, 2, COL2, LEN2, RNG2, LBC2, SLC3) @\ +funcname##Macro(integer, i1, 5, COL5, LEN5, RNG5, LBC5, 3, COL3, LEN3, RNG3, LBC3, SLC2) @\ +funcname##Macro(integer, i1, 5, COL5, LEN5, RNG5, LBC5, 4, COL4, LEN4, RNG4, LBC4, SLC1) @\ +funcname##Macro(integer, i1, 6, COL6, LEN6, RNG6, LBC6, 1, COL1, LEN1, RNG1, LBC1, SLC5) @\ +funcname##Macro(integer, i1, 6, COL6, LEN6, RNG6, LBC6, 2, COL2, LEN2, RNG2, LBC2, SLC4) @\ +funcname##Macro(integer, i1, 6, COL6, LEN6, RNG6, LBC6, 3, COL3, LEN3, RNG3, LBC3, SLC3) @\ +funcname##Macro(integer, i1, 6, COL6, LEN6, RNG6, LBC6, 4, COL4, LEN4, RNG4, LBC4, SLC2) @\ +funcname##Macro(integer, i1, 6, COL6, LEN6, RNG6, LBC6, 5, COL5, LEN5, RNG5, LBC5, SLC1) @\ +funcname##Macro(integer, i1, 7, COL7, LEN7, RNG7, LBC7, 1, COL1, LEN1, RNG1, LBC1, SLC6) @\ +funcname##Macro(integer, i1, 7, COL7, LEN7, RNG7, LBC7, 2, COL2, LEN2, RNG2, LBC2, SLC5) @\ +funcname##Macro(integer, i1, 7, COL7, LEN7, RNG7, LBC7, 3, COL3, LEN3, RNG3, LBC3, SLC4) @\ +funcname##Macro(integer, i1, 7, COL7, LEN7, RNG7, LBC7, 4, COL4, LEN4, RNG4, LBC4, SLC3) @\ +funcname##Macro(integer, i1, 7, COL7, LEN7, RNG7, LBC7, 5, COL5, LEN5, RNG5, LBC5, SLC2) @\ +funcname##Macro(integer, i1, 7, COL7, LEN7, RNG7, LBC7, 6, COL6, LEN6, RNG6, LBC6, SLC1) @\ +^endif @\ +^endif @\ +^ifndef ESMF_NO_INTEGER_2_BYTE @\ +funcname##Macro(integer, i2, 2, COL2, LEN2, RNG2, LBC2, 1, COL1, LEN1, RNG1, LBC1, SLC1) @\ +funcname##Macro(integer, i2, 3, COL3, LEN3, RNG3, LBC3, 1, COL1, LEN1, RNG1, LBC1, SLC2) @\ +funcname##Macro(integer, i2, 3, COL3, LEN3, RNG3, LBC3, 2, COL2, LEN2, RNG2, LBC2, SLC1) @\ +funcname##Macro(integer, i2, 4, COL4, LEN4, RNG4, LBC4, 1, COL1, LEN1, RNG1, LBC1, SLC3) @\ +funcname##Macro(integer, i2, 4, COL4, LEN4, RNG4, LBC4, 2, COL2, LEN2, RNG2, LBC2, SLC2) @\ +funcname##Macro(integer, i2, 4, COL4, LEN4, RNG4, LBC4, 3, COL3, LEN3, RNG3, LBC3, SLC1) @\ +^ifndef ESMF_NO_GREATER_THAN_4D @\ +funcname##Macro(integer, i2, 5, COL5, LEN5, RNG5, LBC5, 1, COL1, LEN1, RNG1, LBC1, SLC4) @\ +funcname##Macro(integer, i2, 5, COL5, LEN5, RNG5, LBC5, 2, COL2, LEN2, RNG2, LBC2, SLC3) @\ +funcname##Macro(integer, i2, 5, COL5, LEN5, RNG5, LBC5, 3, COL3, LEN3, RNG3, LBC3, SLC2) @\ +funcname##Macro(integer, i2, 5, COL5, LEN5, RNG5, LBC5, 4, COL4, LEN4, RNG4, LBC4, SLC1) @\ +funcname##Macro(integer, i2, 6, COL6, LEN6, RNG6, LBC6, 1, COL1, LEN1, RNG1, LBC1, SLC5) @\ +funcname##Macro(integer, i2, 6, COL6, LEN6, RNG6, LBC6, 2, COL2, LEN2, RNG2, LBC2, SLC4) @\ +funcname##Macro(integer, i2, 6, COL6, LEN6, RNG6, LBC6, 3, COL3, LEN3, RNG3, LBC3, SLC3) @\ +funcname##Macro(integer, i2, 6, COL6, LEN6, RNG6, LBC6, 4, COL4, LEN4, RNG4, LBC4, SLC2) @\ +funcname##Macro(integer, i2, 6, COL6, LEN6, RNG6, LBC6, 5, COL5, LEN5, RNG5, LBC5, SLC1) @\ +funcname##Macro(integer, i2, 7, COL7, LEN7, RNG7, LBC7, 1, COL1, LEN1, RNG1, LBC1, SLC6) @\ +funcname##Macro(integer, i2, 7, COL7, LEN7, RNG7, LBC7, 2, COL2, LEN2, RNG2, LBC2, SLC5) @\ +funcname##Macro(integer, i2, 7, COL7, LEN7, RNG7, LBC7, 3, COL3, LEN3, RNG3, LBC3, SLC4) @\ +funcname##Macro(integer, i2, 7, COL7, LEN7, RNG7, LBC7, 4, COL4, LEN4, RNG4, LBC4, SLC3) @\ +funcname##Macro(integer, i2, 7, COL7, LEN7, RNG7, LBC7, 5, COL5, LEN5, RNG5, LBC5, SLC2) @\ +funcname##Macro(integer, i2, 7, COL7, LEN7, RNG7, LBC7, 6, COL6, LEN6, RNG6, LBC6, SLC1) @\ +^endif @\ +^endif @\ +funcname##Macro(integer, i4, 2, COL2, LEN2, RNG2, LBC2, 1, COL1, LEN1, RNG1, LBC1, SLC1) @\ +funcname##Macro(integer, i4, 3, COL3, LEN3, RNG3, LBC3, 1, COL1, LEN1, RNG1, LBC1, SLC2) @\ +funcname##Macro(integer, i4, 3, COL3, LEN3, RNG3, LBC3, 2, COL2, LEN2, RNG2, LBC2, SLC1) @\ +funcname##Macro(integer, i4, 4, COL4, LEN4, RNG4, LBC4, 1, COL1, LEN1, RNG1, LBC1, SLC3) @\ +funcname##Macro(integer, i4, 4, COL4, LEN4, RNG4, LBC4, 2, COL2, LEN2, RNG2, LBC2, SLC2) @\ +funcname##Macro(integer, i4, 4, COL4, LEN4, RNG4, LBC4, 3, COL3, LEN3, RNG3, LBC3, SLC1) @\ +^ifndef ESMF_NO_GREATER_THAN_4D @\ +funcname##Macro(integer, i4, 5, COL5, LEN5, RNG5, LBC5, 1, COL1, LEN1, RNG1, LBC1, SLC4) @\ +funcname##Macro(integer, i4, 5, COL5, LEN5, RNG5, LBC5, 2, COL2, LEN2, RNG2, LBC2, SLC3) @\ +funcname##Macro(integer, i4, 5, COL5, LEN5, RNG5, LBC5, 3, COL3, LEN3, RNG3, LBC3, SLC2) @\ +funcname##Macro(integer, i4, 5, COL5, LEN5, RNG5, LBC5, 4, COL4, LEN4, RNG4, LBC4, SLC1) @\ +funcname##Macro(integer, i4, 6, COL6, LEN6, RNG6, LBC6, 1, COL1, LEN1, RNG1, LBC1, SLC5) @\ +funcname##Macro(integer, i4, 6, COL6, LEN6, RNG6, LBC6, 2, COL2, LEN2, RNG2, LBC2, SLC4) @\ +funcname##Macro(integer, i4, 6, COL6, LEN6, RNG6, LBC6, 3, COL3, LEN3, RNG3, LBC3, SLC3) @\ +funcname##Macro(integer, i4, 6, COL6, LEN6, RNG6, LBC6, 4, COL4, LEN4, RNG4, LBC4, SLC2) @\ +funcname##Macro(integer, i4, 6, COL6, LEN6, RNG6, LBC6, 5, COL5, LEN5, RNG5, LBC5, SLC1) @\ +funcname##Macro(integer, i4, 7, COL7, LEN7, RNG7, LBC7, 1, COL1, LEN1, RNG1, LBC1, SLC6) @\ +funcname##Macro(integer, i4, 7, COL7, LEN7, RNG7, LBC7, 2, COL2, LEN2, RNG2, LBC2, SLC5) @\ +funcname##Macro(integer, i4, 7, COL7, LEN7, RNG7, LBC7, 3, COL3, LEN3, RNG3, LBC3, SLC4) @\ +funcname##Macro(integer, i4, 7, COL7, LEN7, RNG7, LBC7, 4, COL4, LEN4, RNG4, LBC4, SLC3) @\ +funcname##Macro(integer, i4, 7, COL7, LEN7, RNG7, LBC7, 5, COL5, LEN5, RNG5, LBC5, SLC2) @\ +funcname##Macro(integer, i4, 7, COL7, LEN7, RNG7, LBC7, 6, COL6, LEN6, RNG6, LBC6, SLC1) @\ +^endif @\ +funcname##Macro(integer, i8, 2, COL2, LEN2, RNG2, LBC2, 1, COL1, LEN1, RNG1, LBC1, SLC1) @\ +funcname##Macro(integer, i8, 3, COL3, LEN3, RNG3, LBC3, 1, COL1, LEN1, RNG1, LBC1, SLC2) @\ +funcname##Macro(integer, i8, 3, COL3, LEN3, RNG3, LBC3, 2, COL2, LEN2, RNG2, LBC2, SLC1) @\ +funcname##Macro(integer, i8, 4, COL4, LEN4, RNG4, LBC4, 1, COL1, LEN1, RNG1, LBC1, SLC3) @\ +funcname##Macro(integer, i8, 4, COL4, LEN4, RNG4, LBC4, 2, COL2, LEN2, RNG2, LBC2, SLC2) @\ +funcname##Macro(integer, i8, 4, COL4, LEN4, RNG4, LBC4, 3, COL3, LEN3, RNG3, LBC3, SLC1) @\ +^ifndef ESMF_NO_GREATER_THAN_4D @\ +funcname##Macro(integer, i8, 5, COL5, LEN5, RNG5, LBC5, 1, COL1, LEN1, RNG1, LBC1, SLC4) @\ +funcname##Macro(integer, i8, 5, COL5, LEN5, RNG5, LBC5, 2, COL2, LEN2, RNG2, LBC2, SLC3) @\ +funcname##Macro(integer, i8, 5, COL5, LEN5, RNG5, LBC5, 3, COL3, LEN3, RNG3, LBC3, SLC2) @\ +funcname##Macro(integer, i8, 5, COL5, LEN5, RNG5, LBC5, 4, COL4, LEN4, RNG4, LBC4, SLC1) @\ +funcname##Macro(integer, i8, 6, COL6, LEN6, RNG6, LBC6, 1, COL1, LEN1, RNG1, LBC1, SLC5) @\ +funcname##Macro(integer, i8, 6, COL6, LEN6, RNG6, LBC6, 2, COL2, LEN2, RNG2, LBC2, SLC4) @\ +funcname##Macro(integer, i8, 6, COL6, LEN6, RNG6, LBC6, 3, COL3, LEN3, RNG3, LBC3, SLC3) @\ +funcname##Macro(integer, i8, 6, COL6, LEN6, RNG6, LBC6, 4, COL4, LEN4, RNG4, LBC4, SLC2) @\ +funcname##Macro(integer, i8, 6, COL6, LEN6, RNG6, LBC6, 5, COL5, LEN5, RNG5, LBC5, SLC1) @\ +funcname##Macro(integer, i8, 7, COL7, LEN7, RNG7, LBC7, 1, COL1, LEN1, RNG1, LBC1, SLC6) @\ +funcname##Macro(integer, i8, 7, COL7, LEN7, RNG7, LBC7, 2, COL2, LEN2, RNG2, LBC2, SLC5) @\ +funcname##Macro(integer, i8, 7, COL7, LEN7, RNG7, LBC7, 3, COL3, LEN3, RNG3, LBC3, SLC4) @\ +funcname##Macro(integer, i8, 7, COL7, LEN7, RNG7, LBC7, 4, COL4, LEN4, RNG4, LBC4, SLC3) @\ +funcname##Macro(integer, i8, 7, COL7, LEN7, RNG7, LBC7, 5, COL5, LEN5, RNG5, LBC5, SLC2) @\ +funcname##Macro(integer, i8, 7, COL7, LEN7, RNG7, LBC7, 6, COL6, LEN6, RNG6, LBC6, SLC1) @\ +^endif @\ +funcname##Macro(real, r4, 2, COL2, LEN2, RNG2, LBC2, 1, COL1, LEN1, RNG1, LBC1, SLC1) @\ +funcname##Macro(real, r4, 3, COL3, LEN3, RNG3, LBC3, 1, COL1, LEN1, RNG1, LBC1, SLC2) @\ +funcname##Macro(real, r4, 3, COL3, LEN3, RNG3, LBC3, 2, COL2, LEN2, RNG2, LBC2, SLC1) @\ +funcname##Macro(real, r4, 4, COL4, LEN4, RNG4, LBC4, 1, COL1, LEN1, RNG1, LBC1, SLC3) @\ +funcname##Macro(real, r4, 4, COL4, LEN4, RNG4, LBC4, 2, COL2, LEN2, RNG2, LBC2, SLC2) @\ +funcname##Macro(real, r4, 4, COL4, LEN4, RNG4, LBC4, 3, COL3, LEN3, RNG3, LBC3, SLC1) @\ +^ifndef ESMF_NO_GREATER_THAN_4D @\ +funcname##Macro(real, r4, 5, COL5, LEN5, RNG5, LBC5, 1, COL1, LEN1, RNG1, LBC1, SLC4) @\ +funcname##Macro(real, r4, 5, COL5, LEN5, RNG5, LBC5, 2, COL2, LEN2, RNG2, LBC2, SLC3) @\ +funcname##Macro(real, r4, 5, COL5, LEN5, RNG5, LBC5, 3, COL3, LEN3, RNG3, LBC3, SLC2) @\ +funcname##Macro(real, r4, 5, COL5, LEN5, RNG5, LBC5, 4, COL4, LEN4, RNG4, LBC4, SLC1) @\ +funcname##Macro(real, r4, 6, COL6, LEN6, RNG6, LBC6, 1, COL1, LEN1, RNG1, LBC1, SLC5) @\ +funcname##Macro(real, r4, 6, COL6, LEN6, RNG6, LBC6, 2, COL2, LEN2, RNG2, LBC2, SLC4) @\ +funcname##Macro(real, r4, 6, COL6, LEN6, RNG6, LBC6, 3, COL3, LEN3, RNG3, LBC3, SLC3) @\ +funcname##Macro(real, r4, 6, COL6, LEN6, RNG6, LBC6, 4, COL4, LEN4, RNG4, LBC4, SLC2) @\ +funcname##Macro(real, r4, 6, COL6, LEN6, RNG6, LBC6, 5, COL5, LEN5, RNG5, LBC5, SLC1) @\ +funcname##Macro(real, r4, 7, COL7, LEN7, RNG7, LBC7, 1, COL1, LEN1, RNG1, LBC1, SLC6) @\ +funcname##Macro(real, r4, 7, COL7, LEN7, RNG7, LBC7, 2, COL2, LEN2, RNG2, LBC2, SLC5) @\ +funcname##Macro(real, r4, 7, COL7, LEN7, RNG7, LBC7, 3, COL3, LEN3, RNG3, LBC3, SLC4) @\ +funcname##Macro(real, r4, 7, COL7, LEN7, RNG7, LBC7, 4, COL4, LEN4, RNG4, LBC4, SLC3) @\ +funcname##Macro(real, r4, 7, COL7, LEN7, RNG7, LBC7, 5, COL5, LEN5, RNG5, LBC5, SLC2) @\ +funcname##Macro(real, r4, 7, COL7, LEN7, RNG7, LBC7, 6, COL6, LEN6, RNG6, LBC6, SLC1) @\ +^endif @\ +funcname##Macro(real, r8, 2, COL2, LEN2, RNG2, LBC2, 1, COL1, LEN1, RNG1, LBC1, SLC1) @\ +funcname##Macro(real, r8, 3, COL3, LEN3, RNG3, LBC3, 1, COL1, LEN1, RNG1, LBC1, SLC2) @\ +funcname##Macro(real, r8, 3, COL3, LEN3, RNG3, LBC3, 2, COL2, LEN2, RNG2, LBC2, SLC1) @\ +funcname##Macro(real, r8, 4, COL4, LEN4, RNG4, LBC4, 1, COL1, LEN1, RNG1, LBC1, SLC3) @\ +funcname##Macro(real, r8, 4, COL4, LEN4, RNG4, LBC4, 2, COL2, LEN2, RNG2, LBC2, SLC2) @\ +funcname##Macro(real, r8, 4, COL4, LEN4, RNG4, LBC4, 3, COL3, LEN3, RNG3, LBC3, SLC1) @\ +^ifndef ESMF_NO_GREATER_THAN_4D @\ +funcname##Macro(real, r8, 5, COL5, LEN5, RNG5, LBC5, 1, COL1, LEN1, RNG1, LBC1, SLC4) @\ +funcname##Macro(real, r8, 5, COL5, LEN5, RNG5, LBC5, 2, COL2, LEN2, RNG2, LBC2, SLC3) @\ +funcname##Macro(real, r8, 5, COL5, LEN5, RNG5, LBC5, 3, COL3, LEN3, RNG3, LBC3, SLC2) @\ +funcname##Macro(real, r8, 5, COL5, LEN5, RNG5, LBC5, 4, COL4, LEN4, RNG4, LBC4, SLC1) @\ +funcname##Macro(real, r8, 6, COL6, LEN6, RNG6, LBC6, 1, COL1, LEN1, RNG1, LBC1, SLC5) @\ +funcname##Macro(real, r8, 6, COL6, LEN6, RNG6, LBC6, 2, COL2, LEN2, RNG2, LBC2, SLC4) @\ +funcname##Macro(real, r8, 6, COL6, LEN6, RNG6, LBC6, 3, COL3, LEN3, RNG3, LBC3, SLC3) @\ +funcname##Macro(real, r8, 6, COL6, LEN6, RNG6, LBC6, 4, COL4, LEN4, RNG4, LBC4, SLC2) @\ +funcname##Macro(real, r8, 6, COL6, LEN6, RNG6, LBC6, 5, COL5, LEN5, RNG5, LBC5, SLC1) @\ +funcname##Macro(real, r8, 7, COL7, LEN7, RNG7, LBC7, 1, COL1, LEN1, RNG1, LBC1, SLC6) @\ +funcname##Macro(real, r8, 7, COL7, LEN7, RNG7, LBC7, 2, COL2, LEN2, RNG2, LBC2, SLC5) @\ +funcname##Macro(real, r8, 7, COL7, LEN7, RNG7, LBC7, 3, COL3, LEN3, RNG3, LBC3, SLC4) @\ +funcname##Macro(real, r8, 7, COL7, LEN7, RNG7, LBC7, 4, COL4, LEN4, RNG4, LBC4, SLC3) @\ +funcname##Macro(real, r8, 7, COL7, LEN7, RNG7, LBC7, 5, COL5, LEN5, RNG5, LBC5, SLC2) @\ +funcname##Macro(real, r8, 7, COL7, LEN7, RNG7, LBC7, 6, COL6, LEN6, RNG6, LBC6, SLC1) @\ +^endif @\ + @\ +! < end macro - do not edit directly > @\ +!------------------------------------------------------------------------------ @\ + + #if 0 !------------------------------------------------------------------------------ ! Expand generic code for each of the T/K/R procedures. From aab5278c964a310b46aa3fa868b2ec906f690620 Mon Sep 17 00:00:00 2001 From: Gerhard Theurich Date: Thu, 7 Sep 2023 21:00:02 -0700 Subject: [PATCH 14/14] Correct tolerance for single-precision comparison. --- src/Infrastructure/Array/tests/ESMF_ArrayCreateGetUTest.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Infrastructure/Array/tests/ESMF_ArrayCreateGetUTest.F90 b/src/Infrastructure/Array/tests/ESMF_ArrayCreateGetUTest.F90 index 8e03816204..a882461219 100644 --- a/src/Infrastructure/Array/tests/ESMF_ArrayCreateGetUTest.F90 +++ b/src/Infrastructure/Array/tests/ESMF_ArrayCreateGetUTest.F90 @@ -2305,7 +2305,7 @@ program ESMF_ArrayCreateGetUTest * sin(real(j,ESMF_KIND_R4)) & * sin(real(k,ESMF_KIND_R4)) & * sin(real(l,ESMF_KIND_R4)) - if (abs(diffR4) > 1.d-10) then + if (abs(diffR4) > 1.d-6) then dataCorrect=.false. write (msg,*) "diffR4=", diffR4 call ESMF_LogWrite(msg, ESMF_LOGMSG_INFO, rc=rc)