Skip to content

Commit

Permalink
New example to show to extend FPL.
Browse files Browse the repository at this point in the history 
Some minor changes.
  • Loading branch information
@femparadmin
femparadmin committed Nov 6, 2015
1 parent a1ec24d commit 77da49e
Show file tree
Hide file tree
Showing 9 changed files with 468 additions and 77 deletions.
21 changes: 3 additions & 18 deletions src/examples/CMakeLists.txt
View file
Original file line number Diff line number Diff line change
Expand Up @@ -2,12 +2,9 @@
# EXAMPLES
#################################################################

FILE(GLOB_RECURSE EXAMPLES_SRC *.f90 *.F90)
FILE(GLOB EXAMPLES_SRC *.f90 *.F90)
SET(EXAMPLES_SRC ${EXAMPLES_SRC} PARENT_SCOPE)

#################################################################
# EXTERNAL LIBRARIES
#################################################################
SET(EXTEND_WRAPPERS_EXAMPLE_PATH ${EXAMPLES_PATH}/extend_wrappers)

FOREACH(EXAMPLE_SRC ${EXAMPLES_SRC})
GET_FILENAME_COMPONENT(EXE_NAME ${EXAMPLE_SRC} NAME_WE)
Expand All @@ -19,19 +16,7 @@ FOREACH(EXAMPLE_SRC ${EXAMPLES_SRC})
ENDIF()
ENDFOREACH()

IF(${PROJECT_NAME}_ENABLE_MPI)
TARGET_LINK_LIBRARIES(${EXE_NAME} ${MPI_Fortran_LIBRARIES})
ENDIF()

IF(${PROJECT_NAME}_ENABLE_HDF5)
TARGET_LINK_LIBRARIES(${EXE_NAME} ${HDF5_Fortran_HL_LIBRARIES})
TARGET_LINK_LIBRARIES(${EXE_NAME} ${HDF5_HL_LIBRARIES})
TARGET_LINK_LIBRARIES(${EXE_NAME} ${HDF5_Fortran_LIBRARIES})
TARGET_LINK_LIBRARIES(${EXE_NAME} ${HDF5_LIBRARIES})
ENDIF()

ADD_TEST(${EXE_NAME}_TEST ${EXECUTABLE_OUTPUT_PATH}/${EXE_NAME})
ENDFOREACH()



ADD_SUBDIRECTORY(${EXTEND_WRAPPERS_EXAMPLE_PATH})
17 changes: 17 additions & 0 deletions src/examples/extend_wrappers/CMakeLists.txt
View file
Original file line number Diff line number Diff line change
@@ -0,0 +1,17 @@
#################################################################
# EXTEND WRAPPERS EXAMPLE
#################################################################

FILE(GLOB EXTEND_WRAPPERS_EXAMPLE_SRC *.f90 *.F90)
SET(EXTEND_WRAPPERS_EXAMPLE_SRC ${EXTEND_WRAPPERS_EXAMPLE_SRC} PARENT_SCOPE)

SET(EXE_NAME ParameterList_Extend_Wrappers_Example)
ADD_EXECUTABLE(${EXE_NAME} ${EXTEND_WRAPPERS_EXAMPLE_SRC})
TARGET_LINK_LIBRARIES(${EXE_NAME} ${LIB})
FOREACH (EXT_LIB ${EXT_LIBS})
IF(DEFINED ${PROJECT_NAME}_ENABLE_${EXT_LIB} AND ${PROJECT_NAME}_ENABLE_${EXT_LIB} AND ${EXT_LIB}_FOUND)
TARGET_LINK_LIBRARIES(${EXE_NAME} ${${EXT_LIB}_LIBRARIES})
ENDIF()
ENDFOREACH()

ADD_TEST(${EXE_NAME}_TEST ${EXECUTABLE_OUTPUT_PATH}/${EXE_NAME})
56 changes: 56 additions & 0 deletions src/examples/extend_wrappers/Circle.f90
View file
Original file line number Diff line number Diff line change
@@ -0,0 +1,56 @@
module Circle

implicit none
private

type :: Circle_t
private
real :: Radius
contains
private
procedure :: Circle_Assign
procedure, public :: SetRadius => Circle_SetRadius
procedure, public :: GetRadius => Circle_GetRadius
generic, public :: assignment(=) => Circle_Assign
end type Circle_t

public :: Circle_t

contains

subroutine Circle_Assign(A,B)
!-----------------------------------------------------------------
!< Assignment overloading
!-----------------------------------------------------------------

class(Circle_t), intent(OUT) :: A
class(Circle_t), intent(IN) :: B
real :: Radius
!-----------------------------------------------------------------
call B%GetRadius(Radius=Radius)
call A%SetRadius(Radius=Radius)
end subroutine

subroutine Circle_SetRadius(this, Radius)
!-----------------------------------------------------------------
!< Set the radius of the Circle
!-----------------------------------------------------------------

class(Circle_t), intent(INOUT) :: this
real, intent(IN) :: Radius
!-----------------------------------------------------------------
this%Radius = Radius
end subroutine

subroutine Circle_GetRadius(this, Radius)
!-----------------------------------------------------------------
!< Return the radius of the circle
!-----------------------------------------------------------------

class(Circle_t), intent(IN) :: this
real, intent(OUT) :: Radius
!-----------------------------------------------------------------
Radius = this%Radius
end subroutine

end module
145 changes: 145 additions & 0 deletions src/examples/extend_wrappers/CircleWrapper.f90
View file
Original file line number Diff line number Diff line change
@@ -0,0 +1,145 @@
module CircleWrapper

