FieldUtilities.F90 Source File


This file depends on

sourcefile~~fieldutilities.f90~~EfferentGraph sourcefile~fieldutilities.f90 FieldUtilities.F90 sourcefile~fieldpointerutilities.f90 FieldPointerUtilities.F90 sourcefile~fieldutilities.f90->sourcefile~fieldpointerutilities.f90 sourcefile~mapl_errorhandling.f90 MAPL_ErrorHandling.F90 sourcefile~fieldutilities.f90->sourcefile~mapl_errorhandling.f90 sourcefile~mapl_exceptionhandling.f90 MAPL_ExceptionHandling.F90 sourcefile~fieldpointerutilities.f90->sourcefile~mapl_exceptionhandling.f90 sourcefile~mapl_throw.f90 MAPL_Throw.F90 sourcefile~mapl_errorhandling.f90->sourcefile~mapl_throw.f90 sourcefile~mapl_exceptionhandling.f90->sourcefile~mapl_errorhandling.f90 sourcefile~mapl_exceptionhandling.f90->sourcefile~mapl_throw.f90

Files dependent on this one

sourcefile~~fieldutilities.f90~~AfferentGraph sourcefile~fieldutilities.f90 FieldUtilities.F90 sourcefile~fieldutils.f90 FieldUtils.F90 sourcefile~fieldutils.f90->sourcefile~fieldutilities.f90 sourcefile~test_fieldarithmetic.pf Test_FieldArithmetic.pf sourcefile~test_fieldarithmetic.pf->sourcefile~fieldutilities.f90 sourcefile~base_base_implementation.f90 Base_Base_implementation.F90 sourcefile~base_base_implementation.f90->sourcefile~fieldutils.f90 sourcefile~extdatabracket.f90 ExtDataBracket.F90 sourcefile~extdatabracket.f90->sourcefile~fieldutils.f90 sourcefile~extdatagridcompng.f90 ExtDataGridCompNG.F90 sourcefile~extdatagridcompng.f90->sourcefile~fieldutils.f90 sourcefile~mapl_newarthparser.f90 MAPL_NewArthParser.F90 sourcefile~extdatagridcompng.f90->sourcefile~mapl_newarthparser.f90 sourcefile~mapl.f90 MAPL.F90 sourcefile~mapl.f90->sourcefile~fieldutils.f90 sourcefile~mapl_newarthparser.f90->sourcefile~fieldutils.f90 sourcefile~base.f90 Base.F90 sourcefile~base.f90->sourcefile~mapl_newarthparser.f90 sourcefile~capdriver.f90 CapDriver.F90 sourcefile~capdriver.f90->sourcefile~mapl.f90 sourcefile~comp_testing_driver.f90 Comp_Testing_Driver.F90 sourcefile~comp_testing_driver.f90->sourcefile~mapl.f90 sourcefile~extdataabstractfilehandler.f90 ExtDataAbstractFileHandler.F90 sourcefile~extdataabstractfilehandler.f90->sourcefile~extdatabracket.f90 sourcefile~extdataclimfilehandler.f90 ExtDataClimFileHandler.F90 sourcefile~extdataclimfilehandler.f90->sourcefile~extdatabracket.f90 sourcefile~extdataderived.f90 ExtDataDerived.F90 sourcefile~extdataderived.f90->sourcefile~mapl_newarthparser.f90 sourcefile~extdatadriver.f90 ExtDataDriver.F90 sourcefile~extdatadriver.f90->sourcefile~mapl.f90 sourcefile~extdatadrivergridcomp.f90 ExtDataDriverGridComp.F90 sourcefile~extdatadrivergridcomp.f90->sourcefile~extdatagridcompng.f90 sourcefile~extdatadrivergridcomp.f90->sourcefile~mapl.f90 sourcefile~extdatadrivermod.f90 ExtDataDriverMod.F90 sourcefile~extdatadrivermod.f90->sourcefile~mapl.f90 sourcefile~extdatagridcompmod.f90 ExtDataGridCompMod.F90 sourcefile~extdatagridcompmod.f90->sourcefile~mapl_newarthparser.f90 sourcefile~extdatamasking.f90 ExtDataMasking.F90 sourcefile~extdatamasking.f90->sourcefile~mapl_newarthparser.f90 sourcefile~extdataroot_gridcomp.f90 ExtDataRoot_GridComp.F90 sourcefile~extdataroot_gridcomp.f90->sourcefile~mapl.f90 sourcefile~extdatasimplefilehandler.f90 ExtDataSimpleFileHandler.F90 sourcefile~extdatasimplefilehandler.f90->sourcefile~extdatabracket.f90 sourcefile~extdatatypedef.f90 ExtDataTypeDef.F90 sourcefile~extdatatypedef.f90->sourcefile~extdatabracket.f90 sourcefile~extdatatypedef.f90->sourcefile~mapl_newarthparser.f90 sourcefile~mapl_capgridcomp.f90 MAPL_CapGridComp.F90 sourcefile~mapl_capgridcomp.f90->sourcefile~extdatagridcompng.f90 sourcefile~mapl_demo_fargparse.f90 MAPL_demo_fargparse.F90 sourcefile~mapl_demo_fargparse.f90->sourcefile~mapl.f90 sourcefile~mapl_historygridcomp.f90 MAPL_HistoryGridComp.F90 sourcefile~mapl_historygridcomp.f90->sourcefile~mapl_newarthparser.f90 sourcefile~pfio_mapl_demo.f90 pfio_MAPL_demo.F90 sourcefile~pfio_mapl_demo.f90->sourcefile~mapl.f90 sourcefile~regrid_util.f90 Regrid_Util.F90 sourcefile~regrid_util.f90->sourcefile~mapl.f90 sourcefile~time_ave_util.f90 time_ave_util.F90 sourcefile~time_ave_util.f90->sourcefile~mapl.f90 sourcefile~varspecdescription.f90 VarspecDescription.F90 sourcefile~varspecdescription.f90->sourcefile~mapl.f90

