Skip to content

Commit 77da49e

Browse files
femparadminfemparadmin
committed
New example to show to extend FPL.
Some minor changes.
1 parent a1ec24d commit 77da49e

9 files changed

+468
-77
lines changed

‎src/examples/CMakeLists.txt

+3-18
Original file line numberDiff line numberDiff line change
@@ -2,12 +2,9 @@
22
# EXAMPLES
33
#################################################################
44

5-
FILE(GLOB_RECURSE EXAMPLES_SRC *.f90 *.F90)
5+
FILE(GLOB EXAMPLES_SRC *.f90 *.F90)
66
SET(EXAMPLES_SRC ${EXAMPLES_SRC} PARENT_SCOPE)
7-
8-
#################################################################
9-
# EXTERNAL LIBRARIES
10-
#################################################################
7+
SET(EXTEND_WRAPPERS_EXAMPLE_PATH ${EXAMPLES_PATH}/extend_wrappers)
118

129
FOREACH(EXAMPLE_SRC ${EXAMPLES_SRC})
1310
GET_FILENAME_COMPONENT(EXE_NAME ${EXAMPLE_SRC} NAME_WE)
@@ -19,19 +16,7 @@ FOREACH(EXAMPLE_SRC ${EXAMPLES_SRC})
1916
ENDIF()
2017
ENDFOREACH()
2118

22-
IF(${PROJECT_NAME}_ENABLE_MPI)
23-
TARGET_LINK_LIBRARIES(${EXE_NAME} ${MPI_Fortran_LIBRARIES})
24-
ENDIF()
25-
26-
IF(${PROJECT_NAME}_ENABLE_HDF5)
27-
TARGET_LINK_LIBRARIES(${EXE_NAME} ${HDF5_Fortran_HL_LIBRARIES})
28-
TARGET_LINK_LIBRARIES(${EXE_NAME} ${HDF5_HL_LIBRARIES})
29-
TARGET_LINK_LIBRARIES(${EXE_NAME} ${HDF5_Fortran_LIBRARIES})
30-
TARGET_LINK_LIBRARIES(${EXE_NAME} ${HDF5_LIBRARIES})
31-
ENDIF()
32-
3319
ADD_TEST(${EXE_NAME}_TEST ${EXECUTABLE_OUTPUT_PATH}/${EXE_NAME})
3420
ENDFOREACH()
3521

36-
37-
22+
ADD_SUBDIRECTORY(${EXTEND_WRAPPERS_EXAMPLE_PATH})

‎src/examples/extend_wrappers/CMakeLists.txt

+17
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,17 @@
1+
#################################################################
2+
# EXTEND WRAPPERS EXAMPLE
3+
#################################################################
4+
5+
FILE(GLOB EXTEND_WRAPPERS_EXAMPLE_SRC *.f90 *.F90)
6+
SET(EXTEND_WRAPPERS_EXAMPLE_SRC ${EXTEND_WRAPPERS_EXAMPLE_SRC} PARENT_SCOPE)
7+
8+
SET(EXE_NAME ParameterList_Extend_Wrappers_Example)
9+
ADD_EXECUTABLE(${EXE_NAME} ${EXTEND_WRAPPERS_EXAMPLE_SRC})
10+
TARGET_LINK_LIBRARIES(${EXE_NAME} ${LIB})
11+
FOREACH (EXT_LIB ${EXT_LIBS})
12+
IF(DEFINED ${PROJECT_NAME}_ENABLE_${EXT_LIB} AND ${PROJECT_NAME}_ENABLE_${EXT_LIB} AND ${EXT_LIB}_FOUND)
13+
TARGET_LINK_LIBRARIES(${EXE_NAME} ${${EXT_LIB}_LIBRARIES})
14+
ENDIF()
15+
ENDFOREACH()
16+
17+
ADD_TEST(${EXE_NAME}_TEST ${EXECUTABLE_OUTPUT_PATH}/${EXE_NAME})

‎src/examples/extend_wrappers/Circle.f90

