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

source: trunk/NEMOGCM/NEMO/NST_SRC/agrif_opa_update.F90 @ 3819

Last change on this file since 3819 was 3294, checked in by rblod, 12 years ago

Merge of 3.4beta into the trunk
  • Property svn:keywords set to Id
File size: 11.1 KB
RevLine 
[390]1#define TWO_WAY
2
[636]3MODULE agrif_opa_update
[2528]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
[2715]9   USE in_out_manager  ! I/O manager
10   USE lib_mpp
[3294]11   USE wrk_nemo 
12
[636]13   IMPLICIT NONE
14   PRIVATE
[390]15
[636]16   PUBLIC Agrif_Update_Tra, Agrif_Update_Dyn
[390]17
[1300]18   INTEGER, PUBLIC :: nbcline = 0
[390]19
[1156]20   !!----------------------------------------------------------------------
[2528]21   !! NEMO/NST 3.3 , NEMO Consortium (2010)
[1156]22   !! $Id$
[2528]23   !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt)
[1156]24   !!----------------------------------------------------------------------
25
[636]26CONTAINS
27
28   SUBROUTINE Agrif_Update_Tra( kt )
29      !!---------------------------------------------
30      !!   *** ROUTINE Agrif_Update_Tra ***
31      !!---------------------------------------------
[2715]32      !!
[636]33      INTEGER, INTENT(in) :: kt
[3294]34      REAL(wp), POINTER, DIMENSION(:,:,:,:) :: ztab
[636]35
[2715]36       
[636]37      IF((Agrif_NbStepint() .NE. (Agrif_irhot()-1)).AND.(kt /= 0)) RETURN
[390]38#if defined TWO_WAY
[3294]39      CALL wrk_alloc( jpi, jpj, jpk, jpts, ztab )
[2715]40
[390]41      Agrif_UseSpecialValueInUpdate = .TRUE.
42      Agrif_SpecialValueFineGrid = 0.
[636]43
44      IF (MOD(nbcline,nbclineupdate) == 0) THEN
[3294]45         CALL Agrif_Update_Variable(ztab,tsn_id, procname=updateTS)
[390]46      ELSE
[3294]47         CALL Agrif_Update_Variable(ztab,tsn_id,locupdate=(/0,2/), procname=updateTS)
[390]48      ENDIF
49
50      Agrif_UseSpecialValueInUpdate = .FALSE.
[2715]51
[3294]52      CALL wrk_dealloc( jpi, jpj, jpk, jpts, ztab )
[390]53#endif
54
[636]55   END SUBROUTINE Agrif_Update_Tra
[390]56
[636]57   SUBROUTINE Agrif_Update_Dyn( kt )
58      !!---------------------------------------------
59      !!   *** ROUTINE Agrif_Update_Dyn ***
60      !!---------------------------------------------
[2715]61      !!
[636]62      INTEGER, INTENT(in) :: kt
[2715]63      REAL(wp), POINTER, DIMENSION(:,:) :: ztab2d
64      REAL(wp), POINTER, DIMENSION(:,:,:) :: ztab
[636]65
66
[390]67      IF ((Agrif_NbStepint() .NE. (Agrif_irhot()-1)).AND.(kt /= 0)) Return
68#if defined TWO_WAY
[3294]69      CALL wrk_alloc( jpi, jpj,      ztab2d )
70      CALL wrk_alloc( jpi, jpj, jpk, ztab   )
[390]71
72      IF (mod(nbcline,nbclineupdate) == 0) THEN
[2715]73         CALL Agrif_Update_Variable(ztab,un_id,procname = updateU)
74         CALL Agrif_Update_Variable(ztab,vn_id,procname = updateV)
[390]75      ELSE
[2715]76         CALL Agrif_Update_Variable(ztab,un_id,locupdate=(/0,1/),procname = updateU)
77         CALL Agrif_Update_Variable(ztab,vn_id,locupdate=(/0,1/),procname = updateV)         
[390]78      ENDIF
79
[2715]80      CALL Agrif_Update_Variable(ztab2d,e1u_id,procname = updateU2d)
81      CALL Agrif_Update_Variable(ztab2d,e2v_id,procname = updateV2d) 
[636]82
[390]83      nbcline = nbcline + 1
84
[782]85      Agrif_UseSpecialValueInUpdate = ln_spc_dyn
[636]86      Agrif_SpecialValueFineGrid = 0.
[2715]87      CALL Agrif_Update_Variable(ztab2d,sshn_id,procname = updateSSH)
[636]88      Agrif_UseSpecialValueInUpdate = .FALSE.
[390]89
[3294]90      CALL wrk_dealloc( jpi, jpj,      ztab2d )
91      CALL wrk_dealloc( jpi, jpj, jpk, ztab   )
[390]92
[1438]93!Done in step
94!      CALL Agrif_ChildGrid_To_ParentGrid()
95!      CALL recompute_diags( kt )
96!      CALL Agrif_ParentGrid_To_ChildGrid()
[390]97
98#endif
99
[636]100   END SUBROUTINE Agrif_Update_Dyn
101
102   SUBROUTINE recompute_diags( kt )
103      !!---------------------------------------------
104      !!   *** ROUTINE recompute_diags ***
105      !!---------------------------------------------
106      INTEGER, INTENT(in) :: kt
107
108   END SUBROUTINE recompute_diags
109
[3294]110   SUBROUTINE updateTS( tabres, i1, i2, j1, j2, k1, k2, n1, n2, before )
[636]111      !!---------------------------------------------
112      !!           *** ROUTINE updateT ***
113      !!---------------------------------------------
[390]114#  include "domzgr_substitute.h90"
115
[3294]116      INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2,n1,n2
117      REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2), INTENT(inout) :: tabres
[636]118      LOGICAL, iNTENT(in) :: before
[390]119
[3294]120      INTEGER :: ji,jj,jk,jn
[636]121
122      IF (before) THEN
[3294]123         DO jn = n1,n2
124            DO jk=k1,k2
125               DO jj=j1,j2
126                  DO ji=i1,i2
127                     tabres(ji,jj,jk,jn) = tsn(ji,jj,jk,jn)
128                  END DO
[636]129               END DO
130            END DO
131         END DO
132      ELSE
[3294]133         DO jn = n1,n2
134            DO jk=k1,k2
135               DO jj=j1,j2
136                  DO ji=i1,i2
137                     IF( tabres(ji,jj,jk,jn) .NE. 0. ) THEN
138                         tsn(ji,jj,jk,jn) = tabres(ji,jj,jk,jn) * tmask(ji,jj,jk)
139                     END IF
140                  END DO
[636]141               END DO
142            END DO
143         END DO
144      ENDIF
[390]145
[3294]146   END SUBROUTINE updateTS
[390]147
[636]148   SUBROUTINE updateu( tabres, i1, i2, j1, j2, k1, k2, before )
149      !!---------------------------------------------
150      !!           *** ROUTINE updateu ***
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
159      REAL(wp) :: zrhoy
160
161      IF (before) THEN
162         zrhoy = Agrif_Rhoy()
[390]163         DO jk=k1,k2
[636]164            DO jj=j1,j2
165               DO ji=i1,i2
166                  tabres(ji,jj,jk) = e2u(ji,jj) * un(ji,jj,jk)
[2715]167                  tabres(ji,jj,jk) = tabres(ji,jj,jk) * fse3u(ji,jj,jk)
[636]168               END DO
169            END DO
170         END DO
171         tabres = zrhoy * tabres
172      ELSE
[390]173         DO jk=k1,k2
[636]174            DO jj=j1,j2
175               DO ji=i1,i2
176                  un(ji,jj,jk) = tabres(ji,jj,jk) / (e2u(ji,jj))
177                  un(ji,jj,jk) = un(ji,jj,jk) * umask(ji,jj,jk)
178                  un(ji,jj,jk) = un(ji,jj,jk) / fse3u(ji,jj,jk)
179               END DO
180            END DO
181         END DO
182      ENDIF
[390]183
[636]184   END SUBROUTINE updateu
[390]185
[636]186   SUBROUTINE updatev( tabres, i1, i2, j1, j2, k1, k2, before )
187      !!---------------------------------------------
188      !!           *** ROUTINE updatev ***
189      !!---------------------------------------------
[390]190#  include "domzgr_substitute.h90"
191
[636]192      INTEGER :: i1,i2,j1,j2,k1,k2
193      INTEGER :: ji,jj,jk
194      REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2) :: tabres
195      LOGICAL :: before
[390]196
[636]197      REAL(wp) :: zrhox
198
199      IF (before) THEN
200         zrhox = Agrif_Rhox()
[390]201         DO jk=k1,k2
[636]202            DO jj=j1,j2
203               DO ji=i1,i2
204                  tabres(ji,jj,jk) = e1v(ji,jj) * vn(ji,jj,jk)
205                  tabres(ji,jj,jk) = tabres(ji,jj,jk) * fse3v(ji,jj,jk)
206               END DO
207            END DO
208         END DO
209         tabres = zrhox * tabres
210      ELSE
[390]211         DO jk=k1,k2
[636]212            DO jj=j1,j2
213               DO ji=i1,i2
214                  vn(ji,jj,jk) = tabres(ji,jj,jk) / (e1v(ji,jj))
215                  vn(ji,jj,jk) = vn(ji,jj,jk) * vmask(ji,jj,jk)
216                  vn(ji,jj,jk) = vn(ji,jj,jk) / fse3v(ji,jj,jk)
217               END DO
218            END DO
219         END DO
220      ENDIF
[390]221
[636]222   END SUBROUTINE updatev
[390]223
[636]224   SUBROUTINE updateu2d( tabres, i1, i2, j1, j2, before )
225      !!---------------------------------------------
226      !!          *** ROUTINE updateu2d ***
227      !!---------------------------------------------
[390]228#  include "domzgr_substitute.h90"
229
[636]230      INTEGER, INTENT(in) :: i1, i2, j1, j2
231      REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres
232      LOGICAL, INTENT(in) :: before
[390]233
[636]234      INTEGER :: ji, jj, jk
235      REAL(wp) :: zrhoy
236      REAL(wp) :: zhinv
[390]237
[636]238      IF (before) THEN
239         zrhoy = Agrif_Rhoy()
240         DO jk = 1,jpkm1
241            DO jj=j1,j2
242               DO ji=i1,i2
243                  tabres(ji,jj) = tabres(ji,jj) + fse3u(ji,jj,jk) * un(ji,jj,jk)
244               END DO
245            END DO
246         END DO
247         DO jj=j1,j2
248            DO ji=i1,i2
249               tabres(ji,jj) = tabres(ji,jj) * e2u(ji,jj)
250            END DO
251         END DO
252         tabres = zrhoy * tabres
253      ELSE
254         DO jj=j1,j2
255            DO ji=i1,i2
256               IF(umask(ji,jj,1) .NE. 0.) THEN             
257                  spgu(ji,jj) = 0.e0
258                  DO jk=1,jpk
259                     spgu(ji,jj) = spgu(ji,jj) + fse3u(ji,jj,jk) * un(ji,jj,jk)
260                  END DO
261                  spgu(ji,jj) = spgu(ji,jj) * e2u(ji,jj)
262                  zhinv = (tabres(ji,jj)-spgu(ji,jj))/(hu(ji,jj)*e2u(ji,jj))
263                  Do jk=1,jpk             
264                     un(ji,jj,jk) = un(ji,jj,jk) + zhinv
265                     un(ji,jj,jk) = un(ji,jj,jk) * umask(ji,jj,jk)           
266                  END DO
[390]267               ENDIF
[636]268            END DO
269         END DO
270      ENDIF
[390]271
[636]272   END SUBROUTINE updateu2d
[390]273
[636]274   SUBROUTINE updatev2d( tabres, i1, i2, j1, j2, before )
275      !!---------------------------------------------
276      !!          *** ROUTINE updatev2d ***
277      !!---------------------------------------------
[390]278
[636]279      INTEGER, INTENT(in) :: i1, i2, j1, j2
280      REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres
281      LOGICAL, INTENT(in) :: before
[390]282
[636]283      INTEGER :: ji, jj, jk
284      REAL(wp) :: zrhox
285      REAL(wp) :: zhinv
[390]286
[636]287      IF (before) THEN
288         zrhox = Agrif_Rhox()
289         tabres = 0.e0
290         DO jk = 1,jpkm1
291            DO jj=j1,j2
292               DO ji=i1,i2
293                  tabres(ji,jj) = tabres(ji,jj) + fse3v(ji,jj,jk) * vn(ji,jj,jk)
294               END DO
295            END DO
296         END DO
297         DO jj=j1,j2
298            DO ji=i1,i2
299               tabres(ji,jj) = tabres(ji,jj) * e1v(ji,jj)
300            END DO
301         END DO
302         tabres = zrhox * tabres
303      ELSE
304         DO jj=j1,j2
305            DO ji=i1,i2
306               IF(vmask(ji,jj,1) .NE. 0.) THEN             
307                  spgv(ji,jj) = 0.
308                  DO jk=1,jpk
309                     spgv(ji,jj) = spgv(ji,jj) + fse3v(ji,jj,jk) * vn(ji,jj,jk)
310                  END DO
311                  spgv(ji,jj) = spgv(ji,jj) * e1v(ji,jj)
312                  zhinv = (tabres(ji,jj)-spgv(ji,jj))/(hv(ji,jj)*e1v(ji,jj))
313                  DO jk=1,jpk             
314                     vn(ji,jj,jk) = vn(ji,jj,jk) + zhinv
315                     vn(ji,jj,jk) = vn(ji,jj,jk) * vmask(ji,jj,jk)
316                  END DO
[390]317               ENDIF
[636]318            END DO
319         END DO
320      ENDIF
[390]321
[636]322   END SUBROUTINE updatev2d
[390]323
[636]324   SUBROUTINE updateSSH( tabres, i1, i2, j1, j2, before )
325      !!---------------------------------------------
326      !!          *** ROUTINE updateSSH ***
327      !!---------------------------------------------
[390]328#  include "domzgr_substitute.h90"
329
[636]330      INTEGER, INTENT(in) :: i1, i2, j1, j2
331      REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres
332      LOGICAL, INTENT(in) :: before
[390]333
[636]334      INTEGER :: ji, jj
335      REAL(wp) :: zrhox, zrhoy
336
337      IF (before) THEN
338         zrhox = Agrif_Rhox()
339         zrhoy = Agrif_Rhoy()
340         DO jj=j1,j2
341            DO ji=i1,i2
[390]342               tabres(ji,jj) = e1t(ji,jj) * e2t(ji,jj) * sshn(ji,jj)
[636]343            END DO
344         END DO
345         tabres = zrhox * zrhoy * tabres
346      ELSE
347         DO jj=j1,j2
348            DO ji=i1,i2
[390]349               sshn(ji,jj) = tabres(ji,jj) / (e1t(ji,jj) * e2t(ji,jj))
350               sshn(ji,jj) = sshn(ji,jj) * tmask(ji,jj,1)
[636]351            END DO
352         END DO
353      ENDIF
[390]354
[636]355   END SUBROUTINE updateSSH
356
[390]357#else
[636]358CONTAINS
359   SUBROUTINE agrif_opa_update_empty
360      !!---------------------------------------------
361      !!   *** ROUTINE agrif_opa_update_empty ***
362      !!---------------------------------------------
363      WRITE(*,*)  'agrif_opa_update : You should not have seen this print! error?'
364   END SUBROUTINE agrif_opa_update_empty
[390]365#endif
[636]366END MODULE agrif_opa_update
Note: See TracBrowser for help on using the repository browser.