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_lim2_interp.F90 in branches/UKMO/r6232_tracer_advection/NEMOGCM/NEMO/NST_SRC – NEMO

source: branches/UKMO/r6232_tracer_advection/NEMOGCM/NEMO/NST_SRC/agrif_lim2_interp.F90

Last change on this file was 9295, checked in by jcastill, 6 years ago

Remove svn keywords

File size: 23.0 KB
Line 
1MODULE agrif_lim2_interp
2   !!======================================================================
3   !!                       ***  MODULE agrif_lim2_update ***
4   !! Nesting module :  update surface ocean boundary condition over ice
5   !!                   from a child grif
6   !! Sea-Ice model  :  LIM 2.0 Sea ice model time-stepping
7   !!======================================================================
8   !! History :  2.0   !  04-2008  (F. Dupont)  initial version
9   !!            3.4   !  09-2012  (R. Benshila, C. Herbaut) update and EVP
10   !!----------------------------------------------------------------------
11#if defined key_agrif && defined key_lim2 
12   !!----------------------------------------------------------------------
13   !!   'key_lim2'  :                                 LIM 2.0 sea-ice model
14   !!   'key_agrif' :                                 AGRIF library
15   !!----------------------------------------------------------------------
16   !!   agrif_interp_lim2   : update sea-ice model on boundaries or total
17   !!                         sea-ice area
18   !!  agrif_rhg_lim2_load  : interpolcation of ice velocities using Agrif
19   !!  agrif_rhg_lim2       : sub-interpolation of ice velocities for both
20   !!                         splitting time and sea-ice time step
21   !!  agrif_interp_u_ice   : atomic routine to interpolate u_ice
22   !!  agrif_interp_u_ice   : atomic routine to interpolate v_ice
23   !!  agrif_trp_lim2_load  : interpolcation of ice properties using Agrif
24   !!  agrif_trp_lim2       : sub-interpolation of ice properties for 
25   !!                         sea-ice time step
26   !!  agrif_interp_u_ice   : atomic routine to interpolate ice properties
27   !!----------------------------------------------------------------------
28   USE par_oce
29   USE dom_oce
30   USE sbc_oce
31   USE ice_2
32   USE dom_ice_2
33   USE agrif_ice
34
35   IMPLICIT NONE
36   PRIVATE
37
38   PUBLIC agrif_rhg_lim2_load, agrif_rhg_lim2
39   PUBLIC agrif_trp_lim2_load, agrif_trp_lim2
40   PUBLIC interp_u_ice, interp_v_ice
41   PUBLIC interp_adv_ice
42
43   REAL(wp), DIMENSION(:,:)  , ALLOCATABLE, PRIVATE :: uice_agr, vice_agr
44   REAL(wp), DIMENSION(:,:,:), ALLOCATABLE, PRIVATE :: tabice_agr 
45
46
47   !!----------------------------------------------------------------------
48   !! NEMO/NST 3.4 , NEMO Consortium (2012)
49   !! $Id$
50   !! Software governed by the CeCILL licence     (NEMOGCM/NEMO_CeCILL.txt)
51   !!----------------------------------------------------------------------
52
53CONTAINS
54
55# if defined key_lim2_vp
56   SUBROUTINE agrif_rhg_lim2_load
57      !!-----------------------------------------------------------------------
58      !!              *** ROUTINE agrif_rhg_lim2_load ***
59      !!
60      !!  ** Method  : need a special routine for dealing with exchanging data
61      !! between the child and parent grid during ice step
62      !!
63      !!-----------------------------------------------------------------------
64      !
65      IF (Agrif_Root()) RETURN
66
67      Agrif_SpecialValue=0.
68      Agrif_UseSpecialValue = .FALSE.
69      u_ice_nst(:,:) = 0.
70      v_ice_nst(:,:) = 0.
71      CALL Agrif_Bc_variable( u_ice_id ,procname=interp_u_ice, calledweight=1. )
72      CALL Agrif_Bc_variable( v_ice_id ,procname=interp_v_ice, calledweight=1. )
73      Agrif_SpecialValue=0.
74      Agrif_UseSpecialValue = .FALSE.
75      !
76   END SUBROUTINE agrif_rhg_lim2_load
77
78
79   SUBROUTINE agrif_rhg_lim2(pu_n,pv_n)
80      !!-----------------------------------------------------------------------
81      !!                 *** ROUTINE agrif_rhg_lim2 ***
82      !!
83      !!  ** Method  : we feel the boundaries with values stored above
84      !!-----------------------------------------------------------------------
85      REAL(wp), DIMENSION(jpi,0:jpj+1), INTENT(inout) :: pu_n, pv_n
86      !!
87      REAL(wp) :: zrhox, zrhoy
88      INTEGER :: ji,jj
89      !!-----------------------------------------------------------------------
90      !
91      IF (Agrif_Root()) RETURN
92
93      zrhox = Agrif_Rhox()
94      zrhoy = Agrif_Rhoy()
95
96      IF((nbondi == -1).OR.(nbondi == 2)) THEN
97         DO jj=2,jpj
98            pu_n(3,jj) = u_ice_nst(3,jj)/(zrhoy*e2f(2,jj-1))*tmu(3,jj)
99         END DO
100         DO jj=2,jpj
101            pv_n(3,jj) = v_ice_nst(3,jj)/(zrhox*e1f(2,jj-1))*tmu(3,jj)
102         END DO
103      ENDIF
104
105      IF((nbondi == 1).OR.(nbondi == 2)) THEN
106         DO jj=2,jpj
107            pu_n(nlci-1,jj) = u_ice_nst(nlci-1,jj)/(zrhoy*e2f(nlci-2,jj-1))*tmu(nlci-1,jj)
108         END DO
109         DO jj=2,jpj
110            pv_n(nlci-1,jj) = v_ice_nst(nlci-1,jj)/(zrhox*e1f(nlci-2,jj-1))*tmu(nlci-1,jj)
111         END DO
112      ENDIF
113
114      IF((nbondj == -1).OR.(nbondj == 2)) THEN
115         DO ji=2,jpi
116            pv_n(ji,3) = v_ice_nst(ji,3)/(zrhox*e1f(ji-1,2))*tmu(ji,3)
117         END DO
118         DO ji=2,jpi
119            pu_n(ji,3) = u_ice_nst(ji,3)/(zrhoy*e2f(ji-1,2))*tmu(ji,3)
120         END DO
121      ENDIF
122
123      IF((nbondj == 1).OR.(nbondj == 2)) THEN
124         DO ji=2,jpi
125            pv_n(ji,nlcj-1) = v_ice_nst(ji,nlcj-1)/(zrhox*e1f(ji-1,nlcj-2))*tmu(ji,nlcj-1)
126         END DO
127         DO ji=2,jpi
128            pu_n(ji,nlcj-1) = u_ice_nst(ji,nlcj-1)/(zrhoy*e2f(ji-1,nlcj-2))*tmu(ji,nlcj-1)
129         END DO
130      ENDIF
131      !
132   END SUBROUTINE agrif_rhg_lim2
133
134#else
135   SUBROUTINE agrif_rhg_lim2_load
136      !!-----------------------------------------------------------------------
137      !!              *** ROUTINE agrif_rhg_lim2_load ***
138      !!
139      !!  ** Method  : need a special routine for dealing with exchanging data
140      !!  between the child and parent grid during ice step
141      !!               we interpolate and store the boundary if needed, ie if
142      !!  we are in inside a new parent ice time step
143      !!-----------------------------------------------------------------------
144      INTEGER :: ji,jj
145      REAL(wp) :: zrhox, zrhoy
146      !!-----------------------------------------------------------------------
147      !
148      IF (Agrif_Root()) RETURN
149
150      IF( lim_nbstep == 1. ) THEN
151         !
152         ! switch old values by hand
153         u_ice_oe(:,:,1) =  u_ice_oe(:,:,2)
154         v_ice_oe(:,:,1) =  v_ice_oe(:,:,2)
155         u_ice_sn(:,:,1) =  u_ice_sn(:,:,2)
156         v_ice_sn(:,:,1) =  v_ice_sn(:,:,2)
157         ! interpolation of boundaries (called weight prevents AGRIF interpolation)
158         Agrif_SpecialValue=-9999.
159         Agrif_UseSpecialValue = .TRUE.
160         IF( .NOT. ALLOCATED(uice_agr) )THEN
161            ALLOCATE(uice_agr(jpi,jpj), vice_agr(jpi,jpj))
162         ENDIF
163         uice_agr = 0.
164         vice_agr = 0.
165         CALL Agrif_Bc_variable(u_ice_id,procname=interp_u_ice, calledweight=1.)
166         CALL Agrif_Bc_variable(v_ice_id,procname=interp_v_ice, calledweight=1.)
167         Agrif_SpecialValue=0.
168         Agrif_UseSpecialValue = .FALSE.
169         
170         zrhox = agrif_rhox() ;    zrhoy = agrif_rhoy()     
171         uice_agr(:,:) =  uice_agr(:,:)/(zrhoy*e2u(:,:))*umask(:,:,1)
172         vice_agr(:,:) =  vice_agr(:,:)/(zrhox*e1v(:,:))*vmask(:,:,1)
173         ! fill  boundaries
174         DO jj = 1, jpj
175            DO ji = 1, 2
176               u_ice_oe(ji,  jj,2) = uice_agr(ji       ,jj) 
177               u_ice_oe(ji+2,jj,2) = uice_agr(nlci+ji-3,jj)
178            END DO
179         END DO
180         DO jj = 1, jpj
181            v_ice_oe(2,jj,2) = vice_agr(2     ,jj) 
182            v_ice_oe(4,jj,2) = vice_agr(nlci-1,jj)
183         END DO
184         DO ji = 1, jpi
185            u_ice_sn(ji,2,2) = uice_agr(ji,2     ) 
186            u_ice_sn(ji,4,2) = uice_agr(ji,nlcj-1)
187         END DO
188         DO jj = 1, 2
189            DO ji = 1, jpi
190               v_ice_sn(ji,jj  ,2) = vice_agr(ji,jj       ) 
191               v_ice_sn(ji,jj+2,2) = vice_agr(ji,nlcj+jj-3)
192            END DO
193         END DO
194         !
195      ENDIF
196      !
197   END SUBROUTINE agrif_rhg_lim2_load
198
199
200   SUBROUTINE agrif_rhg_lim2( kiter, kitermax, cd_type)
201      !!-----------------------------------------------------------------------
202      !!                 *** ROUTINE agrif_rhg_lim2  ***
203      !!
204      !!  ** Method  : simple call to atomic routines using stored values to
205      !!  fill the boundaries depending of the position of the point and
206      !!  computing factor for time interpolation
207      !!-----------------------------------------------------------------------
208      INTEGER, INTENT(in) :: kiter, kitermax
209      CHARACTER(len=1), INTENT( in ) :: cd_type
210      !!   
211      REAL(wp) :: zalpha, zbeta
212      !!-----------------------------------------------------------------------
213      !
214      IF (Agrif_Root()) RETURN
215      zalpha = REAL(lim_nbstep,wp) / (Agrif_Rhot()*Agrif_PArent(nn_fsbc)/REAL(nn_fsbc))
216      zbeta  = REAL(kiter,wp) / kitermax
217      zbeta = zalpha * zbeta
218      SELECT CASE(cd_type)
219      CASE('U')
220         CALL ParcoursU( zbeta )
221      CASE('V')
222         CALL ParcoursV( zbeta )
223      END SELECT
224      !
225   END SUBROUTINE agrif_rhg_lim2
226
227
228   SUBROUTINE ParcoursU( pbeta )
229      !!-----------------------------------------------------------------------
230      !!                    *** ROUTINE parcoursU ***
231      !!
232      !!  ** Method  : time and spatial interpolation for U-point using values
233      !!  interpolated from the coarse grid and inside dvalues     
234      !!-----------------------------------------------------------------------
235      REAL(wp), INTENT(in) :: pbeta
236      !!
237      INTEGER :: ji, jj
238      !!-----------------------------------------------------------------------
239      !
240      IF((nbondi == -1).OR.(nbondi == 2)) THEN
241         DO jj=1,jpj
242            DO ji=1,2
243               u_ice(ji,jj) = (1-pbeta) * u_ice_oe(ji,jj,1) + pbeta * u_ice_oe(ji,jj,2)
244            END DO
245         END DO
246         DO jj=1,jpj
247            u_ice(2,jj) = 0.25*(u_ice(1,jj)+2.*u_ice(2,jj)+u_ice(3,jj))
248            u_ice(2,jj) = u_ice(2,jj) * umask(2,jj,1)
249         END DO
250      ENDIF
251
252      IF((nbondi == 1).OR.(nbondi == 2)) THEN
253         DO jj=1,jpj
254            DO ji=1,2
255               u_ice(nlci+ji-3,jj) = (1-pbeta) * u_ice_oe(ji+2,jj,1) + pbeta * u_ice_oe(ji+2,jj,2)
256            END DO
257         END DO
258         DO jj=1,jpj
259            u_ice(nlci-2,jj) = 0.25*(u_ice(nlci-3,jj)+2.*u_ice(nlci-2,jj)+u_ice(nlci-1,jj))
260            u_ice(nlci-2,jj) = u_ice(nlci-2,jj) * umask(nlci-2,jj,1)
261         END DO
262      ENDIF
263
264      IF((nbondj == -1).OR.(nbondj == 2)) THEN
265         DO ji=1,jpi
266            u_ice(ji,2) = (1-pbeta) * u_ice_sn(ji,2,1) + pbeta * u_ice_sn(ji,2,2)
267            u_ice(ji,2) = u_ice(ji,2)*umask(ji,2,1)
268         END DO
269      ENDIF
270
271      IF((nbondj == 1).OR.(nbondj == 2)) THEN
272         DO ji=1,jpi
273            u_ice(ji,nlcj-1) = (1-pbeta) * u_ice_sn(ji,4,1) + pbeta * u_ice_sn(ji,4,2)
274            u_ice(ji,nlcj-1) = u_ice(ji,nlcj-1)*umask(ji,nlcj-1,1)
275         END DO
276      ENDIF
277      !
278   END SUBROUTINE ParcoursU
279
280
281   SUBROUTINE ParcoursV( pbeta )
282      !!-----------------------------------------------------------------------
283      !!                    *** ROUTINE parcoursV ***
284      !!
285      !!  ** Method  : time and spatial interpolation for V-point using values
286      !!  interpolated from the coarse grid and inside dvalues     
287      !!-----------------------------------------------------------------------
288      REAL(wp), INTENT(in) :: pbeta
289      !!
290      INTEGER :: ji, jj
291      !!-----------------------------------------------------------------------
292      !
293      IF((nbondi == -1).OR.(nbondi == 2)) THEN
294         DO jj=1,jpj
295            v_ice(2,jj) = (1-pbeta) * v_ice_oe(2,jj,1) + pbeta * v_ice_oe(2,jj,2)
296            v_ice(2,jj) = v_ice(2,jj) * vmask(2,jj,1)
297         END DO
298      ENDIF
299
300      IF((nbondi == 1).OR.(nbondi == 2)) THEN
301         DO jj=1,jpj
302            v_ice(nlci-1,jj) = (1-pbeta) * v_ice_oe(4,jj,1) + pbeta * v_ice_oe(4,jj,2)
303            v_ice(nlci-1,jj) = v_ice(nlci-1,jj)*vmask(nlci-1,jj,1)
304         END DO
305      ENDIF
306
307      IF((nbondj == -1).OR.(nbondj == 2)) THEN
308         DO jj=1,2
309            DO ji=1,jpi
310               v_ice(ji,jj) = (1-pbeta) * v_ice_sn(ji,jj,1) + pbeta * v_ice_sn(ji,jj,2)
311            END DO
312         END DO
313         DO ji=1,jpi
314            v_ice(ji,2)=0.25*(v_ice(ji,1)+2.*v_ice(ji,2)+v_ice(ji,3))
315            v_ice(ji,2)=v_ice(ji,2)*vmask(ji,2,1)
316         END DO
317      ENDIF
318
319      IF((nbondj == 1).OR.(nbondj == 2)) THEN
320         DO jj=1,2
321            DO ji=1,jpi
322               v_ice(ji,nlcj+jj-3) = (1-pbeta) * v_ice_sn(ji,jj+2,1) + pbeta * v_ice_sn(ji,jj+2,2)
323            END DO
324         END DO
325         DO ji=1,jpi
326            v_ice(ji,nlcj-2)=0.25*(v_ice(ji,nlcj-3)+2.*v_ice(ji,nlcj-2)+v_ice(ji,nlcj-1))
327            v_ice(ji,nlcj-2) = v_ice(ji,nlcj-2) * vmask(ji,nlcj-2,1)
328         END DO
329      ENDIF
330      !
331   END SUBROUTINE ParcoursV
332# endif
333   SUBROUTINE agrif_trp_lim2_load
334      !!-----------------------------------------------------------------------
335      !!                 *** ROUTINE agrif_trp_lim2_load ***
336      !!
337      !!  ** Method  : need a special routine for dealing with exchanging data
338      !!  between the child and parent grid during ice step
339      !!               we interpolate and store the boundary if needed, ie if
340      !!  we are in inside a new parent ice time step
341     !!-----------------------------------------------------------------------
342      INTEGER :: ji,jj,jn
343      !!-----------------------------------------------------------------------
344      !
345      IF (Agrif_Root()) RETURN
346      IF( lim_nbstep == 1. ) THEN
347         !
348         ! switch old values
349         adv_ice_oe(:,:,:,1) =  adv_ice_oe(:,:,:,2)
350         adv_ice_sn(:,:,:,1) =  adv_ice_sn(:,:,:,2)
351         ! interpolation of boundaries
352         IF(.NOT.ALLOCATED(tabice_agr))THEN
353            ALLOCATE(tabice_agr(jpi,jpj,7))   
354         ENDIF
355         tabice_agr(:,:,:) = 0.
356         Agrif_SpecialValue=-9999.
357         Agrif_UseSpecialValue = .TRUE.
358         CALL Agrif_Bc_variable( adv_ice_id ,procname=interp_adv_ice,calledweight=1. )
359         Agrif_SpecialValue=0.
360         Agrif_UseSpecialValue = .FALSE.
361         
362         ! fill  boundaries
363         DO jn =1,7
364            DO jj = 1, jpj
365               DO ji=1,2
366                  adv_ice_oe(ji  ,jj,jn,2) = tabice_agr(ji       ,jj,jn) 
367                  adv_ice_oe(ji+2,jj,jn,2) = tabice_agr(nlci-2+ji,jj,jn)
368               END DO
369            END DO
370         END DO
371
372         Do jn =1,7
373            Do jj =1,2
374               DO ji = 1, jpi
375                  adv_ice_sn(ji,jj  ,jn,2) = tabice_agr(ji,jj       ,jn) 
376                  adv_ice_sn(ji,jj+2,jn,2) = tabice_agr(ji,nlcj-2+jj,jn)
377               END DO
378            END DO
379         END DO
380         !
381      ENDIF
382      !
383   END SUBROUTINE agrif_trp_lim2_load
384
385
386   SUBROUTINE agrif_trp_lim2
387      !!-----------------------------------------------------------------------
388      !!                  *** ROUTINE agrif_trp_lim2 ***
389      !!
390      !!  ** Method  : time coefficient and call to atomic routines
391      !!-----------------------------------------------------------------------
392      INTEGER :: ji,jj,jn
393      REAL(wp) :: zalpha
394      REAL(wp), DIMENSION(jpi,jpj,7) :: tabice_agr 
395      !!-----------------------------------------------------------------------     
396      !
397      IF (Agrif_Root()) RETURN
398
399      zalpha = REAL(lim_nbstep,wp) / (Agrif_Rhot()*Agrif_PArent(nn_fsbc)/REAL(nn_fsbc))
400      !
401      tabice_agr(:,:,:) = 0.e0
402      DO jn =1,7
403         DO jj =1,2
404            DO ji = 1, jpi
405               tabice_agr(ji,jj        ,jn) = (1-zalpha)*adv_ice_sn(ji,jj  ,jn,1) + zalpha*adv_ice_sn(ji,jj  ,jn,2) 
406               tabice_agr(ji,nlcj-2+jj ,jn) = (1-zalpha)*adv_ice_sn(ji,jj+2,jn,1) + zalpha*adv_ice_sn(ji,jj+2,jn,2) 
407            END DO
408         END DO
409      END DO
410
411      DO jn =1,7
412         DO jj = 1, jpj
413            DO ji=1,2
414               tabice_agr(ji       ,jj,jn) = (1-zalpha)*adv_ice_oe(ji  ,jj,jn,1) + zalpha*adv_ice_oe(ji  ,jj,jn,2) 
415               tabice_agr(nlci-2+ji,jj,jn) = (1-zalpha)*adv_ice_oe(ji+2,jj,jn,1) + zalpha*adv_ice_oe(ji+2,jj,jn,2) 
416            END DO
417         END DO
418      END DO
419      !
420      CALL parcoursT( tabice_agr(:,:, 1), frld  )
421      CALL parcoursT( tabice_agr(:,:, 2), hicif )
422      CALL parcoursT( tabice_agr(:,:, 3), hsnif )
423      CALL parcoursT( tabice_agr(:,:, 4), tbif(:,:,1) )
424      CALL parcoursT( tabice_agr(:,:, 5), tbif(:,:,2) )
425      CALL parcoursT( tabice_agr(:,:, 6), tbif(:,:,3) )
426      CALL parcoursT( tabice_agr(:,:, 7), qstoif )
427      !
428   END SUBROUTINE agrif_trp_lim2
429
430
431   SUBROUTINE parcoursT ( pinterp, pfinal )
432      !!-----------------------------------------------------------------------
433      !!                    *** ROUTINE parcoursT ***
434      !!
435      !!  ** Method  : fill boundaries for T points
436      !!-----------------------------------------------------------------------
437      REAL(wp), DIMENSION(jpi,jpj), INTENT(in)    :: pinterp
438      REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: pfinal
439      !!
440      REAL(wp) :: zbound, zvbord
441      REAL(wp), DIMENSION(jpi,jpj) ::  zui_u, zvi_v
442      INTEGER :: ji, jj
443      !!-----------------------------------------------------------------------
444      !
445      zui_u = 0.e0
446      zvi_v = 0.e0
447      ! zvbord factor between 1 and 2 to take into account slip or no-slip boundary conditions.
448      zbound=0.
449      zvbord = 1.0 + ( 1.0 - zbound )
450#if defined key_lim2_vp
451      DO jj = 1, jpjm1
452         DO ji = 1, jpim1
453            zui_u(ji,jj) = ( u_ice(ji+1,jj  ) + u_ice(ji+1,jj+1) ) / ( MAX( tmu(ji+1,jj  ) + tmu(ji+1,jj+1), zvbord ) )
454            zvi_v(ji,jj) = ( v_ice(ji  ,jj+1) + v_ice(ji+1,jj+1) ) / ( MAX( tmu(ji  ,jj+1) + tmu(ji+1,jj+1), zvbord ) )
455         END DO
456      END DO
457#else
458      zui_u(:,:) = u_ice(:,:)
459      zvi_v(:,:) = v_ice(:,:)
460#endif
461
462      IF((nbondi == -1).OR.(nbondi == 2)) THEN
463         DO jj=1,jpj
464            !            IF (zui_u(2,jj).EQ.0.) THEN
465            !               pfinal (2,jj) = pfinal (1,jj) * tms(2,jj)
466            !            ELSE
467            pfinal(2,jj) = 0.25* pinterp(1,jj) + 0.5 *  pinterp(2,jj) + 0.25 *pfinal(3,jj)
468            !            ENDIF
469         END DO
470      ENDIF
471
472      IF((nbondj == -1).OR.(nbondj == 2)) THEN
473         DO ji=1,jpi
474            !            IF (zvi_v(ji,2).EQ.0.) THEN
475            !               pfinal (ji,2) = pfinal (ji,1) * tms(ji,2)
476            !            ELSE
477            pfinal(ji,2) = 0.25* pinterp(ji,1) + 0.5 *  pinterp(ji,2) + 0.25 *pfinal(ji,3)
478            !            ENDIF
479         END DO
480      ENDIF
481
482
483      IF((nbondi == 1).OR.(nbondi == 2)) THEN
484         DO jj=1,jpj
485            !            IF (zui_u(nlci-2,jj).EQ.0.) THEN
486            !               pfinal(nlci-1,jj) = pfinal (nlci,jj) * tms(nlci-1,jj)
487            !            ELSE
488            pfinal(nlci-1,jj) = 0.25* pinterp(nlci,jj) + 0.5 *  pinterp(nlci-1,jj) + 0.25 *pfinal(nlci-2,jj)
489            !           ENDIF
490         END DO
491      ENDIF
492
493      IF((nbondj == 1).OR.(nbondj == 2)) THEN
494         DO ji=1,jpi
495            !            IF (zvi_v(ji,nlcj-2).EQ.0.) THEN
496            !               pfinal (ji,nlcj-1) =  pfinal(ji,nlcj) * tms(ji,nlcj-1)
497            !            ELSE
498            pfinal(ji,nlcj-1) = 0.25* pinterp(ji,nlcj) + 0.5 *  pinterp(ji,nlcj-1) + 0.25 *pfinal(ji,nlcj-2)
499            !            ENDIF
500         END DO
501      ENDIF
502
503
504      pfinal (:,:) = pfinal (:,:) * tms(:,:)
505      !
506   END SUBROUTINE parcoursT
507
508
509   SUBROUTINE interp_u_ice( tabres, i1, i2, j1, j2, before )
510      !!-----------------------------------------------------------------------
511      !!                     *** ROUTINE interp_u_ice ***
512      !!-----------------------------------------------------------------------
513      INTEGER, INTENT(in) :: i1, i2, j1, j2
514      REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres
515      LOGICAL, INTENT(in) :: before
516      !!
517      INTEGER :: ji,jj
518      !!-----------------------------------------------------------------------
519      !
520#if defined key_lim2_vp
521      IF( before ) THEN
522         DO jj=MAX(j1,2),j2
523            DO ji=MAX(i1,2),i2
524               IF( tmu(ji,jj) == 0. ) THEN
525                  tabres(ji,jj) = -9999.
526               ELSE
527                  tabres(ji,jj) = e2f(ji-1,jj-1) * u_ice(ji,jj)
528               ENDIF
529            END DO
530         END DO
531      ENDIF
532#else
533      IF( before ) THEN
534         DO jj= j1, j2
535            DO ji= i1, i2
536               IF( umask(ji,jj,1) == 0. ) THEN
537                  tabres(ji,jj) = -9999.
538               ELSE
539                  tabres(ji,jj) = e2u(ji,jj) * u_ice(ji,jj)
540               ENDIF
541            END DO
542         END DO
543      ENDIF
544#endif
545   END SUBROUTINE interp_u_ice
546
547
548   SUBROUTINE interp_v_ice( tabres, i1, i2, j1, j2, before )
549      !!-----------------------------------------------------------------------
550      !!                    *** ROUTINE interp_v_ice ***
551      !!-----------------------------------------------------------------------     
552      INTEGER, INTENT(in) :: i1, i2, j1, j2
553      REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres
554      LOGICAL, INTENT(in) :: before
555      !!
556      INTEGER :: ji, jj
557      !!-----------------------------------------------------------------------
558      !
559#if defined key_lim2_vp
560      IF( before ) THEN
561         DO jj=MAX(j1,2),j2
562            DO ji=MAX(i1,2),i2
563               IF( tmu(ji,jj) == 0. ) THEN
564                  tabres(ji,jj) = -9999.
565               ELSE
566                  tabres(ji,jj) = e1f(ji-1,jj-1) * v_ice(ji,jj)
567               ENDIF
568            END DO
569         END DO
570      ENDIF   
571#else
572      IF( before ) THEN
573         DO jj= j1 ,j2
574            DO ji = i1, i2
575               IF( vmask(ji,jj,1) == 0. ) THEN
576                  tabres(ji,jj) = -9999.
577               ELSE
578                  tabres(ji,jj) = e1v(ji,jj) * v_ice(ji,jj)
579               ENDIF
580            END DO
581         END DO
582      ENDIF
583#endif
584   END SUBROUTINE interp_v_ice
585
586
587   SUBROUTINE interp_adv_ice( tabres, i1, i2, j1, j2, before )
588      !!-----------------------------------------------------------------------
589      !!                    *** ROUTINE interp_adv_ice ***                           
590      !!
591      !! ** Purpose : fill an array with  ice variables
592      !!              to be advected
593      !!              put -9999 where no ice for correct extrapolation             
594      !!-----------------------------------------------------------------------
595      INTEGER, INTENT(in) :: i1, i2, j1, j2
596      REAL(wp), DIMENSION(i1:i2,j1:j2,7), INTENT(inout) :: tabres
597      LOGICAL, INTENT(in) :: before
598      !!
599      INTEGER :: ji, jj, jk
600      !!-----------------------------------------------------------------------
601      !
602      IF( before ) THEN
603         DO jj=j1,j2
604            DO ji=i1,i2
605               IF( tms(ji,jj) == 0. ) THEN
606                  tabres(ji,jj,:) = -9999. 
607               ELSE
608                  tabres(ji,jj, 1) = frld  (ji,jj)
609                  tabres(ji,jj, 2) = hicif (ji,jj)
610                  tabres(ji,jj, 3) = hsnif (ji,jj)
611                  tabres(ji,jj, 4) = tbif  (ji,jj,1)
612                  tabres(ji,jj, 5) = tbif  (ji,jj,2)
613                  tabres(ji,jj, 6) = tbif  (ji,jj,3)
614                  tabres(ji,jj, 7) = qstoif(ji,jj)
615               ENDIF
616            END DO
617         END DO
618      ENDIF
619      !
620   END SUBROUTINE interp_adv_ice
621
622#else
623CONTAINS
624   SUBROUTINE agrif_lim2_interp_empty
625      !!---------------------------------------------
626      !!   *** ROUTINE agrif_lim2_interp_empty ***
627      !!---------------------------------------------
628      WRITE(*,*)  'agrif_lim2_interp : You should not have seen this print! error?'
629   END SUBROUTINE agrif_lim2_interp_empty
630#endif
631END MODULE agrif_lim2_interp
Note: See TracBrowser for help on using the repository browser.