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/2016/dev_INGV_UKMO_2016/NEMOGCM/NEMO/NST_SRC – NEMO

source: branches/2016/dev_INGV_UKMO_2016/NEMOGCM/NEMO/NST_SRC/agrif_opa_interp.F90 @ 7351

Last change on this file since 7351 was 7351, checked in by emanuelaclementi, 7 years ago

ticket #1805 step 3: /2016/dev_INGV_UKMO_2016 aligned to the trunk at revision 7161

  • Property svn:keywords set to Id
File size: 47.5 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   PUBLIC   interpun, interpvn
38   PUBLIC   interptsn,  interpsshn
39   PUBLIC   interpunb, interpvnb, interpub2b, interpvb2b
40   PUBLIC   interpe3t, interpumsk, interpvmsk
41# if defined key_zdftke
42   PUBLIC   Agrif_tke, interpavm
43# endif
44
45   INTEGER ::   bdy_tinterp = 0
46
47#  include "vectopt_loop_substitute.h90"
48   !!----------------------------------------------------------------------
49   !! NEMO/NST 3.7 , NEMO Consortium (2015)
50   !! $Id$
51   !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt)
52   !!----------------------------------------------------------------------
53CONTAINS
54
55   SUBROUTINE Agrif_tra
56      !!----------------------------------------------------------------------
57      !!                  ***  ROUTINE Agrif_tra  ***
58      !!----------------------------------------------------------------------
59      !
60      IF( Agrif_Root() )   RETURN
61      !
62      Agrif_SpecialValue    = 0._wp
63      Agrif_UseSpecialValue = .TRUE.
64      !
65      CALL Agrif_Bc_variable( tsn_id, procname=interptsn )
66      !
67      Agrif_UseSpecialValue = .FALSE.
68      !
69   END SUBROUTINE Agrif_tra
70
71
72   SUBROUTINE Agrif_dyn( kt )
73      !!----------------------------------------------------------------------
74      !!                  ***  ROUTINE Agrif_DYN  ***
75      !!---------------------------------------------------------------------- 
76      INTEGER, INTENT(in) ::   kt
77      !
78      INTEGER ::   ji, jj, jk       ! dummy loop indices
79      INTEGER ::   j1, j2, i1, i2
80      REAL(wp), POINTER, DIMENSION(:,:) ::   zub, zvb
81      !!---------------------------------------------------------------------- 
82      !
83      IF( Agrif_Root() )   RETURN
84      !
85      CALL wrk_alloc( jpi,jpj,   zub, zvb )
86      !
87      Agrif_SpecialValue    = 0._wp
88      Agrif_UseSpecialValue = ln_spc_dyn
89      !
90      CALL Agrif_Bc_variable( un_interp_id, procname=interpun )
91      CALL Agrif_Bc_variable( vn_interp_id, procname=interpvn )
92      !
93      Agrif_UseSpecialValue = .FALSE.
94      !
95      ! prevent smoothing in ghost cells
96      i1 =  1   ;   i2 = jpi
97      j1 =  1   ;   j2 = jpj
98      IF( nbondj == -1 .OR. nbondj == 2 )   j1 = 3
99      IF( nbondj == +1 .OR. nbondj == 2 )   j2 = nlcj-2
100      IF( nbondi == -1 .OR. nbondi == 2 )   i1 = 3
101      IF( nbondi == +1 .OR. nbondi == 2 )   i2 = nlci-2
102
103      IF( nbondi == -1 .OR. nbondi == 2 ) THEN
104         !
105         ! Smoothing
106         ! ---------
107         IF( .NOT.ln_dynspg_ts ) THEN  ! Store transport
108            ua_b(2,:) = 0._wp
109            DO jk = 1, jpkm1
110               DO jj = 1, jpj
111                  ua_b(2,jj) = ua_b(2,jj) + e3u_a(2,jj,jk) * ua(2,jj,jk)
112               END DO
113            END DO
114            DO jj = 1, jpj
115               ua_b(2,jj) = ua_b(2,jj) * r1_hu_a(2,jj)           
116            END DO
117         ENDIF
118         !
119         DO jk=1,jpkm1                 ! Smooth
120            DO jj=j1,j2
121               ua(2,jj,jk) = 0.25_wp*(ua(1,jj,jk)+2._wp*ua(2,jj,jk)+ua(3,jj,jk))
122               ua(2,jj,jk) = ua(2,jj,jk) * umask(2,jj,jk)
123            END DO
124         END DO
125         !
126         zub(2,:) = 0._wp              ! Correct transport
127         DO jk = 1, jpkm1
128            DO jj = 1, jpj
129               zub(2,jj) = zub(2,jj) + e3u_a(2,jj,jk) * ua(2,jj,jk)
130            END DO
131         END DO
132         DO jj=1,jpj
133            zub(2,jj) = zub(2,jj) * r1_hu_a(2,jj)
134         END DO
135
136         DO jk=1,jpkm1
137            DO jj=1,jpj
138               ua(2,jj,jk) = (ua(2,jj,jk)+ua_b(2,jj)-zub(2,jj))*umask(2,jj,jk)
139            END DO
140         END DO
141
142         ! Set tangential velocities to time splitting estimate
143         !-----------------------------------------------------
144         IF( ln_dynspg_ts ) THEN
145            zvb(2,:) = 0._wp
146            DO jk = 1, jpkm1
147               DO jj = 1, jpj
148                  zvb(2,jj) = zvb(2,jj) + e3v_a(2,jj,jk) * va(2,jj,jk)
149               END DO
150            END DO
151            DO jj = 1, jpj
152               zvb(2,jj) = zvb(2,jj) * r1_hv_a(2,jj)
153            END DO
154            DO jk = 1, jpkm1
155               DO jj = 1, jpj
156                  va(2,jj,jk) = (va(2,jj,jk)+va_b(2,jj)-zvb(2,jj)) * vmask(2,jj,jk)
157               END DO
158            END DO
159         ENDIF
160         !
161         ! Mask domain edges:
162         !-------------------
163         DO jk = 1, jpkm1
164            DO jj = 1, jpj
165               ua(1,jj,jk) = 0._wp
166               va(1,jj,jk) = 0._wp
167            END DO
168         END DO         
169         !
170      ENDIF
171
172      IF( nbondi == 1 .OR. nbondi == 2 ) THEN
173
174         ! Smoothing
175         ! ---------
176         IF( .NOT.ln_dynspg_ts ) THEN  ! Store transport
177            ua_b(nlci-2,:) = 0._wp
178            DO jk=1,jpkm1
179               DO jj=1,jpj
180                  ua_b(nlci-2,jj) = ua_b(nlci-2,jj) + e3u_a(nlci-2,jj,jk) * ua(nlci-2,jj,jk)
181               END DO
182            END DO
183            DO jj=1,jpj
184               ua_b(nlci-2,jj) = ua_b(nlci-2,jj) * r1_hu_a(nlci-2,jj)           
185            END DO
186         ENDIF
187
188         DO jk = 1, jpkm1              ! Smooth
189            DO jj = j1, j2
190               ua(nlci-2,jj,jk) = 0.25_wp * umask(nlci-2,jj,jk)      &
191                  &             * ( ua(nlci-3,jj,jk) + 2._wp*ua(nlci-2,jj,jk) + ua(nlci-1,jj,jk) )
192            END DO
193         END DO
194
195         zub(nlci-2,:) = 0._wp        ! Correct transport
196         DO jk = 1, jpkm1
197            DO jj = 1, jpj
198               zub(nlci-2,jj) = zub(nlci-2,jj) + e3u_a(nlci-2,jj,jk) * ua(nlci-2,jj,jk)
199            END DO
200         END DO
201         DO jj = 1, jpj
202            zub(nlci-2,jj) = zub(nlci-2,jj) * r1_hu_a(nlci-2,jj)
203         END DO
204
205         DO jk = 1, jpkm1
206            DO jj = 1, jpj
207               ua(nlci-2,jj,jk) = ( ua(nlci-2,jj,jk) + ua_b(nlci-2,jj) - zub(nlci-2,jj) ) * umask(nlci-2,jj,jk)
208            END DO
209         END DO
210         !
211         ! Set tangential velocities to time splitting estimate
212         !-----------------------------------------------------
213         IF( ln_dynspg_ts ) THEN
214            zvb(nlci-1,:) = 0._wp
215            DO jk = 1, jpkm1
216               DO jj = 1, jpj
217                  zvb(nlci-1,jj) = zvb(nlci-1,jj) + e3v_a(nlci-1,jj,jk) * va(nlci-1,jj,jk)
218               END DO
219            END DO
220            DO jj=1,jpj
221               zvb(nlci-1,jj) = zvb(nlci-1,jj) * r1_hv_a(nlci-1,jj)
222            END DO
223            DO jk = 1, jpkm1
224               DO jj = 1, jpj
225                  va(nlci-1,jj,jk) = ( va(nlci-1,jj,jk) + va_b(nlci-1,jj) - zvb(nlci-1,jj) ) * vmask(nlci-1,jj,jk)
226               END DO
227            END DO
228         ENDIF
229         !
230         ! Mask domain edges:
231         !-------------------
232         DO jk = 1, jpkm1
233            DO jj = 1, jpj
234               ua(nlci-1,jj,jk) = 0._wp
235               va(nlci  ,jj,jk) = 0._wp
236            END DO
237         END DO 
238         !
239      ENDIF
240
241      IF( nbondj == -1 .OR. nbondj == 2 ) THEN
242
243         ! Smoothing
244         ! ---------
245         IF( .NOT.ln_dynspg_ts ) THEN  ! Store transport
246            va_b(:,2) = 0._wp
247            DO jk = 1, jpkm1
248               DO ji = 1, jpi
249                  va_b(ji,2) = va_b(ji,2) + e3v_a(ji,2,jk) * va(ji,2,jk)
250               END DO
251            END DO
252            DO ji=1,jpi
253               va_b(ji,2) = va_b(ji,2) * r1_hv_a(ji,2)           
254            END DO
255         ENDIF
256         !
257         DO jk = 1, jpkm1              ! Smooth
258            DO ji = i1, i2
259               va(ji,2,jk) = 0.25_wp * vmask(ji,2,jk)    &
260                  &        * ( va(ji,1,jk) + 2._wp*va(ji,2,jk) + va(ji,3,jk) )
261            END DO
262         END DO
263         !
264         zvb(:,2) = 0._wp              ! Correct transport
265         DO jk=1,jpkm1
266            DO ji=1,jpi
267               zvb(ji,2) = zvb(ji,2) + e3v_a(ji,2,jk) * va(ji,2,jk) * vmask(ji,2,jk)
268            END DO
269         END DO
270         DO ji = 1, jpi
271            zvb(ji,2) = zvb(ji,2) * r1_hv_a(ji,2)
272         END DO
273         DO jk = 1, jpkm1
274            DO ji = 1, jpi
275               va(ji,2,jk) = ( va(ji,2,jk) + va_b(ji,2) - zvb(ji,2) ) * vmask(ji,2,jk)
276            END DO
277         END DO
278
279         ! Set tangential velocities to time splitting estimate
280         !-----------------------------------------------------
281         IF( ln_dynspg_ts ) THEN
282            zub(:,2) = 0._wp
283            DO jk = 1, jpkm1
284               DO ji = 1, jpi
285                  zub(ji,2) = zub(ji,2) + e3u_a(ji,2,jk) * ua(ji,2,jk) * umask(ji,2,jk)
286               END DO
287            END DO
288            DO ji = 1, jpi
289               zub(ji,2) = zub(ji,2) * r1_hu_a(ji,2)
290            END DO
291
292            DO jk = 1, jpkm1
293               DO ji = 1, jpi
294                  ua(ji,2,jk) = ( ua(ji,2,jk) + ua_b(ji,2) - zub(ji,2) ) * umask(ji,2,jk)
295               END DO
296            END DO
297         ENDIF
298
299         ! Mask domain edges:
300         !-------------------
301         DO jk = 1, jpkm1
302            DO ji = 1, jpi
303               ua(ji,1,jk) = 0._wp
304               va(ji,1,jk) = 0._wp
305            END DO
306         END DO
307
308      ENDIF
309
310      IF( nbondj == 1 .OR. nbondj == 2 ) THEN
311         !
312         ! Smoothing
313         ! ---------
314         IF( .NOT.ln_dynspg_ts ) THEN  ! Store transport
315            va_b(:,nlcj-2) = 0._wp
316            DO jk = 1, jpkm1
317               DO ji = 1, jpi
318                  va_b(ji,nlcj-2) = va_b(ji,nlcj-2) + e3v_a(ji,nlcj-2,jk) * va(ji,nlcj-2,jk)
319               END DO
320            END DO
321            DO ji = 1, jpi
322               va_b(ji,nlcj-2) = va_b(ji,nlcj-2) * r1_hv_a(ji,nlcj-2)           
323            END DO
324         ENDIF
325         !
326         DO jk = 1, jpkm1              ! Smooth
327            DO ji = i1, i2
328               va(ji,nlcj-2,jk) = 0.25_wp * vmask(ji,nlcj-2,jk)   &
329                  &             * ( va(ji,nlcj-3,jk) + 2._wp * va(ji,nlcj-2,jk) + va(ji,nlcj-1,jk) )
330            END DO
331         END DO
332         !
333         zvb(:,nlcj-2) = 0._wp         ! Correct transport
334         DO jk = 1, jpkm1
335            DO ji = 1, jpi
336               zvb(ji,nlcj-2) = zvb(ji,nlcj-2) + e3v_a(ji,nlcj-2,jk) * va(ji,nlcj-2,jk) * vmask(ji,nlcj-2,jk)
337            END DO
338         END DO
339         DO ji = 1, jpi
340            zvb(ji,nlcj-2) = zvb(ji,nlcj-2) * r1_hv_a(ji,nlcj-2)
341         END DO
342         DO jk = 1, jpkm1
343            DO ji = 1, jpi
344               va(ji,nlcj-2,jk) = ( va(ji,nlcj-2,jk) + va_b(ji,nlcj-2) - zvb(ji,nlcj-2) ) * vmask(ji,nlcj-2,jk)
345            END DO
346         END DO
347         !
348         ! Set tangential velocities to time splitting estimate
349         !-----------------------------------------------------
350         IF( ln_dynspg_ts ) THEN
351            zub(:,nlcj-1) = 0._wp
352            DO jk = 1, jpkm1
353               DO ji = 1, jpi
354                  zub(ji,nlcj-1) = zub(ji,nlcj-1) + e3u_a(ji,nlcj-1,jk) * ua(ji,nlcj-1,jk) * umask(ji,nlcj-1,jk)
355               END DO
356            END DO
357            DO ji = 1, jpi
358               zub(ji,nlcj-1) = zub(ji,nlcj-1) * r1_hu_a(ji,nlcj-1)
359            END DO
360            !
361            DO jk = 1, jpkm1
362               DO ji = 1, jpi
363                  ua(ji,nlcj-1,jk) = ( ua(ji,nlcj-1,jk) + ua_b(ji,nlcj-1) - zub(ji,nlcj-1) ) * umask(ji,nlcj-1,jk)
364               END DO
365            END DO
366         ENDIF
367         !
368         ! Mask domain edges:
369         !-------------------
370         DO jk = 1, jpkm1
371            DO ji = 1, jpi
372               ua(ji,nlcj  ,jk) = 0._wp
373               va(ji,nlcj-1,jk) = 0._wp
374            END DO
375         END DO 
376         !
377      ENDIF
378      !
379      CALL wrk_dealloc( jpi,jpj,   zub, zvb )
380      !
381   END SUBROUTINE Agrif_dyn
382
383
384   SUBROUTINE Agrif_dyn_ts( jn )
385      !!----------------------------------------------------------------------
386      !!                  ***  ROUTINE Agrif_dyn_ts  ***
387      !!---------------------------------------------------------------------- 
388      !!
389      INTEGER, INTENT(in) ::   jn
390      !!
391      INTEGER :: ji, jj
392      !!---------------------------------------------------------------------- 
393      !
394      IF( Agrif_Root() )   RETURN
395      !
396      IF((nbondi == -1).OR.(nbondi == 2)) THEN
397         DO jj=1,jpj
398            va_e(2,jj) = vbdy_w(jj) * hvr_e(2,jj)
399            ! Specified fluxes:
400            ua_e(2,jj) = ubdy_w(jj) * hur_e(2,jj)
401            ! Characteristics method:
402            !alt            ua_e(2,jj) = 0.5_wp * ( ubdy_w(jj) * hur_e(2,jj) + ua_e(3,jj) &
403            !alt                       &           - sqrt(grav * hur_e(2,jj)) * (sshn_e(3,jj) - hbdy_w(jj)) )
404         END DO
405      ENDIF
406      !
407      IF((nbondi == 1).OR.(nbondi == 2)) THEN
408         DO jj=1,jpj
409            va_e(nlci-1,jj) = vbdy_e(jj) * hvr_e(nlci-1,jj)
410            ! Specified fluxes:
411            ua_e(nlci-2,jj) = ubdy_e(jj) * hur_e(nlci-2,jj)
412            ! Characteristics method:
413            !alt            ua_e(nlci-2,jj) = 0.5_wp * ( ubdy_e(jj) * hur_e(nlci-2,jj) + ua_e(nlci-3,jj) &
414            !alt                            &           + sqrt(grav * hur_e(nlci-2,jj)) * (sshn_e(nlci-2,jj) - hbdy_e(jj)) )
415         END DO
416      ENDIF
417      !
418      IF((nbondj == -1).OR.(nbondj == 2)) THEN
419         DO ji=1,jpi
420            ua_e(ji,2) = ubdy_s(ji) * hur_e(ji,2)
421            ! Specified fluxes:
422            va_e(ji,2) = vbdy_s(ji) * hvr_e(ji,2)
423            ! Characteristics method:
424            !alt            va_e(ji,2) = 0.5_wp * ( vbdy_s(ji) * hvr_e(ji,2) + va_e(ji,3) &
425            !alt                       &           - sqrt(grav * hvr_e(ji,2)) * (sshn_e(ji,3) - hbdy_s(ji)) )
426         END DO
427      ENDIF
428      !
429      IF((nbondj == 1).OR.(nbondj == 2)) THEN
430         DO ji=1,jpi
431            ua_e(ji,nlcj-1) = ubdy_n(ji) * hur_e(ji,nlcj-1)
432            ! Specified fluxes:
433            va_e(ji,nlcj-2) = vbdy_n(ji) * hvr_e(ji,nlcj-2)
434            ! Characteristics method:
435            !alt            va_e(ji,nlcj-2) = 0.5_wp * ( vbdy_n(ji) * hvr_e(ji,nlcj-2)  + va_e(ji,nlcj-3) &
436            !alt                            &           + sqrt(grav * hvr_e(ji,nlcj-2)) * (sshn_e(ji,nlcj-2) - hbdy_n(ji)) )
437         END DO
438      ENDIF
439      !
440   END SUBROUTINE Agrif_dyn_ts
441
442
443   SUBROUTINE Agrif_dta_ts( kt )
444      !!----------------------------------------------------------------------
445      !!                  ***  ROUTINE Agrif_dta_ts  ***
446      !!---------------------------------------------------------------------- 
447      !!
448      INTEGER, INTENT(in) ::   kt
449      !!
450      INTEGER :: ji, jj
451      LOGICAL :: ll_int_cons
452      REAL(wp) :: zrhot, zt
453      !!---------------------------------------------------------------------- 
454      !
455      IF( Agrif_Root() )   RETURN
456      !
457      ll_int_cons = ln_bt_fw ! Assume conservative temporal integration in the forward case only
458      !
459      zrhot = Agrif_rhot()
460      !
461      ! "Central" time index for interpolation:
462      IF( ln_bt_fw ) THEN
463         zt = REAL( Agrif_NbStepint()+0.5_wp, wp ) / zrhot
464      ELSE
465         zt = REAL( Agrif_NbStepint()       , wp ) / zrhot
466      ENDIF
467      !
468      ! Linear interpolation of sea level
469      Agrif_SpecialValue    = 0._wp
470      Agrif_UseSpecialValue = .TRUE.
471      CALL Agrif_Bc_variable( sshn_id, calledweight=zt, procname=interpsshn )
472      Agrif_UseSpecialValue = .FALSE.
473      !
474      ! Interpolate barotropic fluxes
475      Agrif_SpecialValue=0.
476      Agrif_UseSpecialValue = ln_spc_dyn
477      !
478      IF( ll_int_cons ) THEN  ! Conservative interpolation
479         ! orders matters here !!!!!!
480         CALL Agrif_Bc_variable( ub2b_interp_id, calledweight=1._wp, procname=interpub2b ) ! Time integrated
481         CALL Agrif_Bc_variable( vb2b_interp_id, calledweight=1._wp, procname=interpvb2b )
482         bdy_tinterp = 1
483         CALL Agrif_Bc_variable( unb_id        , calledweight=1._wp, procname=interpunb  ) ! After
484         CALL Agrif_Bc_variable( vnb_id        , calledweight=1._wp, procname=interpvnb  )
485         bdy_tinterp = 2
486         CALL Agrif_Bc_variable( unb_id        , calledweight=0._wp, procname=interpunb  ) ! Before
487         CALL Agrif_Bc_variable( vnb_id        , calledweight=0._wp, procname=interpvnb  )         
488      ELSE ! Linear interpolation
489         bdy_tinterp = 0
490         ubdy_w(:) = 0._wp   ;   vbdy_w(:) = 0._wp 
491         ubdy_e(:) = 0._wp   ;   vbdy_e(:) = 0._wp 
492         ubdy_n(:) = 0._wp   ;   vbdy_n(:) = 0._wp 
493         ubdy_s(:) = 0._wp   ;   vbdy_s(:) = 0._wp
494         CALL Agrif_Bc_variable( unb_id, calledweight=zt, procname=interpunb )
495         CALL Agrif_Bc_variable( vnb_id, calledweight=zt, procname=interpvnb )
496      ENDIF
497      Agrif_UseSpecialValue = .FALSE.
498      !
499   END SUBROUTINE Agrif_dta_ts
500
501
502   SUBROUTINE Agrif_ssh( kt )
503      !!----------------------------------------------------------------------
504      !!                  ***  ROUTINE Agrif_DYN  ***
505      !!---------------------------------------------------------------------- 
506      INTEGER, INTENT(in) ::   kt
507      !!
508      !!---------------------------------------------------------------------- 
509      !
510      IF( Agrif_Root() )   RETURN
511      !
512      IF((nbondi == -1).OR.(nbondi == 2)) THEN
513         ssha(2,:)=ssha(3,:)
514         sshn(2,:)=sshn(3,:)
515      ENDIF
516      !
517      IF((nbondi == 1).OR.(nbondi == 2)) THEN
518         ssha(nlci-1,:)=ssha(nlci-2,:)
519         sshn(nlci-1,:)=sshn(nlci-2,:)
520      ENDIF
521      !
522      IF((nbondj == -1).OR.(nbondj == 2)) THEN
523         ssha(:,2)=ssha(:,3)
524         sshn(:,2)=sshn(:,3)
525      ENDIF
526      !
527      IF((nbondj == 1).OR.(nbondj == 2)) THEN
528         ssha(:,nlcj-1)=ssha(:,nlcj-2)
529         sshn(:,nlcj-1)=sshn(:,nlcj-2)
530      ENDIF
531      !
532   END SUBROUTINE Agrif_ssh
533
534
535   SUBROUTINE Agrif_ssh_ts( jn )
536      !!----------------------------------------------------------------------
537      !!                  ***  ROUTINE Agrif_ssh_ts  ***
538      !!---------------------------------------------------------------------- 
539      INTEGER, INTENT(in) ::   jn
540      !!
541      INTEGER :: ji,jj
542      !!---------------------------------------------------------------------- 
543      !
544      IF((nbondi == -1).OR.(nbondi == 2)) THEN
545         DO jj = 1, jpj
546            ssha_e(2,jj) = hbdy_w(jj)
547         END DO
548      ENDIF
549      !
550      IF((nbondi == 1).OR.(nbondi == 2)) THEN
551         DO jj = 1, jpj
552            ssha_e(nlci-1,jj) = hbdy_e(jj)
553         END DO
554      ENDIF
555      !
556      IF((nbondj == -1).OR.(nbondj == 2)) THEN
557         DO ji = 1, jpi
558            ssha_e(ji,2) = hbdy_s(ji)
559         END DO
560      ENDIF
561      !
562      IF((nbondj == 1).OR.(nbondj == 2)) THEN
563         DO ji = 1, jpi
564            ssha_e(ji,nlcj-1) = hbdy_n(ji)
565         END DO
566      ENDIF
567      !
568   END SUBROUTINE Agrif_ssh_ts
569
570# if defined key_zdftke
571
572   SUBROUTINE Agrif_tke
573      !!----------------------------------------------------------------------
574      !!                  ***  ROUTINE Agrif_tke  ***
575      !!---------------------------------------------------------------------- 
576      REAL(wp) ::   zalpha
577      !!---------------------------------------------------------------------- 
578      !
579      zalpha = REAL( Agrif_NbStepint() + Agrif_IRhot() - 1, wp ) / REAL( Agrif_IRhot(), wp )
580      IF( zalpha > 1. )   zalpha = 1.
581      !
582      Agrif_SpecialValue    = 0.e0
583      Agrif_UseSpecialValue = .TRUE.
584      !
585      CALL Agrif_Bc_variable(avm_id ,calledweight=zalpha, procname=interpavm)       
586      !
587      Agrif_UseSpecialValue = .FALSE.
588      !
589   END SUBROUTINE Agrif_tke
590   
591# endif
592
593   SUBROUTINE interptsn( ptab, i1, i2, j1, j2, k1, k2, n1, n2, before, nb, ndir )
594      !!----------------------------------------------------------------------
595      !!   *** ROUTINE interptsn ***
596      !!----------------------------------------------------------------------
597      REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2,n1:n2), INTENT(inout) ::   ptab
598      INTEGER                                     , INTENT(in   ) ::   i1, i2, j1, j2, k1, k2, n1, n2
599      LOGICAL                                     , INTENT(in   ) ::   before
600      INTEGER                                     , INTENT(in   ) ::   nb , ndir
601      !
602      INTEGER  ::   ji, jj, jk, jn   ! dummy loop indices
603      INTEGER  ::   imin, imax, jmin, jmax
604      REAL(wp) ::   zrhox , zalpha1, zalpha2, zalpha3
605      REAL(wp) ::   zalpha4, zalpha5, zalpha6, zalpha7
606      LOGICAL  ::   western_side, eastern_side,northern_side,southern_side
607      !!----------------------------------------------------------------------
608      !
609      IF (before) THEN         
610         ptab(i1:i2,j1:j2,k1:k2,n1:n2) = tsn(i1:i2,j1:j2,k1:k2,n1:n2)
611      ELSE
612         !
613         western_side  = (nb == 1).AND.(ndir == 1)
614         eastern_side  = (nb == 1).AND.(ndir == 2)
615         southern_side = (nb == 2).AND.(ndir == 1)
616         northern_side = (nb == 2).AND.(ndir == 2)
617         !
618         zrhox = Agrif_Rhox()
619         !
620         zalpha1 = ( zrhox - 1. ) * 0.5
621         zalpha2 = 1. - zalpha1
622         !
623         zalpha3 = ( zrhox - 1. ) / ( zrhox + 1. )
624         zalpha4 = 1. - zalpha3
625         !
626         zalpha6 = 2. * ( zrhox - 1. ) / ( zrhox + 1. )
627         zalpha7 =    - ( zrhox - 1. ) / ( zrhox + 3. )
628         zalpha5 = 1. - zalpha6 - zalpha7
629         !
630         imin = i1
631         imax = i2
632         jmin = j1
633         jmax = j2
634         !
635         ! Remove CORNERS
636         IF((nbondj == -1).OR.(nbondj == 2)) jmin = 3
637         IF((nbondj == +1).OR.(nbondj == 2)) jmax = nlcj-2
638         IF((nbondi == -1).OR.(nbondi == 2)) imin = 3
639         IF((nbondi == +1).OR.(nbondi == 2)) imax = nlci-2       
640         !
641         IF( eastern_side ) THEN
642            DO jn = 1, jpts
643               tsa(nlci,j1:j2,k1:k2,jn) = zalpha1 * ptab(nlci,j1:j2,k1:k2,jn) + zalpha2 * ptab(nlci-1,j1:j2,k1:k2,jn)
644               DO jk = 1, jpkm1
645                  DO jj = jmin,jmax
646                     IF( umask(nlci-2,jj,jk) == 0._wp ) THEN
647                        tsa(nlci-1,jj,jk,jn) = tsa(nlci,jj,jk,jn) * tmask(nlci-1,jj,jk)
648                     ELSE
649                        tsa(nlci-1,jj,jk,jn)=(zalpha4*tsa(nlci,jj,jk,jn)+zalpha3*tsa(nlci-2,jj,jk,jn))*tmask(nlci-1,jj,jk)
650                        IF( un(nlci-2,jj,jk) > 0._wp ) THEN
651                           tsa(nlci-1,jj,jk,jn)=( zalpha6*tsa(nlci-2,jj,jk,jn)+zalpha5*tsa(nlci,jj,jk,jn) & 
652                                 + zalpha7*tsa(nlci-3,jj,jk,jn) ) * tmask(nlci-1,jj,jk)
653                        ENDIF
654                     ENDIF
655                  END DO
656               END DO
657               tsa(nlci,j1:j2,k1:k2,jn) = 0._wp
658            END DO
659         ENDIF
660         !
661         IF( northern_side ) THEN           
662            DO jn = 1, jpts
663               tsa(i1:i2,nlcj,k1:k2,jn) = zalpha1 * ptab(i1:i2,nlcj,k1:k2,jn) + zalpha2 * ptab(i1:i2,nlcj-1,k1:k2,jn)
664               DO jk = 1, jpkm1
665                  DO ji = imin,imax
666                     IF( vmask(ji,nlcj-2,jk) == 0._wp ) THEN
667                        tsa(ji,nlcj-1,jk,jn) = tsa(ji,nlcj,jk,jn) * tmask(ji,nlcj-1,jk)
668                     ELSE
669                        tsa(ji,nlcj-1,jk,jn)=(zalpha4*tsa(ji,nlcj,jk,jn)+zalpha3*tsa(ji,nlcj-2,jk,jn))*tmask(ji,nlcj-1,jk)       
670                        IF (vn(ji,nlcj-2,jk) > 0._wp ) THEN
671                           tsa(ji,nlcj-1,jk,jn)=( zalpha6*tsa(ji,nlcj-2,jk,jn)+zalpha5*tsa(ji,nlcj,jk,jn)  &
672                                 + zalpha7*tsa(ji,nlcj-3,jk,jn) ) * tmask(ji,nlcj-1,jk)
673                        ENDIF
674                     ENDIF
675                  END DO
676               END DO
677               tsa(i1:i2,nlcj,k1:k2,jn) = 0._wp
678            END DO
679         ENDIF
680         !
681         IF( western_side ) THEN           
682            DO jn = 1, jpts
683               tsa(1,j1:j2,k1:k2,jn) = zalpha1 * ptab(1,j1:j2,k1:k2,jn) + zalpha2 * ptab(2,j1:j2,k1:k2,jn)
684               DO jk = 1, jpkm1
685                  DO jj = jmin,jmax
686                     IF( umask(2,jj,jk) == 0._wp ) THEN
687                        tsa(2,jj,jk,jn) = tsa(1,jj,jk,jn) * tmask(2,jj,jk)
688                     ELSE
689                        tsa(2,jj,jk,jn)=(zalpha4*tsa(1,jj,jk,jn)+zalpha3*tsa(3,jj,jk,jn))*tmask(2,jj,jk)       
690                        IF( un(2,jj,jk) < 0._wp ) THEN
691                           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)
692                        ENDIF
693                     ENDIF
694                  END DO
695               END DO
696               tsa(1,j1:j2,k1:k2,jn) = 0._wp
697            END DO
698         ENDIF
699         !
700         IF( southern_side ) THEN           
701            DO jn = 1, jpts
702               tsa(i1:i2,1,k1:k2,jn) = zalpha1 * ptab(i1:i2,1,k1:k2,jn) + zalpha2 * ptab(i1:i2,2,k1:k2,jn)
703               DO jk = 1, jpk     
704                  DO ji=imin,imax
705                     IF( vmask(ji,2,jk) == 0._wp ) THEN
706                        tsa(ji,2,jk,jn)=tsa(ji,1,jk,jn) * tmask(ji,2,jk)
707                     ELSE
708                        tsa(ji,2,jk,jn)=(zalpha4*tsa(ji,1,jk,jn)+zalpha3*tsa(ji,3,jk,jn))*tmask(ji,2,jk)
709                        IF( vn(ji,2,jk) < 0._wp ) THEN
710                           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)
711                        ENDIF
712                     ENDIF
713                  END DO
714               END DO
715               tsa(i1:i2,1,k1:k2,jn) = 0._wp
716            END DO
717         ENDIF
718         !
719         ! Treatment of corners
720         !
721         ! East south
722         IF ((eastern_side).AND.((nbondj == -1).OR.(nbondj == 2))) THEN
723            tsa(nlci-1,2,:,:) = ptab(nlci-1,2,:,:)
724         ENDIF
725         ! East north
726         IF ((eastern_side).AND.((nbondj == 1).OR.(nbondj == 2))) THEN
727            tsa(nlci-1,nlcj-1,:,:) = ptab(nlci-1,nlcj-1,:,:)
728         ENDIF
729         ! West south
730         IF ((western_side).AND.((nbondj == -1).OR.(nbondj == 2))) THEN
731            tsa(2,2,:,:) = ptab(2,2,:,:)
732         ENDIF
733         ! West north
734         IF ((western_side).AND.((nbondj == 1).OR.(nbondj == 2))) THEN
735            tsa(2,nlcj-1,:,:) = ptab(2,nlcj-1,:,:)
736         ENDIF
737         !
738      ENDIF
739      !
740   END SUBROUTINE interptsn
741
742
743   SUBROUTINE interpsshn( ptab, i1, i2, j1, j2, before, nb, ndir )
744      !!----------------------------------------------------------------------
745      !!                  ***  ROUTINE interpsshn  ***
746      !!---------------------------------------------------------------------- 
747      INTEGER                         , INTENT(in   ) ::   i1, i2, j1, j2
748      REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) ::   ptab
749      LOGICAL                         , INTENT(in   ) ::   before
750      INTEGER                         , INTENT(in   ) ::   nb , ndir
751      !
752      LOGICAL :: western_side, eastern_side,northern_side,southern_side
753      !!---------------------------------------------------------------------- 
754      !
755      IF( before) THEN
756         ptab(i1:i2,j1:j2) = sshn(i1:i2,j1:j2)
757      ELSE
758         western_side  = (nb == 1).AND.(ndir == 1)
759         eastern_side  = (nb == 1).AND.(ndir == 2)
760         southern_side = (nb == 2).AND.(ndir == 1)
761         northern_side = (nb == 2).AND.(ndir == 2)
762         IF(western_side)  hbdy_w(j1:j2) = ptab(i1,j1:j2) * tmask(i1,j1:j2,1)
763         IF(eastern_side)  hbdy_e(j1:j2) = ptab(i1,j1:j2) * tmask(i1,j1:j2,1)
764         IF(southern_side) hbdy_s(i1:i2) = ptab(i1:i2,j1) * tmask(i1:i2,j1,1)
765         IF(northern_side) hbdy_n(i1:i2) = ptab(i1:i2,j1) * tmask(i1:i2,j1,1)
766      ENDIF
767      !
768   END SUBROUTINE interpsshn
769
770
771   SUBROUTINE interpun( ptab, i1, i2, j1, j2, k1, k2, before )
772      !!----------------------------------------------------------------------
773      !!   *** ROUTINE interpun ***
774      !!----------------------------------------------------------------------
775      INTEGER                               , INTENT(in   ) ::   i1, i2, j1, j2, k1, k2
776      REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) ::   ptab
777      LOGICAL                               , INTENT(in   ) ::   before
778      !
779      INTEGER  ::   ji, jj, jk
780      REAL(wp) ::   zrhoy 
781      !!----------------------------------------------------------------------
782      !
783      IF( before ) THEN
784         DO jk = k1, jpk
785            ptab(i1:i2,j1:j2,jk) = e2u(i1:i2,j1:j2) * e3u_n(i1:i2,j1:j2,jk) * un(i1:i2,j1:j2,jk)
786         END DO
787      ELSE
788         zrhoy = Agrif_Rhoy()
789         DO jk = 1, jpkm1
790            DO jj=j1,j2
791               ua(i1:i2,jj,jk) = ptab(i1:i2,jj,jk) / ( zrhoy * e2u(i1:i2,jj) * e3u_n(i1:i2,jj,jk) )
792            END DO
793         END DO
794      ENDIF
795      !
796   END SUBROUTINE interpun
797
798
799   SUBROUTINE interpvn( ptab, i1, i2, j1, j2, k1, k2, before )
800      !!----------------------------------------------------------------------
801      !!   *** ROUTINE interpvn ***
802      !!----------------------------------------------------------------------
803      INTEGER                               , INTENT(in   ) ::   i1, i2, j1, j2, k1, k2
804      REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) ::   ptab
805      LOGICAL                               , INTENT(in   ) ::   before
806      !
807      INTEGER  ::   ji, jj, jk
808      REAL(wp) ::   zrhox 
809      !!----------------------------------------------------------------------
810      !     
811      IF( before ) THEN       !interpv entre 1 et k2 et interpv2d en jpkp1
812         DO jk = k1, jpk
813            ptab(i1:i2,j1:j2,jk) = e1v(i1:i2,j1:j2) * e3v_n(i1:i2,j1:j2,jk) * vn(i1:i2,j1:j2,jk)
814         END DO
815      ELSE         
816         zrhox= Agrif_Rhox()
817         DO jk = 1, jpkm1
818            va(i1:i2,j1:j2,jk) = ptab(i1:i2,j1:j2,jk) / ( zrhox * e1v(i1:i2,j1:j2) * e3v_n(i1:i2,j1:j2,jk) )
819         END DO
820      ENDIF
821      !       
822   END SUBROUTINE interpvn
823   
824
825   SUBROUTINE interpunb( ptab, i1, i2, j1, j2, before, nb, ndir )
826      !!----------------------------------------------------------------------
827      !!                  ***  ROUTINE interpunb  ***
828      !!---------------------------------------------------------------------- 
829      INTEGER                         , INTENT(in   ) ::   i1, i2, j1, j2
830      REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) ::   ptab
831      LOGICAL                         , INTENT(in   ) ::   before
832      INTEGER                         , INTENT(in   ) ::   nb , ndir
833      !
834      INTEGER  ::   ji, jj
835      REAL(wp) ::   zrhoy, zrhot, zt0, zt1, ztcoeff
836      LOGICAL  ::   western_side, eastern_side,northern_side,southern_side
837      !!---------------------------------------------------------------------- 
838      !
839      IF( before ) THEN
840         ptab(i1:i2,j1:j2) = e2u(i1:i2,j1:j2) * hu_n(i1:i2,j1:j2) * un_b(i1:i2,j1:j2)
841      ELSE
842         western_side  = (nb == 1).AND.(ndir == 1)
843         eastern_side  = (nb == 1).AND.(ndir == 2)
844         southern_side = (nb == 2).AND.(ndir == 1)
845         northern_side = (nb == 2).AND.(ndir == 2)
846         zrhoy = Agrif_Rhoy()
847         zrhot = Agrif_rhot()
848         ! Time indexes bounds for integration
849         zt0 = REAL(Agrif_NbStepint()  , wp) / zrhot
850         zt1 = REAL(Agrif_NbStepint()+1, wp) / zrhot     
851         ! Polynomial interpolation coefficients:
852         IF( bdy_tinterp == 1 ) THEN
853            ztcoeff = zrhot * (  zt1**2._wp * (       zt1 - 1._wp)        &
854               &               - zt0**2._wp * (       zt0 - 1._wp)        )
855         ELSEIF( bdy_tinterp == 2 ) THEN
856            ztcoeff = zrhot * (  zt1        * (       zt1 - 1._wp)**2._wp &
857               &               - zt0        * (       zt0 - 1._wp)**2._wp ) 
858
859         ELSE
860            ztcoeff = 1
861         ENDIF
862         !   
863         IF(western_side) THEN
864            ubdy_w(j1:j2) = ubdy_w(j1:j2) + ztcoeff * ptab(i1,j1:j2) 
865         ENDIF
866         IF(eastern_side) THEN
867            ubdy_e(j1:j2) = ubdy_e(j1:j2) + ztcoeff * ptab(i1,j1:j2) 
868         ENDIF
869         IF(southern_side) THEN
870            ubdy_s(i1:i2) = ubdy_s(i1:i2) + ztcoeff * ptab(i1:i2,j1) 
871         ENDIF
872         IF(northern_side) THEN
873            ubdy_n(i1:i2) = ubdy_n(i1:i2) + ztcoeff * ptab(i1:i2,j1) 
874         ENDIF
875         !           
876         IF( bdy_tinterp == 0 .OR. bdy_tinterp == 2) THEN
877            IF(western_side) THEN
878               ubdy_w(j1:j2) = ubdy_w(j1:j2) / (zrhoy*e2u(i1,j1:j2)) * umask(i1,j1:j2,1)
879            ENDIF
880            IF(eastern_side) THEN
881               ubdy_e(j1:j2) = ubdy_e(j1:j2) / (zrhoy*e2u(i1,j1:j2)) * umask(i1,j1:j2,1)
882            ENDIF
883            IF(southern_side) THEN
884               ubdy_s(i1:i2) = ubdy_s(i1:i2) / (zrhoy*e2u(i1:i2,j1)) * umask(i1:i2,j1,1)
885            ENDIF
886            IF(northern_side) THEN
887               ubdy_n(i1:i2) = ubdy_n(i1:i2) / (zrhoy*e2u(i1:i2,j1)) * umask(i1:i2,j1,1)
888            ENDIF
889         ENDIF
890      ENDIF
891      !
892   END SUBROUTINE interpunb
893
894
895   SUBROUTINE interpvnb( ptab, i1, i2, j1, j2, before, nb, ndir )
896      !!----------------------------------------------------------------------
897      !!                  ***  ROUTINE interpvnb  ***
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      INTEGER  ::   ji,jj
905      REAL(wp) ::   zrhox, zrhot, zt0, zt1, ztcoeff   
906      LOGICAL  ::   western_side, eastern_side,northern_side,southern_side
907      !!---------------------------------------------------------------------- 
908      !
909      IF( before ) THEN
910         ptab(i1:i2,j1:j2) = e1v(i1:i2,j1:j2) * hv_n(i1:i2,j1:j2) * vn_b(i1:i2,j1:j2)
911      ELSE
912         western_side  = (nb == 1).AND.(ndir == 1)
913         eastern_side  = (nb == 1).AND.(ndir == 2)
914         southern_side = (nb == 2).AND.(ndir == 1)
915         northern_side = (nb == 2).AND.(ndir == 2)
916         zrhox = Agrif_Rhox()
917         zrhot = Agrif_rhot()
918         ! Time indexes bounds for integration
919         zt0 = REAL(Agrif_NbStepint()  , wp) / zrhot
920         zt1 = REAL(Agrif_NbStepint()+1, wp) / zrhot     
921         IF( bdy_tinterp == 1 ) THEN
922            ztcoeff = zrhot * (  zt1**2._wp * (       zt1 - 1._wp)        &
923               &               - zt0**2._wp * (       zt0 - 1._wp)        )
924         ELSEIF( bdy_tinterp == 2 ) THEN
925            ztcoeff = zrhot * (  zt1        * (       zt1 - 1._wp)**2._wp &
926               &               - zt0        * (       zt0 - 1._wp)**2._wp ) 
927         ELSE
928            ztcoeff = 1
929         ENDIF
930         !
931         IF(western_side) THEN
932            vbdy_w(j1:j2) = vbdy_w(j1:j2) + ztcoeff * ptab(i1,j1:j2) 
933         ENDIF
934         IF(eastern_side) THEN
935            vbdy_e(j1:j2) = vbdy_e(j1:j2) + ztcoeff * ptab(i1,j1:j2) 
936         ENDIF
937         IF(southern_side) THEN
938            vbdy_s(i1:i2) = vbdy_s(i1:i2) + ztcoeff * ptab(i1:i2,j1)
939         ENDIF
940         IF(northern_side) THEN
941            vbdy_n(i1:i2) = vbdy_n(i1:i2) + ztcoeff * ptab(i1:i2,j1) 
942         ENDIF
943         !           
944         IF( bdy_tinterp == 0 .OR. bdy_tinterp == 2) THEN
945            IF(western_side) THEN
946               vbdy_w(j1:j2) = vbdy_w(j1:j2) / (zrhox*e1v(i1,j1:j2))   &
947                     &                                  * vmask(i1,j1:j2,1)
948            ENDIF
949            IF(eastern_side) THEN
950               vbdy_e(j1:j2) = vbdy_e(j1:j2) / (zrhox*e1v(i1,j1:j2))   &
951                     &                                  * vmask(i1,j1:j2,1)
952            ENDIF
953            IF(southern_side) THEN
954               vbdy_s(i1:i2) = vbdy_s(i1:i2) / (zrhox*e1v(i1:i2,j1))   &
955                     &                                  * vmask(i1:i2,j1,1)
956            ENDIF
957            IF(northern_side) THEN
958               vbdy_n(i1:i2) = vbdy_n(i1:i2) / (zrhox*e1v(i1:i2,j1))   &
959                     &                                  * vmask(i1:i2,j1,1)
960            ENDIF
961         ENDIF
962      ENDIF
963      !
964   END SUBROUTINE interpvnb
965
966
967   SUBROUTINE interpub2b( ptab, i1, i2, j1, j2, before, nb, ndir )
968      !!----------------------------------------------------------------------
969      !!                  ***  ROUTINE interpub2b  ***
970      !!---------------------------------------------------------------------- 
971      INTEGER                         , INTENT(in   ) ::   i1, i2, j1, j2
972      REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) ::   ptab
973      LOGICAL                         , INTENT(in   ) ::   before
974      INTEGER                         , INTENT(in   ) ::   nb , ndir
975      !
976      INTEGER  ::   ji,jj
977      REAL(wp) ::   zrhot, zt0, zt1,zat
978      LOGICAL  ::   western_side, eastern_side,northern_side,southern_side
979      !!---------------------------------------------------------------------- 
980      IF( before ) THEN
981         ptab(i1:i2,j1:j2) = e2u(i1:i2,j1:j2) * ub2_b(i1:i2,j1:j2)
982      ELSE
983         western_side  = (nb == 1).AND.(ndir == 1)
984         eastern_side  = (nb == 1).AND.(ndir == 2)
985         southern_side = (nb == 2).AND.(ndir == 1)
986         northern_side = (nb == 2).AND.(ndir == 2)
987         zrhot = Agrif_rhot()
988         ! Time indexes bounds for integration
989         zt0 = REAL(Agrif_NbStepint()  , wp) / zrhot
990         zt1 = REAL(Agrif_NbStepint()+1, wp) / zrhot
991         ! Polynomial interpolation coefficients:
992         zat = zrhot * (  zt1**2._wp * (-2._wp*zt1 + 3._wp)    &
993            &           - zt0**2._wp * (-2._wp*zt0 + 3._wp)    ) 
994         !
995         IF(western_side ) ubdy_w(j1:j2) = zat * ptab(i1,j1:j2) 
996         IF(eastern_side ) ubdy_e(j1:j2) = zat * ptab(i1,j1:j2) 
997         IF(southern_side) ubdy_s(i1:i2) = zat * ptab(i1:i2,j1) 
998         IF(northern_side) ubdy_n(i1:i2) = zat * ptab(i1:i2,j1) 
999      ENDIF
1000      !
1001   END SUBROUTINE interpub2b
1002   
1003
1004   SUBROUTINE interpvb2b( ptab, i1, i2, j1, j2, before, nb, ndir )
1005      !!----------------------------------------------------------------------
1006      !!                  ***  ROUTINE interpvb2b  ***
1007      !!---------------------------------------------------------------------- 
1008      INTEGER                         , INTENT(in   ) ::   i1, i2, j1, j2
1009      REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) ::   ptab
1010      LOGICAL                         , INTENT(in   ) ::   before
1011      INTEGER                         , INTENT(in   ) ::   nb , ndir
1012      !
1013      INTEGER ::   ji,jj
1014      REAL(wp) ::   zrhot, zt0, zt1,zat
1015      LOGICAL ::   western_side, eastern_side,northern_side,southern_side
1016      !!---------------------------------------------------------------------- 
1017      !
1018      IF( before ) THEN
1019         ptab(i1:i2,j1:j2) = e1v(i1:i2,j1:j2) * vb2_b(i1:i2,j1:j2)
1020      ELSE     
1021         western_side  = (nb == 1).AND.(ndir == 1)
1022         eastern_side  = (nb == 1).AND.(ndir == 2)
1023         southern_side = (nb == 2).AND.(ndir == 1)
1024         northern_side = (nb == 2).AND.(ndir == 2)
1025         zrhot = Agrif_rhot()
1026         ! Time indexes bounds for integration
1027         zt0 = REAL(Agrif_NbStepint()  , wp) / zrhot
1028         zt1 = REAL(Agrif_NbStepint()+1, wp) / zrhot
1029         ! Polynomial interpolation coefficients:
1030         zat = zrhot * (  zt1**2._wp * (-2._wp*zt1 + 3._wp)    &
1031            &           - zt0**2._wp * (-2._wp*zt0 + 3._wp)    ) 
1032         !
1033         IF(western_side )   vbdy_w(j1:j2) = zat * ptab(i1,j1:j2) 
1034         IF(eastern_side )   vbdy_e(j1:j2) = zat * ptab(i1,j1:j2) 
1035         IF(southern_side)   vbdy_s(i1:i2) = zat * ptab(i1:i2,j1) 
1036         IF(northern_side)   vbdy_n(i1:i2) = zat * ptab(i1:i2,j1) 
1037      ENDIF
1038      !     
1039   END SUBROUTINE interpvb2b
1040
1041
1042   SUBROUTINE interpe3t( ptab, i1, i2, j1, j2, k1, k2, before, nb, ndir )
1043      !!----------------------------------------------------------------------
1044      !!                  ***  ROUTINE interpe3t  ***
1045      !!---------------------------------------------------------------------- 
1046      INTEGER                              , INTENT(in   ) :: i1, i2, j1, j2, k1, k2
1047      REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: ptab
1048      LOGICAL                              , INTENT(in   ) :: before
1049      INTEGER                              , INTENT(in   ) :: nb , ndir
1050      !
1051      INTEGER :: ji, jj, jk
1052      LOGICAL :: western_side, eastern_side, northern_side, southern_side
1053      REAL(wp) :: ztmpmsk     
1054      !!---------------------------------------------------------------------- 
1055      !   
1056      IF( before ) THEN
1057         ptab(i1:i2,j1:j2,k1:k2) = tmask(i1:i2,j1:j2,k1:k2) * e3t_0(i1:i2,j1:j2,k1:k2)
1058      ELSE
1059         western_side  = (nb == 1).AND.(ndir == 1)
1060         eastern_side  = (nb == 1).AND.(ndir == 2)
1061         southern_side = (nb == 2).AND.(ndir == 1)
1062         northern_side = (nb == 2).AND.(ndir == 2)
1063
1064         DO jk = k1, k2
1065            DO jj = j1, j2
1066               DO ji = i1, i2
1067                  ! Get velocity mask at boundary edge points:
1068                  IF( western_side )   ztmpmsk = umask(ji    ,jj    ,1)
1069                  IF( eastern_side )   ztmpmsk = umask(nlci-2,jj    ,1)
1070                  IF( northern_side)   ztmpmsk = vmask(ji    ,nlcj-2,1)
1071                  IF( southern_side)   ztmpmsk = vmask(ji    ,2     ,1)
1072                  !
1073                  IF( ABS( ptab(ji,jj,jk) - tmask(ji,jj,jk) * e3t_0(ji,jj,jk) )*ztmpmsk > 1.D-2) THEN
1074                     IF (western_side) THEN
1075                        WRITE(numout,*) 'ERROR bathymetry merge at the western border ji,jj,jk ', ji+nimpp-1,jj+njmpp-1,jk
1076                     ELSEIF (eastern_side) THEN
1077                        WRITE(numout,*) 'ERROR bathymetry merge at the eastern border ji,jj,jk ', ji+nimpp-1,jj+njmpp-1,jk
1078                     ELSEIF (southern_side) THEN
1079                        WRITE(numout,*) 'ERROR bathymetry merge at the southern border ji,jj,jk', ji+nimpp-1,jj+njmpp-1,jk
1080                     ELSEIF (northern_side) THEN
1081                        WRITE(numout,*) 'ERROR bathymetry merge at the northen border ji,jj,jk', ji+nimpp-1,jj+njmpp-1,jk
1082                     ENDIF
1083                     WRITE(numout,*) '      ptab(ji,jj,jk), e3t(ji,jj,jk) ', ptab(ji,jj,jk), e3t_0(ji,jj,jk)
1084                     kindic_agr = kindic_agr + 1
1085                  ENDIF
1086               END DO
1087            END DO
1088         END DO
1089         !
1090      ENDIF
1091      !
1092   END SUBROUTINE interpe3t
1093
1094
1095   SUBROUTINE interpumsk( ptab, i1, i2, j1, j2, k1, k2, before, nb, ndir )
1096      !!----------------------------------------------------------------------
1097      !!                  ***  ROUTINE interpumsk  ***
1098      !!---------------------------------------------------------------------- 
1099      INTEGER                              , INTENT(in   ) ::   i1, i2, j1, j2, k1, k2
1100      REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) ::   ptab
1101      LOGICAL                              , INTENT(in   ) ::   before
1102      INTEGER                              , INTENT(in   ) ::   nb , ndir
1103      !
1104      INTEGER ::   ji, jj, jk
1105      LOGICAL ::   western_side, eastern_side   
1106      !!---------------------------------------------------------------------- 
1107      !   
1108      IF( before ) THEN
1109         ptab(i1:i2,j1:j2,k1:k2) = umask(i1:i2,j1:j2,k1:k2)
1110      ELSE
1111         western_side = (nb == 1).AND.(ndir == 1)
1112         eastern_side = (nb == 1).AND.(ndir == 2)
1113         DO jk = k1, k2
1114            DO jj = j1, j2
1115               DO ji = i1, i2
1116                   ! Velocity mask at boundary edge points:
1117                  IF (ABS(ptab(ji,jj,jk) - umask(ji,jj,jk)) > 1.D-2) THEN
1118                     IF (western_side) THEN
1119                        WRITE(numout,*) 'ERROR with umask at the western border ji,jj,jk ', ji+nimpp-1,jj+njmpp-1,jk
1120                        WRITE(numout,*) '      masks: parent, child ', ptab(ji,jj,jk), umask(ji,jj,jk)
1121                        kindic_agr = kindic_agr + 1
1122                     ELSEIF (eastern_side) THEN
1123                        WRITE(numout,*) 'ERROR with umask at the eastern border ji,jj,jk ', ji+nimpp-1,jj+njmpp-1,jk
1124                        WRITE(numout,*) '      masks: parent, child ', ptab(ji,jj,jk), umask(ji,jj,jk)
1125                        kindic_agr = kindic_agr + 1
1126                     ENDIF
1127                  ENDIF
1128               END DO
1129            END DO
1130         END DO
1131         !
1132      ENDIF
1133      !
1134   END SUBROUTINE interpumsk
1135
1136
1137   SUBROUTINE interpvmsk( ptab, i1, i2, j1, j2, k1, k2, before, nb, ndir )
1138      !!----------------------------------------------------------------------
1139      !!                  ***  ROUTINE interpvmsk  ***
1140      !!---------------------------------------------------------------------- 
1141      INTEGER                              , INTENT(in   ) ::   i1,i2,j1,j2,k1,k2
1142      REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) ::   ptab
1143      LOGICAL                              , INTENT(in   ) ::   before
1144      INTEGER                              , INTENT(in   ) :: nb , ndir
1145      !
1146      INTEGER ::   ji, jj, jk
1147      LOGICAL ::   northern_side, southern_side     
1148      !!---------------------------------------------------------------------- 
1149      !   
1150      IF( before ) THEN
1151         ptab(i1:i2,j1:j2,k1:k2) = vmask(i1:i2,j1:j2,k1:k2)
1152      ELSE
1153         southern_side = (nb == 2).AND.(ndir == 1)
1154         northern_side = (nb == 2).AND.(ndir == 2)
1155         DO jk = k1, k2
1156            DO jj = j1, j2
1157               DO ji = i1, i2
1158                   ! Velocity mask at boundary edge points:
1159                  IF (ABS(ptab(ji,jj,jk) - vmask(ji,jj,jk)) > 1.D-2) THEN
1160                     IF (southern_side) THEN
1161                        WRITE(numout,*) 'ERROR with vmask at the southern border ji,jj,jk ', ji+nimpp-1,jj+njmpp-1,jk
1162                        WRITE(numout,*) '      masks: parent, child ', ptab(ji,jj,jk), vmask(ji,jj,jk)
1163                        kindic_agr = kindic_agr + 1
1164                     ELSEIF (northern_side) THEN
1165                        WRITE(numout,*) 'ERROR with vmask at the northern border ji,jj,jk ', ji+nimpp-1,jj+njmpp-1,jk
1166                        WRITE(numout,*) '      masks: parent, child ', ptab(ji,jj,jk), vmask(ji,jj,jk)
1167                        kindic_agr = kindic_agr + 1
1168                     ENDIF
1169                  ENDIF
1170               END DO
1171            END DO
1172         END DO
1173         !
1174      ENDIF
1175      !
1176   END SUBROUTINE interpvmsk
1177
1178# if defined key_zdftke
1179
1180   SUBROUTINE interpavm( ptab, i1, i2, j1, j2, k1, k2, before )
1181      !!----------------------------------------------------------------------
1182      !!                  ***  ROUTINE interavm  ***
1183      !!---------------------------------------------------------------------- 
1184      INTEGER                              , INTENT(in   ) ::   i1, i2, j1, j2, k1, k2
1185      REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) ::   ptab
1186      LOGICAL                              , INTENT(in   ) ::   before
1187      !!---------------------------------------------------------------------- 
1188      !     
1189      IF( before ) THEN
1190         ptab (i1:i2,j1:j2,k1:k2) = avm_k(i1:i2,j1:j2,k1:k2)
1191      ELSE
1192         avm_k(i1:i2,j1:j2,k1:k2) = ptab (i1:i2,j1:j2,k1:k2)
1193      ENDIF
1194      !
1195   END SUBROUTINE interpavm
1196
1197# endif /* key_zdftke */
1198
1199#else
1200   !!----------------------------------------------------------------------
1201   !!   Empty module                                          no AGRIF zoom
1202   !!----------------------------------------------------------------------
1203CONTAINS
1204   SUBROUTINE Agrif_OPA_Interp_empty
1205      WRITE(*,*)  'agrif_opa_interp : You should not have seen this print! error?'
1206   END SUBROUTINE Agrif_OPA_Interp_empty
1207#endif
1208
1209   !!======================================================================
1210END MODULE agrif_opa_interp
Note: See TracBrowser for help on using the repository browser.