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

source: branches/UKMO/AMM15_v3_6_STABLE_package_collate_utils305/NEMOGCM/NEMO/NST_SRC/agrif_opa_update.F90 @ 11979

Last change on this file since 11979 was 8058, checked in by jgraham, 7 years ago

Clear keywords

File size: 22.9 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. 0 ) .AND. (kt /= 0) ) RETURN
163#  if defined TWO_WAY
164
165      Agrif_UseSpecialValueInUpdate = .TRUE.
166      Agrif_SpecialValueFineGrid = 0.
167
168      CALL Agrif_Update_Variable( en_id, locupdate=(/0,0/), procname=updateEN  )
169      CALL Agrif_Update_Variable(avt_id, locupdate=(/0,0/), procname=updateAVT )
170      CALL Agrif_Update_Variable(avm_id, locupdate=(/0,0/), procname=updateAVM )
171
172      Agrif_UseSpecialValueInUpdate = .FALSE.
173
174#  endif
175     
176   END SUBROUTINE Agrif_Update_Tke
177# endif /* key_zdftke */
178
179   SUBROUTINE updateTS( tabres, i1, i2, j1, j2, k1, k2, n1, n2, before )
180      !!---------------------------------------------
181      !!           *** ROUTINE updateT ***
182      !!---------------------------------------------
183#  include "domzgr_substitute.h90"
184      INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2,n1,n2
185      REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2), INTENT(inout) :: tabres
186      LOGICAL, INTENT(in) :: before
187      !!
188      INTEGER :: ji,jj,jk,jn
189      !!---------------------------------------------
190      !
191      IF (before) THEN
192         DO jn = n1,n2
193            DO jk=k1,k2
194               DO jj=j1,j2
195                  DO ji=i1,i2
196                     tabres(ji,jj,jk,jn) = tsn(ji,jj,jk,jn)
197                  END DO
198               END DO
199            END DO
200         END DO
201      ELSE
202         IF (.NOT.(lk_agrif_fstep.AND.(neuler==0))) THEN
203            ! Add asselin part
204            DO jn = n1,n2
205               DO jk=k1,k2
206                  DO jj=j1,j2
207                     DO ji=i1,i2
208                        IF( tabres(ji,jj,jk,jn) .NE. 0. ) THEN
209                           tsb(ji,jj,jk,jn) = tsb(ji,jj,jk,jn) & 
210                                 & + atfp * ( tabres(ji,jj,jk,jn) &
211                                 &             - tsn(ji,jj,jk,jn) ) * tmask(ji,jj,jk)
212                        ENDIF
213                     ENDDO
214                  ENDDO
215               ENDDO
216            ENDDO
217         ENDIF
218         DO jn = n1,n2
219            DO jk=k1,k2
220               DO jj=j1,j2
221                  DO ji=i1,i2
222                     IF( tabres(ji,jj,jk,jn) .NE. 0. ) THEN
223                        tsn(ji,jj,jk,jn) = tabres(ji,jj,jk,jn) * tmask(ji,jj,jk)
224                     END IF
225                  END DO
226               END DO
227            END DO
228         END DO
229      ENDIF
230      !
231   END SUBROUTINE updateTS
232
233   SUBROUTINE updateu( tabres, i1, i2, j1, j2, k1, k2, before )
234      !!---------------------------------------------
235      !!           *** ROUTINE updateu ***
236      !!---------------------------------------------
237#  include "domzgr_substitute.h90"
238      !!
239      INTEGER, INTENT(in) :: i1, i2, j1, j2, k1, k2
240      REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: tabres
241      LOGICAL, INTENT(in) :: before
242      !!
243      INTEGER :: ji, jj, jk
244      REAL(wp) :: zrhoy
245      !!---------------------------------------------
246      !
247      IF (before) THEN
248         zrhoy = Agrif_Rhoy()
249         DO jk=k1,k2
250            DO jj=j1,j2
251               DO ji=i1,i2
252                  tabres(ji,jj,jk) = e2u(ji,jj) * un(ji,jj,jk)
253                  tabres(ji,jj,jk) = tabres(ji,jj,jk) * fse3u_n(ji,jj,jk)
254               END DO
255            END DO
256         END DO
257         tabres = zrhoy * tabres
258      ELSE
259         DO jk=k1,k2
260            DO jj=j1,j2
261               DO ji=i1,i2
262                  tabres(ji,jj,jk) = tabres(ji,jj,jk) / e2u(ji,jj) / fse3u_n(ji,jj,jk)
263                  !
264                  IF (.NOT.(lk_agrif_fstep.AND.(neuler==0))) THEN ! Add asselin part
265                     ub(ji,jj,jk) = ub(ji,jj,jk) & 
266                           & + atfp * ( tabres(ji,jj,jk) - un(ji,jj,jk) ) * umask(ji,jj,jk)
267                  ENDIF
268                  !
269                  un(ji,jj,jk) = tabres(ji,jj,jk) * umask(ji,jj,jk)
270               END DO
271            END DO
272         END DO
273      ENDIF
274      !
275   END SUBROUTINE updateu
276
277   SUBROUTINE updatev( tabres, i1, i2, j1, j2, k1, k2, before )
278      !!---------------------------------------------
279      !!           *** ROUTINE updatev ***
280      !!---------------------------------------------
281#  include "domzgr_substitute.h90"
282      !!
283      INTEGER :: i1,i2,j1,j2,k1,k2
284      INTEGER :: ji,jj,jk
285      REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2) :: tabres
286      LOGICAL :: before
287      !!
288      REAL(wp) :: zrhox
289      !!---------------------------------------------     
290      !
291      IF (before) THEN
292         zrhox = Agrif_Rhox()
293         DO jk=k1,k2
294            DO jj=j1,j2
295               DO ji=i1,i2
296                  tabres(ji,jj,jk) = e1v(ji,jj) * vn(ji,jj,jk)
297                  tabres(ji,jj,jk) = tabres(ji,jj,jk) * fse3v_n(ji,jj,jk)
298               END DO
299            END DO
300         END DO
301         tabres = zrhox * tabres
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) / e1v(ji,jj) / fse3v_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   SUBROUTINE updateu2d( tabres, i1, i2, j1, j2, before )
322      !!---------------------------------------------
323      !!          *** ROUTINE updateu2d ***
324      !!---------------------------------------------
325#  include "domzgr_substitute.h90"
326      !!
327      INTEGER, INTENT(in) :: i1, i2, j1, j2
328      REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres
329      LOGICAL, INTENT(in) :: before
330      !!
331      INTEGER :: ji, jj, jk
332      REAL(wp) :: zrhoy
333      REAL(wp) :: zcorr
334      !!---------------------------------------------
335      !
336      IF (before) THEN
337         zrhoy = Agrif_Rhoy()
338         DO jj=j1,j2
339            DO ji=i1,i2
340               tabres(ji,jj) = un_b(ji,jj) * hu(ji,jj) * e2u(ji,jj)
341            END DO
342         END DO
343         tabres = zrhoy * tabres
344      ELSE
345         DO jj=j1,j2
346            DO ji=i1,i2
347               tabres(ji,jj) =  tabres(ji,jj) * hur(ji,jj) / e2u(ji,jj) 
348               !   
349               ! Update "now" 3d velocities:
350               spgu(ji,jj) = 0.e0
351               DO jk=1,jpkm1
352                  spgu(ji,jj) = spgu(ji,jj) + fse3u_n(ji,jj,jk) * un(ji,jj,jk)
353               END DO
354               spgu(ji,jj) = spgu(ji,jj) * hur(ji,jj)
355               !
356               zcorr = tabres(ji,jj) - spgu(ji,jj)
357               DO jk=1,jpkm1             
358                  un(ji,jj,jk) = un(ji,jj,jk) + zcorr * umask(ji,jj,jk)           
359               END DO
360               !
361               ! Update barotropic velocities:
362#if defined key_dynspg_ts
363               IF (.NOT.(lk_agrif_fstep.AND.(neuler==0))) THEN ! Add asselin part
364                  zcorr = tabres(ji,jj) - un_b(ji,jj)
365                  ub_b(ji,jj) = ub_b(ji,jj) + atfp * zcorr * umask(ji,jj,1)
366               END IF
367#endif               
368               un_b(ji,jj) = tabres(ji,jj) * umask(ji,jj,1)
369               !       
370               ! Correct "before" velocities to hold correct bt component:
371               spgu(ji,jj) = 0.e0
372               DO jk=1,jpkm1
373                  spgu(ji,jj) = spgu(ji,jj) + fse3u_b(ji,jj,jk) * ub(ji,jj,jk)
374               END DO
375               spgu(ji,jj) = spgu(ji,jj) * hur_b(ji,jj)
376               !
377               zcorr = ub_b(ji,jj) - spgu(ji,jj)
378               DO jk=1,jpkm1             
379                  ub(ji,jj,jk) = ub(ji,jj,jk) + zcorr * umask(ji,jj,jk)           
380               END DO
381               !
382            END DO
383         END DO
384      ENDIF
385      !
386   END SUBROUTINE updateu2d
387
388   SUBROUTINE updatev2d( tabres, i1, i2, j1, j2, before )
389      !!---------------------------------------------
390      !!          *** ROUTINE updatev2d ***
391      !!---------------------------------------------
392      INTEGER, INTENT(in) :: i1, i2, j1, j2
393      REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres
394      LOGICAL, INTENT(in) :: before
395      !!
396      INTEGER :: ji, jj, jk
397      REAL(wp) :: zrhox
398      REAL(wp) :: zcorr
399      !!---------------------------------------------
400      !
401      IF (before) THEN
402         zrhox = Agrif_Rhox()
403         DO jj=j1,j2
404            DO ji=i1,i2
405               tabres(ji,jj) = vn_b(ji,jj) * hv(ji,jj) * e1v(ji,jj) 
406            END DO
407         END DO
408         tabres = zrhox * tabres
409      ELSE
410         DO jj=j1,j2
411            DO ji=i1,i2
412               tabres(ji,jj) =  tabres(ji,jj) * hvr(ji,jj) / e1v(ji,jj) 
413               !   
414               ! Update "now" 3d velocities:
415               spgv(ji,jj) = 0.e0
416               DO jk=1,jpkm1
417                  spgv(ji,jj) = spgv(ji,jj) + fse3v_n(ji,jj,jk) * vn(ji,jj,jk)
418               END DO
419               spgv(ji,jj) = spgv(ji,jj) * hvr(ji,jj)
420               !
421               zcorr = tabres(ji,jj) - spgv(ji,jj)
422               DO jk=1,jpkm1             
423                  vn(ji,jj,jk) = vn(ji,jj,jk) + zcorr * vmask(ji,jj,jk)           
424               END DO
425               !
426               ! Update barotropic velocities:
427#if defined key_dynspg_ts
428               IF (.NOT.(lk_agrif_fstep.AND.(neuler==0))) THEN ! Add asselin part
429                  zcorr = tabres(ji,jj) - vn_b(ji,jj)
430                  vb_b(ji,jj) = vb_b(ji,jj) + atfp * zcorr * vmask(ji,jj,1)
431               END IF
432#endif               
433               vn_b(ji,jj) = tabres(ji,jj) * vmask(ji,jj,1)
434               !       
435               ! Correct "before" velocities to hold correct bt component:
436               spgv(ji,jj) = 0.e0
437               DO jk=1,jpkm1
438                  spgv(ji,jj) = spgv(ji,jj) + fse3v_b(ji,jj,jk) * vb(ji,jj,jk)
439               END DO
440               spgv(ji,jj) = spgv(ji,jj) * hvr_b(ji,jj)
441               !
442               zcorr = vb_b(ji,jj) - spgv(ji,jj)
443               DO jk=1,jpkm1             
444                  vb(ji,jj,jk) = vb(ji,jj,jk) + zcorr * vmask(ji,jj,jk)           
445               END DO
446               !
447            END DO
448         END DO
449      ENDIF
450      !
451   END SUBROUTINE updatev2d
452
453
454   SUBROUTINE updateSSH( tabres, i1, i2, j1, j2, before )
455      !!---------------------------------------------
456      !!          *** ROUTINE updateSSH ***
457      !!---------------------------------------------
458      INTEGER, INTENT(in) :: i1, i2, j1, j2
459      REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres
460      LOGICAL, INTENT(in) :: before
461      !!
462      INTEGER :: ji, jj
463      !!---------------------------------------------
464      !
465      IF (before) THEN
466         DO jj=j1,j2
467            DO ji=i1,i2
468               tabres(ji,jj) = sshn(ji,jj)
469            END DO
470         END DO
471      ELSE
472#if ! defined key_dynspg_ts
473         IF (.NOT.(lk_agrif_fstep.AND.(neuler==0))) THEN
474            DO jj=j1,j2
475               DO ji=i1,i2
476                  sshb(ji,jj) =   sshb(ji,jj) &
477                        & + atfp * ( tabres(ji,jj) - sshn(ji,jj) ) * tmask(ji,jj,1)
478               END DO
479            END DO
480         ENDIF
481#endif
482         DO jj=j1,j2
483            DO ji=i1,i2
484               sshn(ji,jj) = tabres(ji,jj) * tmask(ji,jj,1)
485            END DO
486         END DO
487      ENDIF
488      !
489   END SUBROUTINE updateSSH
490
491   SUBROUTINE updateub2b( tabres, i1, i2, j1, j2, before )
492      !!---------------------------------------------
493      !!          *** ROUTINE updateub2b ***
494      !!---------------------------------------------
495      INTEGER, INTENT(in) :: i1, i2, j1, j2
496      REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres
497      LOGICAL, INTENT(in) :: before
498      !!
499      INTEGER :: ji, jj
500      REAL(wp) :: zrhoy
501      !!---------------------------------------------
502      !
503      IF (before) THEN
504         zrhoy = Agrif_Rhoy()
505         DO jj=j1,j2
506            DO ji=i1,i2
507               tabres(ji,jj) = ub2_i_b(ji,jj) * e2u(ji,jj)
508            END DO
509         END DO
510         tabres = zrhoy * tabres
511      ELSE
512         DO jj=j1,j2
513            DO ji=i1,i2
514               ub2_b(ji,jj) = tabres(ji,jj) / e2u(ji,jj)
515            END DO
516         END DO
517      ENDIF
518      !
519   END SUBROUTINE updateub2b
520
521   SUBROUTINE updatevb2b( tabres, i1, i2, j1, j2, before )
522      !!---------------------------------------------
523      !!          *** ROUTINE updatevb2b ***
524      !!---------------------------------------------
525      INTEGER, INTENT(in) :: i1, i2, j1, j2
526      REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres
527      LOGICAL, INTENT(in) :: before
528      !!
529      INTEGER :: ji, jj
530      REAL(wp) :: zrhox
531      !!---------------------------------------------
532      !
533      IF (before) THEN
534         zrhox = Agrif_Rhox()
535         DO jj=j1,j2
536            DO ji=i1,i2
537               tabres(ji,jj) = vb2_i_b(ji,jj) * e1v(ji,jj) 
538            END DO
539         END DO
540         tabres = zrhox * tabres
541      ELSE
542         DO jj=j1,j2
543            DO ji=i1,i2
544               vb2_b(ji,jj) = tabres(ji,jj) / e1v(ji,jj)
545            END DO
546         END DO
547      ENDIF
548      !
549   END SUBROUTINE updatevb2b
550
551
552   SUBROUTINE update_scales( tabres, i1, i2, j1, j2, k1, k2, n1,n2, before )
553      ! currently not used
554      !!---------------------------------------------
555      !!           *** ROUTINE updateT ***
556      !!---------------------------------------------
557#  include "domzgr_substitute.h90"
558
559      INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2,n1,n2
560      REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2), INTENT(inout) :: tabres
561      LOGICAL, iNTENT(in) :: before
562
563      INTEGER :: ji,jj,jk
564      REAL(wp) :: ztemp
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# if defined key_zdftke
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
630         ptab (i1:i2,j1:j2,k1:k2) = avt_k(i1:i2,j1:j2,k1:k2)
631      ELSE
632         avt_k(i1:i2,j1:j2,k1:k2) = ptab (i1:i2,j1:j2,k1:k2) 
633      ENDIF
634      !
635   END SUBROUTINE updateAVT
636
637
638   SUBROUTINE updateAVM( ptab, i1, i2, j1, j2, k1, k2, before )
639      !!---------------------------------------------
640      !!           *** ROUTINE updateavm ***
641      !!---------------------------------------------
642      INTEGER, INTENT(in) :: i1, i2, j1, j2, k1, k2
643      REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: ptab
644      LOGICAL, INTENT(in) :: before
645      !!---------------------------------------------
646      !
647      IF (before) THEN
648         ptab (i1:i2,j1:j2,k1:k2) = avm_k(i1:i2,j1:j2,k1:k2)
649      ELSE
650         avm_k(i1:i2,j1:j2,k1:k2) = ptab (i1:i2,j1:j2,k1:k2) 
651      ENDIF
652      !
653   END SUBROUTINE updateAVM
654
655# endif /* key_zdftke */ 
656
657#else
658CONTAINS
659   SUBROUTINE agrif_opa_update_empty
660      !!---------------------------------------------
661      !!   *** ROUTINE agrif_opa_update_empty ***
662      !!---------------------------------------------
663      WRITE(*,*)  'agrif_opa_update : You should not have seen this print! error?'
664   END SUBROUTINE agrif_opa_update_empty
665#endif
666END MODULE agrif_opa_update
667
Note: See TracBrowser for help on using the repository browser.