Source Code

#include "MAPL_Generic.h"

module MAPL_FieldUtilities
use ESMF
use MAPL_ErrorHandlingMod
use MAPL_FieldPointerUtilities

implicit none
private

public FieldIsConstant
public FieldSet
public FieldNegate
public FieldPow

interface FieldIsConstant
   module procedure FieldIsConstantR4
end interface

interface FieldSet
   module procedure FieldSet_R4
   module procedure FieldSet_R8
end interface

contains

function FieldIsConstantR4(field,constant_val,rc) result(field_is_constant)
   logical :: field_is_constant
   type(ESMF_Field), intent(inout) :: field
   real(kind=ESMF_KIND_R4) :: constant_val
   integer, optional, intent(out) :: rc

   integer :: status
 
   real(ESMF_KIND_R4), pointer :: f_ptr_r4(:)

   type(ESMF_TypeKind_Flag) :: type_kind
   
   call ESMF_FieldGet(field,typekind=type_kind,_RC)

   field_is_constant = .false.
   if (type_kind == ESMF_TYPEKIND_R4) then
      call assign_fptr(field,f_ptr_r4,_RC)
      field_is_constant = all(f_ptr_r4 == constant_val)
   else
      _FAIL("constant_val is single precision so you can not check if it is all undef for an R8")
   end if

   _RETURN(_SUCCESS)

end function FieldIsConstantR4

subroutine FieldSet_r8(field,constant_val,rc)
   type(ESMF_Field), intent(inout) :: field
   real(kind=ESMF_KIND_r8), intent(in) :: constant_val
   integer, intent(out), optional :: rc

   type(ESMF_TYPEKIND_FLAG) :: type_kind
   real(kind=ESMF_KIND_R4), pointer :: f_ptr_r4(:)
   real(kind=ESMF_KIND_R8), pointer :: f_ptr_r8(:)
   integer :: status

   call ESMF_FieldGet(field,typekind=type_kind,_RC)
   if (type_kind == ESMF_TYPEKIND_R4) then
      call assign_fptr(field,f_ptr_r4,_RC)
      f_ptr_r4 = constant_val
   else if (type_kind == ESMF_TYPEKIND_R8) then
      call assign_fptr(field,f_ptr_r8,_RC)
      f_ptr_r8 = constant_val
   else
      _FAIL('unsupported typekind')
   end if
   _RETURN(ESMF_SUCCESS)
end subroutine FieldSet_r8

subroutine FieldSet_r4(field,constant_val,rc)
   type(ESMF_Field), intent(inout) :: field
   real(kind=ESMF_KIND_r4), intent(in) :: constant_val
   integer, intent(out), optional :: rc

   type(ESMF_TYPEKIND_FLAG) :: type_kind
   real(kind=ESMF_KIND_R4), pointer :: f_ptr_r4(:)
   real(kind=ESMF_KIND_R8), pointer :: f_ptr_r8(:)
   integer :: status

   call ESMF_FieldGet(field,typekind=type_kind,_RC)
   if (type_kind == ESMF_TYPEKIND_R4) then
      call assign_fptr(field,f_ptr_r4,_RC)
      f_ptr_r4 = constant_val
   else if (type_kind == ESMF_TYPEKIND_R8) then
      call assign_fptr(field,f_ptr_r8,_RC)
      f_ptr_r8 = constant_val
   else
      _FAIL('unsupported typekind')
   end if
   _RETURN(ESMF_SUCCESS)
