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.
dynspg_flt.F90 in branches/dev_r2586_dynamic_mem/NEMOGCM/NEMO/OPA_SRC/DYN – NEMO

source: branches/dev_r2586_dynamic_mem/NEMOGCM/NEMO/OPA_SRC/DYN/dynspg_flt.F90 @ 2674

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

First set of changes in OPA_SRC to ensure AGRIF compatibility

  • Property svn:keywords set to Id
File size: 19.0 KB
Line 
1MODULE dynspg_flt
2   !!======================================================================
3   !!                   ***  MODULE  dynspg_flt  ***
4   !! Ocean dynamics:  surface pressure gradient trend
5   !!======================================================================
6   !! History    OPA  !  1998-05  (G. Roullet)  free surface
7   !!                 !  1998-10  (G. Madec, M. Imbard)  release 8.2
8   !!   NEMO     O.1  !  2002-08  (G. Madec)  F90: Free form and module
9   !!             -   !  2002-11  (C. Talandier, A-M Treguier) Open boundaries
10   !!            1.0  !  2004-08  (C. Talandier) New trends organization
11   !!             -   !  2005-11  (V. Garnier) Surface pressure gradient organization
12   !!            2.0  !  2006-07  (S. Masson)  distributed restart using iom
13   !!             -   !  2006-08  (J.Chanut, A.Sellar) Calls to BDY routines.
14   !!            3.2  !  2009-03  (G. Madec, M. Leclair, R. Benshila) introduce sshwzv module
15   !!----------------------------------------------------------------------
16#if defined key_dynspg_flt   ||   defined key_esopa 
17   !!----------------------------------------------------------------------
18   !!   'key_dynspg_flt'                              filtered free surface
19   !!----------------------------------------------------------------------
20   !!   dyn_spg_flt  : update the momentum trend with the surface pressure gradient in the filtered free surface case
21   !!   flt_rst      : read/write the time-splitting restart fields in the ocean restart file
22   !!----------------------------------------------------------------------
23   USE oce             ! ocean dynamics and tracers
24   USE dom_oce         ! ocean space and time domain
25   USE zdf_oce         ! ocean vertical physics
26   USE sbc_oce         ! surface boundary condition: ocean
27   USE obc_oce         ! Lateral open boundary condition
28   USE sol_oce         ! ocean elliptic solver
29   USE phycst          ! physical constants
30   USE domvvl          ! variable volume
31   USE dynadv          ! advection
32   USE solmat          ! matrix construction for elliptic solvers
33   USE solpcg          ! preconditionned conjugate gradient solver
34   USE solsor          ! Successive Over-relaxation solver
35   USE obcdyn          ! ocean open boundary condition (obc_dyn routines)
36   USE obcvol          ! ocean open boundary condition (obc_vol routines)
37   USE bdy_oce         ! Unstructured open boundaries condition
38   USE bdydyn          ! Unstructured open boundaries condition (bdy_dyn routine)
39   USE bdyvol          ! Unstructured open boundaries condition (bdy_vol routine)
40   USE cla             ! cross land advection
41   USE in_out_manager  ! I/O manager
42   USE lib_mpp         ! distributed memory computing library
43   USE lbclnk          ! ocean lateral boundary conditions (or mpp link)
44   USE prtctl          ! Print control
45   USE iom
46   USE restart         ! only for lrst_oce
47   USE lib_fortran
48#if defined key_agrif
49   USE agrif_opa_interp
50#endif
51
52   IMPLICIT NONE
53   PRIVATE
54
55   PUBLIC   dyn_spg_flt  ! routine called by step.F90
56   PUBLIC   flt_rst      ! routine called by istate.F90
57
58   !! * Substitutions
59#  include "domzgr_substitute.h90"
60#  include "vectopt_loop_substitute.h90"
61   !!----------------------------------------------------------------------
62   !! NEMO/OPA 3.3 , NEMO Consortium (2010)
63   !! $Id$
64   !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt)
65   !!----------------------------------------------------------------------
66CONTAINS
67
68   SUBROUTINE dyn_spg_flt( kt, kindic )
69      !!----------------------------------------------------------------------
70      !!                  ***  routine dyn_spg_flt  ***
71      !!
72      !! ** Purpose :   Compute the now trend due to the surface pressure
73      !!      gradient in case of filtered free surface formulation  and add
74      !!      it to the general trend of momentum equation.
75      !!
76      !! ** Method  :   Filtered free surface formulation. The surface
77      !!      pressure gradient is given by:
78      !!         spgu = 1/rau0 d/dx(ps) =  1/e1u di( sshn + btda )
79      !!         spgv = 1/rau0 d/dy(ps) =  1/e2v dj( sshn + btda )
80      !!      where sshn is the free surface elevation and btda is the after
81      !!      time derivative of the free surface elevation
82      !!       -1- evaluate the surface presure trend (including the addi-
83      !!      tional force) in three steps:
84      !!        a- compute the right hand side of the elliptic equation:
85      !!            gcb = 1/(e1t e2t) [ di(e2u spgu) + dj(e1v spgv) ]
86      !!         where (spgu,spgv) are given by:
87      !!            spgu = vertical sum[ e3u (ub+ 2 rdt ua ) ]
88      !!                 - grav 2 rdt hu /e1u di[sshn + (emp-rnf)]
89      !!            spgv = vertical sum[ e3v (vb+ 2 rdt va) ]
90      !!                 - grav 2 rdt hv /e2v dj[sshn + (emp-rnf)]
91      !!         and define the first guess from previous computation :
92      !!            zbtd = btda
93      !!            btda = 2 zbtd - btdb
94      !!            btdb = zbtd
95      !!        b- compute the relative accuracy to be reached by the
96      !!         iterative solver
97      !!        c- apply the solver by a call to sol... routine
98      !!       -2- compute and add the free surface pressure gradient inclu-
99      !!      ding the additional force used to stabilize the equation.
100      !!
101      !! ** Action : - Update (ua,va) with the surf. pressure gradient trend
102      !!
103      !! References : Roullet and Madec 1999, JGR.
104      !!---------------------------------------------------------------------
105      USE oce, ONLY :   zub   => ta   ! ta used as workspace
106      USE oce, ONLY :   zvb   => sa   ! ta used as workspace
107      !!
108      INTEGER, INTENT(in   ) ::   kt       ! ocean time-step index
109      INTEGER, INTENT(  out) ::   kindic   ! solver convergence flag (<0 if not converge)
110      !!                                   
111      INTEGER  ::   ji, jj, jk           ! dummy loop indices
112      REAL(wp) ::   z2dt, z2dtg          ! temporary scalars
113      REAL(wp) ::   zgcb, zbtd   !   -          -
114      REAL(wp) ::   ztdgu, ztdgv         !   -          -
115      !!----------------------------------------------------------------------
116      !
117      IF( kt == nit000 ) THEN
118         IF(lwp) WRITE(numout,*)
119         IF(lwp) WRITE(numout,*) 'dyn_spg_flt : surface pressure gradient trend'
120         IF(lwp) WRITE(numout,*) '~~~~~~~~~~~   (free surface constant volume case)'
121       
122         ! set to zero free surface specific arrays
123         spgu(:,:) = 0.e0                     ! surface pressure gradient (i-direction)
124         spgv(:,:) = 0.e0                     ! surface pressure gradient (j-direction)
125
126         ! read filtered free surface arrays in restart file
127         ! when using agrif, sshn, gcx have to be read in istate
128         IF(.NOT. lk_agrif)   CALL flt_rst( nit000, 'READ' )      ! read or initialize the following fields:
129         !                                                        ! gcx, gcxb
130      ENDIF
131
132      ! Local constant initialization
133      z2dt = 2. * rdt                                             ! time step: leap-frog
134      IF( neuler == 0 .AND. kt == nit000   )   z2dt = rdt         ! time step: Euler if restart from rest
135      IF( neuler == 0 .AND. kt == nit000+1 )   CALL sol_mat( kt )
136      z2dtg  = grav * z2dt
137
138      ! Evaluate the masked next velocity (effect of the additional force not included)
139      ! --------------------------------- 
140      IF( lk_vvl ) THEN          ! variable volume  (surface pressure gradient already included in dyn_hpg)
141         !
142         IF( ln_dynadv_vec ) THEN      ! vector form : applied on velocity
143            DO jk = 1, jpkm1
144               DO jj = 2, jpjm1
145                  DO ji = fs_2, fs_jpim1   ! vector opt.
146                     ua(ji,jj,jk) = (  ub(ji,jj,jk) + z2dt * ua(ji,jj,jk)  ) * umask(ji,jj,jk)
147                     va(ji,jj,jk) = (  vb(ji,jj,jk) + z2dt * va(ji,jj,jk)  ) * vmask(ji,jj,jk)
148                  END DO
149               END DO
150            END DO
151            !
152         ELSE                          ! flux form : applied on thickness weighted velocity
153            DO jk = 1, jpkm1
154               DO jj = 2, jpjm1
155                  DO ji = fs_2, fs_jpim1   ! vector opt.
156                     ua(ji,jj,jk) = (        ub(ji,jj,jk) * fse3u_b(ji,jj,jk)      &
157                        &           + z2dt * ua(ji,jj,jk) * fse3u_n(ji,jj,jk)  )   &
158                        &         / fse3u_a(ji,jj,jk) * umask(ji,jj,jk)
159                     va(ji,jj,jk) = (        vb(ji,jj,jk) * fse3v_b(ji,jj,jk)      &
160                        &           + z2dt * va(ji,jj,jk) * fse3v_n(ji,jj,jk)  )   &
161                        &         / fse3v_a(ji,jj,jk) * vmask(ji,jj,jk)
162                 END DO
163               END DO
164            END DO
165            !
166         ENDIF
167         !
168      ELSE                       ! fixed volume  (add the surface pressure gradient + unweighted time stepping)
169         !
170         DO jj = 2, jpjm1              ! Surface pressure gradient (now)
171            DO ji = fs_2, fs_jpim1   ! vector opt.
172               spgu(ji,jj) = - grav * ( sshn(ji+1,jj) - sshn(ji,jj) ) / e1u(ji,jj)
173               spgv(ji,jj) = - grav * ( sshn(ji,jj+1) - sshn(ji,jj) ) / e2v(ji,jj)
174            END DO
175         END DO
176         DO jk = 1, jpkm1              ! unweighted time stepping
177            DO jj = 2, jpjm1
178               DO ji = fs_2, fs_jpim1   ! vector opt.
179                  ua(ji,jj,jk) = (  ub(ji,jj,jk) + z2dt * ( ua(ji,jj,jk) + spgu(ji,jj) )  ) * umask(ji,jj,jk)
180                  va(ji,jj,jk) = (  vb(ji,jj,jk) + z2dt * ( va(ji,jj,jk) + spgv(ji,jj) )  ) * vmask(ji,jj,jk)
181               END DO
182            END DO
183         END DO
184         !
185      ENDIF
186
187#if defined key_obc
188      CALL obc_dyn( kt )      ! Update velocities on each open boundary with the radiation algorithm
189      CALL obc_vol( kt )      ! Correction of the barotropic componant velocity to control the volume of the system
190#endif
191#if defined key_bdy
192      CALL bdy_dyn_frs( kt )       ! Update velocities on unstructured boundary using the Flow Relaxation Scheme
193      CALL bdy_vol( kt )           ! Correction of the barotropic component velocity to control the volume of the system
194#endif
195#if defined key_agrif
196      CALL Agrif_dyn( kt )    ! Update velocities on each coarse/fine interfaces
197#endif
198      IF( nn_cla == 1 )   CALL cla_dynspg( kt )      ! Cross Land Advection (update (ua,va))
199
200      ! compute the next vertically averaged velocity (effect of the additional force not included)
201      ! ---------------------------------------------
202      DO jj = 2, jpjm1
203         DO ji = fs_2, fs_jpim1   ! vector opt.
204            spgu(ji,jj) = 0.e0
205            spgv(ji,jj) = 0.e0
206         END DO
207      END DO
208
209      ! vertical sum
210!CDIR NOLOOPCHG
211      IF( lk_vopt_loop ) THEN          ! vector opt., forced unroll
212         DO jk = 1, jpkm1
213            DO ji = 1, jpij
214               spgu(ji,1) = spgu(ji,1) + fse3u(ji,1,jk) * ua(ji,1,jk)
215               spgv(ji,1) = spgv(ji,1) + fse3v(ji,1,jk) * va(ji,1,jk)
216            END DO
217         END DO
218      ELSE                        ! No  vector opt.
219         DO jk = 1, jpkm1
220            DO jj = 2, jpjm1
221               DO ji = 2, jpim1
222                  spgu(ji,jj) = spgu(ji,jj) + fse3u(ji,jj,jk) * ua(ji,jj,jk)
223                  spgv(ji,jj) = spgv(ji,jj) + fse3v(ji,jj,jk) * va(ji,jj,jk)
224               END DO
225            END DO
226         END DO
227      ENDIF
228
229      ! transport: multiplied by the horizontal scale factor
230      DO jj = 2, jpjm1
231         DO ji = fs_2, fs_jpim1   ! vector opt.
232            spgu(ji,jj) = spgu(ji,jj) * e2u(ji,jj)
233            spgv(ji,jj) = spgv(ji,jj) * e1v(ji,jj)
234         END DO
235      END DO
236      CALL lbc_lnk( spgu, 'U', -1. )       ! lateral boundary conditions
237      CALL lbc_lnk( spgv, 'V', -1. )
238
239      IF( lk_vvl ) CALL sol_mat( kt )      ! build the matrix at kt (vvl case only)
240
241      ! Right hand side of the elliptic equation and first guess
242      ! --------------------------------------------------------
243      DO jj = 2, jpjm1
244         DO ji = fs_2, fs_jpim1   ! vector opt.
245            ! Divergence of the after vertically averaged velocity
246            zgcb =  spgu(ji,jj) - spgu(ji-1,jj)   &
247                  + spgv(ji,jj) - spgv(ji,jj-1)
248            gcb(ji,jj) = gcdprc(ji,jj) * zgcb
249            ! First guess of the after barotropic transport divergence
250            zbtd = gcx(ji,jj)
251            gcx (ji,jj) = 2. * zbtd   - gcxb(ji,jj)
252            gcxb(ji,jj) =      zbtd
253         END DO
254      END DO
255      ! applied the lateral boundary conditions
256      IF( nn_solv == 2 .AND. MAX( jpr2di, jpr2dj ) > 0 )   CALL lbc_lnk_e( gcb, c_solver_pt, 1. )   
257
258#if defined key_agrif
259      IF( .NOT. AGRIF_ROOT() ) THEN
260         ! add contribution of gradient of after barotropic transport divergence
261         IF( nbondi == -1 .OR. nbondi == 2 )   gcb(3     ,:) =   &
262            &    gcb(3     ,:) - z2dtg * z2dt * laplacu(2     ,:) * gcdprc(3     ,:) * hu(2     ,:) * e2u(2     ,:)
263         IF( nbondi ==  1 .OR. nbondi == 2 )   gcb(nlci-2,:) =   &
264            &    gcb(nlci-2,:) + z2dtg * z2dt * laplacu(nlci-2,:) * gcdprc(nlci-2,:) * hu(nlci-2,:) * e2u(nlci-2,:)
265         IF( nbondj == -1 .OR. nbondj == 2 )   gcb(:     ,3) =   &
266            &    gcb(:,3     ) - z2dtg * z2dt * laplacv(:,2     ) * gcdprc(:,3     ) * hv(:,2     ) * e1v(:,2     )
267         IF( nbondj ==  1 .OR. nbondj == 2 )   gcb(:,nlcj-2) =   &
268            &    gcb(:,nlcj-2) + z2dtg * z2dt * laplacv(:,nlcj-2) * gcdprc(:,nlcj-2) * hv(:,nlcj-2) * e1v(:,nlcj-2)
269      ENDIF
270#endif
271
272
273      ! Relative precision (computation on one processor)
274      ! ------------------
275      rnorme =0.e0
276      rnorme = GLOB_SUM( gcb(1:jpi,1:jpj) * gcdmat(1:jpi,1:jpj) * gcb(1:jpi,1:jpj) * bmask(:,:) )
277
278      epsr = eps * eps * rnorme
279      ncut = 0
280      ! if rnorme is 0, the solution is 0, the solver is not called
281      IF( rnorme == 0.e0 ) THEN
282         gcx(:,:) = 0.e0
283         res   = 0.e0
284         niter = 0
285         ncut  = 999
286      ENDIF
287
288      ! Evaluate the next transport divergence
289      ! --------------------------------------
290      !    Iterarive solver for the elliptic equation (except IF sol.=0)
291      !    (output in gcx with boundary conditions applied)
292      kindic = 0
293      IF( ncut == 0 ) THEN
294         IF    ( nn_solv == 1 ) THEN   ;   CALL sol_pcg( kindic )      ! diagonal preconditioned conjuguate gradient
295         ELSEIF( nn_solv == 2 ) THEN   ;   CALL sol_sor( kindic )      ! successive-over-relaxation
296         ENDIF
297      ENDIF
298
299      ! Transport divergence gradient multiplied by z2dt
300      ! --------------------------------------------====
301      DO jj = 2, jpjm1
302         DO ji = fs_2, fs_jpim1   ! vector opt.
303            ! trend of Transport divergence gradient
304            ztdgu = z2dtg * (gcx(ji+1,jj  ) - gcx(ji,jj) ) / e1u(ji,jj)
305            ztdgv = z2dtg * (gcx(ji  ,jj+1) - gcx(ji,jj) ) / e2v(ji,jj)
306            ! multiplied by z2dt
307#if defined key_obc
308            ! caution : grad D = 0 along open boundaries
309            spgu(ji,jj) = z2dt * ztdgu * obcumask(ji,jj)
310            spgv(ji,jj) = z2dt * ztdgv * obcvmask(ji,jj)
311#elif defined key_bdy
312            ! caution : grad D = 0 along open boundaries
313            ! Remark: The filtering force could be reduced here in the FRS zone
314            !         by multiplying spgu/spgv by (1-alpha) ?? 
315            spgu(ji,jj) = z2dt * ztdgu * bdyumask(ji,jj)
316            spgv(ji,jj) = z2dt * ztdgv * bdyvmask(ji,jj)           
317#else
318            spgu(ji,jj) = z2dt * ztdgu
319            spgv(ji,jj) = z2dt * ztdgv
320#endif
321         END DO
322      END DO
323
324#if defined key_agrif     
325      IF( .NOT. Agrif_Root() ) THEN
326         ! caution : grad D (fine) = grad D (coarse) at coarse/fine interface
327         IF( nbondi == -1 .OR. nbondi == 2 ) spgu(2     ,:) = z2dtg * z2dt * laplacu(2     ,:) * umask(2     ,:,1)
328         IF( nbondi ==  1 .OR. nbondi == 2 ) spgu(nlci-2,:) = z2dtg * z2dt * laplacu(nlci-2,:) * umask(nlci-2,:,1)
329         IF( nbondj == -1 .OR. nbondj == 2 ) spgv(:,2     ) = z2dtg * z2dt * laplacv(:,2     ) * vmask(:     ,2,1)
330         IF( nbondj ==  1 .OR. nbondj == 2 ) spgv(:,nlcj-2) = z2dtg * z2dt * laplacv(:,nlcj-2) * vmask(:,nlcj-2,1)
331      ENDIF
332#endif     
333      ! Add the trends multiplied by z2dt to the after velocity
334      ! -------------------------------------------------------
335      !     ( c a u t i o n : (ua,va) here are the after velocity not the
336      !                       trend, the leap-frog time stepping will not
337      !                       be done in dynnxt.F90 routine)
338      DO jk = 1, jpkm1
339         DO jj = 2, jpjm1
340            DO ji = fs_2, fs_jpim1   ! vector opt.
341               ua(ji,jj,jk) = ( ua(ji,jj,jk) + spgu(ji,jj) ) * umask(ji,jj,jk)
342               va(ji,jj,jk) = ( va(ji,jj,jk) + spgv(ji,jj) ) * vmask(ji,jj,jk)
343            END DO
344         END DO
345      END DO
346
347      ! write filtered free surface arrays in restart file
348      ! --------------------------------------------------
349      IF( lrst_oce ) CALL flt_rst( kt, 'WRITE' )
350      !
351   END SUBROUTINE dyn_spg_flt
352
353
354   SUBROUTINE flt_rst( kt, cdrw )
355     !!---------------------------------------------------------------------
356     !!                   ***  ROUTINE ts_rst  ***
357     !!
358     !! ** Purpose : Read or write filtered free surface arrays in restart file
359     !!----------------------------------------------------------------------
360     INTEGER         , INTENT(in) ::   kt         ! ocean time-step
361     CHARACTER(len=*), INTENT(in) ::   cdrw       ! "READ"/"WRITE" flag
362     !!----------------------------------------------------------------------
363
364     IF( TRIM(cdrw) == 'READ' ) THEN
365        IF( iom_varid( numror, 'gcx', ldstop = .FALSE. ) > 0 ) THEN
366! Caution : extra-hallow
367! gcx and gcxb are defined as: DIMENSION(1-jpr2di:jpi+jpr2di,1-jpr2dj:jpj+jpr2dj)
368           CALL iom_get( numror, jpdom_autoglo, 'gcx' , gcx (1:jpi,1:jpj) )
369           CALL iom_get( numror, jpdom_autoglo, 'gcxb', gcxb(1:jpi,1:jpj) )
370           IF( neuler == 0 )   gcxb(:,:) = gcx (:,:)
371        ELSE
372           gcx (:,:) = 0.e0
373           gcxb(:,:) = 0.e0
374        ENDIF
375     ELSEIF( TRIM(cdrw) == 'WRITE' ) THEN
376! Caution : extra-hallow
377! gcx and gcxb are defined as: DIMENSION(1-jpr2di:jpi+jpr2di,1-jpr2dj:jpj+jpr2dj)
378        CALL iom_rstput( kt, nitrst, numrow, 'gcx' , gcx (1:jpi,1:jpj) )
379        CALL iom_rstput( kt, nitrst, numrow, 'gcxb', gcxb(1:jpi,1:jpj) )
380     ENDIF
381     !
382   END SUBROUTINE flt_rst
383
384#else
385   !!----------------------------------------------------------------------
386   !!   Default case :   Empty module   No standart free surface cst volume
387   !!----------------------------------------------------------------------
388CONTAINS
389   SUBROUTINE dyn_spg_flt( kt, kindic )       ! Empty routine
390      WRITE(*,*) 'dyn_spg_flt: You should not have seen this print! error?', kt, kindic
391   END SUBROUTINE dyn_spg_flt
392   SUBROUTINE flt_rst    ( kt, cdrw )         ! Empty routine
393      INTEGER         , INTENT(in) ::   kt         ! ocean time-step
394      CHARACTER(len=*), INTENT(in) ::   cdrw       ! "READ"/"WRITE" flag
395      WRITE(*,*) 'flt_rst: You should not have seen this print! error?', kt, cdrw
396   END SUBROUTINE flt_rst
397#endif
398   
399   !!======================================================================
400END MODULE dynspg_flt
Note: See TracBrowser for help on using the repository browser.