USE Circle !< USE the data type to store
USE DimensionsWrapper0D !< USE the DimensionsWrapper0D abstract class
USE ErrorMessages !< USE the ErrorMessages for printing error messages
USE IR_Precision, only: I4P, str !< USE I4P data type and str for string conversion

implicit none
private

type, extends(DimensionsWrapper0D_t) :: CircleWrapper_t !< Extends from DimensionsWrapper0D_t (scalar value)
type(Circle_T), allocatable :: Value !< Value stores a copy of the input data by assignment
contains
private
procedure, public :: Set => CircleWrapper_Set !< Sets the Value into the Wrapper
procedure, public :: Get => CircleWrapper_Get !< Gets the Value from the Wrapper
procedure, public :: GetShape => CircleWrapper_GetShape !< Return the shape of the stored Value (0, scalar value)
procedure, public :: GetPointer => CircleWrapper_GetPointer !< Return an unlimited polymorphic pointer to the Value
procedure, public :: isOfDataType => CircleWrapper_isOfDataType !< Check if the data type of a input Mold is Circle_t
procedure, public :: Free => CircleWrapper_Free !< Free the Wrapper
procedure, public :: Print => CircleWrapper_Print !< Print the Wrapper content
end type

public :: CircleWrapper_t

contains

subroutine CircleWrapper_Set(this, Value)
!-----------------------------------------------------------------
!< Set Circle Wrapper Value
!-----------------------------------------------------------------
class(CircleWrapper_t), intent(INOUT) :: this
class(*), intent(IN) :: Value
integer :: err
!-----------------------------------------------------------------
select type (Value)
type is (Circle_t)
allocate(this%Value, stat=err)
this%Value = Value
if(err/=0) &
call msg%Error(txt='Setting Value: Allocation error ('//&
str(no_sign=.true.,n=err)//')', &
file=__FILE__, line=__LINE__ )
class Default
call msg%Warn(txt='Setting value: Expected data type (Circle)',&
file=__FILE__, line=__LINE__ )
end select
end subroutine


subroutine CircleWrapper_Get(this, Value)
!-----------------------------------------------------------------
!< Get Circle Wrapper Value
!-----------------------------------------------------------------
class(CircleWrapper_t), intent(IN) :: this
class(*), intent(OUT) :: Value
!-----------------------------------------------------------------
select type (Value)
type is (Circle_t)
Value = this%Value
class Default
call msg%Warn(txt='Getting value: Expected data type (Circle)',&
file=__FILE__, line=__LINE__ )
end select
end subroutine

function CircleWrapper_GetShape(this) result(ValueShape)
!-----------------------------------------------------------------
!< Return the shape of the Wrapper Value
!-----------------------------------------------------------------
class(CircleWrapper_t), intent(IN) :: this
integer(I4P), allocatable :: ValueShape(:)
!-----------------------------------------------------------------
allocate(ValueShape(1))
ValueShape = 0
end function


function CircleWrapper_GetPointer(this) result(Value)
!-----------------------------------------------------------------
!< Get Unlimited Polymorphic pointer to Wrapper Value
!-----------------------------------------------------------------
class(CircleWrapper_t), target, intent(IN) :: this
class(*), pointer :: Value
!-----------------------------------------------------------------
Value => this%Value
end function


subroutine CircleWrapper_Free(this)
!-----------------------------------------------------------------
!< Free a CircleWrapper0D
!-----------------------------------------------------------------
class(CircleWrapper_t), intent(INOUT) :: this
integer :: err
!-----------------------------------------------------------------
if(allocated(this%Value)) then
deallocate(this%Value, stat=err)
if(err/=0) call msg%Error(txt='Freeing Value: Deallocation error ('// &
str(no_sign=.true.,n=err)//')', &
file=__FILE__, line=__LINE__ )
endif
end subroutine


function CircleWrapper_isOfDataType(this, Mold) result(isOfDataType)
!-----------------------------------------------------------------
!< Check if Mold and Value are of the same datatype
!-----------------------------------------------------------------
class(CircleWrapper_t), intent(IN) :: this !< Circle wrapper 0D
class(*), intent(IN) :: Mold !< Mold for data type comparison
logical :: isOfDataType !< Boolean flag to check if Value is of the same data type as Mold
!-----------------------------------------------------------------
isOfDataType = .false.
select type (Mold)
type is (Circle_t)
isOfDataType = .true.
end select
end function CircleWrapper_isOfDataType


subroutine CircleWrapper_Print(this, unit, prefix, iostat, iomsg)
!-----------------------------------------------------------------
!< Print Wrapper
!-----------------------------------------------------------------
class(CircleWrapper_t), intent(IN) :: this !< CircleWrapper
integer(I4P), intent(IN) :: unit !< Logic unit.
character(*), optional, intent(IN) :: prefix !< Prefixing string.
integer(I4P), optional, intent(OUT) :: iostat !< IO error.
character(*), optional, intent(OUT) :: iomsg !< IO error message.
character(len=:), allocatable :: prefd !< Prefixing string.
integer(I4P) :: iostatd !< IO error.
character(500) :: iomsgd !< Temporary variable for IO error message.
real :: Radius !< Circle radius
!-----------------------------------------------------------------
prefd = '' ; if (present(prefix)) prefd = prefix
call this%Value%GetRadius(Radius=Radius)
write(unit=unit,fmt='(A)',iostat=iostatd,iomsg=iomsgd) prefd//' Data Type = Circle'//&
', Radius = '//str(no_sign=.true., n=Radius)
if (present(iostat)) iostat = iostatd
if (present(iomsg)) iomsg = iomsgd
end subroutine CircleWrapper_Print


end module CircleWrapper
Loading

0 comments on commit 77da49e

Please sign in to comment.