New URL for NEMO forge!   http://forge.nemo-ocean.eu

Since March 2022 along with NEMO 4.2 release, the code development moved to a self-hosted GitLab.
This present forge is now archived and remained online for history.
agrif_opa_update.F90 in branches/2013/dev_MERGE_2013/NEMOGCM/NEMO/NST_SRC – NEMO

source: branches/2013/dev_MERGE_2013/NEMOGCM/NEMO/NST_SRC/agrif_opa_update.F90 @ 4317

Last change on this file since 4317 was 3294, checked in by rblod, 12 years ago

Merge of 3.4beta into the trunk
  • Property svn:keywords set to Id
File size: 11.1 KB
Line 
1#define TWO_WAY
2
3MODULE agrif_opa_update
4#if defined key_agrif  && ! defined key_offline
5   USE par_oce
6   USE oce
7   USE dom_oce
8   USE agrif_oce
9   USE in_out_manager  ! I/O manager
10   USE lib_mpp
11   USE wrk_nemo 
12
13   IMPLICIT NONE
14   PRIVATE
15
16   PUBLIC Agrif_Update_Tra, Agrif_Update_Dyn
17
18   INTEGER, PUBLIC :: nbcline = 0
19
20   !!----------------------------------------------------------------------
21   !! NEMO/NST 3.3 , NEMO Consortium (2010)
22   !! $Id$
23   !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt)
24   !!----------------------------------------------------------------------
25
26CONTAINS
27
28   SUBROUTINE Agrif_Update_Tra( kt )
29      !!---------------------------------------------
30      !!   *** ROUTINE Agrif_Update_Tra ***
31      !!---------------------------------------------
32      !!
33      INTEGER, INTENT(in) :: kt
34      REAL(wp), POINTER, DIMENSION(:,:,:,:) :: ztab
35
36       
37      IF((Agrif_NbStepint() .NE. (Agrif_irhot()-1)).AND.(kt /= 0)) RETURN
38#if defined TWO_WAY
39      CALL wrk_alloc( jpi, jpj, jpk, jpts, ztab )
40
41      Agrif_UseSpecialValueInUpdate = .TRUE.
42      Agrif_SpecialValueFineGrid = 0.
43
44      IF (MOD(nbcline,nbclineupdate) == 0) THEN
45         CALL Agrif_Update_Variable(ztab,tsn_id, procname=updateTS)
46      ELSE
47         CALL Agrif_Update_Variable(ztab,tsn_id,locupdate=(/0,2/), procname=updateTS)
48      ENDIF
49
50      Agrif_UseSpecialValueInUpdate = .FALSE.
51
52      CALL wrk_dealloc( jpi, jpj, jpk, jpts, ztab )
53#endif
54
55   END SUBROUTINE Agrif_Update_Tra
56
57   SUBROUTINE Agrif_Update_Dyn( kt )
58      !!---------------------------------------------
59      !!   *** ROUTINE Agrif_Update_Dyn ***
60      !!---------------------------------------------
61      !!
62      INTEGER, INTENT(in) :: kt
63      REAL(wp), POINTER, DIMENSION(:,:) :: ztab2d
64      REAL(wp), POINTER, DIMENSION(:,:,:) :: ztab
65
66
67      IF ((Agrif_NbStepint() .NE. (Agrif_irhot()-1)).AND.(kt /= 0)) Return
68#if defined TWO_WAY
69      CALL wrk_alloc( jpi, jpj,      ztab2d )
70      CALL wrk_alloc( jpi, jpj, jpk, ztab   )
71
72      IF (mod(nbcline,nbclineupdate) == 0) THEN
73         CALL Agrif_Update_Variable(ztab,un_id,procname = updateU)
74         CALL Agrif_Update_Variable(ztab,vn_id,procname = updateV)
75      ELSE
76         CALL Agrif_Update_Variable(ztab,un_id,locupdate=(/0,1/),procname = updateU)
77         CALL Agrif_Update_Variable(ztab,vn_id,locupdate=(/0,1/),procname = updateV)         
78      ENDIF
79
80      CALL Agrif_Update_Variable(ztab2d,e1u_id,procname = updateU2d)
81      CALL Agrif_Update_Variable(ztab2d,e2v_id,procname = updateV2d) 
82
83      nbcline = nbcline + 1
84
85      Agrif_UseSpecialValueInUpdate = ln_spc_dyn
86      Agrif_SpecialValueFineGrid = 0.
87      CALL Agrif_Update_Variable(ztab2d,sshn_id,procname = updateSSH)
88      Agrif_UseSpecialValueInUpdate = .FALSE.
89
90      CALL wrk_dealloc( jpi, jpj,      ztab2d )
91      CALL wrk_dealloc( jpi, jpj, jpk, ztab   )
92
93!Done in step
94!      CALL Agrif_ChildGrid_To_ParentGrid()
95!      CALL recompute_diags( kt )
96!      CALL Agrif_ParentGrid_To_ChildGrid()
97
98#endif
99
100   END SUBROUTINE Agrif_Update_Dyn
101
102   SUBROUTINE recompute_diags( kt )
103      !!---------------------------------------------
104      !!   *** ROUTINE recompute_diags ***
105      !!---------------------------------------------
106      INTEGER, INTENT(in) :: kt
107
108   END SUBROUTINE recompute_diags
109
110   SUBROUTINE updateTS( tabres, i1, i2, j1, j2, k1, k2, n1, n2, before )
111      !!---------------------------------------------
112      !!           *** ROUTINE updateT ***
113      !!---------------------------------------------
114#  include "domzgr_substitute.h90"
115
116      INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2,n1,n2
117      REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2), INTENT(inout) :: tabres
118      LOGICAL, iNTENT(in) :: before
119
120      INTEGER :: ji,jj,jk,jn
121
122      IF (before) THEN
123         DO jn = n1,n2
124            DO jk=k1,k2
125               DO jj=j1,j2
126                  DO ji=i1,i2
127                     tabres(ji,jj,jk,jn) = tsn(ji,jj,jk,jn)
128                  END DO
129               END DO
130            END DO
131         END DO
132      ELSE
133         DO jn = n1,n2
134            DO jk=k1,k2
135               DO jj=j1,j2
136                  DO ji=i1,i2
137                     IF( tabres(ji,jj,jk,jn) .NE. 0. ) THEN
138                         tsn(ji,jj,jk,jn) = tabres(ji,jj,jk,jn) * tmask(ji,jj,jk)
139                     END IF
140                  END DO
141               END DO
142            END DO
143         END DO
144      ENDIF
145
146   END SUBROUTINE updateTS
147
148   SUBROUTINE updateu( tabres, i1, i2, j1, j2, k1, k2, before )
149      !!---------------------------------------------
150      !!           *** ROUTINE updateu ***
151      !!---------------------------------------------
152#  include "domzgr_substitute.h90"
153
154      INTEGER, INTENT(in) :: i1, i2, j1, j2, k1, k2
155      REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: tabres
156      LOGICAL, INTENT(in) :: before
157
158      INTEGER :: ji, jj, jk
159      REAL(wp) :: zrhoy
160
161      IF (before) THEN
162         zrhoy = Agrif_Rhoy()
163         DO jk=k1,k2
164            DO jj=j1,j2
165               DO ji=i1,i2
166                  tabres(ji,jj,jk) = e2u(ji,jj) * un(ji,jj,jk)
167                  tabres(ji,jj,jk) = tabres(ji,jj,jk) * fse3u(ji,jj,jk)
168               END DO
169            END DO
170         END DO
171         tabres = zrhoy * tabres
172      ELSE
173         DO jk=k1,k2
174            DO jj=j1,j2
175               DO ji=i1,i2
176                  un(ji,jj,jk) = tabres(ji,jj,jk) / (e2u(ji,jj))
177                  un(ji,jj,jk) = un(ji,jj,jk) * umask(ji,jj,jk)
178                  un(ji,jj,jk) = un(ji,jj,jk) / fse3u(ji,jj,jk)
179               END DO
180            END DO
181         END DO
182      ENDIF
183
184   END SUBROUTINE updateu
185
186   SUBROUTINE updatev( tabres, i1, i2, j1, j2, k1, k2, before )
187      !!---------------------------------------------
188      !!           *** ROUTINE updatev ***
189      !!---------------------------------------------
190#  include "domzgr_substitute.h90"
191
192      INTEGER :: i1,i2,j1,j2,k1,k2
193      INTEGER :: ji,jj,jk
194      REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2) :: tabres
195      LOGICAL :: before
196
197      REAL(wp) :: zrhox
198
199      IF (before) THEN
200         zrhox = Agrif_Rhox()
201         DO jk=k1,k2
202            DO jj=j1,j2
203               DO ji=i1,i2
204                  tabres(ji,jj,jk) = e1v(ji,jj) * vn(ji,jj,jk)
205                  tabres(ji,jj,jk) = tabres(ji,jj,jk) * fse3v(ji,jj,jk)
206               END DO
207            END DO
208         END DO
209         tabres = zrhox * tabres
210      ELSE
211         DO jk=k1,k2
212            DO jj=j1,j2
213               DO ji=i1,i2
214                  vn(ji,jj,jk) = tabres(ji,jj,jk) / (e1v(ji,jj))
215                  vn(ji,jj,jk) = vn(ji,jj,jk) * vmask(ji,jj,jk)
216                  vn(ji,jj,jk) = vn(ji,jj,jk) / fse3v(ji,jj,jk)
217               END DO
218            END DO
219         END DO
220      ENDIF
221
222   END SUBROUTINE updatev
223
224   SUBROUTINE updateu2d( tabres, i1, i2, j1, j2, before )
225      !!---------------------------------------------
226      !!          *** ROUTINE updateu2d ***
227      !!---------------------------------------------
228#  include "domzgr_substitute.h90"
229
230      INTEGER, INTENT(in) :: i1, i2, j1, j2
231      REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres
232      LOGICAL, INTENT(in) :: before
233
234      INTEGER :: ji, jj, jk
235      REAL(wp) :: zrhoy
236      REAL(wp) :: zhinv
237
238      IF (before) THEN
239         zrhoy = Agrif_Rhoy()
240         DO jk = 1,jpkm1
241            DO jj=j1,j2
242               DO ji=i1,i2
243                  tabres(ji,jj) = tabres(ji,jj) + fse3u(ji,jj,jk) * un(ji,jj,jk)
244               END DO
245            END DO
246         END DO
247         DO jj=j1,j2
248            DO ji=i1,i2
249               tabres(ji,jj) = tabres(ji,jj) * e2u(ji,jj)
250            END DO
251         END DO
252         tabres = zrhoy * tabres
253      ELSE
254         DO jj=j1,j2
255            DO ji=i1,i2
256               IF(umask(ji,jj,1) .NE. 0.) THEN             
257                  spgu(ji,jj) = 0.e0
258                  DO jk=1,jpk
259                     spgu(ji,jj) = spgu(ji,jj) + fse3u(ji,jj,jk) * un(ji,jj,jk)
260                  END DO
261                  spgu(ji,jj) = spgu(ji,jj) * e2u(ji,jj)
262                  zhinv = (tabres(ji,jj)-spgu(ji,jj))/(hu(ji,jj)*e2u(ji,jj))
263                  Do jk=1,jpk             
264                     un(ji,jj,jk) = un(ji,jj,jk) + zhinv
265                     un(ji,jj,jk) = un(ji,jj,jk) * umask(ji,jj,jk)           
266                  END DO
267               ENDIF
268            END DO
269         END DO
270      ENDIF
271
272   END SUBROUTINE updateu2d
273
274   SUBROUTINE updatev2d( tabres, i1, i2, j1, j2, before )
275      !!---------------------------------------------
276      !!          *** ROUTINE updatev2d ***
277      !!---------------------------------------------
278
279      INTEGER, INTENT(in) :: i1, i2, j1, j2
280      REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres
281      LOGICAL, INTENT(in) :: before
282
283      INTEGER :: ji, jj, jk
284      REAL(wp) :: zrhox
285      REAL(wp) :: zhinv
286
287      IF (before) THEN
288         zrhox = Agrif_Rhox()
289         tabres = 0.e0
290         DO jk = 1,jpkm1
291            DO jj=j1,j2
292               DO ji=i1,i2
293                  tabres(ji,jj) = tabres(ji,jj) + fse3v(ji,jj,jk) * vn(ji,jj,jk)
294               END DO
295            END DO
296         END DO
297         DO jj=j1,j2
298            DO ji=i1,i2
299               tabres(ji,jj) = tabres(ji,jj) * e1v(ji,jj)
300            END DO
301         END DO
302         tabres = zrhox * tabres
303      ELSE
304         DO jj=j1,j2
305            DO ji=i1,i2
306               IF(vmask(ji,jj,1) .NE. 0.) THEN             
307                  spgv(ji,jj) = 0.
308                  DO jk=1,jpk
309                     spgv(ji,jj) = spgv(ji,jj) + fse3v(ji,jj,jk) * vn(ji,jj,jk)
310                  END DO
311                  spgv(ji,jj) = spgv(ji,jj) * e1v(ji,jj)
312                  zhinv = (tabres(ji,jj)-spgv(ji,jj))/(hv(ji,jj)*e1v(ji,jj))
313                  DO jk=1,jpk             
314                     vn(ji,jj,jk) = vn(ji,jj,jk) + zhinv
315                     vn(ji,jj,jk) = vn(ji,jj,jk) * vmask(ji,jj,jk)
316                  END DO
317               ENDIF
318            END DO
319         END DO
320      ENDIF
321
322   END SUBROUTINE updatev2d
323
324   SUBROUTINE updateSSH( tabres, i1, i2, j1, j2, before )
325      !!---------------------------------------------
326      !!          *** ROUTINE updateSSH ***
327      !!---------------------------------------------
328#  include "domzgr_substitute.h90"
329
330      INTEGER, INTENT(in) :: i1, i2, j1, j2
331      REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres
332      LOGICAL, INTENT(in) :: before
333
334      INTEGER :: ji, jj
335      REAL(wp) :: zrhox, zrhoy
336
337      IF (before) THEN
338         zrhox = Agrif_Rhox()
339         zrhoy = Agrif_Rhoy()
340         DO jj=j1,j2
341            DO ji=i1,i2
342               tabres(ji,jj) = e1t(ji,jj) * e2t(ji,jj) * sshn(ji,jj)
343            END DO
344         END DO
345         tabres = zrhox * zrhoy * tabres
346      ELSE
347         DO jj=j1,j2
348            DO ji=i1,i2
349               sshn(ji,jj) = tabres(ji,jj) / (e1t(ji,jj) * e2t(ji,jj))
350               sshn(ji,jj) = sshn(ji,jj) * tmask(ji,jj,1)
351            END DO
352         END DO
353      ENDIF
354
355   END SUBROUTINE updateSSH
356
357#else
358CONTAINS
359   SUBROUTINE agrif_opa_update_empty
360      !!---------------------------------------------
361      !!   *** ROUTINE agrif_opa_update_empty ***
362      !!---------------------------------------------
363      WRITE(*,*)  'agrif_opa_update : You should not have seen this print! error?'
364   END SUBROUTINE agrif_opa_update_empty
365#endif
366END MODULE agrif_opa_update
Note: See TracBrowser for help on using the repository browser.