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

source: branches/2017/dev_CNRS_2017/NEMOGCM/NEMO/NST_SRC/agrif_opa_update.F90 @ 8882

Last change on this file since 8882 was 8882, checked in by flavoni, 6 years ago

dev_CNRS_2017 branch: merged dev_r7881_ENHANCE09_RK3 with trunk r8864

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