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/2011/dev_r2802_LOCEAN10_agrif_lim/NEMOGCM/NEMO/NST_SRC – NEMO

source: branches/2011/dev_r2802_LOCEAN10_agrif_lim/NEMOGCM/NEMO/NST_SRC/agrif_lim2_interp.F90 @ 2805

Last change on this file since 2805 was 2805, checked in by rblod, 13 years ago

dev_r2802_LOCEAN10_agrif_lim: first implementation see ticket #848
File size: 25.8 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.3   !  09-2010  (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_update_lim2  : update sea-ice model on boundaries or total
17   !!                        sea-ice area
18   !!----------------------------------------------------------------------
19   USE ice_2
20   USE dom_ice_2
21   USE par_oce
22   USE dom_oce
23   USE agrif_ice
24
25   IMPLICIT NONE
26   PRIVATE
27
28# if defined key_lim2_vp
29   PUBLIC Agrif_dyn_lim2_load, Agrif_dyn_lim2_copy
30# else
31   PUBLIC Agrif_dyn_lim
32# endif
33   PUBLIC Agrif_adv_lim2
34   PUBLIC Agrif_sadv_lim2
35   PUBLIC interp_adv_ice, interp_sadv_ice
36   PUBLIC interp_u_ice, interp_v_ice
37
38   !!---------------------------------------------------------------------
39   !! NEMO/NST 3.2 , LOCEAN-IPSL (2010)
40   !! $Id$
41   !! Software governed by the CeCILL licence (modipsl/doc/NEMO_CeCILL.txt)
42   !!----------------------------------------------------------------------
43
44CONTAINS
45
46# if defined key_lim2_vp
47   SUBROUTINE agrif_dyn_lim2_load
48      !!-----------------------------------------------------------------------
49      !!              *** ROUTINE agrif_dyn_lim2_load ***
50      !!
51      !! need a special routine for dealing with exchanging data
52      !! between the child and parent grid during ice step
53      !!
54      !!-----------------------------------------------------------------------
55      !
56      IF (Agrif_Root()) RETURN
57
58      Agrif_SpecialValue=-9999.
59      Agrif_UseSpecialValue = .TRUE.
60      u_ice_nst(:,:) = 0.
61      v_ice_nst(:,:) = 0.
62      CALL Agrif_Bc_variable( u_ice_nst, u_ice_id ,procname=interp_u_ice, calledweight=1. )
63      CALL Agrif_Bc_variable( v_ice_nst, v_ice_id ,procname=interp_v_ice, calledweight=1. )
64      Agrif_SpecialValue=0.
65      Agrif_UseSpecialValue = .FALSE.
66      !
67   END SUBROUTINE agrif_dyn_lim2_load
68
69
70   SUBROUTINE agrif_dyn_lim2_copy(pu_n,pv_n)
71      !!-----------------------------------------------------------------------
72      !!                 *** ROUTINE agrif_dyn_lim2_copy ***
73      !!-----------------------------------------------------------------------
74      REAL(wp), DIMENSION(jpi,0:jpj+1), INTENT(inout) :: pu_n, pv_n
75      !!
76      REAL(wp) :: zrhox, zrhoy
77      INTEGER :: ji,jj
78      !!-----------------------------------------------------------------------
79      !
80      IF (Agrif_Root()) RETURN
81
82      zrhox = Agrif_Rhox()
83      zrhoy = Agrif_Rhoy()
84
85      IF((nbondi == -1).OR.(nbondi == 2)) THEN
86            DO jj=2,jpj
87               pu_n(3,jj) = u_ice_nst(3,jj)/(zrhoy*e2f(2,jj-1))*tmu(3,jj)
88            END DO
89            DO jj=2,jpj
90               pv_n(3,jj) = v_ice_nst(3,jj)/(zrhox*e1f(2,jj-1))*tmu(3,jj)
91            END DO
92      ENDIF
93
94      IF((nbondi == 1).OR.(nbondi == 2)) THEN
95            DO jj=2,jpj
96               pu_n(nlci-1,jj) = u_ice_nst(nlci-1,jj)/(zrhoy*e2f(nlci-2,jj-1))*tmu(nlci-1,jj)
97            END DO
98            DO jj=2,jpj
99               pv_n(nlci-1,jj) = v_ice_nst(nlci-1,jj)/(zrhox*e1f(nlci-2,jj-1))*tmu(nlci-1,jj)
100            END DO
101      ENDIF
102
103      IF((nbondj == -1).OR.(nbondj == 2)) THEN
104            DO ji=2,jpi
105               pv_n(ji,3) = v_ice_nst(ji,3)/(zrhox*e1f(ji-1,2))*tmu(ji,3)
106            END DO
107            DO ji=2,jpi
108               pu_n(ji,3) = u_ice_nst(ji,3)/(zrhoy*e2f(ji-1,2))*tmu(ji,3)
109            END DO
110      ENDIF
111
112      IF((nbondj == 1).OR.(nbondj == 2)) THEN
113            DO ji=2,jpi
114               pv_n(ji,nlcj-1) = v_ice_nst(ji,nlcj-1)/(zrhox*e1f(ji-1,nlcj-2))*tmu(ji,nlcj-1)
115            END DO
116            DO ji=2,jpi
117               pu_n(ji,nlcj-1) = u_ice_nst(ji,nlcj-1)/(zrhoy*e2f(ji-1,nlcj-2))*tmu(ji,nlcj-1)
118            END DO
119      ENDIF
120      !
121   END SUBROUTINE agrif_dyn_lim2_copy
122
123#else
124
125   SUBROUTINE agrif_dyn_lim( kiter, kitermax, cd_type )
126      !!-----------------------------------------------------------------------
127      !!                    *** ROUTINE dyn_lim ***
128      !!-----------------------------------------------------------------------
129      INTEGER, INTENT(in) :: kiter, kitermax
130      CHARACTER(len=1), INTENT( in ) :: cd_type
131      !!
132      INTEGER :: ji,jj
133      REAL(wp) :: alpha, beta, zrhox, zrhoy
134      REAL(wp), DIMENSION(:,:), ALLOCATABLE :: zuice, zvice
135      !!-----------------------------------------------------------------------
136      !
137      IF (Agrif_Root()) RETURN
138   
139      IF( childfreq == 1. .AND. ( kiter == 0 .OR. kiter == 1 ) .AND. cd_type == 'V') THEN
140        !
141        ALLOCATE( zuice(jpi,jpj) , zvice(jpi,jpj) )
142        ! switch old values
143         IF(kiter > 0 ) THEN
144            u_ice_oe(:,:,1) =  u_ice_oe(:,:,2)
145            v_ice_oe(:,:,1) =  v_ice_oe(:,:,2)
146            u_ice_sn(:,:,1) =  u_ice_sn(:,:,2)
147            v_ice_sn(:,:,1) =  v_ice_sn(:,:,2)
148         ENDIF
149         ! interpolation of boundaries
150         Agrif_SpecialValue=-9999.
151         Agrif_UseSpecialValue = .TRUE.
152         zuice = 0.
153         zvice = 0.
154         CALL Agrif_Bc_variable(zuice,u_ice_id,procname=interp_u_ice, calledweight=1.)
155         CALL Agrif_Bc_variable(zvice,v_ice_id,procname=interp_v_ice, calledweight=1.)
156         Agrif_SpecialValue=0.
157         Agrif_UseSpecialValue = .FALSE.
158         ! 
159         zrhox = agrif_rhox() ;    zrhoy = agrif_rhoy()     
160         zuice(:,:) =  zuice(:,:)/(zrhoy*e2u(:,:))*umask(:,:,1)
161         zvice(:,:) =  zvice(:,:)/(zrhox*e1v(:,:))*vmask(:,:,1)
162         ! fill  boundaries
163         DO jj = 1, jpj
164         DO ji = 1, 2
165            u_ice_oe(ji,jj,2) = zuice(ji,jj) ;  u_ice_oe(ji+2,jj,2) =  zuice(nlci+ji-3,jj)
166         END DO
167         END DO
168         DO jj = 1, jpj
169            v_ice_oe(  2,jj,2) = zvice(  2,jj) ;  v_ice_oe(  4,jj,2) =  zvice(       nlci-1,jj)
170         END DO
171         DO ji = 1, jpi
172            u_ice_sn( ji,2,2) = zuice(ji,  2) ;  u_ice_sn( ji,4,2) =  zuice(ji,       nlcj-1)
173         END DO
174         DO jj = 1, 2
175         DO ji = 1, jpi
176            v_ice_sn(ji,jj,2) = zvice(ji,jj) ;  v_ice_sn(ji,jj+2,2) =  zvice(ji,nlcj+jj-3)
177         END DO
178         END DO
179         !
180         IF(kiter == 0 ) THEN
181            u_ice_oe(:,:,1) =  u_ice_oe(:,:,2)
182            v_ice_oe(:,:,1) =  v_ice_oe(:,:,2)
183            u_ice_sn(:,:,1) =  u_ice_sn(:,:,2)
184            v_ice_sn(:,:,1) =  v_ice_sn(:,:,2)
185         ENDIF
186         !`
187         DEALLOCATE( zuice, zvice )
188         !
189      ENDIF
190
191      alpha = (childfreq ) / Agrif_Rhot()
192      beta  = REAL(kiter,wp) / kitermax
193      beta = alpha * beta
194!RB   beta = 1 to put constant values on boundaries during EVP time-splitting   
195!      beta=1
196      SELECT CASE(cd_type)
197      CASE('U')
198         CALL ParcoursU(beta)
199      CASE('V')
200         CALL ParcoursV(beta)
201      END SELECT
202      !
203   END SUBROUTINE agrif_dyn_lim
204
205
206   SUBROUTINE ParcoursU( pbeta )
207      !!-----------------------------------------------------------------------
208      !!                    *** ROUTINE parcoursU ***
209      !!-----------------------------------------------------------------------
210      REAL(wp), INTENT(in) :: pbeta
211      !!
212      INTEGER :: ji, jj
213      !!-----------------------------------------------------------------------
214      !
215      IF((nbondi == -1).OR.(nbondi == 2)) THEN
216         DO jj=1,jpj
217         DO ji=1,2
218            u_ice(ji,jj) = (1-pbeta) * u_ice_oe(ji,jj,1) + pbeta * u_ice_oe(ji,jj,2)
219         END DO
220         END DO
221         DO jj=1,jpj
222            u_ice(2,jj) = 0.25*(u_ice(1,jj)+2.*u_ice(2,jj)+u_ice(3,jj))
223            u_ice(2,jj) = u_ice(2,jj) * umask(2,jj,1)
224         END DO
225      ENDIF
226
227      IF((nbondi == 1).OR.(nbondi == 2)) THEN
228         DO jj=1,jpj
229         DO ji=1,2
230            u_ice(nlci+ji-3,jj) = (1-pbeta) * u_ice_oe(ji+2,jj,1) + pbeta * u_ice_oe(ji+2,jj,2)
231         END DO
232         END DO
233         DO jj=1,jpj
234            u_ice(nlci-2,jj) = 0.25*(u_ice(nlci-3,jj)+2.*u_ice(nlci-2,jj)+u_ice(nlci-1,jj))
235            u_ice(nlci-2,jj) = u_ice(nlci-2,jj) * umask(nlci-2,jj,1)
236         END DO
237      ENDIF
238
239      IF((nbondj == -1).OR.(nbondj == 2)) THEN
240         DO ji=1,jpi
241            u_ice(ji,2) = (1-pbeta) * u_ice_sn(ji,2,1) + pbeta * u_ice_sn(ji,2,2)
242            u_ice(ji,2) = u_ice(ji,2)*umask(ji,2,1)
243         END DO
244      ENDIF
245
246      IF((nbondj == 1).OR.(nbondj == 2)) THEN
247         DO ji=1,jpi
248            u_ice(ji,nlcj-1) = (1-pbeta) * u_ice_sn(ji,4,1) + pbeta * u_ice_sn(ji,4,2)
249            u_ice(ji,nlcj-1) = u_ice(ji,nlcj-1)*umask(ji,nlcj-1,1)
250         END DO
251      ENDIF
252      !
253   END SUBROUTINE ParcoursU
254
255
256   SUBROUTINE ParcoursV( pbeta )
257      !!-----------------------------------------------------------------------
258      !!                    *** ROUTINE parcoursV ***
259      !!-----------------------------------------------------------------------
260      REAL(wp), INTENT(in) :: pbeta
261      !!
262      INTEGER :: ji, jj
263      !!-----------------------------------------------------------------------
264      !
265      IF((nbondi == -1).OR.(nbondi == 2)) THEN
266        DO jj=1,jpj
267            v_ice(2,jj) = (1-pbeta) * v_ice_oe(2,jj,1) + pbeta * v_ice_oe(2,jj,2)
268            v_ice(2,jj) = v_ice(2,jj) * vmask(2,jj,1)
269         END DO
270      ENDIF
271
272      IF((nbondi == 1).OR.(nbondi == 2)) THEN
273        DO jj=1,jpj
274            v_ice(nlci-1,jj) = (1-pbeta) * v_ice_oe(4,jj,1) + pbeta * v_ice_oe(4,jj,2)
275            v_ice(nlci-1,jj) = v_ice(nlci-1,jj)*vmask(nlci-1,jj,1)
276         END DO
277      ENDIF
278
279      IF((nbondj == -1).OR.(nbondj == 2)) THEN
280         DO jj=1,2
281         DO ji=1,jpi
282            v_ice(ji,jj) = (1-pbeta) * v_ice_sn(ji,jj,1) + pbeta * v_ice_sn(ji,jj,2)
283         END DO
284         END DO
285         DO ji=1,jpi
286            v_ice(ji,2)=0.25*(v_ice(ji,1)+2.*v_ice(ji,2)+v_ice(ji,3))
287            v_ice(ji,2)=v_ice(ji,2)*vmask(ji,2,1)
288         END DO
289      ENDIF
290
291      IF((nbondj == 1).OR.(nbondj == 2)) THEN
292         DO jj=1,2
293         DO ji=1,jpi
294            v_ice(ji,nlcj+jj-3) = (1-pbeta) * v_ice_sn(ji,jj+2,1) + pbeta * v_ice_sn(ji,jj+2,2)
295         END DO
296         END DO
297         DO ji=1,jpi
298            v_ice(ji,nlcj-2)=0.25*(v_ice(ji,nlcj-3)+2.*v_ice(ji,nlcj-2)+v_ice(ji,nlcj-1))
299            v_ice(ji,nlcj-2) = v_ice(ji,nlcj-2) * vmask(ji,nlcj-2,1)
300         END DO
301      ENDIF
302      !
303   END SUBROUTINE ParcoursV
304# endif
305
306   SUBROUTINE agrif_adv_lim2( kt )
307      !!-----------------------------------------------------------------------
308      !!                  *** ROUTINE agrif_adv_lim2 ***
309      !!-----------------------------------------------------------------------
310      INTEGER, INTENT(in) :: kt
311      !!
312      INTEGER :: jk
313      REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: ztab 
314      !!-----------------------------------------------------------------------     
315      !
316      IF (Agrif_Root()) RETURN
317
318      ALLOCATE( ztab(jpi,jpj,7) )
319
320      ztab(:,:,:) = 0.
321      Agrif_SpecialValue=-9999.
322      Agrif_UseSpecialValue = .TRUE.
323      CALL Agrif_Bc_variable( ztab, adv_ice_id ,procname=interp_adv_ice, calledweight=1. )
324      Agrif_SpecialValue=0.
325      Agrif_UseSpecialValue = .FALSE.
326      !
327
328      CALL parcoursT( ztab(:,:, 1), frld  )
329      CALL parcoursT( ztab(:,:, 2), hicif )
330      CALL parcoursT( ztab(:,:, 3), hsnif )
331      CALL parcoursT( ztab(:,:, 4), tbif(:,:,1) )
332      CALL parcoursT( ztab(:,:, 5), tbif(:,:,2) )
333      CALL parcoursT( ztab(:,:, 6), tbif(:,:,3) )
334      CALL parcoursT( ztab(:,:, 7), qstoif )
335      !
336      DEALLOCATE( ztab )
337      !
338   END SUBROUTINE agrif_adv_lim2
339
340
341   SUBROUTINE agrif_sadv_lim2( kt )
342      !!-----------------------------------------------------------------------
343      !!                  *** ROUTINE agrif_sadv_lim2 ***
344      !!-----------------------------------------------------------------------
345      INTEGER, INTENT(in) :: kt
346      !!
347      INTEGER :: jk
348      REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: ztab
349      !!-----------------------------------------------------------------------     
350      !
351      IF (Agrif_Root()) RETURN
352
353      ALLOCATE( ztab(jpi,jpj,42) )
354
355      ztab(:,:,:) = 0.
356      Agrif_SpecialValue=-9999.
357      Agrif_UseSpecialValue = .TRUE.
358      CALL Agrif_Bc_variable( ztab, sadv_ice_id ,procname=interp_sadv_ice, calledweight=1. )
359      Agrif_SpecialValue=0.
360      Agrif_UseSpecialValue = .FALSE.
361      !
362      DO jk = 1, 42
363         ztab(:,:,jk) = ztab(:,:,jk) * area(:,:)
364      END DO
365
366      CALL parcoursT( ztab(:,:, 1), sxice  )
367      CALL parcoursT( ztab(:,:, 2), syice  )
368      CALL parcoursT( ztab(:,:, 3), sxxice )
369      CALL parcoursT( ztab(:,:, 4), syyice )
370      CALL parcoursT( ztab(:,:, 5), sxyice )
371      CALL parcoursT( ztab(:,:, 6), sxa    )
372      CALL parcoursT( ztab(:,:, 7), sya    )
373      CALL parcoursT( ztab(:,:, 8), sxxa   )
374      CALL parcoursT( ztab(:,:, 9), syya   )
375      CALL parcoursT( ztab(:,:,10), sxya   )
376      CALL parcoursT( ztab(:,:,11), sxsn   )
377      CALL parcoursT( ztab(:,:,12), sysn   )
378      CALL parcoursT( ztab(:,:,13), sxxsn  )
379      CALL parcoursT( ztab(:,:,14), syysn  )
380      CALL parcoursT( ztab(:,:,15), sxysn  )
381      CALL parcoursT( ztab(:,:,16), sxc0   )
382      CALL parcoursT( ztab(:,:,17), syc0   )
383      CALL parcoursT( ztab(:,:,18), sxxc0  )
384      CALL parcoursT( ztab(:,:,19), syyc0  )
385      CALL parcoursT( ztab(:,:,20), sxyc0  )
386      CALL parcoursT( ztab(:,:,21), sxc1   )
387      CALL parcoursT( ztab(:,:,22), syc1   )
388      CALL parcoursT( ztab(:,:,23), sxxc1  )
389      CALL parcoursT( ztab(:,:,24), syyc1  )
390      CALL parcoursT( ztab(:,:,25), sxyc1  )
391      CALL parcoursT( ztab(:,:,26), sxc2   )
392      CALL parcoursT( ztab(:,:,27), syc2   )
393      CALL parcoursT( ztab(:,:,28), sxxc2  )
394      CALL parcoursT( ztab(:,:,29), syyc2  )
395      CALL parcoursT( ztab(:,:,30), sxyc2  )
396      CALL parcoursT( ztab(:,:,31), sxst   )
397      CALL parcoursT( ztab(:,:,32), syst   )
398      CALL parcoursT( ztab(:,:,33), sxxst  )
399      CALL parcoursT( ztab(:,:,34), syyst  )
400      CALL parcoursT( ztab(:,:,35), sxyst  )
401
402      CALL parcoursT( ztab(:,:,36), s0ice  )
403      CALL parcoursT( ztab(:,:,37), s0a  )
404      CALL parcoursT( ztab(:,:,38), s0sn  )
405      CALL parcoursT( ztab(:,:,39), s0c0  )
406      CALL parcoursT( ztab(:,:,40), s0c1  )
407      CALL parcoursT( ztab(:,:,41), s0c2  )
408      CALL parcoursT( ztab(:,:,42), s0st  )
409      !
410      DEALLOCATE( ztab )
411      !
412   END SUBROUTINE agrif_sadv_lim2
413
414
415   SUBROUTINE parcoursT ( pinterp, pfinal )
416      !!-----------------------------------------------------------------------
417      !!                    *** ROUTINE parcoursT ***
418      !!-----------------------------------------------------------------------
419      REAL(wp), DIMENSION(jpi,jpj), INTENT(in)    :: pinterp
420      REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: pfinal
421      !!
422      INTEGER :: ji, jj
423      REAL(wp) :: zrho
424      REAL(wp) :: zbound, zvbord
425      REAL(wp) :: alpha1, alpha2, alpha3, alpha4
426      REAL(wp) :: alpha5, alpha6, alpha7
427      REAL(wp), DIMENSION(:,:), ALLOCATABLE :: zui_u, zvi_v
428      !!-----------------------------------------------------------------------
429      !
430      ALLOCATE( zui_u(jpi,jpj) ,zvi_v(jpi,jpj) )
431
432      zrho = Agrif_Rhox()
433      alpha1 = ( zrho -1. ) / 2.
434      alpha2 = 1. - alpha1
435      alpha3 = ( zrho - 1 ) / ( zrho + 1 )
436      alpha4 = 1. - alpha3
437      alpha6 = 2. * ( zrho -1. ) / ( zrho + 1. )
438      alpha7 = -( zrho -1 ) / ( zrho + 3 )
439      alpha5 = 1. - alpha6 - alpha7
440
441      zui_u = 0.e0
442      zvi_v = 0.e0
443      ! zvbord factor between 1 and 2 to take into account slip or no-slip boundary conditions.       
444      zbound=0.
445      zvbord = 1.0 + ( 1.0 - zbound )
446#if defined key_lim2_vp
447      DO jj = 1, jpjm1
448         DO ji = 1, jpim1
449            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 ) )
450            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 ) )
451         END DO
452      END DO
453#else
454      zui_u(:,:) = u_ice(:,:)
455      zvi_v(:,:) = v_ice(:,:)
456#endif
457
458      IF((nbondi == 1).OR.(nbondi == 2)) THEN
459         pfinal (nlci,:) = alpha1 * pinterp(nlci,:) + alpha2 * pinterp(nlci-1,:)
460         DO jj=1,jpj
461            IF (umask(nlci-2,jj,1).EQ.0.) THEN
462               pfinal (nlci-1,jj) = pfinal (nlci,jj) * tms(nlci-1,jj)
463            ELSE
464               pfinal (nlci-1,jj)=(alpha4*pfinal (nlci,jj)+alpha3*pfinal (nlci-2,jj))*tms(nlci-1,jj)
465               IF (zui_u(nlci-2,jj).GT.0.) THEN
466              pfinal(nlci-1,jj)=( alpha6*pfinal (nlci-2,jj)+alpha5*pfinal (nlci,jj)  &
467                      + alpha7*pfinal (nlci-3,jj) ) * tms(nlci-1,jj)
468               ENDIF
469            ENDIF
470         END DO
471      ENDIF
472
473      IF((nbondj == 1).OR.(nbondj == 2)) THEN
474         pfinal (:,nlcj) = alpha1 * pinterp(:,nlcj) + alpha2 * pinterp(:,nlcj-1)
475         DO ji=1,jpi
476            IF (vmask(ji,nlcj-2,1).EQ.0.) THEN
477               pfinal (ji,nlcj-1) =  pfinal(ji,nlcj) * tms(ji,nlcj-1)
478            ELSE
479               pfinal (ji,nlcj-1)=(alpha4*pfinal (ji,nlcj)+alpha3*pfinal (ji,nlcj-2))*tms(ji,nlcj-1)
480               IF (zvi_v(ji,nlcj-2) .GT. 0.) THEN
481              pfinal (ji,nlcj-1)=( alpha6*pfinal (ji,nlcj-2)+alpha5*pfinal (ji,nlcj)  &
482                      + alpha7*pfinal (ji,nlcj-3) ) * tms(ji,nlcj-1)
483               ENDIF
484            ENDIF
485         END DO
486      ENDIF
487
488      IF((nbondi == -1).OR.(nbondi == 2)) THEN
489         pfinal (1,:) = alpha1 * pinterp(1,:) + alpha2 * pinterp(2,:)
490         DO jj=1,jpj
491            IF (umask(2,jj,1).EQ.0.) THEN
492               pfinal (2,jj) = pfinal (1,jj) * tms(2,jj)
493            ELSE
494               pfinal (2,jj)=(alpha4*pfinal (1,jj)+alpha3*pfinal (3,jj))*tms(2,jj)     
495              IF (zui_u(2,jj).LT.0.) THEN
496              pfinal (2,jj)=(alpha6*pfinal (3,jj)+alpha5*pfinal (1,jj)+alpha7*pfinal (4,jj))*tms(2,jj)
497               ENDIF
498            ENDIF
499         END DO
500      ENDIF
501
502      IF((nbondj == -1).OR.(nbondj == 2)) THEN
503         pfinal (:,1) = alpha1 * pinterp(:,1) + alpha2 * pinterp(:,2)
504         DO ji=1,jpi
505            IF (vmask(ji,2,1).EQ.0.) THEN
506               pfinal (ji,2) = pfinal (ji,1) * tms(ji,2)
507            ELSE
508               pfinal (ji,2)=(alpha4*pfinal (ji,1)+alpha3*pfinal (ji,3))*tms(ji,2)     
509               IF (zvi_v(ji,2) .LT. 0.) THEN
510              pfinal (ji,2)=(alpha6*pfinal (ji,3)+alpha5*pfinal (ji,1)+alpha7*pfinal (ji,4))*tms(ji,2)
511               ENDIF
512            ENDIF
513         END DO
514      ENDIF
515
516      pfinal (:,:) = pfinal (:,:) * tms(:,:)
517      !
518   END SUBROUTINE parcoursT
519
520
521   SUBROUTINE interp_u_ice( tabres, i1, i2, j1, j2 )
522      !!-----------------------------------------------------------------------
523      !!                     *** ROUTINE interp_u_ice ***
524      !!-----------------------------------------------------------------------
525      INTEGER, INTENT(in) :: i1, i2, j1, j2
526      REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres
527      !!
528      INTEGER :: ji,jj
529      !!-----------------------------------------------------------------------
530      !
531#if defined key_lim2_vp
532      DO jj=MAX(j1,2),j2
533         DO ji=MAX(i1,2),i2
534            IF( tmu(ji,jj) == 0. ) THEN
535               tabres(ji,jj) = -9999.
536            ELSE
537               tabres(ji,jj) = e2f(ji-1,jj-1) * u_ice(ji,jj)
538            ENDIF
539         END DO
540      END DO
541#else
542      DO jj= j1, j2
543         DO ji= i1, i2
544            IF( umask(ji,jj,1) == 0. ) THEN
545               tabres(ji,jj) = -9999.
546            ELSE
547               tabres(ji,jj) = e2u(ji,jj) * u_ice(ji,jj)
548            ENDIF
549         END DO
550      END DO
551#endif
552   END SUBROUTINE interp_u_ice
553
554
555   SUBROUTINE interp_v_ice( tabres, i1, i2, j1, j2 )
556      !!-----------------------------------------------------------------------
557      !!                    *** ROUTINE interp_v_ice ***
558      !!-----------------------------------------------------------------------     
559      INTEGER, INTENT(in) :: i1, i2, j1, j2
560      REAL(wp), DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres
561      !!
562      INTEGER :: ji, jj
563      !!-----------------------------------------------------------------------
564      !
565#if defined key_lim2_vp
566      DO jj=MAX(j1,2),j2
567         DO ji=MAX(i1,2),i2
568            IF( tmu(ji,jj) == 0. ) THEN
569               tabres(ji,jj) = -9999.
570            ELSE
571               tabres(ji,jj) = e1f(ji-1,jj-1) * v_ice(ji,jj)
572            ENDIF
573         END DO
574      END DO
575#else
576      DO jj= j1 ,j2
577         DO ji = i1, i2
578            IF( vmask(ji,jj,1) == 0. ) THEN
579               tabres(ji,jj) = -9999.
580            ELSE
581               tabres(ji,jj) = e1v(ji,jj) * v_ice(ji,jj)
582            ENDIF
583         END DO
584      END DO
585#endif
586   END SUBROUTINE interp_v_ice
587
588
589   SUBROUTINE interp_adv_ice( tabres, i1, i2, j1, j2 )
590      !!-----------------------------------------------------------------------
591      !!                    *** ROUTINE interp_adv_ice ***                           
592      !!
593      !! ** Purpose : fill an array with  ice variables
594      !!              to be advected
595      !!              put -9999 where no ice for correct extrapolation             
596      !!-----------------------------------------------------------------------
597      INTEGER, INTENT(in) :: i1, i2, j1, j2
598      REAL(wp), DIMENSION(i1:i2,j1:j2,7), INTENT(inout) :: tabres
599      !!
600      INTEGER :: ji, jj, jk
601      !!-----------------------------------------------------------------------
602      !
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      !
619   END SUBROUTINE interp_adv_ice
620
621
622   SUBROUTINE interp_sadv_ice( tabres, i1, i2, j1, j2 )
623      !!-----------------------------------------------------------------------
624      !!                 *** ROUTINE interp_sadv_ice ***   
625      !!
626      !! ** Purpose : fill an array with superior moements of ice variables
627      !!              to be advected
628      !!              put -9990 where no ice for correct extrapolation             
629      !!-----------------------------------------------------------------------
630      INTEGER, INTENT(in) :: i1, i2, j1, j2
631      REAL(wp), DIMENSION(i1:i2,j1:j2,42), INTENT(inout) :: tabres
632      !!
633      INTEGER :: ji, jj, jk
634      REAL(wp) :: z1_area
635      !!-----------------------------------------------------------------------
636      !
637      DO jj=j1,j2
638         DO ji=i1,i2
639            IF( tms(ji,jj) == 0. ) THEN
640               tabres(ji,jj,:) = -9999. 
641            ELSE
642               z1_area = 1. / area(ji,jj)
643               tabres(ji,jj, 1) = sxice (ji,jj) * z1_area
644               tabres(ji,jj, 2) = syice (ji,jj) * z1_area 
645               tabres(ji,jj, 3) = sxxice(ji,jj) * z1_area
646               tabres(ji,jj, 4) = syyice(ji,jj) * z1_area
647               tabres(ji,jj, 5) = sxyice(ji,jj) * z1_area
648               tabres(ji,jj, 6) = sxa   (ji,jj) * z1_area
649               tabres(ji,jj, 7) = sya   (ji,jj) * z1_area
650               tabres(ji,jj, 8) = sxxa  (ji,jj) * z1_area
651               tabres(ji,jj, 9) = syya  (ji,jj) * z1_area
652               tabres(ji,jj,10) = sxya  (ji,jj) * z1_area
653               tabres(ji,jj,11) = sxsn  (ji,jj) * z1_area
654               tabres(ji,jj,12) = sysn  (ji,jj) * z1_area
655               tabres(ji,jj,13) = sxxsn (ji,jj) * z1_area
656               tabres(ji,jj,14) = syysn (ji,jj) * z1_area
657               tabres(ji,jj,15) = sxysn (ji,jj) * z1_area
658               tabres(ji,jj,16) = sxc0  (ji,jj) * z1_area
659               tabres(ji,jj,17) = syc0  (ji,jj) * z1_area
660               tabres(ji,jj,18) = sxxc0 (ji,jj) * z1_area
661               tabres(ji,jj,19) = syyc0 (ji,jj) * z1_area
662               tabres(ji,jj,20) = sxyc0 (ji,jj) * z1_area
663               tabres(ji,jj,21) = sxc1  (ji,jj) * z1_area
664               tabres(ji,jj,22) = syc1  (ji,jj) * z1_area
665               tabres(ji,jj,23) = sxxc1 (ji,jj) * z1_area
666               tabres(ji,jj,24) = syyc1 (ji,jj) * z1_area
667               tabres(ji,jj,25) = sxyc1 (ji,jj) * z1_area
668               tabres(ji,jj,26) = sxc2  (ji,jj) * z1_area
669               tabres(ji,jj,27) = syc2  (ji,jj) * z1_area
670               tabres(ji,jj,28) = sxxc2 (ji,jj) * z1_area
671               tabres(ji,jj,29) = syyc2 (ji,jj) * z1_area
672               tabres(ji,jj,30) = sxyc2 (ji,jj) * z1_area
673               tabres(ji,jj,31) = sxst  (ji,jj) * z1_area
674               tabres(ji,jj,32) = syst  (ji,jj) * z1_area
675               tabres(ji,jj,33) = sxxst (ji,jj) * z1_area
676               tabres(ji,jj,34) = syyst (ji,jj) * z1_area
677               tabres(ji,jj,35) = sxyst (ji,jj) * z1_area
678
679               tabres(ji,jj,36) = s0ice (ji,jj)! * z1_area
680               tabres(ji,jj,37) = s0a   (ji,jj)! * z1_area
681               tabres(ji,jj,38) = s0sn  (ji,jj)! * z1_area
682               tabres(ji,jj,39) = s0c0  (ji,jj)! * z1_area
683               tabres(ji,jj,40) = s0c1  (ji,jj)! * z1_area
684               tabres(ji,jj,41) = s0c2  (ji,jj)! * z1_area
685               tabres(ji,jj,42) = s0st  (ji,jj)! * z1_area
686            ENDIF
687         END DO
688      END DO
689      !
690   END SUBROUTINE interp_sadv_ice
691
692#else
693CONTAINS
694   SUBROUTINE agrif_lim2_interp_empty
695      !!---------------------------------------------
696      !!   *** ROUTINE agrif_lim2_interp_empty ***
697      !!---------------------------------------------
698      WRITE(*,*)  'agrif_lim2_interp : You should not have seen this print! error?'
699   END SUBROUTINE agrif_lim2_interp_empty
700#endif
701END MODULE agrif_lim2_interp
Note: See TracBrowser for help on using the repository browser.