+56
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,56 @@
1+
module Circle
2+
3+
implicit none
4+
private
5+
6+
type :: Circle_t
7+
private
8+
real :: Radius
9+
contains
10+
private
11+
procedure :: Circle_Assign
12+
procedure, public :: SetRadius => Circle_SetRadius
13+
procedure, public :: GetRadius => Circle_GetRadius
14+
generic, public :: assignment(=) => Circle_Assign
15+
end type Circle_t
16+
17+
public :: Circle_t
18+
19+
contains
20+
21+
subroutine Circle_Assign(A,B)
22+
!-----------------------------------------------------------------
23+
!< Assignment overloading
24+
!-----------------------------------------------------------------
25+
26+
class(Circle_t), intent(OUT) :: A
27+
class(Circle_t), intent(IN) :: B
28+
real :: Radius
29+
!-----------------------------------------------------------------
30+
call B%GetRadius(Radius=Radius)
31+
call A%SetRadius(Radius=Radius)
32+
end subroutine
33+
34+
subroutine Circle_SetRadius(this, Radius)
35+
!-----------------------------------------------------------------
36+
!< Set the radius of the Circle
37+
!-----------------------------------------------------------------
38+
39+
class(Circle_t), intent(INOUT) :: this
40+
real, intent(IN) :: Radius
41+
!-----------------------------------------------------------------
42+
this%Radius = Radius
43+
end subroutine
44+
45+
subroutine Circle_GetRadius(this, Radius)
46+
!-----------------------------------------------------------------
47+
!< Return the radius of the circle
48+
!-----------------------------------------------------------------
49+
50+
class(Circle_t), intent(IN) :: this
51+
real, intent(OUT) :: Radius
52+
!-----------------------------------------------------------------
53+
Radius = this%Radius
54+
end subroutine
55+
56+
end module

‎src/examples/extend_wrappers/CircleWrapper.f90

