From f31fffa5177c5e44573a5d2c39b3e5e850b4ae94 Mon Sep 17 00:00:00 2001 From: Benjamin Auer Date: Fri, 16 Jun 2023 14:36:59 -0400 Subject: [PATCH 1/5] changes for rank agnostic parser --- base/CMakeLists.txt | 2 +- base/MAPL_NewArthParser.F90 | 598 ++++------------------------- geom/FieldBinaryOperations.F90 | 7 + geom/FieldBinaryOperatorTemplate.H | 12 +- geom/FieldPointerUtilities.F90 | 31 +- geom/tests/Test_FieldArithmetic.pf | 12 +- geom/tests/Test_FieldBLAS.pf | 39 +- 7 files changed, 154 insertions(+), 547 deletions(-) diff --git a/base/CMakeLists.txt b/base/CMakeLists.txt index 26694bb1b3c2..abfccdcf963f 100644 --- a/base/CMakeLists.txt +++ b/base/CMakeLists.txt @@ -66,7 +66,7 @@ endif() esma_add_library( ${this} SRCS ${srcs} - DEPENDENCIES MAPL.shared MAPL.constants MAPL.profiler MAPL.pfio MAPL_cfio_r4 PFLOGGER::pflogger + DEPENDENCIES MAPL.shared MAPL.constants MAPL.profiler MAPL.pfio MAPL_cfio_r4 MAPL.geom PFLOGGER::pflogger GFTL_SHARED::gftl-shared-v2 GFTL_SHARED::gftl-shared-v1 GFTL::gftl-v2 GFTL::gftl-v1 esmf NetCDF::NetCDF_Fortran MPI::MPI_Fortran TYPE ${MAPL_LIBRARY_TYPE}) diff --git a/base/MAPL_NewArthParser.F90 b/base/MAPL_NewArthParser.F90 index d714397803f5..878a22d41aca 100755 --- a/base/MAPL_NewArthParser.F90 +++ b/base/MAPL_NewArthParser.F90 @@ -53,6 +53,7 @@ MODULE MAPL_NewArthParserMod use ESMF use MAPL_BaseMod + use MAPL_Geom use MAPL_CommsMod use MAPL_ExceptionHandling use gFTL_StringVector @@ -117,6 +118,7 @@ MODULE MAPL_NewArthParserMod INTEGER :: ByteCodeSize REAL, DIMENSION(:), POINTER :: Immed => NULL() INTEGER :: ImmedSize + type(ESMF_Field), allocatable :: new_stack(:) TYPE(Ptrs_Type), DIMENSION(:), POINTER :: Stack => NULL() INTEGER :: StackSize, & StackPtr @@ -136,13 +138,13 @@ subroutine bytecode_dealloc(comp,rc) integer, optional, intent(out ) :: rc integer :: i - character(len=ESMF_MAXSTR), parameter :: Iam = "bytecode_dealloc" + integer :: status do i=1,comp%StackSize - if (associated(comp%stack(i)%Q2D)) deallocate(comp%Stack(i)%Q2D) - if (associated(comp%stack(i)%Q3D)) deallocate(comp%Stack(i)%Q3D) + call ESMF_FieldDestroy(comp%new_stack(i),noGarbage=.true.,_RC) end do deallocate(comp%Stack) + deallocate(comp%new_stack) deallocate(comp%ByteCode) deallocate(comp%Immed) _RETURN(ESMF_SUCCESS) @@ -164,37 +166,28 @@ subroutine MAPL_StateEval(state,expression,field,rc) type(tComp) :: pcode logical, allocatable :: needed(:) logical :: isConformal - character(len=ESMF_MAXSTR), parameter :: Iam="MAPL_StateEval" integer :: status - call ESMF_StateGet(state,ITEMCOUNT=varCount,rc=status) - _VERIFY(STATUS) + call ESMF_StateGet(state,ITEMCOUNT=varCount,_RC) allocate(fieldnames(varCount),needed(varCount)) - call ESMF_StateGet(state,itemnamelist=fieldNames,rc=status) - _VERIFY(STATUS) + call ESMF_StateGet(state,itemnamelist=fieldNames,_RC) ! confirm that each needed field is conformal - call CheckSyntax(expression,fieldNames,needed,rc=status) - _VERIFY(STATUS) + call CheckSyntax(expression,fieldNames,needed,_RC) do i=1,varCount if (needed(i)) then - call ESMF_StateGet(state,fieldNames(i),field=state_field,rc=status) - _VERIFY(STATUS) + call ESMF_StateGet(state,fieldNames(i),field=state_field,_RC) - isConformal = CheckIfConformal(field,state_field,rc=status) - _VERIFY(STATUS) + isConformal = FieldsAreBroadcastConformable(state_field,field,_RC) if (.not.isConformal) then _FAIL('needs informative message') end if end if end do - call parsef (pcode, expression, fieldNames, field, rc=status) - _VERIFY(STATUS) - call evalf(pcode,state,fieldNames,field,rc=status) - _VERIFY(STATUS) - call bytecode_dealloc(pcode,rc=status) - _VERIFY(STATUS) + call parsef (pcode, expression, fieldNames, field, _RC) + call evalf(pcode,state,fieldNames,field,_RC) + call bytecode_dealloc(pcode,_RC) deallocate(fieldNames,needed) @@ -213,16 +206,13 @@ SUBROUTINE parsef (Comp, FuncStr, Var, field, rc) INTEGER, OPTIONAL , INTENT(out ) :: rc CHARACTER(len=LEN(FuncStr)) :: Func - character(len=ESMF_MAXSTR), parameter :: Iam="parsef" integer :: status !----- -------- --------- --------- --------- --------- --------- --------- ------- - CALL CheckSyntax (FuncStr,Var,rc=status) - _VERIFY(STATUS) + CALL CheckSyntax (FuncStr,Var,_RC) Func = FuncStr ! Local copy of function string CALL Replace ('**','^ ',Func) ! Exponent into 1-Char. format CALL RemoveSpaces (Func) ! Condense function string - CALL Compile (comp,Func,Var,field,rc=status) ! Compile into bytecode - _VERIFY(STATUS) + CALL Compile (comp,Func,Var,field,_RC) ! Compile into bytecode _RETURN(ESMF_SUCCESS) END SUBROUTINE parsef ! @@ -241,7 +231,6 @@ SUBROUTINE evalf (Comp, State, FieldNames, ResField, rc) SP ! Stack pointer INTEGER :: CurrByte,ValNumber TYPE(ESMF_Field) :: state_field - character(len=ESMF_MAXSTR), parameter :: Iam="evalf" integer :: status !----- -------- --------- --------- --------- --------- --------- --------- ------- DP = 1 @@ -250,500 +239,98 @@ SUBROUTINE evalf (Comp, State, FieldNames, ResField, rc) CurrByte = Comp%ByteCode(IP) if (CurrByte == cImmed) then SP=SP+1 - call CopyScalarToField(Comp%Stack(SP),Comp%Immed(DP),rc=status) - _VERIFY(STATUS) + call FieldSet(comp%new_stack(sp),comp%immed(dp),_RC) DP=DP+1 end if if (CurrByte == cNeg) then - call UnaryFuncField(Comp%Stack(SP),CurrByte,rc=status) - _VERIFY(STATUS) + call FieldNegate(comp%new_stack(sp),_RC) end if if (CurrByte >= cAdd .and. CurrByte <= cPow) then - call ArthFieldToField(Comp%Stack(SP),Comp%Stack(SP-1),CurrByte,rc=status) - _VERIFY(STATUS) + call field_binary(Comp%new_stack(SP),Comp%new_stack(SP-1),CurrByte,_RC) SP=SP-1 end if if (CurrByte >= cAbs .and. CurrByte <= cHeav) then - call UnaryFuncField(Comp%Stack(SP),CurrByte,rc=status) - _VERIFY(STATUS) + call field_unary(comp%new_stack(sp),currByte,_RC) end if if (CurrByte > cHeav) then SP=SP+1 ValNumber = CurrByte-VarBegin+1 - call ESMF_StateGet(state,FieldNames(ValNumber),state_field,rc=status) - _VERIFY(STATUS) - call CopyFieldToPtr(state_field,Comp%Stack(SP),rc=status) - _VERIFY(STATUS) + call ESMF_StateGet(state,FieldNames(ValNumber),state_field,_RC) + call FieldCopyBroadcast(state_field,comp%new_stack(sp),_RC) end if END DO - call CopyPtrToField(Comp%Stack(1),ResField,rc=status) - _VERIFY(STATUS) + call FieldCopyBroadcast(comp%new_stack(1),ResField,_RC) _RETURN(ESMF_SUCCESS) END SUBROUTINE evalf - FUNCTION CheckIfConformal(field_1,field_2,rc) result(res) - TYPE(ESMF_Field), intent(inout) :: field_1 - TYPE(ESMF_Field), intent(inout) :: field_2 - integer, optional, intent(out ) :: rc - - logical :: res - - character(len=ESMF_MAXSTR), parameter :: Iam ="CheckIfConformal" - integer :: status - type(ESMF_Array) :: array_1,array_2 - type (ESMF_LocalArray), target :: larrayList(1) - type(ESMF_LocalArray), pointer :: larray_1,larray_2 - integer :: rank_1, rank_2 - integer :: lbnds_1(ESMF_MAXDIM), ubnds_1(ESMF_MAXDIM) - integer :: lbnds_2(ESMF_MAXDIM), ubnds_2(ESMF_MAXDIM) - integer :: i - - call ESMF_FieldGet(field_1,array=array_1,rc=status) - _VERIFY(STATUS) - call ESMF_ArrayGet(array_1, localarrayList=larrayList, rc=status) - _VERIFY(STATUS) - larray_1 => lArrayList(1) ! alias - call ESMF_LocalArrayGet(larray_1,rank=rank_1,totalLBound=lbnds_1,totalUBound=ubnds_1,rc=status) - _VERIFY(STATUS) - - call ESMF_FieldGet(field_2,array=array_2,rc=status) - _VERIFY(STATUS) - call ESMF_ArrayGet(array_2, localarrayList=larrayList, rc=status) - _VERIFY(STATUS) - larray_2 => lArrayList(1) ! alias - call ESMF_LocalArrayGet(larray_2,rank=rank_2,totalLBound=lbnds_2,totalUBound=ubnds_2,rc=status) - _VERIFY(STATUS) - - if (rank_1 == 2 .and. rank_2 == 2) then - do i=1,2 - if (lbnds_1(i) /= lbnds_2(i)) then - res = .false. - else if (ubnds_1(i) /= ubnds_2(i)) then - res = .false. - else - res = .true. - end if - end do - end if - if (rank_1 == 3 .and. rank_2 == 3) then - do i=1,3 - if (lbnds_1(i) /= lbnds_2(i)) then - res = .false. - else if (ubnds_1(i) /= ubnds_2(i)) then - res = .false. - else - res = .true. - end if - end do - end if - if (rank_1 == 3 .and. rank_2 == 2) then - do i=1,2 - if (lbnds_1(i) /= lbnds_2(i)) then - res = .false. - else if (ubnds_1(i) /= ubnds_2(i)) then - res = .false. - else - res = .true. - end if - end do - end if - if (rank_1 == 2 .and. rank_2 == 3) then - do i=1,2 - if (lbnds_1(i) /= lbnds_2(i)) then - res = .false. - else if (ubnds_1(i) /= ubnds_2(i)) then - res = .false. - else - res = .true. - end if - end do - end if - - _RETURN(ESMF_SUCCESS) - - END FUNCTION CheckIfConformal + subroutine field_binary(field1,field2,arthcode,rc) + type(ESMF_Field), intent(inout) :: field1 + type(ESMF_Field), intent(inout) :: field2 + integer, intent(in) :: arthcode + integer, optional, intent(out) :: rc - SUBROUTINE CopyFieldtoPtr(field,ptrs,rc) - ! take data from input field and copy to output field - ! if input is 2D and output is 3D replicate 2D on each slice of 3D - TYPE(ESMF_Field), intent(inout) :: field - TYPE(Ptrs_Type), intent(inout) :: ptrs - integer, optional, intent(out ) :: rc - - real, pointer :: var2d(:,:), var3d(:,:,:) - - type(ESMF_Array) :: array - integer :: rank - character(len=ESMF_MAXSTR), parameter :: Iam="CopyFieldtoField" integer :: status - integer :: i - - call ESMF_FieldGet(field,array=array,rc=status) - _VERIFY(STATUS) - call ESMF_ArrayGet(array,rank=rank,rc=status) - _VERIFY(STATUS) - if (rank == 3 .and. ptrs%rank ==3) then - call ESMF_FieldGet(field,0,var3d,rc=status) - _VERIFY(STATUS) - ptrs%Q3D=var3d - else if (rank == 2 .and. ptrs%rank ==2) then - call ESMF_FieldGet(field,0,var2d,rc=status) - _VERIFY(STATUS) - ptrs%Q2D=var2d - else if (rank == 2 .and. ptrs%rank ==3) then - call ESMF_FieldGet(field,0,var2d,rc=status) - _VERIFY(STATUS) - do i=ptrs%lb(3),ptrs%ub(3) - ptrs%Q3D(:,:,i)=var2d - end do - end if - _RETURN(ESMF_SUCCESS) - - END SUBROUTINE CopyFieldToPtr - - SUBROUTINE CopyPtrtoField(ptrs,field,rc) - ! take data from input field and copy to output field - ! if input is 2D and output is 3D replicate 2D on each slice of 3D - TYPE(ESMF_Field), intent(inout) :: field - TYPE(Ptrs_Type), intent(inout) :: ptrs - integer, optional, intent(out ) :: rc - - real, pointer :: var2d(:,:), var3d(:,:,:) - - type(ESMF_Array) :: array - integer :: rank - character(len=ESMF_MAXSTR), parameter :: Iam="CopyFieldtoField" - integer :: status - - call ESMF_FieldGet(field,array=array,rc=status) - _VERIFY(STATUS) - call ESMF_ArrayGet(array,rank=rank,rc=status) - _VERIFY(STATUS) - if (rank == 3 .and. ptrs%rank ==3) then - call ESMF_FieldGet(field,0,var3d,rc=status) - _VERIFY(STATUS) - var3d=ptrs%Q3D - else if (rank == 2 .and. ptrs%rank ==2) then - call ESMF_FieldGet(field,0,var2d,rc=status) - _VERIFY(STATUS) - var2d=ptrs%Q2D - end if - _RETURN(ESMF_SUCCESS) - - END SUBROUTINE CopyPtrToField - - - SUBROUTINE ArthFieldToField(ptrs_1,ptrs_2,arthcode,rc) - ! perform arthimetic operation indicated by input code between field_1 and field_2 - ! result will overwrite data in field_2 - TYPE(Ptrs_Type), intent(inout) :: ptrs_1 - TYPE(Ptrs_Type), intent(inout) :: ptrs_2 - integer, intent(in ) :: arthcode - integer, optional, intent(out ) :: rc - Character(len=ESMF_MAXSTR), parameter :: Iam="ArthFieldToField" - - if (ptrs_1%rank == 3 .and. ptrs_2%rank ==3) then - select case(arthcode) - case(cAdd) - where(ptrs_1%Q3D /= MAPL_UNDEF .and. ptrs_2%Q3D /= MAPL_UNDEF) - ptrs_2%Q3D = ptrs_2%Q3D + ptrs_1%Q3D - else where - ptrs_2%Q3D = MAPL_UNDEF - end where - case(cSub) - where(ptrs_1%Q3D /= MAPL_UNDEF .and. ptrs_2%Q3D /= MAPL_UNDEF) - ptrs_2%Q3D = ptrs_2%Q3D - ptrs_1%Q3D - else where - ptrs_2%Q3D = MAPL_UNDEF - end where - case(cMul) - where(ptrs_1%Q3D /= MAPL_UNDEF .and. ptrs_2%Q3D /= MAPL_UNDEF) - ptrs_2%Q3D = ptrs_2%Q3D * ptrs_1%Q3D - else where - ptrs_2%Q3D = MAPL_UNDEF - end where - case(cDiv) - where(ptrs_1%Q3D /= MAPL_UNDEF .and. ptrs_2%Q3D /= MAPL_UNDEF) - ptrs_2%Q3D = ptrs_2%Q3D / ptrs_1%Q3D - else where - ptrs_2%Q3D = MAPL_UNDEF - end where - case(cPow) - where(ptrs_1%Q3D /= MAPL_UNDEF .and. ptrs_2%Q3D /= MAPL_UNDEF) - ptrs_2%Q3D = ptrs_2%Q3D ** ptrs_1%Q3D - else where - ptrs_2%Q3D = MAPL_UNDEF - end where - end select - else if (ptrs_1%rank == 2 .and. ptrs_2%rank ==2) then - select case(arthcode) - case(cAdd) - where(ptrs_1%Q2D /= MAPL_UNDEF .and. ptrs_2%Q2D /= MAPL_UNDEF) - ptrs_2%Q2D = ptrs_2%Q2D + ptrs_1%Q2D - else where - ptrs_2%Q2D = MAPL_UNDEF - end where - case(cSub) - where(ptrs_1%Q2D /= MAPL_UNDEF .and. ptrs_2%Q2D /= MAPL_UNDEF) - ptrs_2%Q2D = ptrs_2%Q2D - ptrs_1%Q2D - else where - ptrs_2%Q2D = MAPL_UNDEF - end where - case(cMul) - where(ptrs_1%Q2D /= MAPL_UNDEF .and. ptrs_2%Q2D /= MAPL_UNDEF) - ptrs_2%Q2D = ptrs_2%Q2D * ptrs_1%Q2D - else where - ptrs_2%Q2D = MAPL_UNDEF - end where - case(cDiv) - where(ptrs_1%Q2D /= MAPL_UNDEF .and. ptrs_2%Q2D /= MAPL_UNDEF) - ptrs_2%Q2D = ptrs_2%Q2D / ptrs_1%Q2D - else where - ptrs_2%Q2D = MAPL_UNDEF - end where - case(cPow) - where(ptrs_1%Q2D /= MAPL_UNDEF .and. ptrs_2%Q2D /= MAPL_UNDEF) - ptrs_2%Q2D = ptrs_2%Q2D ** ptrs_1%Q2D - else where - ptrs_2%Q2D = MAPL_UNDEF - end where - end select -! maybe put in 2d + 3d, not needed for now - end if - _RETURN(ESMF_SUCCESS) - - END SUBROUTINE ArthFieldToField - - SUBROUTINE UnaryFuncField(ptrs,funcCode,rc) - ! perform arthimetic operation indicated by input code between field_1 and field_2 - ! result will overwrite data in field_2 - TYPE(ptrs_type), intent(inout) :: ptrs + select case(arthcode) + case(cAdd) + call FieldAdd(field2,field2,field1,_RC) + case(cSub) + call FieldSubtract(field2,field2,field1,_RC) + case(cMul) + call FieldMultiply(field2,field2,field1,_RC) + case(cDiv) + call FieldDivide(field2,field2,field1,_RC) + case(cPow) + call FieldPower(field2,field2,field1,_RC) + end select + _RETURN(_SUCCESS) + end subroutine field_binary + + subroutine field_unary(field,funcCode,rc) + type(ESMF_Field), intent(inout) :: field integer, intent(in ) :: funcCode integer, optional, intent(out ) :: rc - character(len=ESMF_MAXSTR), parameter :: Iam="UnaryFuncField" - - if (ptrs%rank == 3) then - select case(funcCode) - case(cNeg) - where(ptrs%Q3D /= MAPL_UNDEF) - ptrs%Q3D = -ptrs%Q3D - else where - ptrs%Q3D = MAPL_UNDEF - end where - case(cAbs) - where(ptrs%Q3D /= MAPL_UNDEF) - ptrs%Q3D = abs(ptrs%Q3D) - else where - ptrs%Q3D = MAPL_UNDEF - end where - case(cExp) - where(ptrs%Q3D /= MAPL_UNDEF) - ptrs%Q3D = exp(ptrs%Q3D) - else where - ptrs%Q3D = MAPL_UNDEF - end where - case(cLog10) - where(ptrs%Q3D /= MAPL_UNDEF) - ptrs%Q3D = log10(ptrs%Q3D) - else where - ptrs%Q3D = MAPL_UNDEF - end where - case(cLog) - where(ptrs%Q3D /= MAPL_UNDEF) - ptrs%Q3D = log(ptrs%Q3D) - else where - ptrs%Q3D = MAPL_UNDEF - end where - case(cSqrt) - where(ptrs%Q3D /= MAPL_UNDEF) - ptrs%Q3D = sqrt(ptrs%Q3D) - else where - ptrs%Q3D = MAPL_UNDEF - end where - case(cSinh) - where(ptrs%Q3D /= MAPL_UNDEF) - ptrs%Q3D = sinh(ptrs%Q3D) - else where - ptrs%Q3D = MAPL_UNDEF - end where - case(cCosh) - where(ptrs%Q3D /= MAPL_UNDEF) - ptrs%Q3D = cosh(ptrs%Q3D) - else where - ptrs%Q3D = MAPL_UNDEF - end where - case(cTanh) - where(ptrs%Q3D /= MAPL_UNDEF) - ptrs%Q3D = tanh(ptrs%Q3D) - else where - ptrs%Q3D = MAPL_UNDEF - end where - case(cSin) - where(ptrs%Q3D /= MAPL_UNDEF) - ptrs%Q3D = sin(ptrs%Q3D) - else where - ptrs%Q3D = MAPL_UNDEF - end where - case(cCos) - where(ptrs%Q3D /= MAPL_UNDEF) - ptrs%Q3D = cos(ptrs%Q3D) - else where - ptrs%Q3D = MAPL_UNDEF - end where - case(cTan) - where(ptrs%Q3D /= MAPL_UNDEF) - ptrs%Q3D = tan(ptrs%Q3D) - else where - ptrs%Q3D = MAPL_UNDEF - end where - case(cAsin) - where(ptrs%Q3D /= MAPL_UNDEF) - ptrs%Q3D = asin(ptrs%Q3D) - else where - ptrs%Q3D = MAPL_UNDEF - end where - case(cAcos) - where(ptrs%Q3D /= MAPL_UNDEF) - ptrs%Q3D = acos(ptrs%Q3D) - else where - ptrs%Q3D = MAPL_UNDEF - end where - case(cAtan) - where(ptrs%Q3D /= MAPL_UNDEF) - ptrs%Q3D = atan(ptrs%Q3D) - else where - ptrs%Q3D = MAPL_UNDEF - end where - case(cHeav) - where(ptrs%Q3D /= MAPL_UNDEF) - ptrs%Q3D = Heav3D(ptrs%Q3D) - else where - ptrs%Q3D = MAPL_UNDEF - end where - end select - else if (ptrs%rank == 2) then - select case(funcCode) - case(cNeg) - where(ptrs%Q2D /= MAPL_UNDEF) - ptrs%Q2D = -ptrs%Q2D - else where - ptrs%Q2D = MAPL_UNDEF - end where - case(cAbs) - where(ptrs%Q2D /= MAPL_UNDEF) - ptrs%Q2D = abs(ptrs%Q2D) - else where - ptrs%Q2D = MAPL_UNDEF - end where - case(cExp) - where(ptrs%Q2D /= MAPL_UNDEF) - ptrs%Q2D = exp(ptrs%Q2D) - else where - ptrs%Q2D = MAPL_UNDEF - end where - case(cLog10) - where(ptrs%Q2D /= MAPL_UNDEF) - ptrs%Q2D = log10(ptrs%Q2D) - else where - ptrs%Q2D = MAPL_UNDEF - end where - case(cLog) - where(ptrs%Q2D /= MAPL_UNDEF) - ptrs%Q2D = log(ptrs%Q2D) - else where - ptrs%Q2D = MAPL_UNDEF - end where - case(cSqrt) - where(ptrs%Q2D /= MAPL_UNDEF) - ptrs%Q2D = sqrt(ptrs%Q2D) - else where - ptrs%Q2D = MAPL_UNDEF - end where - case(cSinh) - where(ptrs%Q2D /= MAPL_UNDEF) - ptrs%Q2D = sinh(ptrs%Q2D) - else where - ptrs%Q2D = MAPL_UNDEF - end where - case(cCosh) - where(ptrs%Q2D /= MAPL_UNDEF) - ptrs%Q2D = cosh(ptrs%Q2D) - else where - ptrs%Q2D = MAPL_UNDEF - end where - case(cTanh) - where(ptrs%Q2D /= MAPL_UNDEF) - ptrs%Q2D = tanh(ptrs%Q2D) - else where - ptrs%Q2D = MAPL_UNDEF - end where - case(cSin) - where(ptrs%Q2D /= MAPL_UNDEF) - ptrs%Q2D = sin(ptrs%Q2D) - else where - ptrs%Q2D = MAPL_UNDEF - end where - case(cCos) - where(ptrs%Q2D /= MAPL_UNDEF) - ptrs%Q2D = cos(ptrs%Q2D) - else where - ptrs%Q2D = MAPL_UNDEF - end where - case(cTan) - where(ptrs%Q2D /= MAPL_UNDEF) - ptrs%Q2D = tan(ptrs%Q2D) - else where - ptrs%Q2D = MAPL_UNDEF - end where - case(cAsin) - where(ptrs%Q2D /= MAPL_UNDEF) - ptrs%Q2D = asin(ptrs%Q2D) - else where - ptrs%Q2D = MAPL_UNDEF - end where - case(cAcos) - where(ptrs%Q2D /= MAPL_UNDEF) - ptrs%Q2D = acos(ptrs%Q2D) - else where - ptrs%Q2D = MAPL_UNDEF - end where - case(cAtan) - where(ptrs%Q2D /= MAPL_UNDEF) - ptrs%Q2D = atan(ptrs%Q2D) - else where - ptrs%Q2D = MAPL_UNDEF - end where - case(cHeav) - where(ptrs%Q2D /= MAPL_UNDEF) - ptrs%Q2D = Heav2D(ptrs%Q2D) - else where - ptrs%Q2D = MAPL_UNDEF - end where - end select - end if - _RETURN(ESMF_SUCCESS) - - END SUBROUTINE UnaryFuncField - - SUBROUTINE CopyScalarToField(ptrs,rn,rc) - ! copy a scalar to ESMF field - TYPE(Ptrs_Type), intent(inout) :: ptrs - real, intent(in ) :: rn - integer, optional, intent(out ) :: rc - - character(len=ESMF_MAXSTR), parameter :: Iam="CopyScalarToField" + integer :: status - if (ptrs%rank == 2) then - ptrs%Q2D=rn - else if (ptrs%rank == 3) then - ptrs%Q3D=rn - end if - _RETURN(ESMF_SUCCESS) + select case(funcCode) + case(cNeg) + call FieldNegate(field,_RC) + case(cAbs) + call FieldAbs(field,field,_RC) + case(cExp) + call FieldExp(field,field,_RC) + case(cLog10) + call FieldLog10(field,field,_RC) + case(cLog) + call FieldLog(field,field,_RC) + case(cSqrt) + call FieldSqrt(field,field,_RC) + case(cSinh) + call FieldSinh(field,field,_RC) + case(cCosh) + call FieldCosh(field,field,_RC) + case(cTanh) + call FieldTanh(field,field,_RC) + case(cSin) + call FieldSin(field,field,_RC) + case(cCos) + call FieldCos(field,field,_RC) + case(cTan) + call FieldTan(field,field,_RC) + case(cAsin) + call FieldAsin(field,field,_RC) + case(cAcos) + call FieldAcos(field,field,_RC) + case(cAtan) + call FieldAtan(field,field,_RC) + case(cHeav) + _FAIL("heaviside needs implementation") + end select + + _RETURN(_SUCCESS) + end subroutine field_unary - END SUBROUTINE CopyScalarToField - ! function parser_variables_in_expression (FuncStr,rc) result(variables_in_expression) !----- -------- --------- --------- --------- --------- --------- --------- ------- ! Check syntax of function string, returns 0 if syntax is ok @@ -761,7 +348,6 @@ function parser_variables_in_expression (FuncStr,rc) result(variables_in_express LOGICAL :: isUndef character(len=ESMF_MAXPATHLEN) :: func integer, allocatable :: ipos(:) - character(len=ESMF_MAXSTR), parameter :: IAm="CheckSyntax" !----- -------- --------- --------- --------- --------- --------- --------- ------- Func = FuncStr ! Local copy of function string ALLOCATE (ipos(LEN_TRIM(FuncStr))) @@ -882,7 +468,6 @@ SUBROUTINE CheckSyntax (FuncStr,Var,needed,ExtVar,rc) LOGICAL :: isUndef character(len=ESMF_MAXPATHLEN) :: func integer, allocatable :: ipos(:) - character(len=ESMF_MAXSTR), parameter :: IAm="CheckSyntax" !----- -------- --------- --------- --------- --------- --------- --------- ------- Func = FuncStr ! Local copy of function string ALLOCATE (ipos(LEN_TRIM(FuncStr))) @@ -1194,7 +779,6 @@ SUBROUTINE Compile (Comp, F, Var, field, rc) INTEGER :: ResRank INTEGER :: lb(ESMF_MAXDIM) INTEGER :: ub(ESMF_MAXDIM) - character(len=ESMF_MAXSTR), parameter :: Iam = "Compile" integer :: status !----- -------- --------- --------- --------- --------- --------- --------- ------- IF (ASSOCIATED(Comp%ByteCode)) DEALLOCATE ( Comp%ByteCode, & @@ -1208,24 +792,12 @@ SUBROUTINE Compile (Comp, F, Var, field, rc) ALLOCATE ( Comp%ByteCode(Comp%ByteCodeSize), & Comp%Immed(Comp%ImmedSize), & Comp%Stack(Comp%StackSize), & + Comp%new_stack(comp%stackSize), & STAT = istat ) - call ESMF_FieldGet(field,array=array,rc=status) - _VERIFY(STATUS) - call ESMF_ArrayGet(array,localarrayList=larrayList,rc=status) - _VERIFY(STATUS) - lArray => lArrayList(1) - call ESMF_LocalArrayGet(larray,rank=ResRank,totallbound=lb,totalubound=ub,rc=status) - _VERIFY(STATUS) DO i=1,Comp%StackSize - Comp%Stack(i)%rank = ResRank - Comp%Stack(i)%lb = lb - Comp%Stack(i)%ub = ub - IF (ResRank == 2) then - allocate(Comp%Stack(i)%Q2D(lb(1):ub(1),lb(2):ub(2)) ) - ELSE IF (ResRank == 3) then - allocate(Comp%Stack(i)%Q3D(lb(1):ub(1),lb(2):ub(2),lb(3):ub(3)) ) - END IF + call FieldClone(field,comp%new_stack(i),_RC) + call ESMF_AttributeSet(field,name="missing_value",value=MAPL_UNDEF,_RC) END DO Comp%ByteCodeSize = 0 diff --git a/geom/FieldBinaryOperations.F90 b/geom/FieldBinaryOperations.F90 index c675f0e5a908..3b4bbff8f706 100644 --- a/geom/FieldBinaryOperations.F90 +++ b/geom/FieldBinaryOperations.F90 @@ -12,6 +12,7 @@ module MAPL_FieldBinaryOperations public fieldSubtract public fieldDivide public fieldMultiply + public fieldPower contains @@ -39,4 +40,10 @@ module MAPL_FieldBinaryOperations #undef _OP #undef _FUNC +#define _OP ** +#define _FUNC Power +#include "FieldBinaryOperatorTemplate.H" +#undef _OP +#undef _FUNC + end module MAPL_FieldBinaryOperations diff --git a/geom/FieldBinaryOperatorTemplate.H b/geom/FieldBinaryOperatorTemplate.H index 4bae5cc5fb03..765f28b7263e 100644 --- a/geom/FieldBinaryOperatorTemplate.H +++ b/geom/FieldBinaryOperatorTemplate.H @@ -39,12 +39,12 @@ if (has_undef) then call GetFieldsUndef(fields,undef_r4,_RC) where( (ptr1_r4 /= undef_r4(1)) .and. (ptr2_r4 /= undef_r4(2)) ) - ptr1_r4 = ptr1_r4 _OP ptr2_r4 + ptr_out_r4 = ptr1_r4 _OP ptr2_r4 elsewhere - ptr1_r4 = undef_r4(3) + ptr_out_r4 = undef_r4(3) end where else - ptr1_r4 = ptr1_r4 _OP ptr2_r4 + ptr_out_r4 = ptr1_r4 _OP ptr2_r4 end if else if (tk_A == ESMF_TypeKind_R8) then call assign_fptr(field_a,ptr1_r8,_RC) @@ -53,12 +53,12 @@ if (has_undef) then call GetFieldsUndef(fields,undef_r8,_RC) where( (ptr1_r8 /= undef_r8(1)) .and. (ptr2_r8 /= undef_r8(2)) ) - ptr1_r8 = ptr1_r8 _OP ptr2_r8 + ptr_out_r8 = ptr1_r8 _OP ptr2_r8 else where - ptr1_r8 = undef_r8(3) + ptr_out_r8 = undef_r8(3) endwhere else - ptr1_r8 = ptr1_r8 _OP ptr2_r8 + ptr_out_r8 = ptr1_r8 _OP ptr2_r8 end if else _FAIL("unsupported type") diff --git a/geom/FieldPointerUtilities.F90 b/geom/FieldPointerUtilities.F90 index 4e40762e6172..41ca1bcbfed0 100644 --- a/geom/FieldPointerUtilities.F90 +++ b/geom/FieldPointerUtilities.F90 @@ -363,25 +363,29 @@ subroutine clone(x, y, rc) integer, optional, intent(out) :: rc character(len=*), parameter :: CLONE_TAG = '_clone' - type(ESMF_ArraySpec) :: arrayspec + !type(ESMF_ArraySpec) :: arrayspec type(ESMF_Grid) :: grid type(ESMF_StaggerLoc) :: staggerloc integer, allocatable :: gridToFieldMap(:) integer, allocatable :: ungriddedLBound(:) integer, allocatable :: ungriddedUBound(:) - integer, allocatable :: totalLWidth(:,:) - integer, allocatable :: totalUWidth(:,:) + type(ESMF_TypeKind_Flag) :: tk character(len=:), allocatable :: name integer :: status - - call ESMF_FieldGet(x, arrayspec=arrayspec, grid=grid, & + integer :: field_rank, grid_rank,ungrid_size + + call ESMF_FieldGet(x,grid=grid,rank=field_rank,_RC) + call ESMF_GridGet(grid,dimCount=grid_rank,_RC) + ungrid_size = field_rank-grid_rank + allocate(gridToFieldMap(grid_rank)) + allocate(ungriddedLBound(ungrid_size),ungriddedUBound(ungrid_size)) + call ESMF_FieldGet(x, typekind=tk, & staggerloc=staggerloc, gridToFieldMap=gridToFieldMap, & - ungriddedLBound=ungriddedLBound, ungriddedUBound=ungriddedUBound, & - totalLWidth=totalLWidth, totalUWidth=totalUWidth, _RC) + ungriddedLBound=ungriddedLBound, ungriddedUBound=ungriddedUBound, _RC) name = name // CLONE_TAG - y = ESMF_FieldCreate(grid, arrayspec, staggerloc=staggerloc, & + y = ESMF_FieldCreate(grid, typekind=tk, staggerloc=staggerloc, & gridToFieldMap=gridToFieldMap, ungriddedLBound=ungriddedLBound, & ungriddedUBound=ungriddedUBound, name=name, _RC) @@ -439,12 +443,19 @@ logical function are_broadcast_conformable(x, y, rc) result(conformable) integer :: rank_x, rank_y integer, dimension(:), allocatable :: count_x, count_y integer :: status + logical :: normal_conformable + conformable = .false. ! this should really used the geom and ungridded dims ! for now we will do this until we have a geom agnostic stuff worked out... ! the ideal algorithm would be if geom == geom and input does not have ungridded ! and thing we are copying to does, then we are "conformable" - conformable = .false. + normal_conformable = FIeldsAreConformable(x,y,_RC) + + if (normal_conformable) then + conformable = .true. + _RETURN(_SUCCESS) + end if call ESMF_FieldGet(x, rank=rank_x, _RC) call ESMF_FieldGet(y, rank=rank_y, _RC) @@ -540,7 +551,7 @@ subroutine copy_broadcast(x, y, rc) _RETURN(_SUCCESS) end if broadcast = FieldsAreBroadcastConformable(x,y) - _ASSERT(broadcast, 'FieldCopy() - fields not be broadcast.') + _ASSERT(broadcast, 'FieldCopy() - field can not be broadcast.') call MAPL_FieldGetLocalElementCount(x,x_shape,_RC) call MAPL_FieldGetLocalElementCount(y,y_shape,_RC) diff --git a/geom/tests/Test_FieldArithmetic.pf b/geom/tests/Test_FieldArithmetic.pf index 84d63e1c6f61..a0325a702a98 100644 --- a/geom/tests/Test_FieldArithmetic.pf +++ b/geom/tests/Test_FieldArithmetic.pf @@ -62,8 +62,8 @@ contains y_ptr = 3.0 result_array = x_ptr result_array = 5.0 - call FieldAdd(x, x, y, _RC) - @assertEqual(x_ptr, result_array) + call FieldAdd(y, x, y, _RC) + @assertEqual(y_ptr, result_array) end subroutine test_FieldAddR4 @Test @@ -83,8 +83,8 @@ contains y_ptr = reshape(source=[undef,3.0,3.0,undef],shape=[2,2]) result_array = x_ptr result_array = reshape(source=[undef,5.0,5.0,undef],shape=[2,2]) - call FieldAdd(x, x, y, _RC) - @assertEqual(x_ptr, result_array) + call FieldAdd(y, x, y, _RC) + @assertEqual(y_ptr, result_array) end subroutine test_FieldAddR4_missing @Test @@ -104,8 +104,8 @@ contains y_ptr = 3.d0 result_array = x_ptr result_array = 5.d0 - call FieldAdd(x, x, y, _RC) - @assertEqual(x_ptr, result_array) + call FieldAdd(y, x, y, _RC) + @assertEqual(y_ptr, result_array) end subroutine test_FieldAddR8 @Test diff --git a/geom/tests/Test_FieldBLAS.pf b/geom/tests/Test_FieldBLAS.pf index 7cb31c63a202..df6fcb90f59d 100644 --- a/geom/tests/Test_FieldBLAS.pf +++ b/geom/tests/Test_FieldBLAS.pf @@ -342,23 +342,40 @@ contains !@Test !wdb fixme not done yet - subroutine test_FieldClone() + subroutine test_FieldClone3D() type(ESMF_Field) :: x, y integer :: status, rc -! type(ESMF_ArraySpec) :: arrayspec -! type(ESMF_Grid) :: grid -! type(ESMF_StaggerLoc) :: staggerloc -! integer, allocatable :: gridToFieldMap(:) -! integer, allocatable :: ungriddedLBound(:) -! integer, allocatable :: ungriddedUBound(:) -! integer, allocatable :: totalLWidth(:,:) -! integer, allocatable :: totalUWidth(:,:) + type(ESMF_TypeKind_Flag) :: tk_x,tk_y + type(ESMF_Grid) :: grid + integer, allocatable :: ungriddedLBound_x(:),ungriddedLBound_y(:) + integer, allocatable :: ungriddedUBound_x(:),ungriddedUBound_y(:) + integer :: grid_rank_x, grid_rank_y + integer :: field_rank_x, field_rank_y + integer :: ungrid_x,ungrid_y + + x = XR4_3D + + call ESMF_FieldGet(x,rank=field_rank_x,grid=grid,typekind=tk_x,_RC) + call ESMF_GridGet(grid,dimCount=grid_rank_x) + ungrid_x = field_rank_x - grid_rank_x + allocate(ungriddedLBound_x(ungrid_x),ungriddedUBound_x(ungrid_x)) + call ESMF_FieldGet(x,ungriddedLBound=UngriddedLBound_x,ungriddedUBound=UngriddedUBound_x,_RC) - x = XR4 call FieldClone(x, y, _RC) - end subroutine test_FieldClone + call ESMF_FieldGet(y,rank=field_rank_y,grid=grid,typekind=tk_y,_RC) + call ESMF_GridGet(grid,dimCount=grid_rank_y) + ungrid_y = field_rank_y - grid_rank_y + allocate(ungriddedLBound_y(ungrid_y),ungriddedUBound_y(ungrid_y)) + call ESMF_FieldGet(y,ungriddedLBound=UngriddedLBound_y,ungriddedUBound=UngriddedUBound_y,_RC) + @assertEqual(field_rank_x,field_rank_y) + @assertEqual(ungrid_x,ungrid_y) + @assertTrue(tk_x==tk_y,"kinds not equal") + @assertEqual(ungriddedLBound_x,ungriddedLBound_y) + @assertEqual(ungriddedUBound_x,ungriddedUBound_y) + + end subroutine test_FieldClone3D @Test subroutine test_almost_equal_scalar() From 9294138e35f9ad30c32fdc31bec842b3fe85cb9f Mon Sep 17 00:00:00 2001 From: Benjamin Auer Date: Fri, 16 Jun 2023 14:37:50 -0400 Subject: [PATCH 2/5] update changelog --- CHANGELOG.md | 1 + 1 file changed, 1 insertion(+) diff --git a/CHANGELOG.md b/CHANGELOG.md index 204e7eea15d4..4c8a40b6d2d6 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -10,6 +10,7 @@ and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0 ### Added - Added field utilities to perform basic numeric operations on fields +- Update arithemetic parser to work with any rank and type of ESMF fields ### Changed From df5af75868b267ac8a1366cca50bf0935d67c587 Mon Sep 17 00:00:00 2001 From: Benjamin Auer Date: Fri, 16 Jun 2023 15:17:21 -0400 Subject: [PATCH 3/5] get clone test working --- geom/tests/Test_FieldBLAS.pf | 7 +++++-- geom/tests/geom_setup.F90 | 39 +++++++++++++++++++++++++++--------- 2 files changed, 34 insertions(+), 12 deletions(-) diff --git a/geom/tests/Test_FieldBLAS.pf b/geom/tests/Test_FieldBLAS.pf index df6fcb90f59d..a117273fa507 100644 --- a/geom/tests/Test_FieldBLAS.pf +++ b/geom/tests/Test_FieldBLAS.pf @@ -36,6 +36,10 @@ contains indexflag=INDEX_FLAG_DEFAULT, name = 'XR8', _RC) YR8 = mk_field(y8array, regDecomp=REG_DECOMP_DEFAULT, minIndex=MIN_INDEX_DEFAULT, maxIndex=MAX_INDEX_DEFAULT, & indexflag=INDEX_FLAG_DEFAULT, name = 'YR8', _RC) + XR4_3D = mk_field_r4_ungrid(regDecomp=REG_DECOMP_DEFAULT, minIndex=MIN_INDEX_DEFAULT, maxIndex=MAX_INDEX_DEFAULT, & + indexflag=INDEX_FLAG_DEFAULT, name = 'XR4_3D', ungriddedLBound=[1],ungriddedUBound=[3],_RC) + YR4_3D = mk_field_r4_ungrid(regDecomp=REG_DECOMP_DEFAULT, minIndex=MIN_INDEX_DEFAULT, maxIndex=MAX_INDEX_DEFAULT, & + indexflag=INDEX_FLAG_DEFAULT, name = 'YR4_3D',ungriddedLBound=[1],ungriddedUBound=[3], _RC) end subroutine set_up_data @@ -340,8 +344,7 @@ contains end subroutine test_FieldConvertPrec_R4R8 - !@Test - !wdb fixme not done yet + @Test subroutine test_FieldClone3D() type(ESMF_Field) :: x, y integer :: status, rc diff --git a/geom/tests/geom_setup.F90 b/geom/tests/geom_setup.F90 index 957925beca16..e43f6b43c7ad 100644 --- a/geom/tests/geom_setup.F90 +++ b/geom/tests/geom_setup.F90 @@ -9,8 +9,8 @@ module geom_setup implicit none interface mk_field - module procedure mk_field_r4 - module procedure mk_field_r8 + module procedure mk_field_r4_2d + module procedure mk_field_r8_2d end interface mk_field interface initialize_array @@ -60,9 +60,27 @@ function mk_grid(regDecomp, minIndex, maxIndex, indexflag, grid_name, rc) result _RETURN(_SUCCESS) end function mk_grid + + function mk_field_r4_ungrid(regDecomp, minIndex, maxIndex, indexflag, name, ungriddedLBound, ungriddedUBound, rc) result(field) + integer, dimension(:), intent(in) :: regDecomp + integer, dimension(:), intent(in) :: minIndex + integer, dimension(:), intent(in) :: maxIndex + type(ESMF_Index_Flag), intent(in) :: indexflag + character(len=*), intent(in) :: name + integer, optional, intent(in) :: ungriddedLBound(:) + integer, optional, intent(in) :: ungriddedUBound(:) + integer, optional, intent(out) :: rc + + type(ESMF_Field) :: field + + integer :: status + + field = mk_field_common(tk = ESMF_TYPEKIND_R4, regDecomp=regDecomp, minIndex=minIndex, maxIndex=maxIndex, indexflag = indexflag, name = name, ungriddedLBound=ungriddedLBound, ungriddedUBound=ungriddedUBound, _RC) + + _RETURN(_SUCCESS) + end function mk_field_r4_ungrid - ! MAKE FIELD FOR REAL(KIND=ESMF_KIND_R4) - function mk_field_r4(farray, regDecomp, minIndex, maxIndex, indexflag, name, rc) result(field) + function mk_field_r4_2d(farray, regDecomp, minIndex, maxIndex, indexflag, name, rc) result(field) real(kind=ESMF_KIND_R4), dimension(:,:), target, intent(in) :: farray integer, dimension(:), intent(in) :: regDecomp integer, dimension(:), intent(in) :: minIndex @@ -81,10 +99,9 @@ function mk_field_r4(farray, regDecomp, minIndex, maxIndex, indexflag, name, rc) ptr => farray _RETURN(_SUCCESS) - end function mk_field_r4 + end function mk_field_r4_2d - ! MAKE FIELD FOR REAL(KIND=ESMF_KIND_R8) - function mk_field_r8(farray, regDecomp, minIndex, maxIndex, indexflag, name, rc) result(field) + function mk_field_r8_2d(farray, regDecomp, minIndex, maxIndex, indexflag, name, rc) result(field) real(kind=ESMF_KIND_R8), dimension(:,:), target, intent(in) :: farray integer, dimension(:), intent(in) :: regDecomp integer, dimension(:), intent(in) :: minIndex @@ -103,15 +120,17 @@ function mk_field_r8(farray, regDecomp, minIndex, maxIndex, indexflag, name, rc) ptr => farray _RETURN(_SUCCESS) - end function mk_field_r8 + end function mk_field_r8_2d - function mk_field_common(tk, regDecomp, minIndex, maxIndex, indexflag, name, rc) result(field) + function mk_field_common(tk, regDecomp, minIndex, maxIndex, indexflag, name, ungriddedLBound, ungriddedUBound, rc) result(field) type(ESMF_TypeKind_Flag), intent(in) :: tk integer, dimension(:), intent(in) :: regDecomp integer, dimension(:), intent(in) :: minIndex integer, dimension(:), intent(in) :: maxIndex type(ESMF_Index_Flag), intent(in) :: indexflag character(len=*), intent(in) :: name + integer, optional, intent(in) :: ungriddedLBound(:) + integer, optional, intent(in) :: ungriddedUBound(:) integer, optional, intent(out) :: rc character(len=*), parameter :: GRID_SUFFIX = '_grid' character(len=*), parameter :: FIELD_SUFFIX = '_field' @@ -121,7 +140,7 @@ function mk_field_common(tk, regDecomp, minIndex, maxIndex, indexflag, name, rc) integer :: status grid = mk_grid(regDecomp=regDecomp, minIndex=minIndex, maxIndex=maxIndex, indexflag = indexflag, grid_name = name // GRID_SUFFIX, _RC) - field = ESMF_FieldCreate(grid, typekind = tk, name = name // FIELD_SUFFIX, _RC) + field = ESMF_FieldCreate(grid, typekind = tk, name = name // FIELD_SUFFIX, ungriddedLBound = ungriddedLBound, ungriddedUBound = ungriddedUBound, _RC) _RETURN(_SUCCESS) end function mk_field_common From 3f5cb5fc2de9c6694ed49836fadb19e793142b54 Mon Sep 17 00:00:00 2001 From: Benjamin Auer Date: Fri, 16 Jun 2023 15:49:22 -0400 Subject: [PATCH 4/5] remove unused code in arth parser after refactoring --- base/MAPL_NewArthParser.F90 | 41 +++++++++++-------------------------- 1 file changed, 12 insertions(+), 29 deletions(-) diff --git a/base/MAPL_NewArthParser.F90 b/base/MAPL_NewArthParser.F90 index 878a22d41aca..a96787cf15df 100755 --- a/base/MAPL_NewArthParser.F90 +++ b/base/MAPL_NewArthParser.F90 @@ -1,5 +1,4 @@ #include "MAPL_Generic.h" -! ! Part of this code is based on a fortran parser by Roland Schmehl: ! !------- -------- --------- --------- --------- --------- --------- --------- ------- @@ -118,19 +117,11 @@ MODULE MAPL_NewArthParserMod INTEGER :: ByteCodeSize REAL, DIMENSION(:), POINTER :: Immed => NULL() INTEGER :: ImmedSize - type(ESMF_Field), allocatable :: new_stack(:) - TYPE(Ptrs_Type), DIMENSION(:), POINTER :: Stack => NULL() + type(ESMF_Field), allocatable :: stack(:) INTEGER :: StackSize, & StackPtr END TYPE tComp - type Ptrs_Type - integer:: rank - integer, dimension(ESMF_MAXDIM):: lb,ub - real, pointer:: Q2D(:,: ) => null() - real, pointer:: Q3D(:,:,:) => null() - end type Ptrs_Type - CONTAINS subroutine bytecode_dealloc(comp,rc) @@ -141,10 +132,9 @@ subroutine bytecode_dealloc(comp,rc) integer :: status do i=1,comp%StackSize - call ESMF_FieldDestroy(comp%new_stack(i),noGarbage=.true.,_RC) + call ESMF_FieldDestroy(comp%stack(i),noGarbage=.true.,_RC) end do - deallocate(comp%Stack) - deallocate(comp%new_stack) + deallocate(comp%stack) deallocate(comp%ByteCode) deallocate(comp%Immed) _RETURN(ESMF_SUCCESS) @@ -239,27 +229,27 @@ SUBROUTINE evalf (Comp, State, FieldNames, ResField, rc) CurrByte = Comp%ByteCode(IP) if (CurrByte == cImmed) then SP=SP+1 - call FieldSet(comp%new_stack(sp),comp%immed(dp),_RC) + call FieldSet(comp%stack(sp),comp%immed(dp),_RC) DP=DP+1 end if if (CurrByte == cNeg) then - call FieldNegate(comp%new_stack(sp),_RC) + call FieldNegate(comp%stack(sp),_RC) end if if (CurrByte >= cAdd .and. CurrByte <= cPow) then - call field_binary(Comp%new_stack(SP),Comp%new_stack(SP-1),CurrByte,_RC) + call field_binary(Comp%stack(SP),Comp%stack(SP-1),CurrByte,_RC) SP=SP-1 end if if (CurrByte >= cAbs .and. CurrByte <= cHeav) then - call field_unary(comp%new_stack(sp),currByte,_RC) + call field_unary(comp%stack(sp),currByte,_RC) end if if (CurrByte > cHeav) then SP=SP+1 ValNumber = CurrByte-VarBegin+1 call ESMF_StateGet(state,FieldNames(ValNumber),state_field,_RC) - call FieldCopyBroadcast(state_field,comp%new_stack(sp),_RC) + call FieldCopyBroadcast(state_field,comp%stack(sp),_RC) end if END DO - call FieldCopyBroadcast(comp%new_stack(1),ResField,_RC) + call FieldCopyBroadcast(comp%stack(1),ResField,_RC) _RETURN(ESMF_SUCCESS) END SUBROUTINE evalf @@ -773,17 +763,11 @@ SUBROUTINE Compile (Comp, F, Var, field, rc) TYPE(ESMF_Field) , INTENT(inout) :: field ! resultant field, use to get its rank, etc . . . INTEGER , INTENT(out ) :: rc INTEGER :: istat, i - TYPE(ESMF_Array) :: Array - type (ESMF_LocalArray), target :: larrayList(1) - TYPE(ESMF_LocalArray) ,pointer :: lArray - INTEGER :: ResRank - INTEGER :: lb(ESMF_MAXDIM) - INTEGER :: ub(ESMF_MAXDIM) integer :: status !----- -------- --------- --------- --------- --------- --------- --------- ------- IF (ASSOCIATED(Comp%ByteCode)) DEALLOCATE ( Comp%ByteCode, & Comp%Immed, & - Comp%Stack ) + Comp%stack ) Comp%ByteCodeSize = 0 Comp%ImmedSize = 0 Comp%StackSize = 0 @@ -791,12 +775,11 @@ SUBROUTINE Compile (Comp, F, Var, field, rc) CALL CompileSubstr (Comp,F,1,LEN_TRIM(F),Var) ! Compile string to determine size ALLOCATE ( Comp%ByteCode(Comp%ByteCodeSize), & Comp%Immed(Comp%ImmedSize), & - Comp%Stack(Comp%StackSize), & - Comp%new_stack(comp%stackSize), & + Comp%stack(comp%stackSize), & STAT = istat ) DO i=1,Comp%StackSize - call FieldClone(field,comp%new_stack(i),_RC) + call FieldClone(field,comp%stack(i),_RC) call ESMF_AttributeSet(field,name="missing_value",value=MAPL_UNDEF,_RC) END DO From cb32cbae1b0a205343d3a42e003d0083d4e34a32 Mon Sep 17 00:00:00 2001 From: Benjamin Auer Date: Fri, 16 Jun 2023 16:39:47 -0400 Subject: [PATCH 5/5] fix gnu bug --- geom/FieldPointerUtilities.F90 | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/geom/FieldPointerUtilities.F90 b/geom/FieldPointerUtilities.F90 index 41ca1bcbfed0..5cc056cc5720 100644 --- a/geom/FieldPointerUtilities.F90 +++ b/geom/FieldPointerUtilities.F90 @@ -370,7 +370,7 @@ subroutine clone(x, y, rc) integer, allocatable :: ungriddedLBound(:) integer, allocatable :: ungriddedUBound(:) type(ESMF_TypeKind_Flag) :: tk - character(len=:), allocatable :: name + character(len=ESMF_MAXSTR) :: name integer :: status integer :: field_rank, grid_rank,ungrid_size @@ -379,11 +379,11 @@ subroutine clone(x, y, rc) ungrid_size = field_rank-grid_rank allocate(gridToFieldMap(grid_rank)) allocate(ungriddedLBound(ungrid_size),ungriddedUBound(ungrid_size)) - call ESMF_FieldGet(x, typekind=tk, & + call ESMF_FieldGet(x, typekind=tk, name = name, & staggerloc=staggerloc, gridToFieldMap=gridToFieldMap, & ungriddedLBound=ungriddedLBound, ungriddedUBound=ungriddedUBound, _RC) - name = name // CLONE_TAG + name = trim(name) // CLONE_TAG y = ESMF_FieldCreate(grid, typekind=tk, staggerloc=staggerloc, & gridToFieldMap=gridToFieldMap, ungriddedLBound=ungriddedLBound, &