libsim Versione 7.2.4
grid_transform_test.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! Programma di test per il module simple_stat
19! migliorare a piacimento
20PROGRAM grid_transform_test
23IMPLICIT NONE
24
25
26INTEGER,PARAMETER :: ninterv=5, nval=7
27REAL :: interv_lower(ninterv)=(/20.,20.,rmiss,20.,20./), &
28 interv_upper(ninterv)=(/40.,rmiss,40.,20.,10./), &
29 interv_testval(nval)=(/5.,10.,15.,20.,30.,40.,50./)
30REAL :: interv_ffresult(nval,ninterv)=reshape((/ &
31 0,0,0,0,1,0,0, &
32 0,0,0,0,1,1,1, &
33 1,1,1,1,1,0,0, &
34 0,0,0,0,0,0,0, &
35 0,0,0,0,0,0,0 &
36 /), (/nval,ninterv/))
37REAL :: &
38interv_ftresult(nval,ninterv)=reshape((/ &
39 0,0,0,0,1,1,0, &
40 0,0,0,0,1,1,1, &
41 1,1,1,1,1,1,0, &
42 0,0,0,0,0,0,0, &
43 0,0,0,0,0,0,0 &
44 /), (/nval,ninterv/)), &
45interv_tfresult(nval,ninterv)=reshape((/ &
46 0,0,0,1,1,0,0, &
47 0,0,0,1,1,1,1, &
48 1,1,1,1,1,0,0, &
49 0,0,0,0,0,0,0, &
50 0,0,0,0,0,0,0 &
51 /), (/nval,ninterv/)), &
52interv_ttresult(nval,ninterv)=reshape((/ &
53 0,0,0,1,1,1,0, &
54 0,0,0,1,1,1,1, &
55 1,1,1,1,1,1,0, &
56 0,0,0,1,0,0,0, &
57 0,0,0,0,0,0,0 &
58 /), (/nval,ninterv/)), &
59 tmpresult(nval,ninterv)
60
61INTEGER :: i, j
62TYPE(interval_info) :: interv, interv_init
63
64print*,'=== Testing grid_transform module ==='
65
66print*,'Checking intervals a<x<b'
67DO j = 1, ninterv
68 interv = interval_info_new(interv_gt=interv_lower(j), interv_lt=interv_upper(j))
69 DO i = 1, nval
70 tmpresult(i,j) = interval_info_valid(interv, interv_testval(i))
71 ENDDO
72ENDDO
73CALL interv_print_result(tmpresult, interv_ffresult)
74
75print*,'Checking intervals a<x<=b'
76DO j = 1, ninterv
77 interv = interval_info_new(interv_gt=interv_lower(j), interv_le=interv_upper(j))
78 DO i = 1, nval
79 tmpresult(i,j) = interval_info_valid(interv, interv_testval(i))
80 ENDDO
81ENDDO
82CALL interv_print_result(tmpresult, interv_ftresult)
83
84print*,'Checking intervals a<=x<b'
85DO j = 1, ninterv
86 interv = interval_info_new(interv_ge=interv_lower(j), interv_lt=interv_upper(j))
87 DO i = 1, nval
88 tmpresult(i,j) = interval_info_valid(interv, interv_testval(i))
89 ENDDO
90ENDDO
91CALL interv_print_result(tmpresult, interv_tfresult)
92
93print*,'Checking intervals a<=x<=b'
94DO j = 1, ninterv
95 interv = interval_info_new(interv_ge=interv_lower(j), interv_le=interv_upper(j))
96 DO i = 1, nval
97 tmpresult(i,j) = interval_info_valid(interv, interv_testval(i))
98 ENDDO
99ENDDO
100CALL interv_print_result(tmpresult, interv_ttresult)
101
102CONTAINS
103
104SUBROUTINE interv_print_result(res, ref)
105REAL,INTENT(in) :: res(nval,ninterv), ref(nval,ninterv)
106
107IF (count(res == ref) == nval*ninterv) THEN
108ELSE
109
110 DO j = 1, ninterv
111 DO i = 1, nval
112 IF (res(i,j) /= ref(i,j)) THEN
113 print*,'Failing: ',interv_lower(j),'<(=)',interv_testval(i),'<(=)',interv_upper(j)
114 print*,'Result: ',res(i,j),' Reference: ',ref(i,j)
115 ENDIF
116 ENDDO
117 ENDDO
118 CALL exit(1)
119ENDIF
120
121END SUBROUTINE interv_print_result
122
123
124
125END PROGRAM grid_transform_test
Module for defining transformations between rectangular georeferenced grids and between grids and spa...
Definitions of constants and functions for working with missing values.

Generated with Doxygen.