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

source: trunk/NEMO/NST_SRC/agrif_opa_update.F90 @ 1437

Last change on this file since 1437 was 1300, checked in by rblod, 15 years ago

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