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 @ 1161

Last change on this file since 1161 was 1156, checked in by rblod, 16 years ago

Update Id and licence information, see ticket #210
  • 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
[393]4#if defined key_agrif
[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
[636]15   INTEGER :: nbcline
[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      USE  ocfzpt
98
99      INTEGER, INTENT(in) :: kt
100
[390]101      ta = hdivb
102      sa = rotb
103      CALL oc_fz_pt
104      Call div_cur(kt)
105
106      hdivb = ta
107      rotb  = sa
108
109      IF( n_cla == 1 ) CALL div_cla( kt )
[636]110      CALL wzv( kt )
[390]111
[636]112   END SUBROUTINE recompute_diags
113
114   SUBROUTINE updateT( tabres, i1, i2, j1, j2, k1, k2, before )
115      !!---------------------------------------------
116      !!           *** ROUTINE updateT ***
117      !!---------------------------------------------
[390]118#  include "domzgr_substitute.h90"
119
[636]120      INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2
121      REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: tabres
122      LOGICAL, iNTENT(in) :: before
[390]123
[636]124      INTEGER :: ji,jj,jk
125
126      IF (before) THEN
[390]127         DO jk=k1,k2
[636]128            DO jj=j1,j2
129               DO ji=i1,i2
130                  tabres(ji,jj,jk) = tn(ji,jj,jk)
131               END DO
132            END DO
133         END DO
134      ELSE
135         DO jk=k1,k2
136            DO jj=j1,j2
137               DO ji=i1,i2
138                  IF( tabres(ji,jj,jk) .NE. 0. ) THEN
139                     tn(ji,jj,jk) = tabres(ji,jj,jk) * tmask(ji,jj,jk)
140                  ENDIF
141               END DO
142            END DO
143         END DO
144      ENDIF
[390]145
[636]146   END SUBROUTINE updateT
[390]147
[636]148   SUBROUTINE updateS( tabres, i1, i2, j1, j2, k1, k2, before )
149      !!---------------------------------------------
150      !!           *** ROUTINE updateS ***
151      !!---------------------------------------------
[390]152#  include "domzgr_substitute.h90"
153
[636]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
[390]157
[636]158      INTEGER :: ji,jj,jk
[390]159
[636]160      IF (before) THEN
[390]161         DO jk=k1,k2
[636]162            DO jj=j1,j2
163               DO ji=i1,i2
164                  tabres(ji,jj,jk) = sn(ji,jj,jk)
165               END DO
166            END DO
167         END DO
168      ELSE
169         DO jk=k1,k2
170            DO jj=j1,j2
171               DO ji=i1,i2
172                  IF (tabres(ji,jj,jk).NE.0.) THEN
173                     sn(ji,jj,jk) = tabres(ji,jj,jk) * tmask(ji,jj,jk)
174                  ENDIF
175               END DO
176            END DO
177         END DO
178      ENDIF
[390]179
[636]180   END SUBROUTINE updateS
[390]181
[636]182   SUBROUTINE updateu( tabres, i1, i2, j1, j2, k1, k2, before )
183      !!---------------------------------------------
184      !!           *** ROUTINE updateu ***
185      !!---------------------------------------------
[390]186#  include "domzgr_substitute.h90"
187
[636]188      INTEGER, INTENT(in) :: i1, i2, j1, j2, k1, k2
189      REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: tabres
190      LOGICAL, INTENT(in) :: before
[390]191
[636]192      INTEGER :: ji, jj, jk
193      REAL(wp) :: zrhoy
194
195      IF (before) THEN
196         zrhoy = Agrif_Rhoy()
[390]197         DO jk=k1,k2
[636]198            DO jj=j1,j2
199               DO ji=i1,i2
200                  tabres(ji,jj,jk) = e2u(ji,jj) * un(ji,jj,jk)
[469]201#if ! defined key_zco
[636]202                  tabres(ji,jj,jk) = tabres(ji,jj,jk) * fse3u(ji,jj,jk)
[390]203#endif
[636]204               END DO
205            END DO
206         END DO
207         tabres = zrhoy * tabres
208      ELSE
[390]209         DO jk=k1,k2
[636]210            DO jj=j1,j2
211               DO ji=i1,i2
212                  un(ji,jj,jk) = tabres(ji,jj,jk) / (e2u(ji,jj))
213                  un(ji,jj,jk) = un(ji,jj,jk) * umask(ji,jj,jk)
[469]214#if ! defined key_zco
[636]215                  un(ji,jj,jk) = un(ji,jj,jk) / fse3u(ji,jj,jk)
[390]216#endif
[636]217               END DO
218            END DO
219         END DO
220      ENDIF
[390]221
[636]222   END SUBROUTINE updateu
[390]223
[636]224   SUBROUTINE updatev( tabres, i1, i2, j1, j2, k1, k2, before )
225      !!---------------------------------------------
226      !!           *** ROUTINE updatev ***
227      !!---------------------------------------------
[390]228#  include "domzgr_substitute.h90"
229
[636]230      INTEGER :: i1,i2,j1,j2,k1,k2
231      INTEGER :: ji,jj,jk
232      REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2) :: tabres
233      LOGICAL :: before
[390]234
[636]235      REAL(wp) :: zrhox
236
237      IF (before) THEN
238         zrhox = Agrif_Rhox()
[390]239         DO jk=k1,k2
[636]240            DO jj=j1,j2
241               DO ji=i1,i2
242                  tabres(ji,jj,jk) = e1v(ji,jj) * vn(ji,jj,jk)
[469]243#if ! defined key_zco
[636]244                  tabres(ji,jj,jk) = tabres(ji,jj,jk) * fse3v(ji,jj,jk)
[390]245#endif
[636]246               END DO
247            END DO
248         END DO
249         tabres = zrhox * tabres
250      ELSE
[390]251         DO jk=k1,k2
[636]252            DO jj=j1,j2
253               DO ji=i1,i2
254                  vn(ji,jj,jk) = tabres(ji,jj,jk) / (e1v(ji,jj))
255                  vn(ji,jj,jk) = vn(ji,jj,jk) * vmask(ji,jj,jk)
[469]256#if ! defined key_zco
[636]257                  vn(ji,jj,jk) = vn(ji,jj,jk) / fse3v(ji,jj,jk)
[390]258#endif
[636]259               END DO
260            END DO
261         END DO
262      ENDIF
[390]263
[636]264   END SUBROUTINE updatev
[390]265
[636]266   SUBROUTINE updateu2d( tabres, i1, i2, j1, j2, before )
267      !!---------------------------------------------
268      !!          *** ROUTINE updateu2d ***
269      !!---------------------------------------------
[390]270#  include "domzgr_substitute.h90"
271
[636]272      INTEGER, INTENT(in) :: i1, i2, j1, j2
273      REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres
274      LOGICAL, INTENT(in) :: before
[390]275
[636]276      INTEGER :: ji, jj, jk
277      REAL(wp) :: zrhoy
278      REAL(wp) :: zhinv
[390]279
[636]280      IF (before) THEN
281         zrhoy = Agrif_Rhoy()
282         DO jk = 1,jpkm1
283            DO jj=j1,j2
284               DO ji=i1,i2
285                  tabres(ji,jj) = tabres(ji,jj) + fse3u(ji,jj,jk) * un(ji,jj,jk)
286               END DO
287            END DO
288         END DO
289         DO jj=j1,j2
290            DO ji=i1,i2
291               tabres(ji,jj) = tabres(ji,jj) * e2u(ji,jj)
292            END DO
293         END DO
294         tabres = zrhoy * tabres
295      ELSE
296         DO jj=j1,j2
297            DO ji=i1,i2
298               IF(umask(ji,jj,1) .NE. 0.) THEN             
299                  spgu(ji,jj) = 0.e0
300                  DO jk=1,jpk
301                     spgu(ji,jj) = spgu(ji,jj) + fse3u(ji,jj,jk) * un(ji,jj,jk)
302                  END DO
303                  spgu(ji,jj) = spgu(ji,jj) * e2u(ji,jj)
304                  zhinv = (tabres(ji,jj)-spgu(ji,jj))/(hu(ji,jj)*e2u(ji,jj))
305                  Do jk=1,jpk             
306                     un(ji,jj,jk) = un(ji,jj,jk) + zhinv
307                     un(ji,jj,jk) = un(ji,jj,jk) * umask(ji,jj,jk)           
308                  END DO
[390]309               ENDIF
[636]310            END DO
311         END DO
312      ENDIF
[390]313
[636]314   END SUBROUTINE updateu2d
[390]315
[636]316   SUBROUTINE updatev2d( tabres, i1, i2, j1, j2, before )
317      !!---------------------------------------------
318      !!          *** ROUTINE updatev2d ***
319      !!---------------------------------------------
[390]320
[636]321      INTEGER, INTENT(in) :: i1, i2, j1, j2
322      REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres
323      LOGICAL, INTENT(in) :: before
[390]324
[636]325      INTEGER :: ji, jj, jk
326      REAL(wp) :: zrhox
327      REAL(wp) :: zhinv
[390]328
[636]329      IF (before) THEN
330         zrhox = Agrif_Rhox()
331         tabres = 0.e0
332         DO jk = 1,jpkm1
333            DO jj=j1,j2
334               DO ji=i1,i2
335                  tabres(ji,jj) = tabres(ji,jj) + fse3v(ji,jj,jk) * vn(ji,jj,jk)
336               END DO
337            END DO
338         END DO
339         DO jj=j1,j2
340            DO ji=i1,i2
341               tabres(ji,jj) = tabres(ji,jj) * e1v(ji,jj)
342            END DO
343         END DO
344         tabres = zrhox * tabres
345      ELSE
346         DO jj=j1,j2
347            DO ji=i1,i2
348               IF(vmask(ji,jj,1) .NE. 0.) THEN             
349                  spgv(ji,jj) = 0.
350                  DO jk=1,jpk
351                     spgv(ji,jj) = spgv(ji,jj) + fse3v(ji,jj,jk) * vn(ji,jj,jk)
352                  END DO
353                  spgv(ji,jj) = spgv(ji,jj) * e1v(ji,jj)
354                  zhinv = (tabres(ji,jj)-spgv(ji,jj))/(hv(ji,jj)*e1v(ji,jj))
355                  DO jk=1,jpk             
356                     vn(ji,jj,jk) = vn(ji,jj,jk) + zhinv
357                     vn(ji,jj,jk) = vn(ji,jj,jk) * vmask(ji,jj,jk)
358                  END DO
[390]359               ENDIF
[636]360            END DO
361         END DO
362      ENDIF
[390]363
[636]364   END SUBROUTINE updatev2d
[390]365
[636]366   SUBROUTINE updateSSH( tabres, i1, i2, j1, j2, before )
367      !!---------------------------------------------
368      !!          *** ROUTINE updateSSH ***
369      !!---------------------------------------------
[390]370#  include "domzgr_substitute.h90"
371
[636]372      INTEGER, INTENT(in) :: i1, i2, j1, j2
373      REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres
374      LOGICAL, INTENT(in) :: before
[390]375
[636]376      INTEGER :: ji, jj
377      REAL(wp) :: zrhox, zrhoy
378
379      IF (before) THEN
380         zrhox = Agrif_Rhox()
381         zrhoy = Agrif_Rhoy()
382         DO jj=j1,j2
383            DO ji=i1,i2
[390]384               tabres(ji,jj) = e1t(ji,jj) * e2t(ji,jj) * sshn(ji,jj)
[636]385            END DO
386         END DO
387         tabres = zrhox * zrhoy * tabres
388      ELSE
389         DO jj=j1,j2
390            DO ji=i1,i2
[390]391               sshn(ji,jj) = tabres(ji,jj) / (e1t(ji,jj) * e2t(ji,jj))
392               sshn(ji,jj) = sshn(ji,jj) * tmask(ji,jj,1)
[636]393            END DO
394         END DO
395      ENDIF
[390]396
[636]397   END SUBROUTINE updateSSH
398
[390]399#else
[636]400CONTAINS
401   SUBROUTINE agrif_opa_update_empty
402      !!---------------------------------------------
403      !!   *** ROUTINE agrif_opa_update_empty ***
404      !!---------------------------------------------
405      WRITE(*,*)  'agrif_opa_update : You should not have seen this print! error?'
406   END SUBROUTINE agrif_opa_update_empty
[390]407#endif
[636]408END MODULE agrif_opa_update
Note: See TracBrowser for help on using the repository browser.