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

source: branches/2017/dev_r7881_HPC09_ZDF/NEMOGCM/NEMO/NST_SRC/agrif_opa_update.F90 @ 7953

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

#1880 (HPC-09): add zdfphy (the ZDF manager) + remove all key_...

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