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

Last change on this file since 4789 was 4789, checked in by rblod, 10 years ago

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