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

source: branches/2015/dev_r5072_UKMO2_OBS_simplification/NEMOGCM/NEMO/NST_SRC/agrif_opa_update.F90 @ 5974

Last change on this file since 5974 was 5974, checked in by timgraham, 8 years ago

Upgrade to head of trunk (r5936)

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