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_interp.F90 in branches/2015/dev_r5803_UKMO_AGRIF_Vert_interp/NEMOGCM/NEMO/NST_SRC – NEMO

source: branches/2015/dev_r5803_UKMO_AGRIF_Vert_interp/NEMOGCM/NEMO/NST_SRC/agrif_opa_interp.F90 @ 6445

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

Corrections to agrif_opa_interp missed when merging with trunk
  • Property svn:keywords set to Id
File size: 55.7 KB
Line 
1MODULE agrif_opa_interp
2   !!======================================================================
3   !!                   ***  MODULE  agrif_opa_interp  ***
4   !! AGRIF: interpolation package
5   !!======================================================================
6   !! History :  2.0  !  2002-06  (XXX)  Original cade
7   !!             -   !  2005-11  (XXX)
8   !!            3.2  !  2009-04  (R. Benshila)
9   !!            3.6  !  2014-09  (R. Benshila)
10   !!----------------------------------------------------------------------
11#if defined key_agrif && ! defined key_offline
12   !!----------------------------------------------------------------------
13   !!   'key_agrif'                                              AGRIF zoom
14   !!   NOT 'key_offline'                               NO off-line tracers
15   !!----------------------------------------------------------------------
16   !!   Agrif_tra     :
17   !!   Agrif_dyn     :
18   !!   interpu       :
19   !!   interpv       :
20   !!----------------------------------------------------------------------
21   USE par_oce
22   USE oce
23   USE dom_oce     
24   USE zdf_oce
25   USE agrif_oce
26   USE phycst
27   !
28   USE in_out_manager
29   USE agrif_opa_sponge
30   USE lib_mpp
31   USE wrk_nemo
32 
33   IMPLICIT NONE
34   PRIVATE
35
36   PUBLIC   Agrif_tra, Agrif_dyn, Agrif_ssh, Agrif_dyn_ts, Agrif_ssh_ts, Agrif_dta_ts
37! VERTICAL REFINEMENT BEGIN   
38   PUBLIC   Agrif_Init_InterpScales
39! VERTICAL REFINEMENT END
40   PUBLIC   interpun, interpvn
41   PUBLIC   interptsn,  interpsshn
42   PUBLIC   interpunb, interpvnb, interpub2b, interpvb2b
43   PUBLIC   interpe3t, interpumsk, interpvmsk
44# if defined key_zdftke
45   PUBLIC   Agrif_tke, interpavm
46# endif
47
48   INTEGER ::   bdy_tinterp = 0
49
50#  include "vectopt_loop_substitute.h90"
51   !!----------------------------------------------------------------------
52   !! NEMO/NST 3.7 , NEMO Consortium (2015)
53   !! $Id$
54   !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt)
55   !!----------------------------------------------------------------------
56! VERTICAL REFINEMENT BEGIN
57   REAL, DIMENSION(:,:,:), ALLOCATABLE :: interp_scales_t, interp_scales_u, interp_scales_v
58!$AGRIF_DO_NOT_TREAT
59   LOGICAL :: scaleT, scaleU, scaleV = .FALSE.
60!$AGRIF_END_DO_NOT_TREAT
61! VERTICAL REFINEMENT END
62
63CONTAINS
64
65! VERTICAL REFINEMENT BEGIN
66
67   SUBROUTINE Agrif_Init_InterpScales
68
69    scaleT = .TRUE.
70    Call Agrif_Bc_Variable(scales_t_id,calledweight=1.,procname=interpscales)
71    scaleT = .FALSE.
72   
73    scaleU = .TRUE.
74    Call Agrif_Bc_Variable(scales_u_id,calledweight=1.,procname=interpscales)
75    scaleU = .FALSE.
76
77    scaleV = .TRUE.
78    Call Agrif_Bc_Variable(scales_v_id,calledweight=1.,procname=interpscales)
79    scaleV = .FALSE.
80
81   END SUBROUTINE Agrif_Init_InterpScales
82   
83   SUBROUTINE interpscales(ptab,i1,i2,j1,j2,k1,k2,before)
84      !!---------------------------------------------
85      !!   *** ROUTINE interpscales ***
86      !!---------------------------------------------
87     
88      INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2
89      REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: ptab
90
91      INTEGER :: ji, jj, jk
92      LOGICAL :: before
93
94      IF (before) THEN
95      IF (scaleT ) THEN
96      DO jk=k1,k2
97         DO jj=j1,j2
98            DO ji=i1,i2
99!               ptab(ji,jj,jk) = e3t_n(ji,jj,jk) * tmask(ji,jj,jk)
100               ptab(ji,jj,jk) = e3t_n(ji,jj,jk)
101            END DO
102         END DO
103      END DO
104      ELSEIF (scaleU) THEN
105      DO jk=k1,k2
106         DO jj=j1,j2
107            DO ji=i1,i2
108!               ptab(ji,jj,jk) = e3u_n(ji,jj,jk) * umask(ji,jj,jk)
109!               ptab(ji,jj,jk) = e3u_n(ji,jj,jk)
110                ptab(ji,jj,jk) = umask(ji,jj,jk)
111            END DO
112         END DO
113      END DO
114      ELSEIF (scaleV) THEN
115      DO jk=k1,k2
116         DO jj=j1,j2
117            DO ji=i1,i2
118!               ptab(ji,jj,jk) = e3v_n(ji,jj,jk) * vmask(ji,jj,jk)
119!               ptab(ji,jj,jk) = e3v_n(ji,jj,jk)
120               ptab(ji,jj,jk) = vmask(ji,jj,jk)
121            END DO
122         END DO
123      END DO
124      ENDIF
125      ELSE
126      IF (scaleT ) THEN
127      IF (.not.allocated(interp_scales_t)) allocate(interp_scales_t(jpi,jpj,k1:k2))
128      DO jk=k1,k2
129         DO jj=j1,j2
130            DO ji=i1,i2
131               interp_scales_t(ji,jj,jk) = ptab(ji,jj,jk)
132            END DO
133         END DO
134      END DO
135      ELSEIF (scaleU) THEN
136      IF (.not.allocated(interp_scales_u)) allocate(interp_scales_u(jpi,jpj,k1:k2))
137      DO jk=k1,k2
138         DO jj=j1,j2
139            DO ji=i1,i2
140               interp_scales_u(ji,jj,jk) = ptab(ji,jj,jk)
141            END DO
142         END DO
143      END DO
144      ELSEIF (scaleV) THEN
145      IF (.not.allocated(interp_scales_v)) allocate(interp_scales_v(jpi,jpj,k1:k2))
146      DO jk=k1,k2
147         DO jj=j1,j2
148            DO ji=i1,i2
149               interp_scales_v(ji,jj,jk) = ptab(ji,jj,jk)
150            END DO
151         END DO
152      END DO
153      ENDIF
154      ENDIF
155
156   END SUBROUTINE interpscales
157
158! VERTICAL REFINEMENT END
159
160   SUBROUTINE Agrif_tra
161      !!----------------------------------------------------------------------
162      !!                  ***  ROUTINE Agrif_tra  ***
163      !!----------------------------------------------------------------------
164      !
165      IF( Agrif_Root() )   RETURN
166      !
167      Agrif_SpecialValue    = 0._wp
168      Agrif_UseSpecialValue = .TRUE.
169      !
170      CALL Agrif_Bc_variable( tsn_id, procname=interptsn )
171      !
172      Agrif_UseSpecialValue = .FALSE.
173      !
174   END SUBROUTINE Agrif_tra
175
176
177   SUBROUTINE Agrif_dyn( kt )
178      !!----------------------------------------------------------------------
179      !!                  ***  ROUTINE Agrif_DYN  ***
180      !!---------------------------------------------------------------------- 
181      INTEGER, INTENT(in) ::   kt
182      !
183      INTEGER ::   ji, jj, jk       ! dummy loop indices
184      INTEGER ::   j1, j2, i1, i2
185      REAL(wp), POINTER, DIMENSION(:,:) ::   zub, zvb
186      !!---------------------------------------------------------------------- 
187      !
188      IF( Agrif_Root() )   RETURN
189      !
190      CALL wrk_alloc( jpi,jpj,   zub, zvb )
191      !
192      Agrif_SpecialValue    = 0._wp
193      Agrif_UseSpecialValue = ln_spc_dyn
194      !
195      CALL Agrif_Bc_variable( un_interp_id, procname=interpun )
196      CALL Agrif_Bc_variable( vn_interp_id, procname=interpvn )
197      !
198      Agrif_UseSpecialValue = .FALSE.
199      !
200      ! prevent smoothing in ghost cells
201      i1 =  1   ;   i2 = jpi
202      j1 =  1   ;   j2 = jpj
203      IF( nbondj == -1 .OR. nbondj == 2 )   j1 = 3
204      IF( nbondj == +1 .OR. nbondj == 2 )   j2 = nlcj-2
205      IF( nbondi == -1 .OR. nbondi == 2 )   i1 = 3
206      IF( nbondi == +1 .OR. nbondi == 2 )   i2 = nlci-2
207
208      IF( nbondi == -1 .OR. nbondi == 2 ) THEN
209         !
210         ! Smoothing
211         ! ---------
212         IF( .NOT.ln_dynspg_ts ) THEN  ! Store transport
213            ua_b(2,:) = 0._wp
214            DO jk = 1, jpkm1
215               DO jj = 1, jpj
216                  ua_b(2,jj) = ua_b(2,jj) + e3u_a(2,jj,jk) * ua(2,jj,jk)
217               END DO
218            END DO
219            DO jj = 1, jpj
220               ua_b(2,jj) = ua_b(2,jj) * r1_hu_a(2,jj)           
221            END DO
222         ENDIF
223         !
224         DO jk=1,jpkm1                 ! Smooth
225            DO jj=j1,j2
226               ua(2,jj,jk) = 0.25_wp*(ua(1,jj,jk)+2._wp*ua(2,jj,jk)+ua(3,jj,jk))
227               ua(2,jj,jk) = ua(2,jj,jk) * umask(2,jj,jk)
228            END DO
229         END DO
230         !
231         zub(2,:) = 0._wp              ! Correct transport
232         DO jk = 1, jpkm1
233            DO jj = 1, jpj
234               zub(2,jj) = zub(2,jj) + e3u_a(2,jj,jk) * ua(2,jj,jk)
235            END DO
236         END DO
237         DO jj=1,jpj
238            zub(2,jj) = zub(2,jj) * r1_hu_a(2,jj)
239         END DO
240
241         DO jk=1,jpkm1
242            DO jj=1,jpj
243               ua(2,jj,jk) = (ua(2,jj,jk)+ua_b(2,jj)-zub(2,jj))*umask(2,jj,jk)
244            END DO
245         END DO
246
247         ! Set tangential velocities to time splitting estimate
248         !-----------------------------------------------------
249         IF( ln_dynspg_ts ) THEN
250            zvb(2,:) = 0._wp
251            DO jk = 1, jpkm1
252               DO jj = 1, jpj
253                  zvb(2,jj) = zvb(2,jj) + e3v_a(2,jj,jk) * va(2,jj,jk)
254               END DO
255            END DO
256            DO jj = 1, jpj
257               zvb(2,jj) = zvb(2,jj) * r1_hv_a(2,jj)
258            END DO
259            DO jk = 1, jpkm1
260               DO jj = 1, jpj
261                  va(2,jj,jk) = (va(2,jj,jk)+va_b(2,jj)-zvb(2,jj)) * vmask(2,jj,jk)
262               END DO
263            END DO
264         ENDIF
265         !
266         ! Mask domain edges:
267         !-------------------
268         DO jk = 1, jpkm1
269            DO jj = 1, jpj
270               ua(1,jj,jk) = 0._wp
271               va(1,jj,jk) = 0._wp
272            END DO
273         END DO         
274         !
275      ENDIF
276
277      IF( nbondi == 1 .OR. nbondi == 2 ) THEN
278
279         ! Smoothing
280         ! ---------
281         IF( .NOT.ln_dynspg_ts ) THEN  ! Store transport
282            ua_b(nlci-2,:) = 0._wp
283            DO jk=1,jpkm1
284               DO jj=1,jpj
285                  ua_b(nlci-2,jj) = ua_b(nlci-2,jj) + e3u_a(nlci-2,jj,jk) * ua(nlci-2,jj,jk)
286               END DO
287            END DO
288            DO jj=1,jpj
289               ua_b(nlci-2,jj) = ua_b(nlci-2,jj) * r1_hu_a(nlci-2,jj)           
290            END DO
291         ENDIF
292
293         DO jk = 1, jpkm1              ! Smooth
294            DO jj = j1, j2
295               ua(nlci-2,jj,jk) = 0.25_wp * umask(nlci-2,jj,jk)      &
296                  &             * ( ua(nlci-3,jj,jk) + 2._wp*ua(nlci-2,jj,jk) + ua(nlci-1,jj,jk) )
297            END DO
298         END DO
299
300         zub(nlci-2,:) = 0._wp        ! Correct transport
301         DO jk = 1, jpkm1
302            DO jj = 1, jpj
303               zub(nlci-2,jj) = zub(nlci-2,jj) + e3u_a(nlci-2,jj,jk) * ua(nlci-2,jj,jk)
304            END DO
305         END DO
306         DO jj = 1, jpj
307            zub(nlci-2,jj) = zub(nlci-2,jj) * r1_hu_a(nlci-2,jj)
308         END DO
309
310         DO jk = 1, jpkm1
311            DO jj = 1, jpj
312               ua(nlci-2,jj,jk) = ( ua(nlci-2,jj,jk) + ua_b(nlci-2,jj) - zub(nlci-2,jj) ) * umask(nlci-2,jj,jk)
313            END DO
314         END DO
315         !
316         ! Set tangential velocities to time splitting estimate
317         !-----------------------------------------------------
318         IF( ln_dynspg_ts ) THEN
319            zvb(nlci-1,:) = 0._wp
320            DO jk = 1, jpkm1
321               DO jj = 1, jpj
322                  zvb(nlci-1,jj) = zvb(nlci-1,jj) + e3v_a(nlci-1,jj,jk) * va(nlci-1,jj,jk)
323               END DO
324            END DO
325            DO jj=1,jpj
326               zvb(nlci-1,jj) = zvb(nlci-1,jj) * r1_hv_a(nlci-1,jj)
327            END DO
328            DO jk = 1, jpkm1
329               DO jj = 1, jpj
330                  va(nlci-1,jj,jk) = ( va(nlci-1,jj,jk) + va_b(nlci-1,jj) - zvb(nlci-1,jj) ) * vmask(nlci-1,jj,jk)
331               END DO
332            END DO
333         ENDIF
334         !
335         ! Mask domain edges:
336         !-------------------
337         DO jk = 1, jpkm1
338            DO jj = 1, jpj
339               ua(nlci-1,jj,jk) = 0._wp
340               va(nlci  ,jj,jk) = 0._wp
341            END DO
342         END DO 
343         !
344      ENDIF
345
346      IF( nbondj == -1 .OR. nbondj == 2 ) THEN
347
348         ! Smoothing
349         ! ---------
350         IF( .NOT.ln_dynspg_ts ) THEN  ! Store transport
351            va_b(:,2) = 0._wp
352            DO jk = 1, jpkm1
353               DO ji = 1, jpi
354                  va_b(ji,2) = va_b(ji,2) + e3v_a(ji,2,jk) * va(ji,2,jk)
355               END DO
356            END DO
357            DO ji=1,jpi
358               va_b(ji,2) = va_b(ji,2) * r1_hv_a(ji,2)           
359            END DO
360         ENDIF
361         !
362         DO jk = 1, jpkm1              ! Smooth
363            DO ji = i1, i2
364               va(ji,2,jk) = 0.25_wp * vmask(ji,2,jk)    &
365                  &        * ( va(ji,1,jk) + 2._wp*va(ji,2,jk) + va(ji,3,jk) )
366            END DO
367         END DO
368         !
369         zvb(:,2) = 0._wp              ! Correct transport
370         DO jk=1,jpkm1
371            DO ji=1,jpi
372               zvb(ji,2) = zvb(ji,2) + e3v_a(ji,2,jk) * va(ji,2,jk) * vmask(ji,2,jk)
373            END DO
374         END DO
375         DO ji = 1, jpi
376            zvb(ji,2) = zvb(ji,2) * r1_hv_a(ji,2)
377         END DO
378         DO jk = 1, jpkm1
379            DO ji = 1, jpi
380               va(ji,2,jk) = ( va(ji,2,jk) + va_b(ji,2) - zvb(ji,2) ) * vmask(ji,2,jk)
381            END DO
382         END DO
383
384         ! Set tangential velocities to time splitting estimate
385         !-----------------------------------------------------
386         IF( ln_dynspg_ts ) THEN
387            zub(:,2) = 0._wp
388            DO jk = 1, jpkm1
389               DO ji = 1, jpi
390                  zub(ji,2) = zub(ji,2) + e3u_a(ji,2,jk) * ua(ji,2,jk) * umask(ji,2,jk)
391               END DO
392            END DO
393            DO ji = 1, jpi
394               zub(ji,2) = zub(ji,2) * r1_hu_a(ji,2)
395            END DO
396
397            DO jk = 1, jpkm1
398               DO ji = 1, jpi
399                  ua(ji,2,jk) = ( ua(ji,2,jk) + ua_b(ji,2) - zub(ji,2) ) * umask(ji,2,jk)
400               END DO
401            END DO
402         ENDIF
403
404         ! Mask domain edges:
405         !-------------------
406         DO jk = 1, jpkm1
407            DO ji = 1, jpi
408               ua(ji,1,jk) = 0._wp
409               va(ji,1,jk) = 0._wp
410            END DO
411         END DO
412
413      ENDIF
414
415      IF( nbondj == 1 .OR. nbondj == 2 ) THEN
416         !
417         ! Smoothing
418         ! ---------
419         IF( .NOT.ln_dynspg_ts ) THEN  ! Store transport
420            va_b(:,nlcj-2) = 0._wp
421            DO jk = 1, jpkm1
422               DO ji = 1, jpi
423                  va_b(ji,nlcj-2) = va_b(ji,nlcj-2) + e3v_a(ji,nlcj-2,jk) * va(ji,nlcj-2,jk)
424               END DO
425            END DO
426            DO ji = 1, jpi
427               va_b(ji,nlcj-2) = va_b(ji,nlcj-2) * r1_hv_a(ji,nlcj-2)           
428            END DO
429         ENDIF
430         !
431         DO jk = 1, jpkm1              ! Smooth
432            DO ji = i1, i2
433               va(ji,nlcj-2,jk) = 0.25_wp * vmask(ji,nlcj-2,jk)   &
434                  &             * ( va(ji,nlcj-3,jk) + 2._wp * va(ji,nlcj-2,jk) + va(ji,nlcj-1,jk) )
435            END DO
436         END DO
437         !
438         zvb(:,nlcj-2) = 0._wp         ! Correct transport
439         DO jk = 1, jpkm1
440            DO ji = 1, jpi
441               zvb(ji,nlcj-2) = zvb(ji,nlcj-2) + e3v_a(ji,nlcj-2,jk) * va(ji,nlcj-2,jk) * vmask(ji,nlcj-2,jk)
442            END DO
443         END DO
444         DO ji = 1, jpi
445            zvb(ji,nlcj-2) = zvb(ji,nlcj-2) * r1_hv_a(ji,nlcj-2)
446         END DO
447         DO jk = 1, jpkm1
448            DO ji = 1, jpi
449               va(ji,nlcj-2,jk) = ( va(ji,nlcj-2,jk) + va_b(ji,nlcj-2) - zvb(ji,nlcj-2) ) * vmask(ji,nlcj-2,jk)
450            END DO
451         END DO
452         !
453         ! Set tangential velocities to time splitting estimate
454         !-----------------------------------------------------
455         IF( ln_dynspg_ts ) THEN
456            zub(:,nlcj-1) = 0._wp
457            DO jk = 1, jpkm1
458               DO ji = 1, jpi
459                  zub(ji,nlcj-1) = zub(ji,nlcj-1) + e3u_a(ji,nlcj-1,jk) * ua(ji,nlcj-1,jk) * umask(ji,nlcj-1,jk)
460               END DO
461            END DO
462            DO ji = 1, jpi
463               zub(ji,nlcj-1) = zub(ji,nlcj-1) * r1_hu_a(ji,nlcj-1)
464            END DO
465            !
466            DO jk = 1, jpkm1
467               DO ji = 1, jpi
468                  ua(ji,nlcj-1,jk) = ( ua(ji,nlcj-1,jk) + ua_b(ji,nlcj-1) - zub(ji,nlcj-1) ) * umask(ji,nlcj-1,jk)
469               END DO
470            END DO
471         ENDIF
472         !
473         ! Mask domain edges:
474         !-------------------
475         DO jk = 1, jpkm1
476            DO ji = 1, jpi
477               ua(ji,nlcj  ,jk) = 0._wp
478               va(ji,nlcj-1,jk) = 0._wp
479            END DO
480         END DO 
481         !
482      ENDIF
483      !
484      CALL wrk_dealloc( jpi,jpj,   zub, zvb )
485      !
486   END SUBROUTINE Agrif_dyn
487
488
489   SUBROUTINE Agrif_dyn_ts( jn )
490      !!----------------------------------------------------------------------
491      !!                  ***  ROUTINE Agrif_dyn_ts  ***
492      !!---------------------------------------------------------------------- 
493      !!
494      INTEGER, INTENT(in) ::   jn
495      !!
496      INTEGER :: ji, jj
497      !!---------------------------------------------------------------------- 
498      !
499      IF( Agrif_Root() )   RETURN
500      !
501      IF((nbondi == -1).OR.(nbondi == 2)) THEN
502         DO jj=1,jpj
503            va_e(2,jj) = vbdy_w(jj) * hvr_e(2,jj)
504            ! Specified fluxes:
505            ua_e(2,jj) = ubdy_w(jj) * hur_e(2,jj)
506            ! Characteristics method:
507            !alt            ua_e(2,jj) = 0.5_wp * ( ubdy_w(jj) * hur_e(2,jj) + ua_e(3,jj) &
508            !alt                       &           - sqrt(grav * hur_e(2,jj)) * (sshn_e(3,jj) - hbdy_w(jj)) )
509         END DO
510      ENDIF
511      !
512      IF((nbondi == 1).OR.(nbondi == 2)) THEN
513         DO jj=1,jpj
514            va_e(nlci-1,jj) = vbdy_e(jj) * hvr_e(nlci-1,jj)
515            ! Specified fluxes:
516            ua_e(nlci-2,jj) = ubdy_e(jj) * hur_e(nlci-2,jj)
517            ! Characteristics method:
518            !alt            ua_e(nlci-2,jj) = 0.5_wp * ( ubdy_e(jj) * hur_e(nlci-2,jj) + ua_e(nlci-3,jj) &
519            !alt                            &           + sqrt(grav * hur_e(nlci-2,jj)) * (sshn_e(nlci-2,jj) - hbdy_e(jj)) )
520         END DO
521      ENDIF
522      !
523      IF((nbondj == -1).OR.(nbondj == 2)) THEN
524         DO ji=1,jpi
525            ua_e(ji,2) = ubdy_s(ji) * hur_e(ji,2)
526            ! Specified fluxes:
527            va_e(ji,2) = vbdy_s(ji) * hvr_e(ji,2)
528            ! Characteristics method:
529            !alt            va_e(ji,2) = 0.5_wp * ( vbdy_s(ji) * hvr_e(ji,2) + va_e(ji,3) &
530            !alt                       &           - sqrt(grav * hvr_e(ji,2)) * (sshn_e(ji,3) - hbdy_s(ji)) )
531         END DO
532      ENDIF
533      !
534      IF((nbondj == 1).OR.(nbondj == 2)) THEN
535         DO ji=1,jpi
536            ua_e(ji,nlcj-1) = ubdy_n(ji) * hur_e(ji,nlcj-1)
537            ! Specified fluxes:
538            va_e(ji,nlcj-2) = vbdy_n(ji) * hvr_e(ji,nlcj-2)
539            ! Characteristics method:
540            !alt            va_e(ji,nlcj-2) = 0.5_wp * ( vbdy_n(ji) * hvr_e(ji,nlcj-2)  + va_e(ji,nlcj-3) &
541            !alt                            &           + sqrt(grav * hvr_e(ji,nlcj-2)) * (sshn_e(ji,nlcj-2) - hbdy_n(ji)) )
542         END DO
543      ENDIF
544      !
545   END SUBROUTINE Agrif_dyn_ts
546
547
548   SUBROUTINE Agrif_dta_ts( kt )
549      !!----------------------------------------------------------------------
550      !!                  ***  ROUTINE Agrif_dta_ts  ***
551      !!---------------------------------------------------------------------- 
552      !!
553      INTEGER, INTENT(in) ::   kt
554      !!
555      INTEGER :: ji, jj
556      LOGICAL :: ll_int_cons
557      REAL(wp) :: zrhot, zt
558      !!---------------------------------------------------------------------- 
559      !
560      IF( Agrif_Root() )   RETURN
561      !
562      ll_int_cons = ln_bt_fw ! Assume conservative temporal integration in the forward case only
563      !
564      zrhot = Agrif_rhot()
565      !
566      ! "Central" time index for interpolation:
567      IF( ln_bt_fw ) THEN
568         zt = REAL( Agrif_NbStepint()+0.5_wp, wp ) / zrhot
569      ELSE
570         zt = REAL( Agrif_NbStepint()       , wp ) / zrhot
571      ENDIF
572      !
573      ! Linear interpolation of sea level
574      Agrif_SpecialValue    = 0._wp
575      Agrif_UseSpecialValue = .TRUE.
576      CALL Agrif_Bc_variable( sshn_id, calledweight=zt, procname=interpsshn )
577      Agrif_UseSpecialValue = .FALSE.
578      !
579      ! Interpolate barotropic fluxes
580      Agrif_SpecialValue=0.
581      Agrif_UseSpecialValue = ln_spc_dyn
582      !
583      IF( ll_int_cons ) THEN  ! Conservative interpolation
584         ! orders matters here !!!!!!
585         CALL Agrif_Bc_variable( ub2b_interp_id, calledweight=1._wp, procname=interpub2b ) ! Time integrated
586         CALL Agrif_Bc_variable( vb2b_interp_id, calledweight=1._wp, procname=interpvb2b )
587         bdy_tinterp = 1
588         CALL Agrif_Bc_variable( unb_id        , calledweight=1._wp, procname=interpunb  ) ! After
589         CALL Agrif_Bc_variable( vnb_id        , calledweight=1._wp, procname=interpvnb  )
590         bdy_tinterp = 2
591         CALL Agrif_Bc_variable( unb_id        , calledweight=0._wp, procname=interpunb  ) ! Before
592         CALL Agrif_Bc_variable( vnb_id        , calledweight=0._wp, procname=interpvnb  )         
593      ELSE ! Linear interpolation
594         bdy_tinterp = 0
595         ubdy_w(:) = 0._wp   ;   vbdy_w(:) = 0._wp 
596         ubdy_e(:) = 0._wp   ;   vbdy_e(:) = 0._wp 
597         ubdy_n(:) = 0._wp   ;   vbdy_n(:) = 0._wp 
598         ubdy_s(:) = 0._wp   ;   vbdy_s(:) = 0._wp
599         CALL Agrif_Bc_variable( unb_id, calledweight=zt, procname=interpunb )
600         CALL Agrif_Bc_variable( vnb_id, calledweight=zt, procname=interpvnb )
601      ENDIF
602      Agrif_UseSpecialValue = .FALSE.
603      !
604   END SUBROUTINE Agrif_dta_ts
605
606
607   SUBROUTINE Agrif_ssh( kt )
608      !!----------------------------------------------------------------------
609      !!                  ***  ROUTINE Agrif_DYN  ***
610      !!---------------------------------------------------------------------- 
611      INTEGER, INTENT(in) ::   kt
612      !!
613      !!---------------------------------------------------------------------- 
614      !
615      IF( Agrif_Root() )   RETURN
616      !
617      IF((nbondi == -1).OR.(nbondi == 2)) THEN
618         ssha(2,:)=ssha(3,:)
619         sshn(2,:)=sshn(3,:)
620      ENDIF
621      !
622      IF((nbondi == 1).OR.(nbondi == 2)) THEN
623         ssha(nlci-1,:)=ssha(nlci-2,:)
624         sshn(nlci-1,:)=sshn(nlci-2,:)
625      ENDIF
626      !
627      IF((nbondj == -1).OR.(nbondj == 2)) THEN
628         ssha(:,2)=ssha(:,3)
629         sshn(:,2)=sshn(:,3)
630      ENDIF
631      !
632      IF((nbondj == 1).OR.(nbondj == 2)) THEN
633         ssha(:,nlcj-1)=ssha(:,nlcj-2)
634         sshn(:,nlcj-1)=sshn(:,nlcj-2)
635      ENDIF
636      !
637   END SUBROUTINE Agrif_ssh
638
639
640   SUBROUTINE Agrif_ssh_ts( jn )
641      !!----------------------------------------------------------------------
642      !!                  ***  ROUTINE Agrif_ssh_ts  ***
643      !!---------------------------------------------------------------------- 
644      INTEGER, INTENT(in) ::   jn
645      !!
646      INTEGER :: ji,jj
647      !!---------------------------------------------------------------------- 
648      !
649      IF((nbondi == -1).OR.(nbondi == 2)) THEN
650         DO jj = 1, jpj
651            ssha_e(2,jj) = hbdy_w(jj)
652         END DO
653      ENDIF
654      !
655      IF((nbondi == 1).OR.(nbondi == 2)) THEN
656         DO jj = 1, jpj
657            ssha_e(nlci-1,jj) = hbdy_e(jj)
658         END DO
659      ENDIF
660      !
661      IF((nbondj == -1).OR.(nbondj == 2)) THEN
662         DO ji = 1, jpi
663            ssha_e(ji,2) = hbdy_s(ji)
664         END DO
665      ENDIF
666      !
667      IF((nbondj == 1).OR.(nbondj == 2)) THEN
668         DO ji = 1, jpi
669            ssha_e(ji,nlcj-1) = hbdy_n(ji)
670         END DO
671      ENDIF
672      !
673   END SUBROUTINE Agrif_ssh_ts
674
675# if defined key_zdftke
676
677   SUBROUTINE Agrif_tke
678      !!----------------------------------------------------------------------
679      !!                  ***  ROUTINE Agrif_tke  ***
680      !!---------------------------------------------------------------------- 
681      REAL(wp) ::   zalpha
682      !!---------------------------------------------------------------------- 
683      !
684      return
685     
686      zalpha = REAL( Agrif_NbStepint() + Agrif_IRhot() - 1, wp ) / REAL( Agrif_IRhot(), wp )
687      IF( zalpha > 1. )   zalpha = 1.
688      !
689      Agrif_SpecialValue    = 0.e0
690      Agrif_UseSpecialValue = .TRUE.
691      !
692      CALL Agrif_Bc_variable(avm_id ,calledweight=zalpha, procname=interpavm)       
693      !
694      Agrif_UseSpecialValue = .FALSE.
695      !
696   END SUBROUTINE Agrif_tke
697   
698# endif
699
700   SUBROUTINE interptsn( ptab, i1, i2, j1, j2, k1, k2, n1, n2, before, nb, ndir )
701      !!----------------------------------------------------------------------
702      !!   *** ROUTINE interptsn ***
703      !!----------------------------------------------------------------------
704      REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2), INTENT(inout) ::   ptab
705      INTEGER                                     , INTENT(in   ) ::   i1, i2, j1, j2, k1, k2, n1, n2
706      LOGICAL                                     , INTENT(in   ) ::   before
707      INTEGER                                     , INTENT(in   ) ::   nb , ndir
708      !
709      INTEGER  ::   ji, jj, jk, jn   ! dummy loop indices
710      INTEGER  ::   imin, imax, jmin, jmax
711      REAL(wp) ::   zrhox , zalpha1, zalpha2, zalpha3
712      REAL(wp) ::   zalpha4, zalpha5, zalpha6, zalpha7
713      LOGICAL :: western_side, eastern_side,northern_side,southern_side
714! VERTICAL REFINEMENT BEGIN
715      REAL(wp), DIMENSION(i1:i2,j1:j2,1:jpk,n1:n2) :: ptab_child
716      REAL(wp) :: h_in(k1:k2)
717      REAL(wp) :: h_out(1:jpk)
718      INTEGER :: N_in, N_out
719      REAL(wp) :: h_diff
720! VERTICAL REFINEMENT END
721
722      IF (before) THEN         
723         ptab(i1:i2,j1:j2,k1:k2,n1:n2) = tsn(i1:i2,j1:j2,k1:k2,n1:n2)
724      ELSE 
725! VERTICAL REFINEMENT BEGIN
726
727         ptab_child(:,:,:,:) = 0.
728         do jj=j1,j2
729         do ji=i1,i2
730           h_in(k1:k2) = interp_scales_t(ji,jj,k1:k2)
731           h_out(1:jpk) = e3t_n(ji,jj,1:jpk)
732           h_diff = sum(h_out(1:jpk-1))-sum(h_in(k1:k2-1))
733           N_in = k2-1
734           N_out = jpk-1
735           if (h_diff > 0) then
736             h_in(N_in+1) = h_diff
737             N_in = N_in + 1
738           else
739             h_out(N_out+1) = -h_diff
740             N_out = N_out + 1
741           endif
742           ptab(ji,jj,k2,:) = ptab(ji,jj,k2-1,:)
743           do jn=1,jpts
744             call reconstructandremap(ptab(ji,jj,1:N_in,jn),h_in,ptab_child(ji,jj,1:N_out,jn),h_out,N_in,N_out)
745           enddo
746!           if (abs(h_diff) > 1000.) then
747!           do jn=1,jpts
748!             do jk=1,N_out
749!             print *,'AVANT APRES = ',ji,jj,jk,N_out,ptab(ji,jj,jk,jn),ptab_child(ji,jj,jk,jn)
750!             enddo
751!           enddo
752!         endif
753         enddo
754         enddo
755
756! VERTICAL REFINEMENT END
757
758         !
759         western_side  = (nb == 1).AND.(ndir == 1)
760         eastern_side  = (nb == 1).AND.(ndir == 2)
761         southern_side = (nb == 2).AND.(ndir == 1)
762         northern_side = (nb == 2).AND.(ndir == 2)
763         !
764         zrhox = Agrif_Rhox()
765         !
766         zalpha1 = ( zrhox - 1. ) * 0.5
767         zalpha2 = 1. - zalpha1
768         !
769         zalpha3 = ( zrhox - 1. ) / ( zrhox + 1. )
770         zalpha4 = 1. - zalpha3
771         !
772         zalpha6 = 2. * ( zrhox - 1. ) / ( zrhox + 1. )
773         zalpha7 =    - ( zrhox - 1. ) / ( zrhox + 3. )
774         zalpha5 = 1. - zalpha6 - zalpha7
775         !
776         imin = i1
777         imax = i2
778         jmin = j1
779         jmax = j2
780         !
781         ! Remove CORNERS
782         IF((nbondj == -1).OR.(nbondj == 2)) jmin = 3
783         IF((nbondj == +1).OR.(nbondj == 2)) jmax = nlcj-2
784         IF((nbondi == -1).OR.(nbondi == 2)) imin = 3
785         IF((nbondi == +1).OR.(nbondi == 2)) imax = nlci-2       
786         !
787! VERTICAL REFINEMENT BEGIN
788
789! WARNING :
790! ptab replaced by ptab_child in the following
791! k1 k2 replaced by 1 jpk
792! VERTICAL REFINEMENT END
793         IF( eastern_side) THEN
794            DO jn = 1, jpts
795               tsa(nlci,j1:j2,1:jpk,jn) = zalpha1 * ptab_child(nlci,j1:j2,1:jpk,jn) + zalpha2 * ptab_child(nlci-1,j1:j2,1:jpk,jn)
796               DO jk = 1, jpkm1
797                  DO jj = jmin,jmax
798                     IF( umask(nlci-2,jj,jk) == 0._wp ) THEN
799                        tsa(nlci-1,jj,jk,jn) = tsa(nlci,jj,jk,jn) * tmask(nlci-1,jj,jk)
800                     ELSE
801                        tsa(nlci-1,jj,jk,jn)=(zalpha4*tsa(nlci,jj,jk,jn)+zalpha3*tsa(nlci-2,jj,jk,jn))*tmask(nlci-1,jj,jk)
802                        IF( un(nlci-2,jj,jk) > 0._wp ) THEN
803                           tsa(nlci-1,jj,jk,jn)=( zalpha6*tsa(nlci-2,jj,jk,jn)+zalpha5*tsa(nlci,jj,jk,jn) & 
804                                 + zalpha7*tsa(nlci-3,jj,jk,jn) ) * tmask(nlci-1,jj,jk)
805                        ENDIF
806                     ENDIF
807                  END DO
808               END DO
809               tsa(nlci,j1:j2,k1:k2,jn) = 0._wp
810            END DO
811         ENDIF
812         !
813         IF( northern_side ) THEN           
814            DO jn = 1, jpts
815               tsa(i1:i2,nlcj,1:jpk,jn) = zalpha1 * ptab_child(i1:i2,nlcj,1:jpk,jn) + zalpha2 * ptab_child(i1:i2,nlcj-1,1:jpk,jn)
816               DO jk = 1, jpkm1
817                  DO ji = imin,imax
818                     IF( vmask(ji,nlcj-2,jk) == 0._wp ) THEN
819                        tsa(ji,nlcj-1,jk,jn) = tsa(ji,nlcj,jk,jn) * tmask(ji,nlcj-1,jk)
820                     ELSE
821                        tsa(ji,nlcj-1,jk,jn)=(zalpha4*tsa(ji,nlcj,jk,jn)+zalpha3*tsa(ji,nlcj-2,jk,jn))*tmask(ji,nlcj-1,jk)       
822                        IF (vn(ji,nlcj-2,jk) > 0._wp ) THEN
823                           tsa(ji,nlcj-1,jk,jn)=( zalpha6*tsa(ji,nlcj-2,jk,jn)+zalpha5*tsa(ji,nlcj,jk,jn)  &
824                                 + zalpha7*tsa(ji,nlcj-3,jk,jn) ) * tmask(ji,nlcj-1,jk)
825                        ENDIF
826                     ENDIF
827                  END DO
828               END DO
829               tsa(i1:i2,nlcj,k1:k2,jn) = 0._wp
830            END DO
831         ENDIF
832         !
833         IF( western_side ) THEN           
834            DO jn = 1, jpts
835               tsa(1,j1:j2,1:jpk,jn) = zalpha1 * ptab_child(1,j1:j2,1:jpk,jn) + zalpha2 * ptab_child(2,j1:j2,1:jpk,jn)
836               DO jk = 1, jpkm1
837                  DO jj = jmin,jmax
838                     IF( umask(2,jj,jk) == 0._wp ) THEN
839                        tsa(2,jj,jk,jn) = tsa(1,jj,jk,jn) * tmask(2,jj,jk)
840                     ELSE
841                        tsa(2,jj,jk,jn)=(zalpha4*tsa(1,jj,jk,jn)+zalpha3*tsa(3,jj,jk,jn))*tmask(2,jj,jk)       
842                        IF( un(2,jj,jk) < 0._wp ) THEN
843                           tsa(2,jj,jk,jn)=(zalpha6*tsa(3,jj,jk,jn)+zalpha5*tsa(1,jj,jk,jn)+zalpha7*tsa(4,jj,jk,jn))*tmask(2,jj,jk)
844                        ENDIF
845                     ENDIF
846                  END DO
847               END DO
848               tsa(1,j1:j2,k1:k2,jn) = 0._wp
849            END DO
850         ENDIF
851         !
852         IF( southern_side ) THEN           
853            DO jn = 1, jpts
854               tsa(i1:i2,1,1:jpk,jn) = zalpha1 * ptab_child(i1:i2,1,1:jpk,jn) + zalpha2 * ptab_child(i1:i2,2,1:jpk,jn)
855               DO jk = 1, jpk     
856                  DO ji=imin,imax
857                     IF( vmask(ji,2,jk) == 0._wp ) THEN
858                        tsa(ji,2,jk,jn)=tsa(ji,1,jk,jn) * tmask(ji,2,jk)
859                     ELSE
860                        tsa(ji,2,jk,jn)=(zalpha4*tsa(ji,1,jk,jn)+zalpha3*tsa(ji,3,jk,jn))*tmask(ji,2,jk)
861                        IF( vn(ji,2,jk) < 0._wp ) THEN
862                           tsa(ji,2,jk,jn)=(zalpha6*tsa(ji,3,jk,jn)+zalpha5*tsa(ji,1,jk,jn)+zalpha7*tsa(ji,4,jk,jn))*tmask(ji,2,jk)
863                        ENDIF
864                     ENDIF
865                  END DO
866               END DO
867               tsa(i1:i2,1,k1:k2,jn) = 0._wp
868            END DO
869         ENDIF
870         !
871         ! Treatment of corners
872         !
873         ! East south
874         IF ((eastern_side).AND.((nbondj == -1).OR.(nbondj == 2))) THEN
875            tsa(nlci-1,2,:,:) = ptab_child(nlci-1,2,:,:)
876         ENDIF
877         ! East north
878         IF ((eastern_side).AND.((nbondj == 1).OR.(nbondj == 2))) THEN
879            tsa(nlci-1,nlcj-1,:,:) = ptab_child(nlci-1,nlcj-1,:,:)
880         ENDIF
881         ! West south
882         IF ((western_side).AND.((nbondj == -1).OR.(nbondj == 2))) THEN
883            tsa(2,2,:,:) = ptab_child(2,2,:,:)
884         ENDIF
885         ! West north
886         IF ((western_side).AND.((nbondj == 1).OR.(nbondj == 2))) THEN
887            tsa(2,nlcj-1,:,:) = ptab_child(2,nlcj-1,:,:)
888         ENDIF
889         !
890      ENDIF
891      !
892   END SUBROUTINE interptsn
893
894
895   SUBROUTINE interpsshn( ptab, i1, i2, j1, j2, before, nb, ndir )
896      !!----------------------------------------------------------------------
897      !!                  ***  ROUTINE interpsshn  ***
898      !!---------------------------------------------------------------------- 
899      INTEGER                         , INTENT(in   ) ::   i1, i2, j1, j2
900      REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) ::   ptab
901      LOGICAL                         , INTENT(in   ) ::   before
902      INTEGER                         , INTENT(in   ) ::   nb , ndir
903      !
904      LOGICAL :: western_side, eastern_side,northern_side,southern_side
905      !!---------------------------------------------------------------------- 
906      !
907      IF( before) THEN
908         ptab(i1:i2,j1:j2) = sshn(i1:i2,j1:j2)
909      ELSE
910         western_side  = (nb == 1).AND.(ndir == 1)
911         eastern_side  = (nb == 1).AND.(ndir == 2)
912         southern_side = (nb == 2).AND.(ndir == 1)
913         northern_side = (nb == 2).AND.(ndir == 2)
914         IF(western_side)  hbdy_w(j1:j2) = ptab(i1,j1:j2) * tmask(i1,j1:j2,1)
915         IF(eastern_side)  hbdy_e(j1:j2) = ptab(i1,j1:j2) * tmask(i1,j1:j2,1)
916         IF(southern_side) hbdy_s(i1:i2) = ptab(i1:i2,j1) * tmask(i1:i2,j1,1)
917         IF(northern_side) hbdy_n(i1:i2) = ptab(i1:i2,j1) * tmask(i1:i2,j1,1)
918      ENDIF
919      !
920   END SUBROUTINE interpsshn
921
922   SUBROUTINE interpun(ptab,i1,i2,j1,j2,k1,k2,m1,m2,before,nb,ndir)
923      !!---------------------------------------------
924      !!   *** ROUTINE interpun ***
925      !!---------------------------------------------   
926      !!
927      INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2,m1,m2
928      REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2,m1:m2), INTENT(inout) :: ptab
929      LOGICAL, INTENT(in) :: before
930      INTEGER, INTENT(in) :: nb , ndir
931      !!
932      INTEGER :: ji,jj,jk
933      REAL(wp) :: zrhoy
934! VERTICAL REFINEMENT BEGIN
935      REAL(wp), DIMENSION(i1:i2,j1:j2,1:jpk) :: ptab_child
936      REAL(wp), DIMENSION(k1:k2) :: tabin
937      REAL(wp) :: h_in(k1:k2)
938      REAL(wp) :: h_out(1:jpk)
939      INTEGER :: N_in, N_out
940      REAL(wp) :: h_diff
941      LOGICAL :: western_side, eastern_side
942      INTEGER :: iref
943
944! VERTICAL REFINEMENT END
945      !!---------------------------------------------   
946      !
947      IF (before) THEN
948         DO jk=1,jpk
949            DO jj=j1,j2
950               DO ji=i1,i2
951                  ptab(ji,jj,jk,1) = e2u(ji,jj) * un(ji,jj,jk)
952                  ptab(ji,jj,jk,1) = ptab(ji,jj,jk,1) * e3u_n(ji,jj,jk)
953                  ptab(ji,jj,jk,2) = e3u_n(ji,jj,jk)
954               END DO
955            END DO
956         END DO
957      ELSE
958! VERTICAL REFINEMENT BEGIN
959         western_side  = (nb == 1).AND.(ndir == 1)
960         eastern_side  = (nb == 1).AND.(ndir == 2)
961         
962         ptab_child(:,:,:) = 0.
963         do jj=j1,j2
964         do ji=i1,i2
965         iref = ji
966         IF (western_side) iref = 2
967         IF (eastern_side) iref = nlci-2
968
969         N_in = 0
970         do jk=k1,k2
971           if (interp_scales_u(ji,jj,jk) == 0) EXIT
972             N_in = N_in + 1
973             tabin(jk) = ptab(ji,jj,jk,1)/ptab(ji,jj,jk,2)
974             h_in(N_in) = ptab(ji,jj,jk,2)
975         enddo
976         
977         IF (N_in == 0) THEN
978           ptab_child(ji,jj,:) = 0.
979           CYCLE
980         ENDIF
981         
982         N_out = 0
983         do jk=1,jpk
984           if (umask(iref,jj,jk) == 0) EXIT
985           N_out = N_out + 1
986           h_out(N_out) = e3u_n(ji,jj,jk)
987         enddo
988         
989         IF (N_out == 0) THEN
990           ptab_child(ji,jj,:) = 0.
991           CYCLE
992         ENDIF
993         
994         h_diff = sum(h_out(1:N_out))-sum(h_in(1:N_in))
995         IF (h_diff > 0.) THEN
996           N_in = N_in + 1
997           h_in(N_in) = h_diff
998           tabin(N_in) = 0.
999         ELSE
1000           h_out(N_out) = h_out(N_out) - h_diff
1001         ENDIF
1002         
1003         call reconstructandremap(tabin(1:N_in),h_in(1:N_in),ptab_child(ji,jj,1:N_out),h_out(1:N_out),N_in,N_out)
1004         
1005         ptab_child(ji,jj,N_out) = ptab_child(ji,jj,N_out) * h_out(N_out) / e3u_n(ji,jj,N_out)
1006
1007         ENDDO
1008         ENDDO
1009
1010! in the following
1011! remove division of ua by fs e3u (already done)
1012! VERTICAL REFINEMENT END
1013
1014         zrhoy = Agrif_Rhoy()
1015         DO jk = 1, jpkm1
1016            DO jj=j1,j2
1017               ua(i1:i2,jj,jk) = (ptab_child(i1:i2,jj,jk)/(zrhoy*e2u(i1:i2,jj)))
1018            END DO
1019         END DO
1020      ENDIF
1021      !
1022   END SUBROUTINE interpun
1023
1024
1025
1026   SUBROUTINE interpvn(ptab,i1,i2,j1,j2,k1,k2,m1,m2,before,nb,ndir)
1027      !!---------------------------------------------
1028      !!   *** ROUTINE interpvn ***
1029      !!----------------------------------------------------------------------
1030      !
1031      INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2,m1,m2
1032      REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2,m1:m2), INTENT(inout) :: ptab
1033      LOGICAL, INTENT(in) :: before
1034      INTEGER, INTENT(in) :: nb , ndir
1035      !
1036      INTEGER :: ji,jj,jk
1037      REAL(wp) :: zrhox
1038! VERTICAL REFINEMENT BEGIN
1039      REAL(wp), DIMENSION(i1:i2,j1:j2,1:jpk) :: ptab_child
1040      REAL(wp), DIMENSION(k1:k2) :: tabin
1041      REAL(wp) :: h_in(k1:k2)
1042      REAL(wp) :: h_out(1:jpk)
1043      INTEGER :: N_in, N_out
1044      REAL(wp) :: h_diff
1045      LOGICAL :: northern_side,southern_side
1046      INTEGER :: jref
1047
1048! VERTICAL REFINEMENT END
1049      !!---------------------------------------------   
1050      !     
1051      IF (before) THEN         
1052         !interpv entre 1 et k2 et interpv2d en jpkp1
1053         DO jk=k1,jpk
1054            DO jj=j1,j2
1055               DO ji=i1,i2
1056                  ptab(ji,jj,jk,1) = e1v(ji,jj) * vn(ji,jj,jk)
1057                  ptab(ji,jj,jk,1) = ptab(ji,jj,jk,1) * e3v_n(ji,jj,jk)
1058                  ptab(ji,jj,jk,2) = e3v_n(ji,jj,jk)
1059               END DO
1060            END DO
1061         END DO
1062      ELSE       
1063! VERTICAL REFINEMENT BEGIN
1064         ptab_child(:,:,:) = 0.
1065         southern_side = (nb == 2).AND.(ndir == 1)
1066         northern_side = (nb == 2).AND.(ndir == 2)
1067         do jj=j1,j2
1068         jref = jj
1069         IF (southern_side) jref = 2
1070         IF (northern_side) jref = nlcj-2
1071         do ji=i1,i2
1072
1073         N_in = 0
1074         do jk=k1,k2
1075           if (interp_scales_v(ji,jj,jk) == 0) EXIT
1076             N_in = N_in + 1
1077             tabin(jk) = ptab(ji,jj,jk,1)/ptab(ji,jj,jk,2)
1078             h_in(N_in) = ptab(ji,jj,jk,2)
1079         enddo
1080         IF (N_in == 0) THEN
1081           ptab_child(ji,jj,:) = 0.
1082           CYCLE
1083         ENDIF
1084         
1085         N_out = 0
1086         do jk=1,jpk
1087           if (vmask(ji,jref,jk) == 0) EXIT
1088           N_out = N_out + 1
1089           h_out(N_out) = e3v_n(ji,jj,jk)
1090         enddo
1091         IF (N_out == 0) THEN
1092           ptab_child(ji,jj,:) = 0.
1093           CYCLE
1094         ENDIF
1095         
1096         h_diff = sum(h_out(1:N_out))-sum(h_in(1:N_in))
1097         IF (h_diff > 0.) THEN
1098           N_in = N_in + 1
1099           h_in(N_in) = h_diff
1100           tabin(N_in) = 0.
1101         ELSE
1102           h_out(N_out) = h_out(N_out) - h_diff
1103         ENDIF
1104         
1105         call reconstructandremap(tabin(1:N_in),h_in(1:N_in),ptab_child(ji,jj,1:N_out),h_out(1:N_out),N_in,N_out)
1106         
1107         ptab_child(ji,jj,N_out) = ptab_child(ji,jj,N_out) * h_out(N_out) / e3v_n(ji,jj,N_out)
1108
1109         enddo
1110         enddo
1111! in the following
1112! remove division of va by fs e3v (already done)
1113! VERTICAL REFINEMENT END
1114         zrhox= Agrif_Rhox()
1115         DO jk=1,jpkm1
1116            DO jj=j1,j2
1117               va(i1:i2,jj,jk) = (ptab_child(i1:i2,jj,jk)/(zrhox*e1v(i1:i2,jj)))
1118            END DO
1119         END DO
1120      ENDIF
1121      !       
1122   END SUBROUTINE interpvn
1123   
1124
1125   SUBROUTINE interpunb( ptab, i1, i2, j1, j2, before, nb, ndir )
1126      !!----------------------------------------------------------------------
1127      !!                  ***  ROUTINE interpunb  ***
1128      !!---------------------------------------------------------------------- 
1129      INTEGER                         , INTENT(in   ) ::   i1, i2, j1, j2
1130      REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) ::   ptab
1131      LOGICAL                         , INTENT(in   ) ::   before
1132      INTEGER                         , INTENT(in   ) ::   nb , ndir
1133      !
1134      INTEGER  ::   ji, jj
1135      REAL(wp) ::   zrhoy, zrhot, zt0, zt1, ztcoeff
1136      LOGICAL  ::   western_side, eastern_side,northern_side,southern_side
1137      !!---------------------------------------------------------------------- 
1138      !
1139      IF( before ) THEN
1140         ptab(i1:i2,j1:j2) = e2u(i1:i2,j1:j2) * hu_n(i1:i2,j1:j2) * un_b(i1:i2,j1:j2)
1141      ELSE
1142         western_side  = (nb == 1).AND.(ndir == 1)
1143         eastern_side  = (nb == 1).AND.(ndir == 2)
1144         southern_side = (nb == 2).AND.(ndir == 1)
1145         northern_side = (nb == 2).AND.(ndir == 2)
1146         zrhoy = Agrif_Rhoy()
1147         zrhot = Agrif_rhot()
1148         ! Time indexes bounds for integration
1149         zt0 = REAL(Agrif_NbStepint()  , wp) / zrhot
1150         zt1 = REAL(Agrif_NbStepint()+1, wp) / zrhot     
1151         ! Polynomial interpolation coefficients:
1152         IF( bdy_tinterp == 1 ) THEN
1153            ztcoeff = zrhot * (  zt1**2._wp * (       zt1 - 1._wp)        &
1154               &               - zt0**2._wp * (       zt0 - 1._wp)        )
1155         ELSEIF( bdy_tinterp == 2 ) THEN
1156            ztcoeff = zrhot * (  zt1        * (       zt1 - 1._wp)**2._wp &
1157               &               - zt0        * (       zt0 - 1._wp)**2._wp ) 
1158
1159         ELSE
1160            ztcoeff = 1
1161         ENDIF
1162         !   
1163         IF(western_side) THEN
1164            ubdy_w(j1:j2) = ubdy_w(j1:j2) + ztcoeff * ptab(i1,j1:j2) 
1165         ENDIF
1166         IF(eastern_side) THEN
1167            ubdy_e(j1:j2) = ubdy_e(j1:j2) + ztcoeff * ptab(i1,j1:j2) 
1168         ENDIF
1169         IF(southern_side) THEN
1170            ubdy_s(i1:i2) = ubdy_s(i1:i2) + ztcoeff * ptab(i1:i2,j1) 
1171         ENDIF
1172         IF(northern_side) THEN
1173            ubdy_n(i1:i2) = ubdy_n(i1:i2) + ztcoeff * ptab(i1:i2,j1) 
1174         ENDIF
1175         !           
1176         IF( bdy_tinterp == 0 .OR. bdy_tinterp == 2) THEN
1177            IF(western_side) THEN
1178               ubdy_w(j1:j2) = ubdy_w(j1:j2) / (zrhoy*e2u(i1,j1:j2)) * umask(i1,j1:j2,1)
1179            ENDIF
1180            IF(eastern_side) THEN
1181               ubdy_e(j1:j2) = ubdy_e(j1:j2) / (zrhoy*e2u(i1,j1:j2)) * umask(i1,j1:j2,1)
1182            ENDIF
1183            IF(southern_side) THEN
1184               ubdy_s(i1:i2) = ubdy_s(i1:i2) / (zrhoy*e2u(i1:i2,j1)) * umask(i1:i2,j1,1)
1185            ENDIF
1186            IF(northern_side) THEN
1187               ubdy_n(i1:i2) = ubdy_n(i1:i2) / (zrhoy*e2u(i1:i2,j1)) * umask(i1:i2,j1,1)
1188            ENDIF
1189         ENDIF
1190      ENDIF
1191      !
1192   END SUBROUTINE interpunb
1193
1194
1195   SUBROUTINE interpvnb( ptab, i1, i2, j1, j2, before, nb, ndir )
1196      !!----------------------------------------------------------------------
1197      !!                  ***  ROUTINE interpvnb  ***
1198      !!---------------------------------------------------------------------- 
1199      INTEGER                         , INTENT(in   ) ::   i1, i2, j1, j2
1200      REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) ::   ptab
1201      LOGICAL                         , INTENT(in   ) ::   before
1202      INTEGER                         , INTENT(in   ) ::   nb , ndir
1203      !
1204      INTEGER  ::   ji,jj
1205      REAL(wp) ::   zrhox, zrhot, zt0, zt1, ztcoeff   
1206      LOGICAL  ::   western_side, eastern_side,northern_side,southern_side
1207      !!---------------------------------------------------------------------- 
1208      !
1209      IF( before ) THEN
1210         ptab(i1:i2,j1:j2) = e1v(i1:i2,j1:j2) * hv_n(i1:i2,j1:j2) * vn_b(i1:i2,j1:j2)
1211      ELSE
1212         western_side  = (nb == 1).AND.(ndir == 1)
1213         eastern_side  = (nb == 1).AND.(ndir == 2)
1214         southern_side = (nb == 2).AND.(ndir == 1)
1215         northern_side = (nb == 2).AND.(ndir == 2)
1216         zrhox = Agrif_Rhox()
1217         zrhot = Agrif_rhot()
1218         ! Time indexes bounds for integration
1219         zt0 = REAL(Agrif_NbStepint()  , wp) / zrhot
1220         zt1 = REAL(Agrif_NbStepint()+1, wp) / zrhot     
1221         IF( bdy_tinterp == 1 ) THEN
1222            ztcoeff = zrhot * (  zt1**2._wp * (       zt1 - 1._wp)        &
1223               &               - zt0**2._wp * (       zt0 - 1._wp)        )
1224         ELSEIF( bdy_tinterp == 2 ) THEN
1225            ztcoeff = zrhot * (  zt1        * (       zt1 - 1._wp)**2._wp &
1226               &               - zt0        * (       zt0 - 1._wp)**2._wp ) 
1227         ELSE
1228            ztcoeff = 1
1229         ENDIF
1230         !
1231         IF(western_side) THEN
1232            vbdy_w(j1:j2) = vbdy_w(j1:j2) + ztcoeff * ptab(i1,j1:j2) 
1233         ENDIF
1234         IF(eastern_side) THEN
1235            vbdy_e(j1:j2) = vbdy_e(j1:j2) + ztcoeff * ptab(i1,j1:j2) 
1236         ENDIF
1237         IF(southern_side) THEN
1238            vbdy_s(i1:i2) = vbdy_s(i1:i2) + ztcoeff * ptab(i1:i2,j1)
1239         ENDIF
1240         IF(northern_side) THEN
1241            vbdy_n(i1:i2) = vbdy_n(i1:i2) + ztcoeff * ptab(i1:i2,j1) 
1242         ENDIF
1243         !           
1244         IF( bdy_tinterp == 0 .OR. bdy_tinterp == 2) THEN
1245            IF(western_side) THEN
1246               vbdy_w(j1:j2) = vbdy_w(j1:j2) / (zrhox*e1v(i1,j1:j2))   &
1247                     &                                  * vmask(i1,j1:j2,1)
1248            ENDIF
1249            IF(eastern_side) THEN
1250               vbdy_e(j1:j2) = vbdy_e(j1:j2) / (zrhox*e1v(i1,j1:j2))   &
1251                     &                                  * vmask(i1,j1:j2,1)
1252            ENDIF
1253            IF(southern_side) THEN
1254               vbdy_s(i1:i2) = vbdy_s(i1:i2) / (zrhox*e1v(i1:i2,j1))   &
1255                     &                                  * vmask(i1:i2,j1,1)
1256            ENDIF
1257            IF(northern_side) THEN
1258               vbdy_n(i1:i2) = vbdy_n(i1:i2) / (zrhox*e1v(i1:i2,j1))   &
1259                     &                                  * vmask(i1:i2,j1,1)
1260            ENDIF
1261         ENDIF
1262      ENDIF
1263      !
1264   END SUBROUTINE interpvnb
1265
1266
1267   SUBROUTINE interpub2b( ptab, i1, i2, j1, j2, before, nb, ndir )
1268      !!----------------------------------------------------------------------
1269      !!                  ***  ROUTINE interpub2b  ***
1270      !!---------------------------------------------------------------------- 
1271      INTEGER                         , INTENT(in   ) ::   i1, i2, j1, j2
1272      REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) ::   ptab
1273      LOGICAL                         , INTENT(in   ) ::   before
1274      INTEGER                         , INTENT(in   ) ::   nb , ndir
1275      !
1276      INTEGER  ::   ji,jj
1277      REAL(wp) ::   zrhot, zt0, zt1,zat
1278      LOGICAL  ::   western_side, eastern_side,northern_side,southern_side
1279      !!---------------------------------------------------------------------- 
1280      IF( before ) THEN
1281         ptab(i1:i2,j1:j2) = e2u(i1:i2,j1:j2) * ub2_b(i1:i2,j1:j2)
1282      ELSE
1283         western_side  = (nb == 1).AND.(ndir == 1)
1284         eastern_side  = (nb == 1).AND.(ndir == 2)
1285         southern_side = (nb == 2).AND.(ndir == 1)
1286         northern_side = (nb == 2).AND.(ndir == 2)
1287         zrhot = Agrif_rhot()
1288         ! Time indexes bounds for integration
1289         zt0 = REAL(Agrif_NbStepint()  , wp) / zrhot
1290         zt1 = REAL(Agrif_NbStepint()+1, wp) / zrhot
1291         ! Polynomial interpolation coefficients:
1292         zat = zrhot * (  zt1**2._wp * (-2._wp*zt1 + 3._wp)    &
1293            &           - zt0**2._wp * (-2._wp*zt0 + 3._wp)    ) 
1294         !
1295         IF(western_side ) ubdy_w(j1:j2) = zat * ptab(i1,j1:j2) 
1296         IF(eastern_side ) ubdy_e(j1:j2) = zat * ptab(i1,j1:j2) 
1297         IF(southern_side) ubdy_s(i1:i2) = zat * ptab(i1:i2,j1) 
1298         IF(northern_side) ubdy_n(i1:i2) = zat * ptab(i1:i2,j1) 
1299      ENDIF
1300      !
1301   END SUBROUTINE interpub2b
1302   
1303
1304   SUBROUTINE interpvb2b( ptab, i1, i2, j1, j2, before, nb, ndir )
1305      !!----------------------------------------------------------------------
1306      !!                  ***  ROUTINE interpvb2b  ***
1307      !!---------------------------------------------------------------------- 
1308      INTEGER                         , INTENT(in   ) ::   i1, i2, j1, j2
1309      REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) ::   ptab
1310      LOGICAL                         , INTENT(in   ) ::   before
1311      INTEGER                         , INTENT(in   ) ::   nb , ndir
1312      !
1313      INTEGER ::   ji,jj
1314      REAL(wp) ::   zrhot, zt0, zt1,zat
1315      LOGICAL ::   western_side, eastern_side,northern_side,southern_side
1316      !!---------------------------------------------------------------------- 
1317      !
1318      IF( before ) THEN
1319         ptab(i1:i2,j1:j2) = e1v(i1:i2,j1:j2) * vb2_b(i1:i2,j1:j2)
1320      ELSE     
1321         western_side  = (nb == 1).AND.(ndir == 1)
1322         eastern_side  = (nb == 1).AND.(ndir == 2)
1323         southern_side = (nb == 2).AND.(ndir == 1)
1324         northern_side = (nb == 2).AND.(ndir == 2)
1325         zrhot = Agrif_rhot()
1326         ! Time indexes bounds for integration
1327         zt0 = REAL(Agrif_NbStepint()  , wp) / zrhot
1328         zt1 = REAL(Agrif_NbStepint()+1, wp) / zrhot
1329         ! Polynomial interpolation coefficients:
1330         zat = zrhot * (  zt1**2._wp * (-2._wp*zt1 + 3._wp)    &
1331            &           - zt0**2._wp * (-2._wp*zt0 + 3._wp)    ) 
1332         !
1333         IF(western_side )   vbdy_w(j1:j2) = zat * ptab(i1,j1:j2) 
1334         IF(eastern_side )   vbdy_e(j1:j2) = zat * ptab(i1,j1:j2) 
1335         IF(southern_side)   vbdy_s(i1:i2) = zat * ptab(i1:i2,j1) 
1336         IF(northern_side)   vbdy_n(i1:i2) = zat * ptab(i1:i2,j1) 
1337      ENDIF
1338      !     
1339   END SUBROUTINE interpvb2b
1340
1341
1342   SUBROUTINE interpe3t( ptab, i1, i2, j1, j2, k1, k2, before, nb, ndir )
1343      !!----------------------------------------------------------------------
1344      !!                  ***  ROUTINE interpe3t  ***
1345      !!---------------------------------------------------------------------- 
1346      INTEGER                              , INTENT(in   ) :: i1, i2, j1, j2, k1, k2
1347      REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: ptab
1348      LOGICAL                              , INTENT(in   ) :: before
1349      INTEGER                              , INTENT(in   ) :: nb , ndir
1350      !
1351      INTEGER :: ji, jj, jk
1352      LOGICAL :: western_side, eastern_side, northern_side, southern_side
1353      REAL(wp) :: ztmpmsk     
1354      !!---------------------------------------------------------------------- 
1355      !   
1356      IF( before ) THEN
1357         ptab(i1:i2,j1:j2,k1:k2) = tmask(i1:i2,j1:j2,k1:k2) * e3t_0(i1:i2,j1:j2,k1:k2)
1358      ELSE
1359         western_side  = (nb == 1).AND.(ndir == 1)
1360         eastern_side  = (nb == 1).AND.(ndir == 2)
1361         southern_side = (nb == 2).AND.(ndir == 1)
1362         northern_side = (nb == 2).AND.(ndir == 2)
1363
1364         DO jk = k1, k2
1365            DO jj = j1, j2
1366               DO ji = i1, i2
1367                  ! Get velocity mask at boundary edge points:
1368                  IF( western_side )   ztmpmsk = umask(ji    ,jj    ,1)
1369                  IF( eastern_side )   ztmpmsk = umask(nlci-2,jj    ,1)
1370                  IF( northern_side)   ztmpmsk = vmask(ji    ,nlcj-2,1)
1371                  IF( southern_side)   ztmpmsk = vmask(ji    ,2     ,1)
1372                  !
1373                  IF( ABS( ptab(ji,jj,jk) - tmask(ji,jj,jk) * e3t_0(ji,jj,jk) )*ztmpmsk > 1.D-2) THEN
1374                     IF (western_side) THEN
1375                        WRITE(numout,*) 'ERROR bathymetry merge at the western border ji,jj,jk ', ji+nimpp-1,jj+njmpp-1,jk
1376                     ELSEIF (eastern_side) THEN
1377                        WRITE(numout,*) 'ERROR bathymetry merge at the eastern border ji,jj,jk ', ji+nimpp-1,jj+njmpp-1,jk
1378                     ELSEIF (southern_side) THEN
1379                        WRITE(numout,*) 'ERROR bathymetry merge at the southern border ji,jj,jk', ji+nimpp-1,jj+njmpp-1,jk
1380                     ELSEIF (northern_side) THEN
1381                        WRITE(numout,*) 'ERROR bathymetry merge at the northen border ji,jj,jk', ji+nimpp-1,jj+njmpp-1,jk
1382                     ENDIF
1383                     WRITE(numout,*) '      ptab(ji,jj,jk), e3t(ji,jj,jk) ', ptab(ji,jj,jk), e3t_0(ji,jj,jk)
1384                     kindic_agr = kindic_agr + 1
1385                  ENDIF
1386               END DO
1387            END DO
1388         END DO
1389         !
1390      ENDIF
1391      !
1392   END SUBROUTINE interpe3t
1393
1394
1395   SUBROUTINE interpumsk( ptab, i1, i2, j1, j2, k1, k2, before, nb, ndir )
1396      !!----------------------------------------------------------------------
1397      !!                  ***  ROUTINE interpumsk  ***
1398      !!---------------------------------------------------------------------- 
1399      INTEGER                              , INTENT(in   ) ::   i1, i2, j1, j2, k1, k2
1400      REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) ::   ptab
1401      LOGICAL                              , INTENT(in   ) ::   before
1402      INTEGER                              , INTENT(in   ) ::   nb , ndir
1403      !
1404      INTEGER ::   ji, jj, jk
1405      LOGICAL ::   western_side, eastern_side   
1406      !!---------------------------------------------------------------------- 
1407      !   
1408      IF( before ) THEN
1409         ptab(i1:i2,j1:j2,k1:k2) = umask(i1:i2,j1:j2,k1:k2)
1410      ELSE
1411         western_side = (nb == 1).AND.(ndir == 1)
1412         eastern_side = (nb == 1).AND.(ndir == 2)
1413         DO jk = k1, k2
1414            DO jj = j1, j2
1415               DO ji = i1, i2
1416                   ! Velocity mask at boundary edge points:
1417                  IF (ABS(ptab(ji,jj,jk) - umask(ji,jj,jk)) > 1.D-2) THEN
1418                     IF (western_side) THEN
1419                        WRITE(numout,*) 'ERROR with umask at the western border ji,jj,jk ', ji+nimpp-1,jj+njmpp-1,jk
1420                        WRITE(numout,*) '      masks: parent, child ', ptab(ji,jj,jk), umask(ji,jj,jk)
1421                        kindic_agr = kindic_agr + 1
1422                     ELSEIF (eastern_side) THEN
1423                        WRITE(numout,*) 'ERROR with umask at the eastern border ji,jj,jk ', ji+nimpp-1,jj+njmpp-1,jk
1424                        WRITE(numout,*) '      masks: parent, child ', ptab(ji,jj,jk), umask(ji,jj,jk)
1425                        kindic_agr = kindic_agr + 1
1426                     ENDIF
1427                  ENDIF
1428               END DO
1429            END DO
1430         END DO
1431         !
1432      ENDIF
1433      !
1434   END SUBROUTINE interpumsk
1435
1436
1437   SUBROUTINE interpvmsk( ptab, i1, i2, j1, j2, k1, k2, before, nb, ndir )
1438      !!----------------------------------------------------------------------
1439      !!                  ***  ROUTINE interpvmsk  ***
1440      !!---------------------------------------------------------------------- 
1441      INTEGER                              , INTENT(in   ) ::   i1,i2,j1,j2,k1,k2
1442      REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) ::   ptab
1443      LOGICAL                              , INTENT(in   ) ::   before
1444      INTEGER                              , INTENT(in   ) :: nb , ndir
1445      !
1446      INTEGER ::   ji, jj, jk
1447      LOGICAL ::   northern_side, southern_side     
1448      !!---------------------------------------------------------------------- 
1449      !   
1450      IF( before ) THEN
1451         ptab(i1:i2,j1:j2,k1:k2) = vmask(i1:i2,j1:j2,k1:k2)
1452      ELSE
1453         southern_side = (nb == 2).AND.(ndir == 1)
1454         northern_side = (nb == 2).AND.(ndir == 2)
1455         DO jk = k1, k2
1456            DO jj = j1, j2
1457               DO ji = i1, i2
1458                   ! Velocity mask at boundary edge points:
1459                  IF (ABS(ptab(ji,jj,jk) - vmask(ji,jj,jk)) > 1.D-2) THEN
1460                     IF (southern_side) THEN
1461                        WRITE(numout,*) 'ERROR with vmask at the southern border ji,jj,jk ', ji+nimpp-1,jj+njmpp-1,jk
1462                        WRITE(numout,*) '      masks: parent, child ', ptab(ji,jj,jk), vmask(ji,jj,jk)
1463                        kindic_agr = kindic_agr + 1
1464                     ELSEIF (northern_side) THEN
1465                        WRITE(numout,*) 'ERROR with vmask at the northern border ji,jj,jk ', ji+nimpp-1,jj+njmpp-1,jk
1466                        WRITE(numout,*) '      masks: parent, child ', ptab(ji,jj,jk), vmask(ji,jj,jk)
1467                        kindic_agr = kindic_agr + 1
1468                     ENDIF
1469                  ENDIF
1470               END DO
1471            END DO
1472         END DO
1473         !
1474      ENDIF
1475      !
1476   END SUBROUTINE interpvmsk
1477
1478# if defined key_zdftke
1479
1480   SUBROUTINE interpavm( ptab, i1, i2, j1, j2, k1, k2, before )
1481      !!----------------------------------------------------------------------
1482      !!                  ***  ROUTINE interavm  ***
1483      !!---------------------------------------------------------------------- 
1484      INTEGER                              , INTENT(in   ) ::   i1, i2, j1, j2, k1, k2
1485      REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) ::   ptab
1486      LOGICAL                              , INTENT(in   ) ::   before
1487      !!---------------------------------------------------------------------- 
1488      !     
1489      IF( before ) THEN
1490         ptab (i1:i2,j1:j2,k1:k2) = avm_k(i1:i2,j1:j2,k1:k2)
1491      ELSE
1492         avm_k(i1:i2,j1:j2,k1:k2) = ptab (i1:i2,j1:j2,k1:k2)
1493      ENDIF
1494      !
1495   END SUBROUTINE interpavm
1496
1497# endif /* key_zdftke */
1498
1499#else
1500   !!----------------------------------------------------------------------
1501   !!   Empty module                                          no AGRIF zoom
1502   !!----------------------------------------------------------------------
1503CONTAINS
1504   SUBROUTINE Agrif_OPA_Interp_empty
1505      WRITE(*,*)  'agrif_opa_interp : You should not have seen this print! error?'
1506   END SUBROUTINE Agrif_OPA_Interp_empty
1507#endif
1508
1509   !!======================================================================
1510END MODULE agrif_opa_interp
Note: See TracBrowser for help on using the repository browser.