source: trunk/NEMOGCM/NEMO/NST_SRC/agrif_opa_update.F90 @ 7795

Last change on this file since 7795 was 7646, checked in by timgraham, 4 years ago

Merge of dev_merge_2016 into trunk. UPDATE TO ARCHFILES NEEDED for XIOS2.
LIM_SRC_s/limrhg.F90 to follow in next commit due to change of kind (I'm unable to do it in this commit).
Merged using the following steps:

1) svn merge —reintegrate svn+ssh://forge.ipsl.jussieu.fr/ipsl/forge/projets/nemo/svn/trunk .
2) Resolve minor conflicts in sette.sh and namelist_cfg for ORCA2LIM3 (due to a change in trunk after branch was created)
3) svn commit
4) svn switch svn+ssh://forge.ipsl.jussieu.fr/ipsl/forge/projets/nemo/svn/trunk
5) svn merge svn+ssh://forge.ipsl.jussieu.fr/ipsl/forge/projets/nemo/svn/branches/2016/dev_merge_2016 .
6) At this stage I checked out a clean copy of the branch to compare against what is about to be committed to the trunk.
6) svn commit #Commit code to the trunk

In this commit I have also reverted a change to Fcheck_archfile.sh which was causing problems on the Paris machine.

  • Property svn:keywords set to Id
