-
Notifications
You must be signed in to change notification settings - Fork 1
/
grid.f03
175 lines (141 loc) · 4.2 KB
/
grid.f03
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
module grid_mod
use Grid_Coordinate_mod
implicit none
private
public :: Grid, DefaultGrid
type, abstract :: Grid
private
contains
procedure(getValueGC_def), deferred :: getValueGC
procedure(getValueInt_def), deferred :: getValueInt
generic :: getValue => getValueGC, getValueInt
procedure(setValueGC_def), deferred :: setValueGC
procedure(setValueInt_def), deferred :: setValueInt
generic :: setValue => setValueGC, setValueInt
procedure(getColumns_def), deferred :: getColumns
procedure(getRows_def), deferred :: getRows
end type Grid
abstract interface
function getValueGC_def(self, coord)
import Grid, GridCoordinate
CLASS(Grid) :: self
CLASS(GridCoordinate) :: coord
real :: getValueGC_def
end function getValueGC_def
end interface
abstract interface
function getValueInt_def(self, col, row)
import Grid
CLASS(Grid) :: self
integer :: col, row
real getValueInt_def
end function getValueInt_def
end interface
abstract interface
subroutine setValueGC_def(self, coord, value)
import Grid, GridCoordinate
CLASS(Grid) :: self
CLASS(GridCoordinate) :: coord
real :: value
end subroutine setValueGC_def
end interface
abstract interface
subroutine setValueInt_def(self, col, row, value)
import Grid
CLASS(Grid) :: self
integer :: col, row
real :: value
end subroutine setValueInt_def
end interface
abstract interface
function getColumns_def(self)
import Grid
CLASS(grid) :: self
integer :: getColumns_def
end function
end interface
abstract interface
function getRows_def(self)
import Grid
CLASS(Grid) :: self
integer :: getRows_def
end function
end interface
!
! Set up a default implementation of the Grid interface
! which is backed by a 2D array of Reals.
!
type, extends(Grid) :: DefaultGrid
private
real, dimension(:,:), pointer :: grid_array
contains
procedure :: getValueGC => getValueGC_dg
procedure :: getValueInt => getValueInt_dg
procedure :: setValueGC => setValueGC_dg
procedure :: setValueInt => setValueInt_dg
procedure :: getColumns => getColumns_dg
procedure :: getRows => getRows_dg
end type
interface DefaultGrid
procedure constructor
end interface
contains
function getColumns_dg(self)
CLASS(DefaultGrid) :: self
integer :: getColumns_dg
integer :: rank
integer, dimension(:), pointer :: max_idx
integer :: cols
cols = 0
! Do we need to deallocate this manually?
max_idx = shape(self%grid_array)
if (size(max_idx) == 2) then
cols = max_idx(1)
end if
getColumns_dg = cols
end function
function getRows_dg(self)
CLASS(DefaultGrid) :: self
integer :: getRows_dg
integer :: rank
integer, dimension(:), pointer :: max_idx
integer :: rows
rows = 0
! Do we need to deallocate this manually?
max_idx = shape(self%grid_array)
if (size(max_idx) == 2) then
rows = max_idx(2)
end if
getRows_dg = rows
end function
function getValueGC_dg(self, coord)
CLASS(DefaultGrid) :: self
CLASS(GridCoordinate) :: coord
real :: getValueGC_dg
getValueGC_dg = self%grid_array(coord%getColumn(), coord%getRow())
end function
function getValueInt_dg(self, col, row)
CLASS(DefaultGrid) :: self
integer :: col, row
real :: getValueInt_dg
getValueInt_dg = self%grid_array(col, row)
end function
subroutine setValueGC_dg(self, coord, value)
CLASS(DefaultGrid) :: self
CLASS(GridCoordinate) :: coord
real :: value
self%grid_array(coord%getColumn(), coord%getRow()) = value
end subroutine
subroutine setValueInt_dg(self, col, row, value)
CLASS(DefaultGrid) :: self
integer :: col, row
real :: value
self%grid_array(col, row) = value
end subroutine
function constructor(source_array)
real, dimension(:,:), pointer :: source_array
CLASS(DefaultGrid), pointer :: constructor
ALLOCATE(constructor)
constructor%grid_array = source_array
end function
end module grid_mod