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

source: branches/2017/dev_r7881_ENHANCE09_RK3/NEMOGCM/NEMO/NST_SRC/agrif_opa_update.F90 @ 8586

Last change on this file since 8586 was 8586, checked in by gm, 7 years ago

#1911 (ENHANCE-09): PART I.3 - phasing with branch dev_r8183_ICEMODEL revision 8575
  • Property svn:keywords set to Id
File size: 25.7 KB
Line 
1#define TWO_WAY        /* TWO WAY NESTING */
2#undef DECAL_FEEDBACK /* SEPARATION of INTERFACES*/
3 
4MODULE agrif_opa_update
5   !!======================================================================
6   !!                   ***  MODULE  agrif_opa_interp  ***
7   !! AGRIF: update package for the ocean dynamics (OPA)
8   !!======================================================================
9   !! History :  2.0  !  2002-06  (XXX)  Original cade
10   !!             -   !  2005-11  (XXX)
11   !!            3.2  !  2009-04  (R. Benshila)
12   !!            3.6  !  2014-09  (R. Benshila)
13   !!----------------------------------------------------------------------
14#if defined key_agrif 
15   !!----------------------------------------------------------------------
16   !!   'key_agrif'                                              AGRIF zoom
17   !!----------------------------------------------------------------------
18   USE par_oce
19   USE oce
20   USE dom_oce
21   USE zdf_oce        ! vertical physics: ocean variables
22   USE agrif_oce
23   !
24   USE in_out_manager ! I/O manager
25   USE lib_mpp        ! MPP library
26
27   IMPLICIT NONE
28   PRIVATE
29
30   PUBLIC   Agrif_Update_Tra, Agrif_Update_Dyn, Update_Scales
31   PUBLIC   Agrif_Update_Tke
32
33   !!----------------------------------------------------------------------
34   !! NEMO/NST 4.0 , NEMO Consortium (2017)
35   !! $Id$
36   !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt)
37   !!----------------------------------------------------------------------
38CONTAINS
39
40   RECURSIVE SUBROUTINE Agrif_Update_Tra( )
41      !!----------------------------------------------------------------------
42      !!                   *** ROUTINE Agrif_Update_Tra ***
43      !!----------------------------------------------------------------------
44      !
45      IF (Agrif_Root()) RETURN
46      !
47#if defined TWO_WAY 
48      IF (lwp.AND.lk_agrif_debug) Write(*,*) 'Update tracers  from grid Number',Agrif_Fixed(), 'nbcline', nbcline
49
50      Agrif_UseSpecialValueInUpdate = .TRUE.
51      Agrif_SpecialValueFineGrid    = 0._wp
52      !
53      IF (MOD(nbcline,nbclineupdate) == 0) THEN
54# if ! defined DECAL_FEEDBACK
55         CALL Agrif_Update_Variable(tsn_id, procname=updateTS)
56# else
57         CALL Agrif_Update_Variable(tsn_id, locupdate=(/1,0/),procname=updateTS)
58# endif
59      ELSE
60# if ! defined DECAL_FEEDBACK
61         CALL Agrif_Update_Variable(tsn_id,locupdate=(/0,2/), procname=updateTS)
62# else
63         CALL Agrif_Update_Variable(tsn_id,locupdate=(/1,2/), procname=updateTS)
64# endif
65      ENDIF
66      !
67      Agrif_UseSpecialValueInUpdate = .FALSE.
68      !
69      IF ( lk_agrif_doupd ) THEN ! Initialisation: do recursive update:
70         CALL Agrif_ChildGrid_To_ParentGrid()
71         CALL Agrif_Update_Tra()
72         CALL Agrif_ParentGrid_To_ChildGrid()
73      ENDIF
74      !
75#endif
76      !
77   END SUBROUTINE Agrif_Update_Tra
78
79
80   RECURSIVE SUBROUTINE Agrif_Update_Dyn( )
81      !!----------------------------------------------------------------------
82      !!                   *** ROUTINE Agrif_Update_Dyn ***
83      !!----------------------------------------------------------------------
84      !
85      IF (Agrif_Root()) RETURN
86      !
87#if defined TWO_WAY
88      IF (lwp.AND.lk_agrif_debug) Write(*,*) 'Update momentum from grid Number',Agrif_Fixed(), 'nbcline', nbcline
89
90      Agrif_UseSpecialValueInUpdate = .FALSE.
91      Agrif_SpecialValueFineGrid = 0.
92      !     
93      IF (mod(nbcline,nbclineupdate) == 0) THEN
94# if ! defined DECAL_FEEDBACK
95         CALL Agrif_Update_Variable(un_update_id,procname = updateU)
96         CALL Agrif_Update_Variable(vn_update_id,procname = updateV)
97# else
98         CALL Agrif_Update_Variable(un_update_id,locupdate1=(/0,-1/),locupdate2=(/1,-2/),procname = updateU)
99         CALL Agrif_Update_Variable(vn_update_id,locupdate1=(/1,-2/),locupdate2=(/0,-1/),procname = updateV)
100# endif
101      ELSE
102# if ! defined DECAL_FEEDBACK
103         CALL Agrif_Update_Variable(un_update_id,locupdate=(/0,1/),procname = updateU)
104         CALL Agrif_Update_Variable(vn_update_id,locupdate=(/0,1/),procname = updateV)         
105# else
106         CALL Agrif_Update_Variable(un_update_id,locupdate1=(/0,1/),locupdate2=(/1,1/),procname = updateU)
107         CALL Agrif_Update_Variable(vn_update_id,locupdate1=(/1,1/),locupdate2=(/0,1/),procname = updateV)
108# endif
109      ENDIF
110
111# if ! defined DECAL_FEEDBACK
112      CALL Agrif_Update_Variable(e1u_id,procname = updateU2d)
113      CALL Agrif_Update_Variable(e2v_id,procname = updateV2d) 
114# else
115      CALL Agrif_Update_Variable(e1u_id,locupdate1=(/0,-1/),locupdate2=(/1,-2/),procname = updateU2d)
116      CALL Agrif_Update_Variable(e2v_id,locupdate1=(/1,-2/),locupdate2=(/0,-1/),procname = updateV2d) 
117# endif
118
119      IF ( ln_dynspg_ts .AND. ln_bt_fw ) THEN
120         ! Update time integrated transports
121         IF (mod(nbcline,nbclineupdate) == 0) THEN
122#  if ! defined DECAL_FEEDBACK
123            CALL Agrif_Update_Variable(ub2b_update_id,procname = updateub2b)
124            CALL Agrif_Update_Variable(vb2b_update_id,procname = updatevb2b)
125#  else
126            CALL Agrif_Update_Variable(ub2b_update_id,locupdate1=(/0,-1/),locupdate2=(/1,-2/),procname = updateub2b)
127            CALL Agrif_Update_Variable(vb2b_update_id,locupdate1=(/1,-2/),locupdate2=(/0,-1/),procname = updatevb2b)
128#  endif
129         ELSE
130#  if ! defined DECAL_FEEDBACK
131            CALL Agrif_Update_Variable(ub2b_update_id,locupdate=(/0,1/),procname = updateub2b)
132            CALL Agrif_Update_Variable(vb2b_update_id,locupdate=(/0,1/),procname = updatevb2b)
133#  else
134            CALL Agrif_Update_Variable(ub2b_update_id,locupdate1=(/0,1/),locupdate2=(/1,1/),procname = updateub2b)
135            CALL Agrif_Update_Variable(vb2b_update_id,locupdate1=(/1,1/),locupdate2=(/0,1/),procname = updatevb2b)
136#  endif
137         ENDIF
138      END IF
139      !
140      nbcline = nbcline + 1
141      !
142      Agrif_UseSpecialValueInUpdate = .TRUE.
143      Agrif_SpecialValueFineGrid = 0.
144# if ! defined DECAL_FEEDBACK
145      CALL Agrif_Update_Variable(sshn_id,procname = updateSSH)
146# else
147      CALL Agrif_Update_Variable(sshn_id,locupdate=(/1,0/),procname = updateSSH)
148# endif
149      Agrif_UseSpecialValueInUpdate = .FALSE.
150      !
151#endif
152      !
153      ! Do recursive update:
154      IF ( lk_agrif_doupd ) THEN ! Initialisation: do recursive update:
155         CALL Agrif_ChildGrid_To_ParentGrid()
156         CALL Agrif_Update_Dyn()
157         CALL Agrif_ParentGrid_To_ChildGrid()
158      ENDIF
159      !
160   END SUBROUTINE Agrif_Update_Dyn
161
162!!gm Missing GLS case !!!!!
163
164   SUBROUTINE Agrif_Update_Tke( kt )
165      !!----------------------------------------------------------------------
166      !!                   *** ROUTINE Agrif_Update_Tke ***
167      !!----------------------------------------------------------------------
168      INTEGER, INTENT(in) ::   kt   ! timestep index
169      !!----------------------------------------------------------------------
170      !
171!!gm test on kt/=0  ????  why not nit000-1  ?  doesn't seem logic
172      IF( ( Agrif_NbStepint() /= 0 ) .AND. kt /= 0 )   RETURN
173#  if defined TWO_WAY
174      !
175      Agrif_UseSpecialValueInUpdate = .TRUE.
176      Agrif_SpecialValueFineGrid    = 0._wp
177      !
178      CALL Agrif_Update_Variable(  en_id, locupdate=(/0,0/), procname=updateEN  )
179      CALL Agrif_Update_Variable( avt_id, locupdate=(/0,0/), procname=updateAVT )
180      CALL Agrif_Update_Variable( avm_id, locupdate=(/0,0/), procname=updateAVM )
181      !
182      Agrif_UseSpecialValueInUpdate = .FALSE.
183      !
184#  endif
185      !
186   END SUBROUTINE Agrif_Update_Tke
187   
188
189   SUBROUTINE updateTS( tabres, i1, i2, j1, j2, k1, k2, n1, n2, before )
190      !!----------------------------------------------------------------------
191      !!           *** ROUTINE updateT ***
192      !!----------------------------------------------------------------------
193      INTEGER                                    , INTENT(in   ) ::   i1, i2, j1, j2, k1, k2, n1, n2
194      REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2), INTENT(inout) ::   tabres
195      LOGICAL                                    , INTENT(in   ) ::   before
196      !
197      INTEGER :: ji, jj, jk, jn
198      !!----------------------------------------------------------------------
199      !
200      IF( before ) THEN
201         DO jn = n1, n2
202            DO jk = k1, k2
203               DO jj = j1, j2
204                  DO ji = i1, i2
205                     tabres(ji,jj,jk,jn) = tsn(ji,jj,jk,jn)
206                  END DO
207               END DO
208            END DO
209         END DO
210      ELSE
211         IF (.NOT.(lk_agrif_fstep.AND.(neuler==0))) THEN
212            ! Add asselin part
213            DO jn = n1,n2
214               DO jk = k1, k2
215                  DO jj = j1, j2
216                     DO ji = i1, i2
217                        IF( tabres(ji,jj,jk,jn) .NE. 0. ) THEN
218                           tsb(ji,jj,jk,jn) = tsb(ji,jj,jk,jn) & 
219                              &             + atfp * ( tabres(ji,jj,jk,jn) - tsn(ji,jj,jk,jn) ) * tmask(ji,jj,jk)
220                        ENDIF
221                     END DO
222                  END DO
223               END DO
224            END DO
225         ENDIF
226         DO jn = n1,n2
227            DO jk=k1,k2
228               DO jj=j1,j2
229                  DO ji=i1,i2
230                     IF( tabres(ji,jj,jk,jn) .NE. 0. ) THEN
231                        tsn(ji,jj,jk,jn) = tabres(ji,jj,jk,jn) * tmask(ji,jj,jk)
232                     END IF
233                  END DO
234               END DO
235            END DO
236         END DO
237      ENDIF
238      !
239   END SUBROUTINE updateTS
240
241
242   SUBROUTINE updateu( tabres, i1, i2, j1, j2, k1, k2, before )
243      !!---------------------------------------------
244      !!           *** ROUTINE updateu ***
245      !!---------------------------------------------
246      INTEGER                               , INTENT(in   ) :: i1, i2, j1, j2, k1, k2
247      REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: tabres
248      LOGICAL                               , INTENT(in   ) :: before
249      !
250      INTEGER ::   ji, jj, jk
251      REAL(wp)::   zrhoy
252      !!---------------------------------------------
253      !
254      IF( before ) THEN
255         zrhoy = Agrif_Rhoy()
256         DO jk = k1, k2
257            tabres(i1:i2,j1:j2,jk) = zrhoy * e2u(i1:i2,j1:j2) * e3u_n(i1:i2,j1:j2,jk) * un(i1:i2,j1:j2,jk)
258         END DO
259      ELSE
260         DO jk=k1,k2
261            DO jj=j1,j2
262               DO ji=i1,i2
263                  tabres(ji,jj,jk) = tabres(ji,jj,jk) * r1_e2u(ji,jj) / e3u_n(ji,jj,jk)
264                  !
265                  IF (.NOT.(lk_agrif_fstep.AND.(neuler==0))) THEN ! Add asselin part
266                     ub(ji,jj,jk) = ub(ji,jj,jk) & 
267                           & + atfp * ( tabres(ji,jj,jk) - un(ji,jj,jk) ) * umask(ji,jj,jk)
268                  ENDIF
269                  !
270                  un(ji,jj,jk) = tabres(ji,jj,jk) * umask(ji,jj,jk)
271               END DO
272            END DO
273         END DO
274      ENDIF
275      !
276   END SUBROUTINE updateu
277
278
279   SUBROUTINE updatev( tabres, i1, i2, j1, j2, k1, k2, before )
280      !!----------------------------------------------------------------------
281      !!                      *** ROUTINE updatev ***
282      !!----------------------------------------------------------------------
283      INTEGER                               , INTENT(in   ) :: i1, i2, j1, j2, k1, k2
284      REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: tabres
285      LOGICAL                               , INTENT(in   ) :: before
286      !!
287      INTEGER  ::   ji, jj, jk
288      REAL(wp) ::   zrhox
289      !!----------------------------------------------------------------------
290      !
291      IF( before ) THEN
292         zrhox = Agrif_Rhox()
293         DO jk = k1, k2
294            DO jj = j1, j2
295               DO ji = i1, i2
296                  tabres(ji,jj,jk) = zrhox * e1v(ji,jj) * e3v_n(ji,jj,jk) * vn(ji,jj,jk)
297               END DO
298            END DO
299         END DO
300      ELSE
301         DO jk = k1, k2
302            DO jj = j1, j2
303               DO ji = i1, i2
304                  tabres(ji,jj,jk) = tabres(ji,jj,jk) * r1_e1v(ji,jj) / e3v_n(ji,jj,jk)
305                  !
306                  IF( .NOT.(lk_agrif_fstep.AND.(neuler==0)) ) THEN ! Add asselin part
307                     vb(ji,jj,jk) = vb(ji,jj,jk) & 
308                        &         + atfp * ( tabres(ji,jj,jk) - vn(ji,jj,jk) ) * vmask(ji,jj,jk)
309                  ENDIF
310                  !
311                  vn(ji,jj,jk) = tabres(ji,jj,jk) * vmask(ji,jj,jk)
312               END DO
313            END DO
314         END DO
315      ENDIF
316      !
317   END SUBROUTINE updatev
318
319
320   SUBROUTINE updateu2d( tabres, i1, i2, j1, j2, before )
321      !!----------------------------------------------------------------------
322      !!                      *** ROUTINE updateu2d ***
323      !!----------------------------------------------------------------------
324      INTEGER                         , INTENT(in   ) ::   i1, i2, j1, j2
325      REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) ::   tabres
326      LOGICAL                         , INTENT(in   ) ::   before
327      !!
328      INTEGER ::   ji, jj, jk
329      REAL(wp)::   zrhoy, zcorr
330      !!---------------------------------------------
331      !
332      IF( before ) THEN
333         zrhoy = Agrif_Rhoy()
334         DO jj=j1,j2
335            DO ji=i1,i2
336               tabres(ji,jj) = zrhoy * un_b(ji,jj) * hu_n(ji,jj) * e2u(ji,jj)
337            END DO
338         END DO
339      ELSE
340         DO jj=j1,j2
341            DO ji=i1,i2
342               tabres(ji,jj) =  tabres(ji,jj) * r1_hu_n(ji,jj) * r1_e2u(ji,jj) 
343               !   
344               ! Update "now" 3d velocities:
345               spgu(ji,jj) = 0._wp
346               DO jk=1,jpkm1
347                  spgu(ji,jj) = spgu(ji,jj) + e3u_n(ji,jj,jk) * un(ji,jj,jk)
348               END DO
349               spgu(ji,jj) = spgu(ji,jj) * r1_hu_n(ji,jj)
350               !
351               zcorr = tabres(ji,jj) - spgu(ji,jj)
352               DO jk=1,jpkm1             
353                  un(ji,jj,jk) = un(ji,jj,jk) + zcorr * umask(ji,jj,jk)           
354               END DO
355               !
356               ! Update barotropic velocities:
357               IF ( .NOT.ln_dynspg_ts .OR. (ln_dynspg_ts.AND.(.NOT.ln_bt_fw)) ) THEN
358                  IF (.NOT.(lk_agrif_fstep.AND.(neuler==0))) THEN ! Add asselin part
359                     zcorr = tabres(ji,jj) - un_b(ji,jj)
360                     ub_b(ji,jj) = ub_b(ji,jj) + atfp * zcorr * umask(ji,jj,1)
361                  END IF
362               ENDIF             
363               un_b(ji,jj) = tabres(ji,jj) * umask(ji,jj,1)
364               !       
365               ! Correct "before" velocities to hold correct bt component:
366               spgu(ji,jj) = 0.e0
367               DO jk=1,jpkm1
368                  spgu(ji,jj) = spgu(ji,jj) + e3u_b(ji,jj,jk) * ub(ji,jj,jk)
369               END DO
370               spgu(ji,jj) = spgu(ji,jj) * r1_hu_b(ji,jj)
371               !
372               zcorr = ub_b(ji,jj) - spgu(ji,jj)
373               DO jk=1,jpkm1             
374                  ub(ji,jj,jk) = ub(ji,jj,jk) + zcorr * umask(ji,jj,jk)           
375               END DO
376               !
377            END DO
378         END DO
379      ENDIF
380      !
381   END SUBROUTINE updateu2d
382
383
384   SUBROUTINE updatev2d( tabres, i1, i2, j1, j2, before )
385      !!----------------------------------------------------------------------
386      !!                   *** ROUTINE updatev2d ***
387      !!----------------------------------------------------------------------
388      INTEGER                         , INTENT(in   ) ::   i1, i2, j1, j2
389      REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) ::   tabres
390      LOGICAL                         , INTENT(in   ) ::   before
391      !
392      INTEGER :: ji, jj, jk
393      REAL(wp) :: zrhox, zcorr
394      !!----------------------------------------------------------------------
395      !
396      IF( before ) THEN
397         zrhox = Agrif_Rhox()
398         DO jj=j1,j2
399            DO ji=i1,i2
400               tabres(ji,jj) = zrhox * vn_b(ji,jj) * hv_n(ji,jj) * e1v(ji,jj) 
401            END DO
402         END DO
403      ELSE
404         DO jj=j1,j2
405            DO ji=i1,i2
406               tabres(ji,jj) =  tabres(ji,jj) * r1_hv_n(ji,jj) * r1_e1v(ji,jj) 
407               !   
408               ! Update "now" 3d velocities:
409               spgv(ji,jj) = 0.e0
410               DO jk=1,jpkm1
411                  spgv(ji,jj) = spgv(ji,jj) + e3v_n(ji,jj,jk) * vn(ji,jj,jk)
412               END DO
413               spgv(ji,jj) = spgv(ji,jj) * r1_hv_n(ji,jj)
414               !
415               zcorr = tabres(ji,jj) - spgv(ji,jj)
416               DO jk=1,jpkm1             
417                  vn(ji,jj,jk) = vn(ji,jj,jk) + zcorr * vmask(ji,jj,jk)           
418               END DO
419               !
420               ! Update barotropic velocities:
421               IF ( .NOT.ln_dynspg_ts .OR. (ln_dynspg_ts.AND.(.NOT.ln_bt_fw)) ) THEN
422                  IF (.NOT.(lk_agrif_fstep.AND.(neuler==0))) THEN ! Add asselin part
423                     zcorr = tabres(ji,jj) - vn_b(ji,jj)
424                     vb_b(ji,jj) = vb_b(ji,jj) + atfp * zcorr * vmask(ji,jj,1)
425                  END IF
426               ENDIF             
427               vn_b(ji,jj) = tabres(ji,jj) * vmask(ji,jj,1)
428               !       
429               ! Correct "before" velocities to hold correct bt component:
430               spgv(ji,jj) = 0.e0
431               DO jk=1,jpkm1
432                  spgv(ji,jj) = spgv(ji,jj) + e3v_b(ji,jj,jk) * vb(ji,jj,jk)
433               END DO
434               spgv(ji,jj) = spgv(ji,jj) * r1_hv_b(ji,jj)
435               !
436               zcorr = vb_b(ji,jj) - spgv(ji,jj)
437               DO jk=1,jpkm1             
438                  vb(ji,jj,jk) = vb(ji,jj,jk) + zcorr * vmask(ji,jj,jk)           
439               END DO
440               !
441            END DO
442         END DO
443      ENDIF
444      !
445   END SUBROUTINE updatev2d
446
447
448   SUBROUTINE updateSSH( tabres, i1, i2, j1, j2, before )
449      !!----------------------------------------------------------------------
450      !!                   *** ROUTINE updateSSH ***
451      !!----------------------------------------------------------------------
452      INTEGER                         , INTENT(in   ) ::   i1, i2, j1, j2
453      REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) ::   tabres
454      LOGICAL                         , INTENT(in   ) ::   before
455      !!
456      INTEGER :: ji, jj
457      !!----------------------------------------------------------------------
458      !
459      IF( before ) THEN
460         DO jj=j1,j2
461            DO ji=i1,i2
462               tabres(ji,jj) = sshn(ji,jj)
463            END DO
464         END DO
465      ELSE
466         IF( .NOT.ln_dynspg_ts .OR. ( ln_dynspg_ts .AND. .NOT.ln_bt_fw ) ) THEN
467            IF (.NOT.(lk_agrif_fstep.AND.(neuler==0))) THEN
468               DO jj=j1,j2
469                  DO ji=i1,i2
470                     sshb(ji,jj) =   sshb(ji,jj) &
471                           & + atfp * ( tabres(ji,jj) - sshn(ji,jj) ) * tmask(ji,jj,1)
472                  END DO
473               END DO
474            ENDIF
475         ENDIF
476         !
477         DO jj=j1,j2
478            DO ji=i1,i2
479               sshn(ji,jj) = tabres(ji,jj) * tmask(ji,jj,1)
480            END DO
481         END DO
482      ENDIF
483      !
484   END SUBROUTINE updateSSH
485
486
487   SUBROUTINE updateub2b( tabres, i1, i2, j1, j2, before )
488      !!----------------------------------------------------------------------
489      !!                      *** ROUTINE updateub2b ***
490      !!----------------------------------------------------------------------
491      INTEGER                            , INTENT(in) ::   i1, i2, j1, j2
492      REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) ::   tabres
493      LOGICAL                            , INTENT(in) ::   before
494      !!
495      INTEGER ::   ji, jj
496      REAL(wp)::   zrhoy
497      !!----------------------------------------------------------------------
498      !
499      IF (before) THEN
500         zrhoy = Agrif_Rhoy()
501         DO jj=j1,j2
502            DO ji=i1,i2
503               tabres(ji,jj) = ub2_i_b(ji,jj) * e2u(ji,jj)
504            END DO
505         END DO
506         tabres = zrhoy * tabres
507      ELSE
508         DO jj=j1,j2
509            DO ji=i1,i2
510               ub2_b(ji,jj) = tabres(ji,jj) / e2u(ji,jj)
511            END DO
512         END DO
513      ENDIF
514      !
515   END SUBROUTINE updateub2b
516
517
518   SUBROUTINE updatevb2b( tabres, i1, i2, j1, j2, before )
519      !!----------------------------------------------------------------------
520      !!                      *** ROUTINE updatevb2b ***
521      !!----------------------------------------------------------------------
522      INTEGER                         , INTENT(in   ) ::   i1, i2, j1, j2
523      REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) ::   tabres
524      LOGICAL                         , INTENT(in   ) ::   before
525      !!
526      INTEGER ::   ji, jj
527      REAL(wp)::   zrhox
528      !!----------------------------------------------------------------------
529      !
530      IF( before ) THEN
531         zrhox = Agrif_Rhox()
532         DO jj=j1,j2
533            DO ji=i1,i2
534               tabres(ji,jj) = vb2_i_b(ji,jj) * e1v(ji,jj) 
535            END DO
536         END DO
537         tabres = zrhox * tabres
538      ELSE
539         DO jj=j1,j2
540            DO ji=i1,i2
541               vb2_b(ji,jj) = tabres(ji,jj) / e1v(ji,jj)
542            END DO
543         END DO
544      ENDIF
545      !
546   END SUBROUTINE updatevb2b
547
548
549   SUBROUTINE update_scales( tabres, i1, i2, j1, j2, k1, k2, n1,n2, before )
550      !
551      ! ====>>>>>>>>>>    currently not used
552      !
553      !!----------------------------------------------------------------------
554      !!                      *** ROUTINE updateT ***
555      !!----------------------------------------------------------------------
556      INTEGER                                    , INTENT(in   ) ::   i1, i2, j1, j2, k1, k2, n1, n2
557      REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2), INTENT(inout) ::   tabres
558      LOGICAL                                    , INTENT(in   ) ::   before
559      !!
560      INTEGER :: ji,jj,jk
561      REAL(wp) :: ztemp
562      !!----------------------------------------------------------------------
563
564      IF (before) THEN
565         DO jk=k1,k2
566            DO jj=j1,j2
567               DO ji=i1,i2
568                  tabres(ji,jj,jk,1) = e1t(ji,jj)*e2t(ji,jj)*tmask(ji,jj,jk)
569                  tabres(ji,jj,jk,2) = e1t(ji,jj)*tmask(ji,jj,jk)
570                  tabres(ji,jj,jk,3) = e2t(ji,jj)*tmask(ji,jj,jk)
571               END DO
572            END DO
573         END DO
574         tabres(:,:,:,1)=tabres(:,:,:,1)*Agrif_Rhox()*Agrif_Rhoy()
575         tabres(:,:,:,2)=tabres(:,:,:,2)*Agrif_Rhox()
576         tabres(:,:,:,3)=tabres(:,:,:,3)*Agrif_Rhoy()
577      ELSE
578         DO jk=k1,k2
579            DO jj=j1,j2
580               DO ji=i1,i2
581                  IF( tabres(ji,jj,jk,1) .NE. 0. ) THEN
582                     print *,'VAL = ',ji,jj,jk,tabres(ji,jj,jk,1),e1t(ji,jj)*e2t(ji,jj)*tmask(ji,jj,jk)
583                     print *,'VAL2 = ',ji,jj,jk,tabres(ji,jj,jk,2),e1t(ji,jj)*tmask(ji,jj,jk)
584                     print *,'VAL3 = ',ji,jj,jk,tabres(ji,jj,jk,3),e2t(ji,jj)*tmask(ji,jj,jk)
585                     ztemp = sqrt(tabres(ji,jj,jk,1)/(tabres(ji,jj,jk,2)*tabres(ji,jj,jk,3)))
586                     print *,'CORR = ',ztemp-1.
587                     print *,'NEW VALS = ',tabres(ji,jj,jk,2)*ztemp,tabres(ji,jj,jk,3)*ztemp, &
588                           tabres(ji,jj,jk,2)*ztemp*tabres(ji,jj,jk,3)*ztemp
589                     e1t(ji,jj) = tabres(ji,jj,jk,2)*ztemp
590                     e2t(ji,jj) = tabres(ji,jj,jk,3)*ztemp
591                  END IF
592               END DO
593            END DO
594         END DO
595      ENDIF
596      !
597   END SUBROUTINE update_scales
598
599
600   SUBROUTINE updateEN( ptab, i1, i2, j1, j2, k1, k2, before )
601      !!----------------------------------------------------------------------
602      !!                      *** ROUTINE updateen ***
603      !!----------------------------------------------------------------------
604      INTEGER                               , INTENT(in   ) ::   i1, i2, j1, j2, k1, k2
605      REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) ::   ptab
606      LOGICAL                               , INTENT(in   ) ::   before
607      !!----------------------------------------------------------------------
608      !
609      IF( before ) THEN
610         ptab (i1:i2,j1:j2,k1:k2) = en(i1:i2,j1:j2,k1:k2)
611      ELSE
612         en(i1:i2,j1:j2,k1:k2) = ptab (i1:i2,j1:j2,k1:k2) 
613      ENDIF
614      !
615   END SUBROUTINE updateEN
616
617
618   SUBROUTINE updateAVT( ptab, i1, i2, j1, j2, k1, k2, before )
619      !!----------------------------------------------------------------------
620      !!                      *** ROUTINE updateavt ***
621      !!----------------------------------------------------------------------
622      INTEGER                               , INTENT(in   ) ::   i1, i2, j1, j2, k1, k2
623      REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) ::   ptab
624      LOGICAL                               , INTENT(in   ) ::   before
625      !!----------------------------------------------------------------------
626      !
627      IF( before ) THEN   ;   ptab (i1:i2,j1:j2,k1:k2) = avt_k(i1:i2,j1:j2,k1:k2)
628      ELSE                ;   avt_k(i1:i2,j1:j2,k1:k2) = ptab (i1:i2,j1:j2,k1:k2) 
629      ENDIF
630      !
631   END SUBROUTINE updateAVT
632
633
634   SUBROUTINE updateAVM( ptab, i1, i2, j1, j2, k1, k2, before )
635      !!---------------------------------------------
636      !!           *** ROUTINE updateavm ***
637      !!----------------------------------------------------------------------
638      INTEGER                               , INTENT(in   ) ::   i1, i2, j1, j2, k1, k2
639      REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) ::   ptab
640      LOGICAL                               , INTENT(in   ) ::   before
641      !!----------------------------------------------------------------------
642      !
643      IF( before ) THEN   ;   ptab (i1:i2,j1:j2,k1:k2) = avm_k(i1:i2,j1:j2,k1:k2)
644      ELSE                ;   avm_k(i1:i2,j1:j2,k1:k2) = ptab (i1:i2,j1:j2,k1:k2) 
645      ENDIF
646      !
647   END SUBROUTINE updateAVM
648
649#else
650   !!----------------------------------------------------------------------
651   !!   Empty module                                          no AGRIF zoom
652   !!----------------------------------------------------------------------
653CONTAINS
654   SUBROUTINE agrif_opa_update_empty
655      WRITE(*,*)  'agrif_opa_update : You should not have seen this print! error?'
656   END SUBROUTINE agrif_opa_update_empty
657#endif
658
659   !!======================================================================
660END MODULE agrif_opa_update
661
Note: See TracBrowser for help on using the repository browser.