+145
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,145 @@
1+
module CircleWrapper
2+
3+
USE Circle !< USE the data type to store
4+
USE DimensionsWrapper0D !< USE the DimensionsWrapper0D abstract class
5+
USE ErrorMessages !< USE the ErrorMessages for printing error messages
6+
USE IR_Precision, only: I4P, str !< USE I4P data type and str for string conversion
7+
8+
implicit none
9+
private
10+
11+
type, extends(DimensionsWrapper0D_t) :: CircleWrapper_t !< Extends from DimensionsWrapper0D_t (scalar value)
12+
type(Circle_T), allocatable :: Value !< Value stores a copy of the input data by assignment
13+
contains
14+
private
15+
procedure, public :: Set => CircleWrapper_Set !< Sets the Value into the Wrapper
16+
procedure, public :: Get => CircleWrapper_Get !< Gets the Value from the Wrapper
17+
procedure, public :: GetShape => CircleWrapper_GetShape !< Return the shape of the stored Value (0, scalar value)
18+
procedure, public :: GetPointer => CircleWrapper_GetPointer !< Return an unlimited polymorphic pointer to the Value
19+
procedure, public :: isOfDataType => CircleWrapper_isOfDataType !< Check if the data type of a input Mold is Circle_t
20+
procedure, public :: Free => CircleWrapper_Free !< Free the Wrapper
21+
procedure, public :: Print => CircleWrapper_Print !< Print the Wrapper content
22+
end type
23+
24+
public :: CircleWrapper_t
25+
26+
contains
27+
28+
subroutine CircleWrapper_Set(this, Value)
29+
!-----------------------------------------------------------------
30+
!< Set Circle Wrapper Value
31+
!-----------------------------------------------------------------
32+
class(CircleWrapper_t), intent(INOUT) :: this
33+
class(*), intent(IN) :: Value
34+
integer :: err
35+
!-----------------------------------------------------------------
36+
select type (Value)
37+
type is (Circle_t)
38+
allocate(this%Value, stat=err)
39+
this%Value = Value
40+
if(err/=0) &
41+
call msg%Error(txt='Setting Value: Allocation error ('//&
42+
str(no_sign=.true.,n=err)//')', &
43+
file=__FILE__, line=__LINE__ )
44+
class Default
45+
call msg%Warn(txt='Setting value: Expected data type (Circle)',&
46+
file=__FILE__, line=__LINE__ )
47+
end select
48+
end subroutine
49+
50+
51+
subroutine CircleWrapper_Get(this, Value)
52+
!-----------------------------------------------------------------
53+
!< Get Circle Wrapper Value
54+
!-----------------------------------------------------------------
55+
class(CircleWrapper_t), intent(IN) :: this
56+
class(*), intent(OUT) :: Value
57+
!-----------------------------------------------------------------
58+
select type (Value)
59+
type is (Circle_t)
60+
Value = this%Value
61+
class Default
62+
call msg%Warn(txt='Getting value: Expected data type (Circle)',&
63+
file=__FILE__, line=__LINE__ )
64+
end select
65+
end subroutine
66+
67+
function CircleWrapper_GetShape(this) result(ValueShape)
68+
!-----------------------------------------------------------------
69+
!< Return the shape of the Wrapper Value
70+
!-----------------------------------------------------------------
71+
class(CircleWrapper_t), intent(IN) :: this
72+
integer(I4P), allocatable :: ValueShape(:)
73+
!-----------------------------------------------------------------
74+
allocate(ValueShape(1))
75+
ValueShape = 0
76+
end function
77+
78+
79+
function CircleWrapper_GetPointer(this) result(Value)
80+
!-----------------------------------------------------------------
81+
!< Get Unlimited Polymorphic pointer to Wrapper Value
82+
!-----------------------------------------------------------------
83+
class(CircleWrapper_t), target, intent(IN) :: this
84+
class(*), pointer :: Value
85+
!-----------------------------------------------------------------
86+
Value => this%Value
87+
end function
88+
89+
90+
subroutine CircleWrapper_Free(this)
91+
!-----------------------------------------------------------------
92+
!< Free a CircleWrapper0D
93+
!-----------------------------------------------------------------
94+
class(CircleWrapper_t), intent(INOUT) :: this
95+
integer :: err
96+
!-----------------------------------------------------------------
97+
if(allocated(this%Value)) then
98+
deallocate(this%Value, stat=err)
99+
if(err/=0) call msg%Error(txt='Freeing Value: Deallocation error ('// &
100+
str(no_sign=.true.,n=err)//')', &
101+
file=__FILE__, line=__LINE__ )
102+
endif
103+
end subroutine
104+
105+
106+
function CircleWrapper_isOfDataType(this, Mold) result(isOfDataType)
107+
!-----------------------------------------------------------------
108+
!< Check if Mold and Value are of the same datatype
109+
!-----------------------------------------------------------------
110+
class(CircleWrapper_t), intent(IN) :: this !< Circle wrapper 0D
111+
class(*), intent(IN) :: Mold !< Mold for data type comparison
112+
logical :: isOfDataType !< Boolean flag to check if Value is of the same data type as Mold
113+
!-----------------------------------------------------------------
114+
isOfDataType = .false.
115+
select type (Mold)
116+
type is (Circle_t)
117+
isOfDataType = .true.
118+
end select
119+
end function CircleWrapper_isOfDataType
120+
121+
122+
subroutine CircleWrapper_Print(this, unit, prefix, iostat, iomsg)
123+
!-----------------------------------------------------------------
124+
!< Print Wrapper
125+
!-----------------------------------------------------------------
126+
class(CircleWrapper_t), intent(IN) :: this !< CircleWrapper
127+
integer(I4P), intent(IN) :: unit !< Logic unit.
128+
character(*), optional, intent(IN) :: prefix !< Prefixing string.
129+
integer(I4P), optional, intent(OUT) :: iostat !< IO error.
130+
character(*), optional, intent(OUT) :: iomsg !< IO error message.
131+
character(len=:), allocatable :: prefd !< Prefixing string.
132+
integer(I4P) :: iostatd !< IO error.
133+
character(500) :: iomsgd !< Temporary variable for IO error message.
134+
real :: Radius !< Circle radius
135+
!-----------------------------------------------------------------
136+
prefd = '' ; if (present(prefix)) prefd = prefix
137+
call this%Value%GetRadius(Radius=Radius)
138+
write(unit=unit,fmt='(A)',iostat=iostatd,iomsg=iomsgd) prefd//' Data Type = Circle'//&
139+
', Radius = '//str(no_sign=.true., n=Radius)
140+
if (present(iostat)) iostat = iostatd
141+
if (present(iomsg)) iomsg = iomsgd
142+
end subroutine CircleWrapper_Print
143+
144+
145+
end module CircleWrapper

0 commit comments

Comments
 (0)