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

Last change on this file since 2618 was 2618, checked in by gm, 12 years ago

dynamic mem: #785 ; move dyn allocation from nemogcm to module when possible (continuation)

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