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

source: branches/2014/dev_r4765_CNRS_agrif/NEMOGCM/NEMO/NST_SRC/agrif_opa_update.F90 @ 4980

Last change on this file since 4980 was 4980, checked in by jchanut, 9 years ago

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