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

Last change on this file since 700 was 699, checked in by smasson, 17 years ago

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