File size: 22.8 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 
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   !!----------------------------------------------------------------------
27CONTAINS
28
29   RECURSIVE SUBROUTINE Agrif_Update_Tra( )
30      !!---------------------------------------------
31      !!   *** ROUTINE Agrif_Update_Tra ***
32      !!---------------------------------------------
33      !
34      IF (Agrif_Root()) RETURN
35      !
36#if defined TWO_WAY 
37      IF (lwp.AND.lk_agrif_debug) Write(*,*) 'Update tracers  from grid Number',Agrif_Fixed(), 'nbcline', nbcline
38
39      Agrif_UseSpecialValueInUpdate = .TRUE.
40      Agrif_SpecialValueFineGrid = 0.
41      !
42      IF (MOD(nbcline,nbclineupdate) == 0) THEN
43# if ! defined DECAL_FEEDBACK
44         CALL Agrif_Update_Variable(tsn_id, procname=updateTS)
45# else
46         CALL Agrif_Update_Variable(tsn_id, locupdate=(/1,0/),procname=updateTS)
47# endif
48      ELSE
49# if ! defined DECAL_FEEDBACK
50         CALL Agrif_Update_Variable(tsn_id,locupdate=(/0,2/), procname=updateTS)
51# else
52         CALL Agrif_Update_Variable(tsn_id,locupdate=(/1,2/), procname=updateTS)
53# endif
54      ENDIF
55      !
56      Agrif_UseSpecialValueInUpdate = .FALSE.
57      !
58      IF ( lk_agrif_doupd ) THEN ! Initialisation: do recursive update:
59         CALL Agrif_ChildGrid_To_ParentGrid()
60         CALL Agrif_Update_Tra()
61         CALL Agrif_ParentGrid_To_ChildGrid()
62      ENDIF
63      !
64#endif
65      !
66   END SUBROUTINE Agrif_Update_Tra
67
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
153   SUBROUTINE Agrif_Update_Tke( kt )
154      !!---------------------------------------------
155      !!   *** ROUTINE Agrif_Update_Tke ***
156      !!---------------------------------------------
157      !!
158      INTEGER, INTENT(in) :: kt
159      !       
160      IF( ( Agrif_NbStepint() .NE. 0 ) .AND. (kt /= 0) ) RETURN
161#  if defined TWO_WAY
162
163      Agrif_UseSpecialValueInUpdate = .TRUE.
164      Agrif_SpecialValueFineGrid = 0.
165
166      CALL Agrif_Update_Variable( en_id, locupdate=(/0,0/), procname=updateEN  )
167      CALL Agrif_Update_Variable(avt_id, locupdate=(/0,0/), procname=updateAVT )
168      CALL Agrif_Update_Variable(avm_id, locupdate=(/0,0/), procname=updateAVM )
169
170      Agrif_UseSpecialValueInUpdate = .FALSE.
171
172#  endif
173     
174   END SUBROUTINE Agrif_Update_Tke
175   
176# endif /* key_zdftke */
177
178   SUBROUTINE updateTS( tabres, i1, i2, j1, j2, k1, k2, n1, n2, before )
179      !!---------------------------------------------
180      !!           *** ROUTINE updateT ***
181      !!---------------------------------------------
182      INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2,n1,n2
183      REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2), INTENT(inout) :: tabres
184      LOGICAL, INTENT(in) :: before
185      !!
186      INTEGER :: ji,jj,jk,jn
187      !!---------------------------------------------
188      !
189      IF (before) THEN
190         DO jn = n1,n2
191            DO jk=k1,k2
192               DO jj=j1,j2
193                  DO ji=i1,i2
194                     tabres(ji,jj,jk,jn) = tsn(ji,jj,jk,jn)
195                  END DO
196               END DO
197            END DO
198         END DO
199      ELSE
200         IF (.NOT.(lk_agrif_fstep.AND.(neuler==0))) THEN
201            ! Add asselin part
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                           tsb(ji,jj,jk,jn) = tsb(ji,jj,jk,jn) & 
208                                 & + atfp * ( tabres(ji,jj,jk,jn) &
209                                 &             - tsn(ji,jj,jk,jn) ) * tmask(ji,jj,jk)
210                        ENDIF
211                     ENDDO
212                  ENDDO
213               ENDDO
214            ENDDO
215         ENDIF
216         DO jn = n1,n2
217            DO jk=k1,k2
218               DO jj=j1,j2
219                  DO ji=i1,i2
220                     IF( tabres(ji,jj,jk,jn) .NE. 0. ) THEN
221                        tsn(ji,jj,jk,jn) = tabres(ji,jj,jk,jn) * tmask(ji,jj,jk)
222                     END IF
223                  END DO
224               END DO
225            END DO
226         END DO
227      ENDIF
228      !
229   END SUBROUTINE updateTS
230
231
232   SUBROUTINE updateu( tabres, i1, i2, j1, j2, k1, k2, before )
233      !!---------------------------------------------
234      !!           *** ROUTINE updateu ***
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            tabres(i1:i2,j1:j2,jk) = zrhoy * e2u(i1:i2,j1:j2) * e3u_n(i1:i2,j1:j2,jk) * un(i1:i2,j1:j2,jk)
248         END DO
249      ELSE
250         DO jk=k1,k2
251            DO jj=j1,j2
252               DO ji=i1,i2
253                  tabres(ji,jj,jk) = tabres(ji,jj,jk) * r1_e2u(ji,jj) / e3u_n(ji,jj,jk)
254                  !
255                  IF (.NOT.(lk_agrif_fstep.AND.(neuler==0))) THEN ! Add asselin part
256                     ub(ji,jj,jk) = ub(ji,jj,jk) & 
257                           & + atfp * ( tabres(ji,jj,jk) - un(ji,jj,jk) ) * umask(ji,jj,jk)
258                  ENDIF
259                  !
260                  un(ji,jj,jk) = tabres(ji,jj,jk) * umask(ji,jj,jk)
261               END DO
262            END DO
263         END DO
264      ENDIF
265      !
266   END SUBROUTINE updateu
267
268
269   SUBROUTINE updatev( tabres, i1, i2, j1, j2, k1, k2, before )
270      !!---------------------------------------------
271      !!           *** ROUTINE updatev ***
272      !!---------------------------------------------
273      INTEGER :: i1,i2,j1,j2,k1,k2
274      INTEGER :: ji,jj,jk
275      REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2) :: tabres
276      LOGICAL :: before
277      !!
278      REAL(wp) :: zrhox
279      !!---------------------------------------------     
280      !
281      IF (before) THEN
282         zrhox = Agrif_Rhox()
283         DO jk=k1,k2
284            DO jj=j1,j2
285               DO ji=i1,i2
286                  tabres(ji,jj,jk) = zrhox * e1v(ji,jj) * e3v_n(ji,jj,jk) * vn(ji,jj,jk)
287               END DO
288            END DO
289         END DO
290      ELSE
291         DO jk=k1,k2
292            DO jj=j1,j2
293               DO ji=i1,i2
294                  tabres(ji,jj,jk) = tabres(ji,jj,jk) * r1_e1v(ji,jj) / e3v_n(ji,jj,jk)
295                  !
296                  IF (.NOT.(lk_agrif_fstep.AND.(neuler==0))) THEN ! Add asselin part
297                     vb(ji,jj,jk) = vb(ji,jj,jk) & 
298                           & + atfp * ( tabres(ji,jj,jk) - vn(ji,jj,jk) ) * vmask(ji,jj,jk)
299                  ENDIF
300                  !
301                  vn(ji,jj,jk) = tabres(ji,jj,jk) * vmask(ji,jj,jk)
302               END DO
303            END DO
304         END DO
305      ENDIF
306      !
307   END SUBROUTINE updatev
308
309
310   SUBROUTINE updateu2d( tabres, i1, i2, j1, j2, before )
311      !!---------------------------------------------
312      !!          *** ROUTINE updateu2d ***
313      !!---------------------------------------------
314      INTEGER, INTENT(in) :: i1, i2, j1, j2
315      REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres
316      LOGICAL, INTENT(in) :: before
317      !!
318      INTEGER :: ji, jj, jk
319      REAL(wp) :: zrhoy
320      REAL(wp) :: zcorr
321      !!---------------------------------------------
322      !
323      IF (before) THEN
324         zrhoy = Agrif_Rhoy()
325         DO jj=j1,j2
326            DO ji=i1,i2
327               tabres(ji,jj) = zrhoy * un_b(ji,jj) * hu_n(ji,jj) * e2u(ji,jj)
328            END DO
329         END DO
330      ELSE
331         DO jj=j1,j2
332            DO ji=i1,i2
333               tabres(ji,jj) =  tabres(ji,jj) * r1_hu_n(ji,jj) * r1_e2u(ji,jj) 
334               !   
335               ! Update "now" 3d velocities:
336               spgu(ji,jj) = 0._wp
337               DO jk=1,jpkm1
338                  spgu(ji,jj) = spgu(ji,jj) + e3u_n(ji,jj,jk) * un(ji,jj,jk)
339               END DO
340               spgu(ji,jj) = spgu(ji,jj) * r1_hu_n(ji,jj)
341               !
342               zcorr = tabres(ji,jj) - spgu(ji,jj)
343               DO jk=1,jpkm1             
344                  un(ji,jj,jk) = un(ji,jj,jk) + zcorr * umask(ji,jj,jk)           
345               END DO
346               !
347               ! Update barotropic velocities:
348               IF ( .NOT.ln_dynspg_ts .OR. (ln_dynspg_ts.AND.(.NOT.ln_bt_fw)) ) THEN
349                  IF (.NOT.(lk_agrif_fstep.AND.(neuler==0))) THEN ! Add asselin part
350                     zcorr = tabres(ji,jj) - un_b(ji,jj)
351                     ub_b(ji,jj) = ub_b(ji,jj) + atfp * zcorr * umask(ji,jj,1)
352                  END IF
353               ENDIF             
354               un_b(ji,jj) = tabres(ji,jj) * umask(ji,jj,1)
355               !       
356               ! Correct "before" velocities to hold correct bt component:
357               spgu(ji,jj) = 0.e0
358               DO jk=1,jpkm1
359                  spgu(ji,jj) = spgu(ji,jj) + e3u_b(ji,jj,jk) * ub(ji,jj,jk)
360               END DO
361               spgu(ji,jj) = spgu(ji,jj) * r1_hu_b(ji,jj)
362               !
363               zcorr = ub_b(ji,jj) - spgu(ji,jj)
364               DO jk=1,jpkm1             
365                  ub(ji,jj,jk) = ub(ji,jj,jk) + zcorr * umask(ji,jj,jk)           
366               END DO
367               !
368            END DO
369         END DO
370      ENDIF
371      !
372   END SUBROUTINE updateu2d
373
374
375   SUBROUTINE updatev2d( tabres, i1, i2, j1, j2, before )
376      !!---------------------------------------------
377      !!          *** ROUTINE updatev2d ***
378      !!---------------------------------------------
379      INTEGER, INTENT(in) :: i1, i2, j1, j2
380      REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres
381      LOGICAL, INTENT(in) :: before
382      !!
383      INTEGER :: ji, jj, jk
384      REAL(wp) :: zrhox
385      REAL(wp) :: zcorr
386      !!---------------------------------------------
387      !
388      IF (before) THEN
389         zrhox = Agrif_Rhox()
390         DO jj=j1,j2
391            DO ji=i1,i2
392               tabres(ji,jj) = zrhox * vn_b(ji,jj) * hv_n(ji,jj) * e1v(ji,jj) 
393            END DO
394         END DO
395      ELSE
396         DO jj=j1,j2
397            DO ji=i1,i2
398               tabres(ji,jj) =  tabres(ji,jj) * r1_hv_n(ji,jj) * r1_e1v(ji,jj) 
399               !   
400               ! Update "now" 3d velocities:
401               spgv(ji,jj) = 0.e0
402               DO jk=1,jpkm1
403                  spgv(ji,jj) = spgv(ji,jj) + e3v_n(ji,jj,jk) * vn(ji,jj,jk)
404               END DO
405               spgv(ji,jj) = spgv(ji,jj) * r1_hv_n(ji,jj)
406               !
407               zcorr = tabres(ji,jj) - spgv(ji,jj)
408               DO jk=1,jpkm1             
409                  vn(ji,jj,jk) = vn(ji,jj,jk) + zcorr * vmask(ji,jj,jk)           
410               END DO
411               !
412               ! Update barotropic velocities:
413               IF ( .NOT.ln_dynspg_ts .OR. (ln_dynspg_ts.AND.(.NOT.ln_bt_fw)) ) THEN
414                  IF (.NOT.(lk_agrif_fstep.AND.(neuler==0))) THEN ! Add asselin part
415                     zcorr = tabres(ji,jj) - vn_b(ji,jj)
416                     vb_b(ji,jj) = vb_b(ji,jj) + atfp * zcorr * vmask(ji,jj,1)
417                  END IF
418               ENDIF             
419               vn_b(ji,jj) = tabres(ji,jj) * vmask(ji,jj,1)
420               !       
421               ! Correct "before" velocities to hold correct bt component:
422               spgv(ji,jj) = 0.e0
423               DO jk=1,jpkm1
424                  spgv(ji,jj) = spgv(ji,jj) + e3v_b(ji,jj,jk) * vb(ji,jj,jk)
425               END DO
426               spgv(ji,jj) = spgv(ji,jj) * r1_hv_b(ji,jj)
427               !
428               zcorr = vb_b(ji,jj) - spgv(ji,jj)
429               DO jk=1,jpkm1             
430                  vb(ji,jj,jk) = vb(ji,jj,jk) + zcorr * vmask(ji,jj,jk)           
431               END DO
432               !
433            END DO
434         END DO
435      ENDIF
436      !
437   END SUBROUTINE updatev2d
438
439
440   SUBROUTINE updateSSH( tabres, i1, i2, j1, j2, before )
441      !!---------------------------------------------
442      !!          *** ROUTINE updateSSH ***
443      !!---------------------------------------------
444      INTEGER, INTENT(in) :: i1, i2, j1, j2
445      REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres
446      LOGICAL, INTENT(in) :: before
447      !!
448      INTEGER :: ji, jj
449      !!---------------------------------------------
450      !
451      IF (before) THEN
452         DO jj=j1,j2
453            DO ji=i1,i2
454               tabres(ji,jj) = sshn(ji,jj)
455            END DO
456         END DO
457      ELSE
458         IF( .NOT.ln_dynspg_ts .OR. ( ln_dynspg_ts .AND. .NOT.ln_bt_fw ) ) THEN
459            IF (.NOT.(lk_agrif_fstep.AND.(neuler==0))) THEN
460               DO jj=j1,j2
461                  DO ji=i1,i2
462                     sshb(ji,jj) =   sshb(ji,jj) &
463                           & + atfp * ( tabres(ji,jj) - sshn(ji,jj) ) * tmask(ji,jj,1)
464                  END DO
465               END DO
466            ENDIF
467         ENDIF
468         !
469         DO jj=j1,j2
470            DO ji=i1,i2
471               sshn(ji,jj) = tabres(ji,jj) * tmask(ji,jj,1)
472            END DO
473         END DO
474      ENDIF
475      !
476   END SUBROUTINE updateSSH
477
478
479   SUBROUTINE updateub2b( tabres, i1, i2, j1, j2, before )
480      !!---------------------------------------------
481      !!          *** ROUTINE updateub2b ***
482      !!---------------------------------------------
483      INTEGER, INTENT(in) :: i1, i2, j1, j2
484      REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres
485      LOGICAL, INTENT(in) :: before
486      !!
487      INTEGER :: ji, jj
488      REAL(wp) :: zrhoy
489      !!---------------------------------------------
490      !
491      IF (before) THEN
492         zrhoy = Agrif_Rhoy()
493         DO jj=j1,j2
494            DO ji=i1,i2
495               tabres(ji,jj) = ub2_i_b(ji,jj) * e2u(ji,jj)
496            END DO
497         END DO
498         tabres = zrhoy * tabres
499      ELSE
500         DO jj=j1,j2
501            DO ji=i1,i2
502               ub2_b(ji,jj) = tabres(ji,jj) / e2u(ji,jj)
503            END DO
504         END DO
505      ENDIF
506      !
507   END SUBROUTINE updateub2b
508
509
510   SUBROUTINE updatevb2b( tabres, i1, i2, j1, j2, before )
511      !!---------------------------------------------
512      !!          *** ROUTINE updatevb2b ***
513      !!---------------------------------------------
514      INTEGER, INTENT(in) :: i1, i2, j1, j2
515      REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres
516      LOGICAL, INTENT(in) :: before
517      !!
518      INTEGER :: ji, jj
519      REAL(wp) :: zrhox
520      !!---------------------------------------------
521      !
522      IF (before) THEN
523         zrhox = Agrif_Rhox()
524         DO jj=j1,j2
525            DO ji=i1,i2
526               tabres(ji,jj) = vb2_i_b(ji,jj) * e1v(ji,jj) 
527            END DO
528         END DO
529         tabres = zrhox * tabres
530      ELSE
531         DO jj=j1,j2
532            DO ji=i1,i2
533               vb2_b(ji,jj) = tabres(ji,jj) / e1v(ji,jj)
534            END DO
535         END DO
536      ENDIF
537      !
538   END SUBROUTINE updatevb2b
539
540
541   SUBROUTINE update_scales( tabres, i1, i2, j1, j2, k1, k2, n1,n2, before )
542      ! currently not used
543      !!---------------------------------------------
544      !!           *** ROUTINE updateT ***
545      !!---------------------------------------------
546      INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2,n1,n2
547      REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2), INTENT(inout) :: tabres
548      LOGICAL, iNTENT(in) :: before
549      !
550      INTEGER :: ji,jj,jk
551      REAL(wp) :: ztemp
552      !!---------------------------------------------
553
554      IF (before) THEN
555         DO jk=k1,k2
556            DO jj=j1,j2
557               DO ji=i1,i2
558                  tabres(ji,jj,jk,1) = e1t(ji,jj)*e2t(ji,jj)*tmask(ji,jj,jk)
559                  tabres(ji,jj,jk,2) = e1t(ji,jj)*tmask(ji,jj,jk)
560                  tabres(ji,jj,jk,3) = e2t(ji,jj)*tmask(ji,jj,jk)
561               END DO
562            END DO
563         END DO
564         tabres(:,:,:,1)=tabres(:,:,:,1)*Agrif_Rhox()*Agrif_Rhoy()
565         tabres(:,:,:,2)=tabres(:,:,:,2)*Agrif_Rhox()
566         tabres(:,:,:,3)=tabres(:,:,:,3)*Agrif_Rhoy()
567      ELSE
568         DO jk=k1,k2
569            DO jj=j1,j2
570               DO ji=i1,i2
571                  IF( tabres(ji,jj,jk,1) .NE. 0. ) THEN
572                     print *,'VAL = ',ji,jj,jk,tabres(ji,jj,jk,1),e1t(ji,jj)*e2t(ji,jj)*tmask(ji,jj,jk)
573                     print *,'VAL2 = ',ji,jj,jk,tabres(ji,jj,jk,2),e1t(ji,jj)*tmask(ji,jj,jk)
574                     print *,'VAL3 = ',ji,jj,jk,tabres(ji,jj,jk,3),e2t(ji,jj)*tmask(ji,jj,jk)
575                     ztemp = sqrt(tabres(ji,jj,jk,1)/(tabres(ji,jj,jk,2)*tabres(ji,jj,jk,3)))
576                     print *,'CORR = ',ztemp-1.
577                     print *,'NEW VALS = ',tabres(ji,jj,jk,2)*ztemp,tabres(ji,jj,jk,3)*ztemp, &
578                           tabres(ji,jj,jk,2)*ztemp*tabres(ji,jj,jk,3)*ztemp
579                     e1t(ji,jj) = tabres(ji,jj,jk,2)*ztemp
580                     e2t(ji,jj) = tabres(ji,jj,jk,3)*ztemp
581                  END IF
582               END DO
583            END DO
584         END DO
585      ENDIF
586      !
587   END SUBROUTINE update_scales
588
589# if defined key_zdftke
590
591   SUBROUTINE updateEN( ptab, i1, i2, j1, j2, k1, k2, before )
592      !!---------------------------------------------
593      !!           *** ROUTINE updateen ***
594      !!---------------------------------------------
595      INTEGER, INTENT(in) :: i1, i2, j1, j2, k1, k2
596      REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: ptab
597      LOGICAL, INTENT(in) :: before
598      !!---------------------------------------------
599      !
600      IF (before) THEN
601         ptab (i1:i2,j1:j2,k1:k2) = en(i1:i2,j1:j2,k1:k2)
602      ELSE
603         en(i1:i2,j1:j2,k1:k2) = ptab (i1:i2,j1:j2,k1:k2) 
604      ENDIF
605      !
606   END SUBROUTINE updateEN
607
608
609   SUBROUTINE updateAVT( ptab, i1, i2, j1, j2, k1, k2, before )
610      !!---------------------------------------------
611      !!           *** ROUTINE updateavt ***
612      !!---------------------------------------------
613      INTEGER, INTENT(in) :: i1, i2, j1, j2, k1, k2
614      REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: ptab
615      LOGICAL, INTENT(in) :: before
616      !!---------------------------------------------
617      !
618      IF (before) THEN
619         ptab (i1:i2,j1:j2,k1:k2) = avt_k(i1:i2,j1:j2,k1:k2)
620      ELSE
621         avt_k(i1:i2,j1:j2,k1:k2) = ptab (i1:i2,j1:j2,k1:k2) 
622      ENDIF
623      !
624   END SUBROUTINE updateAVT
625
626
627   SUBROUTINE updateAVM( ptab, i1, i2, j1, j2, k1, k2, before )
628      !!---------------------------------------------
629      !!           *** ROUTINE updateavm ***
630      !!---------------------------------------------
631      INTEGER, INTENT(in) :: i1, i2, j1, j2, k1, k2
632      REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: ptab
633      LOGICAL, INTENT(in) :: before
634      !!---------------------------------------------
635      !
636      IF (before) THEN
637         ptab (i1:i2,j1:j2,k1:k2) = avm_k(i1:i2,j1:j2,k1:k2)
638      ELSE
639         avm_k(i1:i2,j1:j2,k1:k2) = ptab (i1:i2,j1:j2,k1:k2) 
640      ENDIF
641      !
642   END SUBROUTINE updateAVM
643
644# endif /* key_zdftke */ 
645
646#else
647CONTAINS
648   SUBROUTINE agrif_opa_update_empty
649      !!---------------------------------------------
650      !!   *** ROUTINE agrif_opa_update_empty ***
651      !!---------------------------------------------
652      WRITE(*,*)  'agrif_opa_update : You should not have seen this print! error?'
653   END SUBROUTINE agrif_opa_update_empty
654#endif
655END MODULE agrif_opa_update
656
Note: See TracBrowser for help on using the repository browser.