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 tags/nemo_v3_2/nemo_v3_2/NEMO/NST_SRC – NEMO

source: tags/nemo_v3_2/nemo_v3_2/NEMO/NST_SRC/agrif_opa_update.F90 @ 1878

Last change on this file since 1878 was 1878, checked in by flavoni, 14 years ago

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