source: branches/2016/dev_HPC_Gyre_benchmark_test/NEMOGCM/TOOLS/COUNTERS/TESTS/nemo_test.F90 @ 6540

Last change on this file since 6540 was 6540, checked in by mocavero, 6 years ago

added TESTS dir

File size: 8.1 KB
Line 
1PROGRAM nemo
2
3     interface
4        subroutine counting_init ( ) bind ( C,       &
5     & name ="counting_init" )
6                use iso_c_binding
7        end subroutine counting_init
8
9        subroutine counting_start ( ) bind ( C,       &
10     & name ="counting_start" )
11                use iso_c_binding
12        end subroutine counting_start
13
14        subroutine counting_stop ( ) bind ( C,        &
15     & name ="counting_stop" )
16                use iso_c_binding
17        end subroutine counting_stop
18      end interface
19
20     CALL test
21
22CONTAINS
23
24   subroutine test
25
26   REAL, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: tsn, pun, pvn, pwn
27   REAL, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: mydomain, zslpx, zslpy, zwx, zwy, umask, vmask, tmask, zind
28   REAL, ALLOCATABLE, SAVE, DIMENSION(:,:)   :: ztfreez, rnfmsk, upsmsk
29   REAL, ALLOCATABLE, SAVE, DIMENSION(:)     :: rnfmsk_z
30   REAL                                      :: zice
31   REAL                                      ::   zu, z0u, zzwx
32   REAL                                      ::   zv, z0v, zzwy
33   REAL                                      ::   ztra, zbtr, zdt, zalpha
34   INTEGER                                   :: jpi, jpj, jpk
35   INTEGER                                   :: ji, jj, jk
36   CHARACTER(len=10)                         :: env
37
38   CALL get_environment_variable("JPI", env)
39   READ ( env, '(i10)' ) jpi
40   CALL get_environment_variable("JPJ", env)
41   READ ( env, '(i10)' ) jpj
42   CALL get_environment_variable("JPK", env)
43   READ ( env, '(i10)' ) jpk
44
45   ALLOCATE( mydomain (jpi,jpj,jpk))
46   ALLOCATE( zwx (jpi,jpj,jpk))
47   ALLOCATE( zwy (jpi,jpj,jpk))
48   ALLOCATE( zslpx (jpi,jpj,jpk))
49   ALLOCATE( zslpy (jpi,jpj,jpk))
50   ALLOCATE( pun (jpi,jpj,jpk))
51   ALLOCATE( pvn (jpi,jpj,jpk))
52   ALLOCATE( pwn (jpi,jpj,jpk))
53   ALLOCATE( umask (jpi,jpj,jpk))
54   ALLOCATE( vmask (jpi,jpj,jpk))
55   ALLOCATE( tmask (jpi,jpj,jpk))
56   ALLOCATE( zind (jpi,jpj,jpk))
57   ALLOCATE( ztfreez (jpi,jpj))
58   ALLOCATE( rnfmsk (jpi,jpj))
59   ALLOCATE( upsmsk (jpi,jpj))
60   ALLOCATE( rnfmsk_z (jpk))
61   ALLOCATE( tsn(jpi,jpj,jpk))
62
63! array initialization
64   DO jk = 1, jpk
65     DO jj = 1, jpj
66       DO ji = 1, jpi
67         tsn(ji,jj,jk)= ji*jj*jk
68         mydomain(ji,jj,jk) =ji*jj*jk
69         umask(ji,jj,jk) = ji*jj*jk
70         vmask(ji,jj,jk)= ji*jj*jk
71         tmask(ji,jj,jk)= ji*jj*jk
72         pun(ji,jj,jk) =ji*jj*jk
73         pvn(ji,jj,jk) =ji*jj*jk
74         pwn(ji,jj,jk) =ji*jj*jk
75       END DO
76     END DO
77   END DO
78
79   DO jj=1, jpj
80     DO ji=1, jpi
81       ztfreez(ji,jj)=ji*jj
82       upsmsk(ji,jj)=ji*jj
83       rnfmsk(ji,jj) = ji*jj
84     END DO
85   END DO
86
87   DO jk=1, jpk
88     rnfmsk_z(jk)=jk
89   END DO
90
91
92!***********************
93!* Start of the synphony
94!***********************
95
96   call counting_init()
97   call counting_start ()
98   DO jk = 1, jpk
99     DO jj = 1, jpj
100       DO ji = 1, jpi
101         IF( tsn(ji,jj,jk) <= ztfreez(ji,jj) + 0.1 ) THEN   ;   zice = 1.e0
102         ELSE                                                      ;   zice = 0.e0
103         ENDIF
104         zind(ji,jj,jk) = MAX (   &
105           rnfmsk(ji,jj) * rnfmsk_z(jk),      & 
106           upsmsk(ji,jj)               ,      &
107           zice                               &
108           &                  ) * tmask(ji,jj,jk)
109           zind(ji,jj,jk) = 1 - zind(ji,jj,jk)
110         END DO
111       END DO
112     END DO
113
114     zwx(:,:,jpk) = 0.e0   ;   zwy(:,:,jpk) = 0.e0 
115
116     DO jk = 1, jpk-1
117       DO jj = 1, jpj-1
118         DO ji = 1, jpi-1
119           zwx(ji,jj,jk) = umask(ji,jj,jk) * ( mydomain(ji+1,jj,jk) - mydomain(ji,jj,jk) )
120           zwy(ji,jj,jk) = vmask(ji,jj,jk) * ( mydomain(ji,jj+1,jk) - mydomain(ji,jj,jk) )
121         END DO
122       END DO
123     END DO
124
125     zslpx(:,:,jpk) = 0.e0   ;   zslpy(:,:,jpk) = 0.e0
126
127     DO jk = 1, jpk-1
128       DO jj = 2, jpj
129         DO ji = 2, jpi
130           zslpx(ji,jj,jk) =                    ( zwx(ji,jj,jk) + zwx(ji-1,jj  ,jk) )   &
131             &            * ( 0.25 + SIGN( 0.25, zwx(ji,jj,jk) * zwx(ji-1,jj  ,jk) ) )
132           zslpy(ji,jj,jk) =                    ( zwy(ji,jj,jk) + zwy(ji  ,jj-1,jk) )   &
133             &            * ( 0.25 + SIGN( 0.25, zwy(ji,jj,jk) * zwy(ji  ,jj-1,jk) ) )
134         END DO
135       END DO
136     END DO
137
138     DO jk = 1, jpk-1
139       DO jj = 2, jpj
140         DO ji = 2, jpi
141           zslpx(ji,jj,jk) = SIGN( 1., zslpx(ji,jj,jk) ) * MIN(    ABS( zslpx(ji  ,jj,jk) ),   &
142             &                                                 2.*ABS( zwx  (ji-1,jj,jk) ),   &
143             &                                                 2.*ABS( zwx  (ji  ,jj,jk) ) )
144           zslpy(ji,jj,jk) = SIGN( 1., zslpy(ji,jj,jk) ) * MIN(    ABS( zslpy(ji,jj  ,jk) ),   &
145             &                                                 2.*ABS( zwy  (ji,jj-1,jk) ),   &
146             &                                                 2.*ABS( zwy  (ji,jj  ,jk) ) )
147         END DO
148       END DO
149     END DO
150
151     DO jk = 1, jpk-1
152       zdt  = 1
153       DO jj = 2, jpj-1
154         DO ji = 2, jpi-1
155           z0u = SIGN( 0.5, pun(ji,jj,jk) )
156           zalpha = 0.5 - z0u
157           zu  = z0u - 0.5 * pun(ji,jj,jk) * zdt
158
159           zzwx = mydomain(ji+1,jj,jk) + zind(ji,jj,jk) * (zu * zslpx(ji+1,jj,jk))
160           zzwy = mydomain(ji  ,jj,jk) + zind(ji,jj,jk) * (zu * zslpx(ji  ,jj,jk))
161
162           zwx(ji,jj,jk) = pun(ji,jj,jk) * ( zalpha * zzwx + (1.-zalpha) * zzwy )
163           z0v = SIGN( 0.5, pvn(ji,jj,jk) )
164           zalpha = 0.5 - z0v
165           zv  = z0v - 0.5 * pvn(ji,jj,jk) * zdt
166
167           zzwx = mydomain(ji,jj+1,jk) + zind(ji,jj,jk) * (zv * zslpy(ji,jj+1,jk))
168           zzwy = mydomain(ji,jj  ,jk) + zind(ji,jj,jk) * (zv * zslpy(ji,jj  ,jk))
169
170           zwy(ji,jj,jk) = pvn(ji,jj,jk) * ( zalpha * zzwx + (1.-zalpha) * zzwy )
171         END DO
172       END DO
173     END DO
174
175     DO jk = 1, jpk-1
176       DO jj = 2, jpj-1     
177         DO ji = 2, jpi-1
178           zbtr = 1.
179           ztra = - zbtr * ( zwx(ji,jj,jk) - zwx(ji-1,jj  ,jk  )   &
180            &               + zwy(ji,jj,jk) - zwy(ji  ,jj-1,jk  ) )
181           mydomain(ji,jj,jk) = mydomain(ji,jj,jk) + ztra
182         END DO
183       END DO
184     END DO
185
186     zwx (:,:, 1 ) = 0.e0    ;    zwx (:,:,jpk) = 0.e0
187
188     DO jk = 2, jpk-1
189       zwx(:,:,jk) = tmask(:,:,jk) * ( mydomain(:,:,jk-1) - mydomain(:,:,jk) )
190     END DO
191
192     zslpx(:,:,1) = 0.e0
193
194     DO jk = 2, jpk-1
195       DO jj = 1, jpj
196         DO ji = 1, jpi
197           zslpx(ji,jj,jk) =                    ( zwx(ji,jj,jk) + zwx(ji,jj,jk+1) )   &
198              &            * ( 0.25 + SIGN( 0.25, zwx(ji,jj,jk) * zwx(ji,jj,jk+1) ) )
199         END DO
200       END DO
201     END DO
202
203     DO jk = 2, jpk-1
204       DO jj = 1, jpj
205         DO ji = 1, jpi
206           zslpx(ji,jj,jk) = SIGN( 1., zslpx(ji,jj,jk) ) * MIN(    ABS( zslpx(ji,jj,jk  ) ),   &
207                &                                                 2.*ABS( zwx  (ji,jj,jk+1) ),   &
208                &                                                 2.*ABS( zwx  (ji,jj,jk  ) )  )
209         END DO
210       END DO
211     END DO
212
213     zwx(:,:, 1 ) = pwn(:,:,1) * mydomain(:,:,1)
214
215     zdt  = 1
216     zbtr = 1.
217     DO jk = 1, jpk-1
218       DO jj = 2, jpj-1     
219         DO ji = 2, jpi-1
220           z0w = SIGN( 0.5, pwn(ji,jj,jk+1) )
221           zalpha = 0.5 + z0w
222           zw  = z0w - 0.5 * pwn(ji,jj,jk+1) * zdt * zbtr
223
224           zzwx = mydomain(ji,jj,jk+1) + zind(ji,jj,jk) * (zw * zslpx(ji,jj,jk+1))
225           zzwy = mydomain(ji,jj,jk  ) + zind(ji,jj,jk) * (zw * zslpx(ji,jj,jk  ))
226
227           zwx(ji,jj,jk+1) = pwn(ji,jj,jk+1) * ( zalpha * zzwx + (1.-zalpha) * zzwy )
228         END DO
229       END DO
230     END DO
231
232     zbtr = 1.
233     DO jk = 1, jpk-1
234       DO jj = 2, jpj-1     
235         DO ji = 2, jpi-1
236           ztra = - zbtr * ( zwx(ji,jj,jk) - zwx(ji,jj,jk+1) )
237           mydomain(ji,jj,jk) =  mydomain(ji,jj,jk) + ztra
238         END DO
239       END DO
240     END DO
241   
242     call counting_stop()
243
244     DEALLOCATE(mydomain)
245     DEALLOCATE(zwx)
246     DEALLOCATE(zwy)
247     DEALLOCATE(zslpx)
248     DEALLOCATE(zslpy)
249     DEALLOCATE(pun)
250     DEALLOCATE(pvn)
251     DEALLOCATE(pwn)
252     DEALLOCATE(umask)
253     DEALLOCATE(vmask)
254     DEALLOCATE(tmask)
255     DEALLOCATE(zind)
256     DEALLOCATE(ztfreez)
257     DEALLOCATE(rnfmsk)
258     DEALLOCATE(upsmsk)
259     DEALLOCATE(rnfmsk_z)
260     DEALLOCATE(tsn)
261
262     end subroutine test
263
264END PROGRAM nemo
Note: See TracBrowser for help on using the repository browser.