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

source: branches/nemo_v3_3_beta/NEMOGCM/NEMO/NST_SRC/agrif_opa_update.F90 @ 3233

Last change on this file since 3233 was 2487, checked in by rblod, 14 years ago

Correct Agrif inconstency for ssh, nemo_v3_3_beta version, see ticket #669
  • Property svn:keywords set to Id
File size: 11.5 KB
RevLine 
[390]1#define TWO_WAY
2
[636]3MODULE agrif_opa_update
[2342]4#if defined key_agrif  && ! defined key_offline
[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   !!----------------------------------------------------------------------
[2287]18   !! NEMO/NST 3.3 , NEMO Consortium (2010)
[1156]19   !! $Id$
[2287]20   !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt)
[1156]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
[1438]82!Done in step
83!      CALL Agrif_ChildGrid_To_ParentGrid()
84!      CALL recompute_diags( kt )
85!      CALL Agrif_ParentGrid_To_ChildGrid()
[390]86
87#endif
88
[636]89   END SUBROUTINE Agrif_Update_Dyn
90
91   SUBROUTINE recompute_diags( kt )
92      !!---------------------------------------------
93      !!   *** ROUTINE recompute_diags ***
94      !!---------------------------------------------
95      INTEGER, INTENT(in) :: kt
96
97   END SUBROUTINE recompute_diags
98
99   SUBROUTINE updateT( tabres, i1, i2, j1, j2, k1, k2, before )
100      !!---------------------------------------------
101      !!           *** ROUTINE updateT ***
102      !!---------------------------------------------
[390]103#  include "domzgr_substitute.h90"
104
[636]105      INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2
106      REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: tabres
107      LOGICAL, iNTENT(in) :: before
[390]108
[636]109      INTEGER :: ji,jj,jk
110
111      IF (before) THEN
[390]112         DO jk=k1,k2
[636]113            DO jj=j1,j2
114               DO ji=i1,i2
115                  tabres(ji,jj,jk) = tn(ji,jj,jk)
116               END DO
117            END DO
118         END DO
119      ELSE
120         DO jk=k1,k2
121            DO jj=j1,j2
122               DO ji=i1,i2
123                  IF( tabres(ji,jj,jk) .NE. 0. ) THEN
124                     tn(ji,jj,jk) = tabres(ji,jj,jk) * tmask(ji,jj,jk)
125                  ENDIF
126               END DO
127            END DO
128         END DO
129      ENDIF
[390]130
[636]131   END SUBROUTINE updateT
[390]132
[636]133   SUBROUTINE updateS( tabres, i1, i2, j1, j2, k1, k2, before )
134      !!---------------------------------------------
135      !!           *** ROUTINE updateS ***
136      !!---------------------------------------------
[390]137#  include "domzgr_substitute.h90"
138
[636]139      INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2
140      REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: tabres
141      LOGICAL, iNTENT(in) :: before
[390]142
[636]143      INTEGER :: ji,jj,jk
[390]144
[636]145      IF (before) THEN
[390]146         DO jk=k1,k2
[636]147            DO jj=j1,j2
148               DO ji=i1,i2
149                  tabres(ji,jj,jk) = sn(ji,jj,jk)
150               END DO
151            END DO
152         END DO
153      ELSE
154         DO jk=k1,k2
155            DO jj=j1,j2
156               DO ji=i1,i2
157                  IF (tabres(ji,jj,jk).NE.0.) THEN
158                     sn(ji,jj,jk) = tabres(ji,jj,jk) * tmask(ji,jj,jk)
159                  ENDIF
160               END DO
161            END DO
162         END DO
163      ENDIF
[390]164
[636]165   END SUBROUTINE updateS
[390]166
[636]167   SUBROUTINE updateu( tabres, i1, i2, j1, j2, k1, k2, before )
168      !!---------------------------------------------
169      !!           *** ROUTINE updateu ***
170      !!---------------------------------------------
[390]171#  include "domzgr_substitute.h90"
172
[636]173      INTEGER, INTENT(in) :: i1, i2, j1, j2, k1, k2
174      REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: tabres
175      LOGICAL, INTENT(in) :: before
[390]176
[636]177      INTEGER :: ji, jj, jk
178      REAL(wp) :: zrhoy
179
180      IF (before) THEN
181         zrhoy = Agrif_Rhoy()
[390]182         DO jk=k1,k2
[636]183            DO jj=j1,j2
184               DO ji=i1,i2
185                  tabres(ji,jj,jk) = e2u(ji,jj) * un(ji,jj,jk)
186               END DO
187            END DO
188         END DO
189         tabres = zrhoy * tabres
190      ELSE
[390]191         DO jk=k1,k2
[636]192            DO jj=j1,j2
193               DO ji=i1,i2
194                  un(ji,jj,jk) = tabres(ji,jj,jk) / (e2u(ji,jj))
195                  un(ji,jj,jk) = un(ji,jj,jk) * umask(ji,jj,jk)
196                  un(ji,jj,jk) = un(ji,jj,jk) / fse3u(ji,jj,jk)
197               END DO
198            END DO
199         END DO
200      ENDIF
[390]201
[636]202   END SUBROUTINE updateu
[390]203
[636]204   SUBROUTINE updatev( tabres, i1, i2, j1, j2, k1, k2, before )
205      !!---------------------------------------------
206      !!           *** ROUTINE updatev ***
207      !!---------------------------------------------
[390]208#  include "domzgr_substitute.h90"
209
[636]210      INTEGER :: i1,i2,j1,j2,k1,k2
211      INTEGER :: ji,jj,jk
212      REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2) :: tabres
213      LOGICAL :: before
[390]214
[636]215      REAL(wp) :: zrhox
216
217      IF (before) THEN
218         zrhox = Agrif_Rhox()
[390]219         DO jk=k1,k2
[636]220            DO jj=j1,j2
221               DO ji=i1,i2
222                  tabres(ji,jj,jk) = e1v(ji,jj) * vn(ji,jj,jk)
223                  tabres(ji,jj,jk) = tabres(ji,jj,jk) * fse3v(ji,jj,jk)
224               END DO
225            END DO
226         END DO
227         tabres = zrhox * tabres
228      ELSE
[390]229         DO jk=k1,k2
[636]230            DO jj=j1,j2
231               DO ji=i1,i2
232                  vn(ji,jj,jk) = tabres(ji,jj,jk) / (e1v(ji,jj))
233                  vn(ji,jj,jk) = vn(ji,jj,jk) * vmask(ji,jj,jk)
234                  vn(ji,jj,jk) = vn(ji,jj,jk) / fse3v(ji,jj,jk)
235               END DO
236            END DO
237         END DO
238      ENDIF
[390]239
[636]240   END SUBROUTINE updatev
[390]241
[636]242   SUBROUTINE updateu2d( tabres, i1, i2, j1, j2, before )
243      !!---------------------------------------------
244      !!          *** ROUTINE updateu2d ***
245      !!---------------------------------------------
[390]246#  include "domzgr_substitute.h90"
247
[636]248      INTEGER, INTENT(in) :: i1, i2, j1, j2
249      REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres
250      LOGICAL, INTENT(in) :: before
[390]251
[636]252      INTEGER :: ji, jj, jk
253      REAL(wp) :: zrhoy
254      REAL(wp) :: zhinv
[390]255
[636]256      IF (before) THEN
257         zrhoy = Agrif_Rhoy()
258         DO jk = 1,jpkm1
259            DO jj=j1,j2
260               DO ji=i1,i2
261                  tabres(ji,jj) = tabres(ji,jj) + fse3u(ji,jj,jk) * un(ji,jj,jk)
262               END DO
263            END DO
264         END DO
265         DO jj=j1,j2
266            DO ji=i1,i2
267               tabres(ji,jj) = tabres(ji,jj) * e2u(ji,jj)
268            END DO
269         END DO
270         tabres = zrhoy * tabres
271      ELSE
272         DO jj=j1,j2
273            DO ji=i1,i2
274               IF(umask(ji,jj,1) .NE. 0.) THEN             
275                  spgu(ji,jj) = 0.e0
276                  DO jk=1,jpk
277                     spgu(ji,jj) = spgu(ji,jj) + fse3u(ji,jj,jk) * un(ji,jj,jk)
278                  END DO
279                  spgu(ji,jj) = spgu(ji,jj) * e2u(ji,jj)
280                  zhinv = (tabres(ji,jj)-spgu(ji,jj))/(hu(ji,jj)*e2u(ji,jj))
281                  Do jk=1,jpk             
282                     un(ji,jj,jk) = un(ji,jj,jk) + zhinv
283                     un(ji,jj,jk) = un(ji,jj,jk) * umask(ji,jj,jk)           
284                  END DO
[390]285               ENDIF
[636]286            END DO
287         END DO
288      ENDIF
[390]289
[636]290   END SUBROUTINE updateu2d
[390]291
[636]292   SUBROUTINE updatev2d( tabres, i1, i2, j1, j2, before )
293      !!---------------------------------------------
294      !!          *** ROUTINE updatev2d ***
295      !!---------------------------------------------
[390]296
[636]297      INTEGER, INTENT(in) :: i1, i2, j1, j2
298      REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres
299      LOGICAL, INTENT(in) :: before
[390]300
[636]301      INTEGER :: ji, jj, jk
302      REAL(wp) :: zrhox
303      REAL(wp) :: zhinv
[390]304
[636]305      IF (before) THEN
306         zrhox = Agrif_Rhox()
307         tabres = 0.e0
308         DO jk = 1,jpkm1
309            DO jj=j1,j2
310               DO ji=i1,i2
311                  tabres(ji,jj) = tabres(ji,jj) + fse3v(ji,jj,jk) * vn(ji,jj,jk)
312               END DO
313            END DO
314         END DO
315         DO jj=j1,j2
316            DO ji=i1,i2
317               tabres(ji,jj) = tabres(ji,jj) * e1v(ji,jj)
318            END DO
319         END DO
320         tabres = zrhox * tabres
321      ELSE
322         DO jj=j1,j2
323            DO ji=i1,i2
324               IF(vmask(ji,jj,1) .NE. 0.) THEN             
325                  spgv(ji,jj) = 0.
326                  DO jk=1,jpk
327                     spgv(ji,jj) = spgv(ji,jj) + fse3v(ji,jj,jk) * vn(ji,jj,jk)
328                  END DO
329                  spgv(ji,jj) = spgv(ji,jj) * e1v(ji,jj)
330                  zhinv = (tabres(ji,jj)-spgv(ji,jj))/(hv(ji,jj)*e1v(ji,jj))
331                  DO jk=1,jpk             
332                     vn(ji,jj,jk) = vn(ji,jj,jk) + zhinv
333                     vn(ji,jj,jk) = vn(ji,jj,jk) * vmask(ji,jj,jk)
334                  END DO
[390]335               ENDIF
[636]336            END DO
337         END DO
338      ENDIF
[390]339
[636]340   END SUBROUTINE updatev2d
[390]341
[636]342   SUBROUTINE updateSSH( tabres, i1, i2, j1, j2, before )
343      !!---------------------------------------------
344      !!          *** ROUTINE updateSSH ***
345      !!---------------------------------------------
[390]346#  include "domzgr_substitute.h90"
347
[636]348      INTEGER, INTENT(in) :: i1, i2, j1, j2
349      REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres
350      LOGICAL, INTENT(in) :: before
[390]351
[636]352      INTEGER :: ji, jj
353      REAL(wp) :: zrhox, zrhoy
354
355      IF (before) THEN
356         zrhox = Agrif_Rhox()
357         zrhoy = Agrif_Rhoy()
358         DO jj=j1,j2
359            DO ji=i1,i2
[390]360               tabres(ji,jj) = e1t(ji,jj) * e2t(ji,jj) * sshn(ji,jj)
[636]361            END DO
362         END DO
363         tabres = zrhox * zrhoy * tabres
364      ELSE
365         DO jj=j1,j2
366            DO ji=i1,i2
[390]367               sshn(ji,jj) = tabres(ji,jj) / (e1t(ji,jj) * e2t(ji,jj))
368               sshn(ji,jj) = sshn(ji,jj) * tmask(ji,jj,1)
[636]369            END DO
370         END DO
371      ENDIF
[390]372
[636]373   END SUBROUTINE updateSSH
374
[390]375#else
[636]376CONTAINS
377   SUBROUTINE agrif_opa_update_empty
378      !!---------------------------------------------
379      !!   *** ROUTINE agrif_opa_update_empty ***
380      !!---------------------------------------------
381      WRITE(*,*)  'agrif_opa_update : You should not have seen this print! error?'
382   END SUBROUTINE agrif_opa_update_empty
[390]383#endif
[636]384END MODULE agrif_opa_update
Note: See TracBrowser for help on using the repository browser.