end subroutine FieldSet_r4

subroutine FieldNegate(field,rc)
   type(ESMF_Field), intent(inout) :: field
   integer, intent(out), optional :: rc

   type(ESMF_TYPEKIND_FLAG) :: type_kind
   real(kind=ESMF_KIND_R4), pointer :: f_ptr_r4(:)
   real(kind=ESMF_KIND_R8), pointer :: f_ptr_r8(:)
   logical :: has_undef
   real(kind = ESMF_Kind_R4), allocatable :: undef_r4(:)
   real(kind = ESMF_Kind_R8), allocatable :: undef_r8(:) 
   integer :: status
   type(ESMF_Field) :: fields(1)


   fields(1) = field 
   has_undef = FieldsHaveUndef(fields,_RC)  
   call ESMF_FieldGet(field,typekind=type_kind,_RC)
   if (type_kind == ESMF_TYPEKIND_R4) then
      call assign_fptr(field,f_ptr_r4,_RC)
      if (has_undef) then
         call GetFieldsUndef(fields,undef_r4,_RC)
         where(f_ptr_r4 /= undef_r4(1))
            f_ptr_r4 = -f_ptr_r4
         end where
      else
         f_ptr_r4 = -f_ptr_r4
      end if
   else if (type_kind == ESMF_TYPEKIND_R4) then
      call assign_fptr(field,f_ptr_r8,_RC)
      if (has_undef) then
         call GetFieldsUndef(fields,undef_r8,_RC)
         where(f_ptr_r8 /= undef_r8(1))
            f_ptr_r8 = -f_ptr_r8
         end where
      else
         f_ptr_r8 = -f_ptr_r8
      end if
   else
      _FAIL('unsupported typekind')
   end if
   _RETURN(ESMF_SUCCESS)
end subroutine FieldNegate

subroutine FieldPow(field_out,field_in,expo,rc)
   type(ESMF_Field), intent(inout) :: field_out
   type(ESMF_Field), intent(inout) :: field_in
   real, intent(in) :: expo
   integer, intent(out), optional :: rc

   real(kind = ESMF_Kind_R4), allocatable :: undef_r4(:)
   real(kind = ESMF_Kind_R8), allocatable :: undef_r8(:)
   type(ESMF_TypeKind_Flag) :: tk_in, tk_out
   real(kind=ESMF_KIND_R4), pointer :: ptr_r4_in(:),ptr_r4_out(:)
   real(kind=ESMF_KIND_R8), pointer :: ptr_r8_in(:),ptr_r8_out(:)
   integer :: status
   logical :: has_undef,conformable
   type(ESMF_Field) :: fields(2)

   conformable = FieldsAreConformable(field_in,field_out,_RC)
   _ASSERT(conformable,"Fields passed power function are not conformable")

   fields(1) = field_in
   fields(2) = field_out
   has_undef = FieldsHaveUndef(fields,_RC)
   call ESMF_FieldGet(field_in,typekind=tk_in,_RC)
   call ESMF_FieldGet(field_out,typekind=tk_out,_RC)
   _ASSERT(tk_in == tk_out, "For now input and output field must be of same type for a field function")
   if (tk_in == ESMF_TYPEKIND_R4) then
      call assign_fptr(field_in,ptr_r4_in,_RC)
      call assign_fptr(field_out,ptr_r4_out,_RC)
      if (has_undef) then
         call GetFieldsUndef(fields,undef_r4,_RC)
         where(ptr_r4_in /= undef_r4(1))
            ptr_r4_out = ptr_r4_in**expo
         elsewhere
            ptr_r4_out = undef_r4(2)
         end where
      else
         ptr_r4_out = ptr_r4_in**expo
      end if
   else if (tk_in == ESMF_TYPEKIND_R8) then
      call assign_fptr(field_in,ptr_r8_in,_RC)
      call assign_fptr(field_out,ptr_r8_out,_RC)
      if (has_undef) then
         call GetFieldsUndef(fields,undef_r8,_RC)
         where(ptr_r8_in /= undef_r8(1))
            ptr_r8_out = ptr_r8_in**expo
         elsewhere
            ptr_r8_out = undef_r8(2)
         end where
      else
         ptr_r8_out = ptr_r8_in**expo
      end if
   else
      _FAIL('unsupported typekind')
   end if
   _RETURN(ESMF_SUCCESS)
end subroutine FieldPow

end module