libsim  Versione 7.1.8
grid_rect_class.F90
1 ! Copyright (C) 2010 ARPA-SIM <urpsim@smr.arpa.emr.it>
2 ! authors:
3 ! Davide Cesari <dcesari@arpa.emr.it>
4 ! Paolo Patruno <ppatruno@arpa.emr.it>
5 
6 ! This program is free software; you can redistribute it and/or
7 ! modify it under the terms of the GNU General Public License as
8 ! published by the Free Software Foundation; either version 2 of
9 ! the License, or (at your option) any later version.
10 
11 ! This program is distributed in the hope that it will be useful,
12 ! but WITHOUT ANY WARRANTY; without even the implied warranty of
13 ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14 ! GNU General Public License for more details.
15 
16 ! You should have received a copy of the GNU General Public License
17 ! along with this program. If not, see <http://www.gnu.org/licenses/>.
18 #include "config.h"
19 MODULE grid_rect_class
22 IMPLICIT NONE
23 
24 TYPE grid_rect
25  DOUBLE PRECISION :: xmin
26  DOUBLE PRECISION :: xmax
27  DOUBLE PRECISION :: ymin
28  DOUBLE PRECISION :: ymax
29  DOUBLE PRECISION :: dx
30  DOUBLE PRECISION :: dy
31  INTEGER :: component_flag
32 END TYPE grid_rect
33 
34 INTERFACE delete
35  MODULE PROCEDURE grid_rect_delete
36 END INTERFACE
37 
38 INTERFACE get_val
39  MODULE PROCEDURE grid_rect_get_val
40 END INTERFACE
41 
42 INTERFACE set_val
43  MODULE PROCEDURE grid_rect_set_val
44 END INTERFACE
45 
46 INTERFACE copy
47  MODULE PROCEDURE grid_rect_copy
48 END INTERFACE
49 
50 INTERFACE OPERATOR(==)
51  MODULE PROCEDURE grid_rect_eq
52 END INTERFACE
53 
54 INTERFACE write_unit
55  MODULE PROCEDURE grid_rect_write_unit
56 END INTERFACE
57 
58 INTERFACE read_unit
59  MODULE PROCEDURE grid_rect_read_unit
60 END INTERFACE
61 
62 INTERFACE display
63  MODULE PROCEDURE grid_rect_display
64 END INTERFACE
65 
66 
67 PRIVATE grid_rect_delete, grid_rect_get_val, &
68  grid_rect_set_val, grid_rect_copy, grid_rect_eq, &
69  grid_rect_read_unit, grid_rect_write_unit, grid_rect_display
70 
71 CONTAINS
72 
73 FUNCTION grid_rect_new(xmin, xmax, ymin, ymax, dx, dy, component_flag) RESULT(this)
74 DOUBLE PRECISION,INTENT(in),OPTIONAL :: xmin, xmax, ymin, ymax
75 DOUBLE PRECISION,INTENT(in),OPTIONAL :: dx, dy
78 INTEGER,INTENT(in),OPTIONAL :: component_flag
79 
80 TYPE(grid_rect) :: this
81 
82 this%xmin = optio_d(xmin)
83 this%ymin = optio_d(ymin)
84 this%xmax = optio_d(xmax)
85 this%ymax = optio_d(ymax)
86 this%dx = optio_d(dx)
87 this%dy = optio_d(dy)
88 this%component_flag = optio_l(component_flag)
89 
90 END FUNCTION grid_rect_new
91 
92 
93 SUBROUTINE grid_rect_delete(this)
94 TYPE(grid_rect),INTENT(inout) :: this
95 
96 this%xmin = dmiss
97 this%ymin = dmiss
98 this%xmax = dmiss
99 this%ymax = dmiss
100 this%dx = dmiss
101 this%dy = dmiss
102 this%component_flag = imiss
103 
104 END SUBROUTINE grid_rect_delete
105 
106 
107 SUBROUTINE grid_rect_get_val(this, xmin, xmax, ymin, ymax, dx, dy, component_flag)
108 TYPE(grid_rect), INTENT(in) :: this
109 DOUBLE PRECISION,INTENT(out),OPTIONAL :: xmin, xmax, ymin, ymax
110 DOUBLE PRECISION,INTENT(out),OPTIONAL :: dx, dy
113 INTEGER,INTENT(out),OPTIONAL :: component_flag
114 
115 IF (PRESENT(xmin)) THEN
116  xmin = this%xmin
117 ENDIF
118 IF (PRESENT(ymin)) THEN
119  ymin = this%ymin
120 ENDIF
121 IF (PRESENT(xmax)) THEN
122  xmax = this%xmax
123 ENDIF
124 IF (PRESENT(ymax)) THEN
125  ymax = this%ymax
126 ENDIF
127 IF (PRESENT(dx)) THEN
128  dx = this%dx
129 ENDIF
130 IF (PRESENT(dy)) THEN
131  dy = this%dy
132 ENDIF
133 IF (PRESENT(component_flag)) THEN
134  component_flag = this%component_flag
135 ENDIF
136 
137 END SUBROUTINE grid_rect_get_val
138 
139 
140 SUBROUTINE grid_rect_set_val(this, xmin, xmax, ymin, ymax, &
141  dx, dy, component_flag)
142 TYPE(grid_rect), INTENT(inout) :: this
143 DOUBLE PRECISION,INTENT(in),OPTIONAL :: xmin, xmax, ymin, ymax
144 DOUBLE PRECISION,INTENT(in),OPTIONAL :: dx, dy
147 INTEGER,INTENT(in),OPTIONAL :: component_flag
148 
149 
150 IF (PRESENT(xmin)) THEN
151  this%xmin = xmin
152 ENDIF
153 IF (PRESENT(ymin)) THEN
154  this%ymin = ymin
155 ENDIF
156 IF (PRESENT(xmax)) THEN
157  this%xmax = xmax
158 ENDIF
159 IF (PRESENT(ymax)) THEN
160  this%ymax = ymax
161 ENDIF
162 IF (PRESENT(dx)) THEN
163  this%dx = dx
164 ENDIF
165 IF (PRESENT(dy)) THEN
166  this%dy = dy
167 ENDIF
168 IF (PRESENT(component_flag)) THEN
169  this%component_flag = component_flag
170 ENDIF
171 
172 END SUBROUTINE grid_rect_set_val
173 
174 
175 SUBROUTINE grid_rect_copy(this, that)
176 TYPE(grid_rect), INTENT(in) :: this
177 TYPE(grid_rect), INTENT(out) :: that
178 
179 that = this
180 
181 END SUBROUTINE grid_rect_copy
182 
183 
184 ELEMENTAL FUNCTION grid_rect_eq(this, that) RESULT(res)
185 TYPE(grid_rect), INTENT(in) :: this
186 TYPE(grid_rect), INTENT(in) :: that
187 
188 LOGICAL :: res
189 
190 
191 res = (this%xmin == that%xmin .AND. this%xmax == that%xmax .AND. &
192  this%ymin == that%ymin .AND. this%ymax == that%ymax .AND. &
193  this%dx == that%dx .AND. this%dy == that%dy .AND. &
194  this%component_flag == that%component_flag)
195 
196 END FUNCTION grid_rect_eq
197 
198 
203 SUBROUTINE grid_rect_read_unit(this, unit)
204 TYPE(grid_rect),INTENT(out) :: this
205 INTEGER, INTENT(in) :: unit
206 
207 CHARACTER(len=40) :: form
208 
209 INQUIRE(unit, form=form)
210 IF (form == 'FORMATTED') THEN
211  READ(unit,*)this%xmin,this%ymin,this%xmax,this%ymax,this%dx,this%dy,this%component_flag
212 ELSE
213  READ(unit)this%xmin,this%ymin,this%xmax,this%ymax,this%dx,this%dy,this%component_flag
214 ENDIF
215 
216 END SUBROUTINE grid_rect_read_unit
217 
218 
223 SUBROUTINE grid_rect_write_unit(this, unit)
224 TYPE(grid_rect),INTENT(in) :: this
225 INTEGER, INTENT(in) :: unit
226 
227 CHARACTER(len=40) :: form
228 
229 INQUIRE(unit, form=form)
230 IF (form == 'FORMATTED') THEN
231  WRITE(unit,*)this%xmin,this%ymin,this%xmax,this%ymax,this%dx,this%dy,this%component_flag
232 ELSE
233  WRITE(unit)this%xmin,this%ymin,this%xmax,this%ymax,this%dx,this%dy,this%component_flag
234 ENDIF
235 
236 END SUBROUTINE grid_rect_write_unit
237 
238 
240 SUBROUTINE grid_rect_display(this)
241 TYPE(grid_rect),INTENT(in) :: this
242 
243 print*,"xFirst",this%xmin
244 print*,"xLast ",this%xmax
245 print*,"yFirst",this%ymin
246 print*,"yLast ",this%ymax
247 print*,"dx, dy",this%dx,this%dy
248 print*,"componentFlag",this%component_flag
249 
250 END SUBROUTINE grid_rect_display
251 
252 
256 SUBROUTINE grid_rect_coordinates(this, x, y)
257 TYPE(grid_rect),INTENT(in) :: this
258 DOUBLE PRECISION,INTENT(out) :: x(:,:)
259 DOUBLE PRECISION,INTENT(out) :: y(:,:)
260 
261 DOUBLE PRECISION :: dx, dy
262 INTEGER :: nx, ny, i, j
263 
264 nx = SIZE(x,1)
265 ny = SIZE(x,2)
266 
267 #ifdef DEBUG
268 IF (SIZE(y,1) /= nx .OR. SIZE(y,2) /= ny) THEN
269  x(:,:) = dmiss
270  y(:,:) = dmiss
271  RETURN
272 ENDIF
273 #endif
274 
275 CALL grid_rect_steps(this, nx, ny, dx, dy)
276 IF (c_e(dx) .AND. c_e(dy)) THEN
277  x(:,:) = reshape((/ ((this%xmin+(dx*dble(i)), i=0,nx-1), j=0,ny-1) /),&
278  (/nx,ny/))
279  y(:,:) = reshape((/ ((this%ymin+(dy*dble(j)), i=0,nx-1), j=0,ny-1) /),&
280  (/nx,ny/))
281 ELSE
282  x(:,:) = dmiss
283  y(:,:) = dmiss
284 ENDIF
285 
286 END SUBROUTINE grid_rect_coordinates
287 
288 
290 SUBROUTINE grid_rect_steps(this, nx, ny, dx, dy)
291 TYPE(grid_rect), INTENT(in) :: this
292 INTEGER,INTENT(in) :: nx
293 INTEGER,INTENT(in) :: ny
294 DOUBLE PRECISION,INTENT(out) :: dx
295 DOUBLE PRECISION,INTENT(out) :: dy
296 
297 IF (c_e(nx) .AND. c_e(this%xmax) .AND. c_e(this%xmin) .AND. &
298  c_e(nx) .AND. nx > 1) THEN
299  dx = (this%xmax - this%xmin)/dble(nx - 1)
300 ELSE
301  dx = dmiss
302 ENDIF
303 IF (c_e(ny) .AND. c_e(this%ymax) .AND. c_e(this%ymin) .AND. &
304  c_e(ny) .AND. ny > 1) THEN
305  dy = (this%ymax - this%ymin)/dble(ny - 1)
306 ELSE
307  dy = dmiss
308 ENDIF
309 
310 END SUBROUTINE grid_rect_steps
311 
312 
314 SUBROUTINE grid_rect_setsteps(this, nx, ny)
315 TYPE(grid_rect), INTENT(inout) :: this
316 INTEGER,INTENT(in) :: nx
317 INTEGER,INTENT(in) :: ny
318 
319 CALL grid_rect_steps(this, nx, ny, this%dx, this%dy)
320 
321 END SUBROUTINE grid_rect_setsteps
322 
323 END MODULE grid_rect_class
324 
Function to check whether a value is missing or not.
Definitions of constants and functions for working with missing values.
Module for quickly interpreting the OPTIONAL parameters passed to a subprogram.

Generated with Doxygen.