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.
crsdom.F90 in NEMO/trunk/src/OCE/CRS – NEMO

source: NEMO/trunk/src/OCE/CRS/crsdom.F90 @ 11536

Last change on this file since 11536 was 11536, checked in by smasson, 5 years ago

trunk: merge dev_r10984_HPC-13 into the trunk

  • Property svn:keywords set to Id
File size: 111.0 KB
Line 
1MODULE crsdom
2   !!===================================================================
3   !!                  ***  crs.F90 ***
4   !!  Purpose: Interface for calculating quantities from a 
5   !!           higher-resolution grid for the coarse grid.
6   !!
7   !!  Method:  Given the user-defined reduction factor,
8   !!           the averaging bins are set:
9   !!           - nn_binref = 0, starting from the north
10   !!           to the south in the model interior domain,
11   !!           in this way the north fold and redundant halo cells 
12   !!           could be handled in a consistent manner and
13   !!           the irregularities of bin size can be handled
14   !!           more naturally by the presence of land
15   !!           in the southern boundary.  Thus the southernmost bin
16   !!           could be of an irregular bin size.
17   !!           Information on the parent grid is retained, specifically,
18   !!           each coarse grid cell's volume and ocean surface
19   !!           at the faces, relative to the parent grid.
20   !!           - nn_binref = 1 (not yet available), starting
21   !!           at a centralized bin at the equator, being only
22   !!           truly centered for odd-numbered j-direction reduction
23   !!           factors.
24   !!  References:  Aumont, O., J.C. Orr, D. Jamous, P. Monfray
25   !!               O. Marti and G. Madec, 1998. A degradation
26   !!               approach to accelerate simulations to steady-state
27   !!               in a 3-D tracer transport model of the global ocean.
28   !!               Climate Dynamics, 14:101-116.
29   !!  History:
30   !!       Original.   May 2012.  (J. Simeon, C. Calone, G. Madec, C. Ethe)
31   !!===================================================================
32   USE dom_oce        ! ocean space and time domain and to get jperio
33   USE crs            ! domain for coarse grid
34   !
35   USE in_out_manager 
36   USE par_kind
37   USE crslbclnk
38   USE lib_mpp
39
40   IMPLICIT NONE
41
42   PRIVATE
43
44   PUBLIC crs_dom_ope
45   PUBLIC crs_dom_e3, crs_dom_sfc, crs_dom_msk, crs_dom_hgr, crs_dom_coordinates
46   PUBLIC crs_dom_facvol, crs_dom_def, crs_dom_bat
47
48   INTERFACE crs_dom_ope
49      MODULE PROCEDURE crs_dom_ope_3d, crs_dom_ope_2d
50   END INTERFACE
51
52   REAL(wp) :: r_inf = 1e+36
53
54   !!----------------------------------------------------------------------
55   !! NEMO/OCE 4.0 , NEMO Consortium (2018)
56   !! $Id$
57   !! Software governed by the CeCILL license (see ./LICENSE)
58   !!----------------------------------------------------------------------
59CONTAINS
60
61   SUBROUTINE crs_dom_msk
62     
63      INTEGER  ::  ji, jj, jk                   ! dummy loop indices
64      INTEGER  ::  ijie,ijis,ijje,ijjs,ij,je_2
65      REAL(wp) ::  zmask
66     
67      ! Initialize
68
69      tmask_crs(:,:,:) = 0.0
70      vmask_crs(:,:,:) = 0.0
71      umask_crs(:,:,:) = 0.0
72      fmask_crs(:,:,:) = 0.0
73 
74           
75      IF( nldj_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN     !!cc bande du sud style ORCA2
76         IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN
77            je_2 = mje_crs(2)   ;  ij = je_2
78         ENDIF
79      ELSE
80         je_2 = mje_crs(2)      ;  ij = mjs_crs(2) 
81      ENDIF
82      DO jk = 1, jpkm1
83         DO ji = 2, nlei_crs 
84            ijis = mis_crs(ji)  ;  ijie = mie_crs(ji)   
85            !         
86            zmask = 0.0
87            zmask = SUM( tmask(ijis:ijie,ij:je_2,jk) ) 
88            IF ( zmask > 0.0 ) tmask_crs(ji,2,jk) = 1.0
89               
90            zmask = 0.0
91            zmask = SUM( vmask(ijis:ijie,je_2     ,jk) ) 
92            IF ( zmask > 0.0 ) vmask_crs(ji,2,jk) = 1.0
93               
94            zmask = 0.0
95            zmask = SUM(umask(ijie,ij:je_2,jk))   
96            IF ( zmask > 0.0 ) umask_crs(ji,2,jk) = 1.0
97               
98            fmask_crs(ji,je_2,jk) = fmask(ijie,2,jk)
99         ENDDO
100      ENDDO
101      !
102      DO jk = 1, jpkm1
103         DO ji = 2, nlei_crs 
104            ijis = mis_crs(ji)     ;   ijie = mie_crs(ji)       
105            DO jj = 3, nlej_crs
106               ijjs = mjs_crs(jj)  ;   ijje = mje_crs(jj)
107                         
108               zmask = 0.0
109               zmask = SUM( tmask(ijis:ijie,ijjs:ijje,jk) ) 
110               IF ( zmask > 0.0 ) tmask_crs(ji,jj,jk) = 1.0
111               
112               zmask = 0.0
113               zmask = SUM( vmask(ijis:ijie,ijje     ,jk) ) 
114               IF ( zmask > 0.0 ) vmask_crs(ji,jj,jk) = 1.0
115               
116               zmask = 0.0
117               zmask = SUM( umask(ijie     ,ijjs:ijje,jk) ) 
118               IF ( zmask > 0.0 ) umask_crs(ji,jj,jk) = 1.0
119               
120               fmask_crs(ji,jj,jk) = fmask(ijie,ijje,jk) 
121            ENDDO
122         ENDDO
123      ENDDO
124
125      !
126      CALL crs_lbc_lnk( tmask_crs, 'T', 1.0 )
127      CALL crs_lbc_lnk( vmask_crs, 'V', 1.0 )
128      CALL crs_lbc_lnk( umask_crs, 'U', 1.0 )
129      CALL crs_lbc_lnk( fmask_crs, 'F', 1.0 )
130      !
131   END SUBROUTINE crs_dom_msk
132
133
134   SUBROUTINE crs_dom_coordinates( p_gphi, p_glam, cd_type, p_gphi_crs, p_glam_crs )
135      !!----------------------------------------------------------------
136      !!               *** SUBROUTINE crs_coordinates ***
137      !! ** Purpose :  Determine the coordinates for the coarse grid
138      !!
139      !! ** Method  :  From the parent grid subset, search for the central
140      !!               point.  For an odd-numbered reduction factor,
141      !!               the coordinate will be that of the central T-cell.
142      !!               For an even-numbered reduction factor, of a non-square
143      !!               coarse grid box, the coordinate will be that of
144      !!               the east or north face or more likely.  For a square
145      !!               coarse grid box, the coordinate will be that of
146      !!               the central f-corner.
147      !!
148      !! ** Input   :  p_gphi = parent grid gphi[t|u|v|f]
149      !!               p_glam = parent grid glam[t|u|v|f]
150      !!               cd_type  = grid type (T,U,V,F)
151      !! ** Output  :  p_gphi_crs = coarse grid gphi[t|u|v|f]
152      !!               p_glam_crs = coarse grid glam[t|u|v|f]
153      !!             
154      !! History. 1 Jun.
155      !!----------------------------------------------------------------
156      !! Arguments
157      REAL(wp), DIMENSION(jpi,jpj)        , INTENT(in)  :: p_gphi  ! Parent grid latitude
158      REAL(wp), DIMENSION(jpi,jpj)        , INTENT(in)  :: p_glam  ! Parent grid longitude
159      CHARACTER(len=1),                     INTENT(in)  :: cd_type   ! grid type (T,U,V,F)
160      REAL(wp), DIMENSION(jpi_crs,jpj_crs), INTENT(out) :: p_gphi_crs  ! Coarse grid latitude
161      REAL(wp), DIMENSION(jpi_crs,jpj_crs), INTENT(out) :: p_glam_crs  ! Coarse grid longitude
162
163      !! Local variables
164      INTEGER :: ji, jj, jk                   ! dummy loop indices
165      INTEGER :: ijis, ijjs
166
167 
168      SELECT CASE ( cd_type )
169         CASE ( 'T' )
170            DO jj =  nldj_crs, nlej_crs
171               ijjs = mjs_crs(jj) + mybinctr
172               DO ji = 2, nlei_crs
173                  ijis = mis_crs(ji) + mxbinctr 
174                  p_gphi_crs(ji,jj) = p_gphi(ijis,ijjs)
175                  p_glam_crs(ji,jj) = p_glam(ijis,ijjs)
176               ENDDO
177            ENDDO
178         CASE ( 'U' )
179            DO jj =  nldj_crs, nlej_crs
180               ijjs = mjs_crs(jj) + mybinctr                 
181               DO ji = 2, nlei_crs
182                  ijis = mis_crs(ji)
183                  p_gphi_crs(ji,jj) = p_gphi(ijis,ijjs)
184                  p_glam_crs(ji,jj) = p_glam(ijis,ijjs)
185               ENDDO
186            ENDDO
187         CASE ( 'V' )
188            DO jj =  nldj_crs, nlej_crs
189               ijjs = mjs_crs(jj)
190               DO ji = 2, nlei_crs
191                  ijis = mis_crs(ji) + mxbinctr 
192                  p_gphi_crs(ji,jj) = p_gphi(ijis,ijjs)
193                  p_glam_crs(ji,jj) = p_glam(ijis,ijjs)
194               ENDDO
195            ENDDO
196         CASE ( 'F' )
197            DO jj =  nldj_crs, nlej_crs
198               ijjs = mjs_crs(jj)
199               DO ji = 2, nlei_crs
200                  ijis = mis_crs(ji)
201                  p_gphi_crs(ji,jj) = p_gphi(ijis,ijjs)
202                  p_glam_crs(ji,jj) = p_glam(ijis,ijjs)
203               ENDDO
204            ENDDO
205      END SELECT
206
207      ! Retroactively add back the boundary halo cells.
208      CALL crs_lbc_lnk( p_gphi_crs, cd_type, 1.0 )
209      CALL crs_lbc_lnk( p_glam_crs, cd_type, 1.0 )
210         
211      ! Fill up jrow=1 which is zeroed out or not handled by lbc_lnk and lbc_nfd
212      SELECT CASE ( cd_type )
213         CASE ( 'T', 'V' )
214            DO ji = 2, nlei_crs
215               ijis = mis_crs(ji) + mxbinctr 
216               p_gphi_crs(ji,1) = p_gphi(ijis,1)
217               p_glam_crs(ji,1) = p_glam(ijis,1)
218            ENDDO
219         CASE ( 'U', 'F' )
220            DO ji = 2, nlei_crs
221               ijis = mis_crs(ji) 
222               p_gphi_crs(ji,1) = p_gphi(ijis,1)
223               p_glam_crs(ji,1) = p_glam(ijis,1)
224            ENDDO
225      END SELECT
226      !
227   END SUBROUTINE crs_dom_coordinates
228
229  SUBROUTINE crs_dom_hgr( p_e1, p_e2, cd_type, p_e1_crs, p_e2_crs )
230      !!----------------------------------------------------------------
231      !!               *** SUBROUTINE crs_dom_hgr ***
232      !!
233      !! ** Purpose :  Get coarse grid horizontal scale factors and unmasked fraction
234      !!
235      !! ** Method  :  For grid types T,U,V,Fthe 2D scale factors of
236      !!               the coarse grid are the sum of the east or north faces of the
237      !!               parent grid subset comprising the coarse grid box.     
238      !!               - e1,e2 Scale factors
239      !!                 Valid arguments:
240      !! ** Inputs  : p_e1, p_e2  = parent grid e1 or e2 (t,u,v,f)
241      !!              cd_type     = grid type (T,U,V,F) for scale factors; for velocities (U or V)
242      !! ** Outputs : p_e1_crs, p_e2_crs  = parent grid e1 or e2 (t,u,v,f)
243      !!
244      !! History.     4 Jun.  Write for WGT and scale factors only
245      !!----------------------------------------------------------------
246      !!
247      !!  Arguments
248      REAL(wp), DIMENSION(jpi,jpj)        , INTENT(in)  :: p_e1     ! Parent grid U,V scale factors (e1)
249      REAL(wp), DIMENSION(jpi,jpj)        , INTENT(in)  :: p_e2     ! Parent grid U,V scale factors (e2)
250      CHARACTER(len=1)                    , INTENT(in)  :: cd_type  ! grid type U,V
251
252      REAL(wp), DIMENSION(jpi_crs,jpj_crs), INTENT(out) :: p_e1_crs ! Coarse grid box 2D quantity
253      REAL(wp), DIMENSION(jpi_crs,jpj_crs), INTENT(out) :: p_e2_crs ! Coarse grid box 2D quantity
254
255      !! Local variables
256      INTEGER :: ji, jj, jk     ! dummy loop indices
257      INTEGER :: ijie,ijje,ijrs
258 
259      !!---------------------------------------------------------------- 
260      ! Initialize     
261
262      DO jk = 1, jpk   
263         DO ji = 2, nlei_crs
264            ijie = mie_crs(ji)
265            DO jj = nldj_crs, nlej_crs
266               ijje = mje_crs(jj)   ;   ijrs =  mje_crs(jj) - mjs_crs(jj)
267               ! Only for a factro 3 coarsening
268               SELECT CASE ( cd_type )
269                   CASE ( 'T' )
270                      IF( ijrs == 0 .OR. ijrs == 1 ) THEN
271                        ! Si à la frontière sud on a pas assez de maille de la grille mère
272                         p_e1_crs(ji,jj) = p_e1(ijie-1,ijje) * nn_factx
273                         p_e2_crs(ji,jj) = p_e2(ijie-1,ijje) * nn_facty
274                      ELSE
275                         p_e1_crs(ji,jj) = p_e1(ijie-1,ijje-1) * nn_factx
276                         p_e2_crs(ji,jj) = p_e2(ijie-1,ijje-1) * nn_facty
277                      ENDIF
278                   CASE ( 'U' )
279                      IF( ijrs == 0 .OR. ijrs == 1 ) THEN
280                         ! Si à la frontière sud on a pas assez de maille de la grille mère
281                         p_e1_crs(ji,jj) = p_e1(ijie,ijje) * nn_factx                           
282                         p_e2_crs(ji,jj) = p_e2(ijie,ijje) * nn_facty
283                      ELSE
284                         p_e1_crs(ji,jj) = p_e1(ijie,ijje-1) * nn_factx
285                         p_e2_crs(ji,jj) = p_e2(ijie,ijje-1) * nn_facty
286                      ENDIF
287                   CASE ( 'V' )
288                         p_e1_crs(ji,jj) = p_e1(ijie-1,ijje) * nn_factx                           
289                         p_e2_crs(ji,jj) = p_e2(ijie-1,ijje) * nn_facty
290                   CASE ( 'F' )
291                         p_e1_crs(ji,jj) = p_e1(ijie,ijje) * nn_factx                           
292                         p_e2_crs(ji,jj) = p_e2(ijie,ijje) * nn_facty
293               END SELECT
294            ENDDO
295         ENDDO
296      ENDDO
297
298      CALL crs_lbc_lnk( p_e1_crs, cd_type, 1.0, pfillval=1.0 )
299      CALL crs_lbc_lnk( p_e2_crs, cd_type, 1.0, pfillval=1.0 )
300
301   END SUBROUTINE crs_dom_hgr
302
303
304   SUBROUTINE crs_dom_facvol( p_mask, cd_type, p_e1, p_e2, p_e3, p_fld1_crs, p_fld2_crs )
305      !!----------------------------------------------------------------
306      !!               *** SUBROUTINE crsfun_wgt ***
307      !! ** Purpose :  Three applications.
308      !!               1) SUM. Get coarse grid horizontal scale factors and unmasked fraction
309      !!               2) VOL. Get coarse grid box volumes
310      !!               3) WGT. Weighting multiplier for volume-weighted and/or
311      !!                       area-weighted averages.
312      !!                       Weights (i.e. the denominator) calculated here
313      !!                       to avoid IF-tests and division.
314      !! ** Method  :  1) SUM.  For grid types T,U,V,F (and W) the 2D scale factors of
315      !!               the coarse grid are the sum of the east or north faces of the
316      !!               parent grid subset comprising the coarse grid box. 
317      !!               The fractions of masked:total surface (3D) on the east,
318      !!               north and top faces is, optionally, also output.
319      !!               - Top face area sum
320      !!                 Valid arguments: cd_type, cd_op='W', p_pmask, p_e1, p_e2
321      !!               - Top face ocean surface fraction
322      !!                 Valid arguments: cd_type, cd_op='W', p_pmask, p_e1, p_e2       
323      !!               - e1,e2 Scale factors
324      !!                 Valid arguments:
325      !!               2) VOL.  For grid types W and T, the coarse grid box
326      !!               volumes are output. Also optionally, the fraction of 
327      !!               masked:total volume of the parent grid subset is output (i.e. facvol).
328      !!               3) WGT. Based on the grid type, the denominator is pre-determined here to 
329      !!               perform area- or volume- weighted averages,
330      !!               to avoid IF-tests and divisions.
331      !! ** Inputs  : p_e1, p_e2  = parent grid e1 or e2 (t,u,v,f)
332      !!              p_pmask     = parent grid mask (T,U,V,F)
333      !!              cd_type     = grid type (T,U,V,F) for scale factors; for velocities (U or V)
334      !!              cd_op       = applied operation (SUM, VOL, WGT)
335      !!              p_e3      = (Optional) parent grid vertical level thickness (e3u or e3v)
336      !! ** Outputs : p_cfield2d_1 = (Optional) 2D field on coarse grid
337      !!              p_cfield2d_2 = (Optional) 2D field on coarse grid
338      !!              p_cfield3d_1 = (Optional) 3D field on coarse grid
339      !!              p_cfield3d_2 = (Optional) 3D field on coarse grid
340      !!
341      !! History.     4 Jun.  Write for WGT and scale factors only
342      !!----------------------------------------------------------------
343      CHARACTER(len=1),                         INTENT(in   ) ::   cd_type    ! grid type U,V
344      REAL(wp), DIMENSION(jpi,jpj,jpk)        , INTENT(in   ) ::   p_mask     ! Parent grid U,V mask
345      REAL(wp), DIMENSION(jpi,jpj)            , INTENT(in   ) ::   p_e1       ! Parent grid U,V scale factors (e1)
346      REAL(wp), DIMENSION(jpi,jpj)            , INTENT(in   ) ::   p_e2       ! Parent grid U,V scale factors (e2)
347      REAL(wp), DIMENSION(jpi,jpj,jpk)        , INTENT(in   ) ::   p_e3       ! Parent grid vertical level thickness (e3u, e3v)
348      REAL(wp), DIMENSION(jpi_crs,jpj_crs,jpk), INTENT(  out) ::   p_fld1_crs ! Coarse grid box 3D quantity
349      REAL(wp), DIMENSION(jpi_crs,jpj_crs,jpk), INTENT(  out) ::   p_fld2_crs ! Coarse grid box 3D quantity
350      !
351      INTEGER  ::   ji, jj, jk , ii, ij, je_2
352      REAL(wp) ::   zdAm
353      REAL(wp), DIMENSION(jpi,jpj,jpk) ::   zvol, zmask     
354      !!---------------------------------------------------------------- 
355      !
356      !
357      p_fld1_crs(:,:,:) = 0._wp
358      p_fld2_crs(:,:,:) = 0._wp
359
360      DO jk = 1, jpk
361         zvol(:,:,jk) =  p_e1(:,:) * p_e2(:,:) * p_e3(:,:,jk) 
362      END DO
363
364      zmask(:,:,:) = 0._wp
365      IF( cd_type == 'W' ) THEN
366         zmask(:,:,1) = p_mask(:,:,1) 
367         DO jk = 2, jpk
368            zmask(:,:,jk) = p_mask(:,:,jk-1) 
369         ENDDO
370      ELSE
371         DO jk = 1, jpk
372             zmask(:,:,jk) = p_mask(:,:,jk) 
373         ENDDO
374      ENDIF
375
376      IF( nldj_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN     !!cc bande du sud style ORCA2
377         IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN
378            je_2 = mje_crs(2)
379            DO jk = 1, jpk           
380               DO ji = nistr, niend, nn_factx
381                  ii   = ( ji - mis_crs(2) ) * rfactx_r + 2                 ! cordinate in parent grid
382                  p_fld1_crs(ii,2,jk) =  zvol(ji,je_2  ,jk) + zvol(ji+1,je_2  ,jk) + zvol(ji+2,je_2  ,jk)  &
383                     &                 + zvol(ji,je_2-1,jk) + zvol(ji+1,je_2-1,jk) + zvol(ji+2,je_2-1,jk) 
384                  !
385                  zdAm =  zvol(ji  ,je_2,jk) * zmask(ji  ,je_2,jk)  &
386                    &   + zvol(ji+1,je_2,jk) * zmask(ji+1,je_2,jk)  &
387                    &   + zvol(ji+2,je_2,jk) * zmask(ji+2,je_2,jk) 
388                  !
389                  p_fld2_crs(ii,2,jk) = zdAm / p_fld1_crs(ii,2,jk) 
390               ENDDO
391            ENDDO
392         ENDIF
393      ELSE
394         je_2 = mjs_crs(2)
395         DO jk = 1, jpk           
396            DO ji = nistr, niend, nn_factx
397               ii   = ( ji - mis_crs(2) ) * rfactx_r + 2   
398               p_fld1_crs(ii,2,jk) =  zvol(ji,je_2  ,jk) + zvol(ji+1,je_2  ,jk) + zvol(ji+2,je_2  ,jk)  &
399                   &                + zvol(ji,je_2+1,jk) + zvol(ji+1,je_2+1,jk) + zvol(ji+2,je_2+1,jk)  &
400                   &                + zvol(ji,je_2+2,jk) + zvol(ji+1,je_2+2,jk) + zvol(ji+2,je_2+2,jk) 
401              !
402               zdAm = zvol(ji  ,je_2  ,jk) * zmask(ji  ,je_2  ,jk)  &
403                 &  + zvol(ji+1,je_2  ,jk) * zmask(ji+1,je_2  ,jk)  &
404                 &  + zvol(ji+2,je_2  ,jk) * zmask(ji+2,je_2  ,jk)  &
405                 &  + zvol(ji  ,je_2+1,jk) * zmask(ji  ,je_2+1,jk)  &
406                 &  + zvol(ji+1,je_2+1,jk) * zmask(ji+1,je_2+1,jk)  &
407                 &  + zvol(ji+2,je_2+1,jk) * zmask(ji+2,je_2+1,jk)  &
408                 &  + zvol(ji  ,je_2+2,jk) * zmask(ji  ,je_2+2,jk)  &
409                 &  + zvol(ji+1,je_2+2,jk) * zmask(ji+1,je_2+2,jk)  &
410                 &  + zvol(ji+2,je_2+2,jk) * zmask(ji+2,je_2+2,jk)
411                 !
412                 p_fld2_crs(ii,2,jk) = zdAm / p_fld1_crs(ii,2,jk) 
413            ENDDO
414         ENDDO
415      ENDIF
416
417      DO jk = 1, jpk           
418         DO jj  = njstr, njend, nn_facty
419            DO ji = nistr, niend, nn_factx
420               ii  = ( ji - mis_crs(2) ) * rfactx_r + 2                 ! cordinate in parent grid
421               ij  = ( jj - njstr ) * rfacty_r + 3
422               !
423               p_fld1_crs(ii,ij,jk) =  zvol(ji,jj  ,jk) + zvol(ji+1,jj  ,jk) + zvol(ji+2,jj  ,jk)  &
424                   &                 + zvol(ji,jj+1,jk) + zvol(ji+1,jj+1,jk) + zvol(ji+2,jj+1,jk)  &
425                   &                 + zvol(ji,jj+2,jk) + zvol(ji+1,jj+2,jk) + zvol(ji+2,jj+2,jk) 
426               !
427               zdAm =  zvol(ji  ,jj  ,jk) * zmask(ji  ,jj  ,jk)  &
428                 &   + zvol(ji+1,jj  ,jk) * zmask(ji+1,jj  ,jk)  &
429                 &   + zvol(ji+2,jj  ,jk) * zmask(ji+2,jj  ,jk)  &
430                 &   + zvol(ji  ,jj+1,jk) * zmask(ji  ,jj+1,jk)  &
431                 &   + zvol(ji+1,jj+1,jk) * zmask(ji+1,jj+1,jk)  &
432                 &   + zvol(ji+2,jj+1,jk) * zmask(ji+2,jj+1,jk)  &
433                 &   + zvol(ji  ,jj+2,jk) * zmask(ji  ,jj+2,jk)  &
434                 &   + zvol(ji+1,jj+2,jk) * zmask(ji+1,jj+2,jk)  &
435                 &   + zvol(ji+2,jj+2,jk) * zmask(ji+2,jj+2,jk)
436                 !
437                p_fld2_crs(ii,ij,jk) = zdAm / p_fld1_crs(ii,ij,jk) 
438            ENDDO
439         ENDDO
440      ENDDO
441      !                                             !  Retroactively add back the boundary halo cells.
442      CALL crs_lbc_lnk( p_fld1_crs, cd_type, 1.0 ) 
443      CALL crs_lbc_lnk( p_fld2_crs, cd_type, 1.0 ) 
444      !
445      !
446   END SUBROUTINE crs_dom_facvol
447
448
449   SUBROUTINE crs_dom_ope_3d( p_fld, cd_op, cd_type, p_mask, p_fld_crs, p_e12, p_e3, p_surf_crs, p_mask_crs, psgn )
450      !!----------------------------------------------------------------
451      !!               *** SUBROUTINE crsfun_UV ***
452      !! ** Purpose :  Average, area-weighted, of U or V on the east and north faces
453      !!
454      !! ** Method  :  The U and V velocities (3D) are determined as the area-weighted averages
455      !!               on the east and north faces, respectively,
456      !!               of the parent grid subset comprising the coarse grid box.
457      !!               In the case of the V and F grid, the last jrow minus 1 is spurious.
458      !! ** Inputs  : p_e1_e2     = parent grid e1 or e2 (t,u,v,f)
459      !!              cd_type     = grid type (T,U,V,F) for scale factors; for velocities (U or V)
460      !!              psgn        = sign change over north fold (See lbclnk.F90)
461      !!              p_pmask     = parent grid mask (T,U,V,F) for scale factors;
462      !!                                       for velocities (U or V)
463      !!              p_e3      = parent grid vertical level thickness (e3u or e3v)
464      !!              p_pfield    = U or V on the parent grid
465      !!              p_surf_crs  = (Optional) Coarse grid weight for averaging
466      !! ** Outputs : p_cfield3d = 3D field on coarse grid
467      !!
468      !! History.  29 May.  completed draft.
469      !!            4 Jun.  Revision for WGT
470      !!            5 Jun.  Streamline for area-weighted average only ; separate scale factor and weights.
471      !!----------------------------------------------------------------
472      REAL(wp), DIMENSION(jpi,jpj,jpk),         INTENT(in)           :: p_fld      ! T, U, V or W on parent grid
473      CHARACTER(len=3),                         INTENT(in)           :: cd_op      ! Operation SUM, MAX or MIN
474      CHARACTER(len=1),                         INTENT(in)           :: cd_type    ! grid type U,V
475      REAL(wp), DIMENSION(jpi,jpj,jpk),         INTENT(in)           :: p_mask     ! Parent grid T,U,V mask
476      REAL(wp), DIMENSION(jpi,jpj),             INTENT(in), OPTIONAL :: p_e12      ! Parent grid T,U,V scale factors (e1 or e2)
477      REAL(wp), DIMENSION(jpi,jpj,jpk),         INTENT(in), OPTIONAL :: p_e3       ! Parent grid vertical level thickness (e3u, e3v)
478      REAL(wp), DIMENSION(jpi_crs,jpj_crs,jpk), INTENT(in), OPTIONAL :: p_surf_crs ! Coarse grid area-weighting denominator   
479      REAL(wp), DIMENSION(jpi_crs,jpj_crs,jpk), INTENT(in), OPTIONAL :: p_mask_crs ! Coarse grid T,U,V maska
480      REAL(wp),                                 INTENT(in)           :: psgn       ! sign
481      REAL(wp), DIMENSION(jpi_crs,jpj_crs,jpk), INTENT(  out)        :: p_fld_crs  ! Coarse grid box 3D quantity
482      !
483      INTEGER  ::   ji, jj, jk 
484      INTEGER  ::   ii, ij, ijie, ijje, je_2
485      REAL(wp) ::   zflcrs, zsfcrs   
486      REAL(wp), DIMENSION(:,:,:), ALLOCATABLE ::   zsurf, zsurfmsk, zmask 
487      !!---------------------------------------------------------------- 
488      !
489      p_fld_crs(:,:,:) = 0._wp
490      !
491      SELECT CASE ( cd_op )
492      !
493      CASE ( 'VOL' )
494         !
495         ALLOCATE( zsurf(jpi,jpj,jpk), zsurfmsk(jpi,jpj,jpk) )
496         !   
497         SELECT CASE ( cd_type )
498         !   
499         CASE( 'T', 'W' )
500               IF( cd_type == 'T' ) THEN
501                     DO jk = 1, jpk
502                        zsurf   (:,:,jk) =  p_e12(:,:) * p_e3(:,:,jk) *  p_mask(:,:,jk) 
503                        zsurfmsk(:,:,jk) =  zsurf(:,:,jk) 
504                    ENDDO
505                  ELSE
506                     zsurf   (:,:,1) =  p_e12(:,:) * p_e3(:,:,1)
507                     zsurfmsk(:,:,1) =  zsurf(:,:,1) *  p_mask(:,:,1) 
508                     DO jk = 2, jpk
509                        zsurf   (:,:,jk) =  p_e12(:,:) * p_e3(:,:,jk)
510                        zsurfmsk(:,:,jk) =  zsurf(:,:,jk) * p_mask(:,:,jk-1) 
511                     ENDDO
512                  ENDIF
513         
514                  IF( nldj_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN     !!cc bande du sud style ORCA2
515                     IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN
516                        je_2 = mje_crs(2)
517                        DO jk = 1, jpk           
518                           DO ji = nistr, niend, nn_factx
519                              ii   = ( ji - mis_crs(2) ) * rfactx_r + 2       
520                              zflcrs =  p_fld(ji  ,je_2,jk) * zsurfmsk(ji  ,je_2,jk)   &
521                                &     + p_fld(ji+1,je_2,jk) * zsurfmsk(ji+1,je_2,jk)   &
522                                &     + p_fld(ji+2,je_2,jk) * zsurfmsk(ji+2,je_2,jk) 
523 
524                              zsfcrs =  zsurf(ji,je_2,jk) + zsurf(ji+1,je_2,jk) + zsurf(ji+2,je_2,jk) 
525                              !
526                              p_fld_crs(ii,2,jk) = zflcrs
527                              IF( zsfcrs /= 0.0 )  p_fld_crs(ii,2,jk) = zflcrs / zsfcrs
528                           ENDDO
529                        ENDDO
530                     ENDIF
531                  ELSE
532                     je_2 = mjs_crs(2)
533                     DO jk = 1, jpk           
534                        DO ji = nistr, niend, nn_factx
535                           ii   = ( ji - mis_crs(2) ) * rfactx_r + 2   
536                           zflcrs =  p_fld(ji  ,je_2  ,jk) * zsurfmsk(ji  ,je_2  ,jk) &
537                             &     + p_fld(ji+1,je_2  ,jk) * zsurfmsk(ji+1,je_2  ,jk) &
538                             &     + p_fld(ji+2,je_2  ,jk) * zsurfmsk(ji+2,je_2  ,jk) &
539                             &     + p_fld(ji  ,je_2+1,jk) * zsurfmsk(ji  ,je_2+1,jk) &
540                             &     + p_fld(ji+1,je_2+1,jk) * zsurfmsk(ji+1,je_2+1,jk) &
541                             &     + p_fld(ji+2,je_2+1,jk) * zsurfmsk(ji+2,je_2+1,jk) &
542                             &     + p_fld(ji  ,je_2+2,jk) * zsurfmsk(ji  ,je_2+2,jk) &
543                             &     + p_fld(ji+1,je_2+2,jk) * zsurfmsk(ji+1,je_2+2,jk) &
544                             &     + p_fld(ji+2,je_2+2,jk) * zsurfmsk(ji+2,je_2+2,jk) 
545
546                           zsfcrs =  zsurf(ji,je_2  ,jk) + zsurf(ji+1,je_2  ,jk) + zsurf(ji+2,je_2  ,jk) &
547                             &     + zsurf(ji,je_2+1,jk) + zsurf(ji+1,je_2+1,jk) + zsurf(ji+2,je_2+1,jk) &
548                             &     + zsurf(ji,je_2+2,jk) + zsurf(ji+1,je_2+2,jk) + zsurf(ji+2,je_2+2,jk) 
549                            !
550                            p_fld_crs(ii,2,jk) = zflcrs
551                            IF( zsfcrs /= 0.0 )  p_fld_crs(ii,2,jk) = zflcrs / zsfcrs
552                        ENDDO
553                     ENDDO
554                  ENDIF
555                  !
556                  DO jk = 1, jpk           
557                     DO jj  = njstr, njend, nn_facty
558                        DO ji = nistr, niend, nn_factx
559                           ii = ( ji - mis_crs(2) ) * rfactx_r + 2                 ! cordinate in parent grid
560                           ij = ( jj - njstr ) * rfacty_r + 3
561                           zflcrs =  p_fld(ji  ,jj  ,jk) * zsurfmsk(ji  ,jj  ,jk) &
562                             &     + p_fld(ji+1,jj  ,jk) * zsurfmsk(ji+1,jj  ,jk) &
563                             &     + p_fld(ji+2,jj  ,jk) * zsurfmsk(ji+2,jj  ,jk) &
564                             &     + p_fld(ji  ,jj+1,jk) * zsurfmsk(ji  ,jj+1,jk) &
565                             &     + p_fld(ji+1,jj+1,jk) * zsurfmsk(ji+1,jj+1,jk) &
566                             &     + p_fld(ji+2,jj+1,jk) * zsurfmsk(ji+2,jj+1,jk) &
567                             &     + p_fld(ji  ,jj+2,jk) * zsurfmsk(ji  ,jj+2,jk) &
568                             &     + p_fld(ji+1,jj+2,jk) * zsurfmsk(ji+1,jj+2,jk) &
569                             &     + p_fld(ji+2,jj+2,jk) * zsurfmsk(ji+2,jj+2,jk) 
570
571                           zsfcrs =  zsurf(ji,jj  ,jk) + zsurf(ji+1,jj  ,jk) + zsurf(ji+2,jj  ,jk) &
572                             &     + zsurf(ji,jj+1,jk) + zsurf(ji+1,jj+1,jk) + zsurf(ji+2,jj+1,jk) &
573                             &     + zsurf(ji,jj+2,jk) + zsurf(ji+1,jj+2,jk) + zsurf(ji+2,jj+2,jk) 
574                            !
575                           p_fld_crs(ii,ij,jk) = zflcrs
576                           IF( zsfcrs /= 0.0 )  p_fld_crs(ii,ij,jk) = zflcrs / zsfcrs
577                        ENDDO     
578                     ENDDO
579                  ENDDO 
580               CASE DEFAULT
581                  CALL ctl_stop( 'STOP', 'error from crs_dom_ope_3d, you should not be there...' )
582               END SELECT
583
584              DEALLOCATE( zsurf, zsurfmsk )
585
586         CASE ( 'SUM' )
587         
588            ALLOCATE( zsurfmsk(jpi,jpj,jpk) )
589
590            SELECT CASE ( cd_type )
591              CASE( 'W' )
592                  IF( PRESENT( p_e3 ) ) THEN
593                    zsurfmsk(:,:,1) =  p_e12(:,:) * p_e3(:,:,1) * p_mask(:,:,1) 
594                    DO jk = 2, jpk
595                      zsurfmsk(:,:,jk) =  p_e12(:,:) * p_e3(:,:,jk) * p_mask(:,:,jk-1) 
596                    ENDDO
597                 ELSE
598                    zsurfmsk(:,:,1) =  p_e12(:,:) * p_mask(:,:,1) 
599                    DO jk = 2, jpk
600                      zsurfmsk(:,:,jk) =  p_e12(:,:) * p_mask(:,:,jk-1) 
601                    ENDDO
602                 ENDIF
603              CASE DEFAULT
604                 IF( PRESENT( p_e3 ) ) THEN
605                    DO jk = 1, jpk
606                      zsurfmsk(:,:,jk) =  p_e12(:,:) * p_e3(:,:,jk) * p_mask(:,:,jk) 
607                    ENDDO
608                 ELSE
609                    DO jk = 1, jpk
610                      zsurfmsk(:,:,jk) =  p_e12(:,:) * p_mask(:,:,jk) 
611                    ENDDO
612                 ENDIF
613              END SELECT
614
615            SELECT CASE ( cd_type )
616           
617               CASE( 'T', 'W' )
618         
619                  IF( nldj_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN     !!cc bande du sud style ORCA2
620                     IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN
621                        je_2 = mje_crs(2)
622                        DO jk = 1, jpk           
623                           DO ji = nistr, niend, nn_factx
624                              ii   = ( ji - mis_crs(2) ) * rfactx_r + 2         
625                              zflcrs  =  p_fld(ji  ,je_2,jk) * zsurfmsk(ji  ,je_2,jk) &
626                                &      + p_fld(ji+1,je_2,jk) * zsurfmsk(ji+1,je_2,jk) &
627                                &      + p_fld(ji+2,je_2,jk) * zsurfmsk(ji+2,je_2,jk) 
628                               !
629                              p_fld_crs(ii,2,jk) = zflcrs
630                           ENDDO
631                        ENDDO
632                      ENDIF
633                  ELSE
634                     je_2 = mjs_crs(2)
635                     DO jk = 1, jpk           
636                        DO ji = nistr, niend, nn_factx
637                           ii   = ( ji - mis_crs(2) ) * rfactx_r + 2   
638                           zflcrs  =  p_fld(ji  ,je_2  ,jk) * zsurfmsk(ji  ,je_2  ,jk)  &
639                             &      + p_fld(ji+1,je_2  ,jk) * zsurfmsk(ji+1,je_2  ,jk)  &
640                             &      + p_fld(ji+2,je_2  ,jk) * zsurfmsk(ji+2,je_2  ,jk)  &
641                             &      + p_fld(ji  ,je_2+1,jk) * zsurfmsk(ji  ,je_2+1,jk)  &
642                             &      + p_fld(ji+1,je_2+1,jk) * zsurfmsk(ji+1,je_2+1,jk)  &
643                             &      + p_fld(ji+2,je_2+1,jk) * zsurfmsk(ji+2,je_2+1,jk)  &
644                             &      + p_fld(ji  ,je_2+2,jk) * zsurfmsk(ji  ,je_2+2,jk)  &
645                             &      + p_fld(ji+1,je_2+2,jk) * zsurfmsk(ji+1,je_2+2,jk)  &
646                             &      + p_fld(ji+2,je_2+2,jk) * zsurfmsk(ji+2,je_2+2,jk) 
647                            !
648                            p_fld_crs(ii,2,jk) = zflcrs
649                        ENDDO
650                     ENDDO
651                  ENDIF
652                  !
653                  DO jk = 1, jpk           
654                     DO jj  = njstr, njend, nn_facty
655                        DO ji = nistr, niend, nn_factx
656                           ii  = ( ji - mis_crs(2) ) * rfactx_r + 2                 ! cordinate in parent grid
657                           ij  = ( jj - njstr ) * rfacty_r + 3
658                           zflcrs  =  p_fld(ji  ,jj  ,jk) * zsurfmsk(ji  ,jj  ,jk)  &
659                             &      + p_fld(ji+1,jj  ,jk) * zsurfmsk(ji+1,jj  ,jk)  &
660                             &      + p_fld(ji+2,jj  ,jk) * zsurfmsk(ji+2,jj  ,jk)  &
661                             &      + p_fld(ji  ,jj+1,jk) * zsurfmsk(ji  ,jj+1,jk)  &
662                             &      + p_fld(ji+1,jj+1,jk) * zsurfmsk(ji+1,jj+1,jk)  &
663                             &      + p_fld(ji+2,jj+1,jk) * zsurfmsk(ji+2,jj+1,jk)  &
664                             &      + p_fld(ji  ,jj+2,jk) * zsurfmsk(ji  ,jj+2,jk)  &
665                             &      + p_fld(ji+1,jj+2,jk) * zsurfmsk(ji+1,jj+2,jk)  &
666                             &      + p_fld(ji+2,jj+2,jk) * zsurfmsk(ji+2,jj+2,jk) 
667                            !
668                            p_fld_crs(ii,ij,jk) = zflcrs
669                            !
670                        ENDDO     
671                     ENDDO
672                  ENDDO   
673           
674               CASE( 'V' )
675
676                  IF( nldj_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN     !!cc bande du sud style ORCA2
677                     IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN
678                        ijje = mje_crs(2)
679                     ENDIF
680                  ELSE
681                     ijje = mjs_crs(2)
682                  ENDIF
683                  !
684                  DO jk = 1, jpk           
685                     DO ji = nistr, niend, nn_factx
686                        ii   = ( ji - mis_crs(2) ) * rfactx_r + 2   
687                        zflcrs  =  p_fld(ji  ,ijje,jk) * zsurfmsk(ji  ,ijje,jk) &
688                          &      + p_fld(ji+1,ijje,jk) * zsurfmsk(ji+1,ijje,jk) &
689                          &      + p_fld(ji+2,ijje,jk) * zsurfmsk(ji+2,ijje,jk) 
690                          !
691                        p_fld_crs(ii,2,jk) = zflcrs
692                     ENDDO
693                  ENDDO
694                  !
695                  DO jk = 1, jpk           
696                     DO jj  = njstr, njend, nn_facty
697                        DO ji = nistr, niend, nn_factx
698                           ii   = ( ji - mis_crs(2) ) * rfactx_r + 2                 ! cordinate in parent grid
699                           ij   = ( jj - njstr ) * rfacty_r + 3
700                           ijje = mje_crs(ij)
701                           zflcrs  =  p_fld(ji  ,ijje,jk) * zsurfmsk(ji  ,ijje,jk) &
702                             &      + p_fld(ji+1,ijje,jk) * zsurfmsk(ji+1,ijje,jk) &
703                             &      + p_fld(ji+2,ijje,jk) * zsurfmsk(ji+2,ijje,jk) 
704                             !
705                           p_fld_crs(ii,ij,jk) = zflcrs
706                           !
707                        ENDDO     
708                     ENDDO
709                  ENDDO   
710           
711               CASE( 'U' )
712
713                  IF( nldj_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN     !!cc bande du sud style ORCA2
714                     IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN
715                        je_2 = mje_crs(2)
716                        DO jk = 1, jpk           
717                           DO ji = nistr, niend, nn_factx
718                              ii   = ( ji - mis_crs(2) ) * rfactx_r + 2 
719                              ijie = mie_crs(ii)
720                              zflcrs  =  p_fld(ijie,je_2,jk) * zsurfmsk(ijie,je_2,jk) 
721                              p_fld_crs(ii,2,jk) = zflcrs
722                           ENDDO
723                        ENDDO
724                      ENDIF
725                  ELSE
726                     je_2 = mjs_crs(2)
727                     DO jk = 1, jpk           
728                        DO ji = nistr, niend, nn_factx
729                           ii   = ( ji - mis_crs(2) ) * rfactx_r + 2   
730                           ijie = mie_crs(ii)
731                           zflcrs =  p_fld(ijie,je_2  ,jk) * zsurfmsk(ijie,je_2  ,jk)  &
732                             &     + p_fld(ijie,je_2+1,jk) * zsurfmsk(ijie,je_2+1,jk)  &
733                             &     + p_fld(ijie,je_2+2,jk) * zsurfmsk(ijie,je_2+2,jk) 
734
735                           p_fld_crs(ii,2,jk) = zflcrs
736                        ENDDO
737                     ENDDO
738                  ENDIF
739                  !
740                  DO jk = 1, jpk           
741                     DO jj  = njstr, njend, nn_facty
742                        DO ji = nistr, niend, nn_factx
743                           ii   = ( ji - mis_crs(2) ) * rfactx_r + 2     
744                           ij   = ( jj - njstr ) * rfacty_r + 3
745                           ijie = mie_crs(ii)
746                           zflcrs =  p_fld(ijie,jj  ,jk) * zsurfmsk(ijie,jj  ,jk)  &
747                              &    + p_fld(ijie,jj+1,jk) * zsurfmsk(ijie,jj+1,jk)  &
748                              &    + p_fld(ijie,jj+2,jk) * zsurfmsk(ijie,jj+2,jk) 
749                             !
750                           p_fld_crs(ii,ij,jk) = zflcrs
751                           !
752                        ENDDO     
753                     ENDDO
754                  ENDDO   
755
756              END SELECT
757
758              IF( PRESENT( p_surf_crs ) ) THEN
759                 WHERE ( p_surf_crs /= 0.0 ) p_fld_crs(:,:,:) = p_fld_crs(:,:,:) / p_surf_crs(:,:,:)
760              ENDIF
761
762              DEALLOCATE( zsurfmsk )
763
764         CASE ( 'MAX' )    !  search the max of unmasked grid cells
765
766            ALLOCATE( zmask(jpi,jpj,jpk) )
767
768            SELECT CASE ( cd_type )
769              CASE( 'W' )
770                  zmask(:,:,1) = p_mask(:,:,1) 
771                  DO jk = 2, jpk
772                     zmask(:,:,jk) = p_mask(:,:,jk-1) 
773                  ENDDO
774              CASE ( 'T' )
775                  DO jk = 1, jpk
776                     zmask(:,:,jk) = p_mask(:,:,jk) 
777                  ENDDO
778            END SELECT
779
780            SELECT CASE ( cd_type )
781           
782               CASE( 'T', 'W' )
783         
784                  IF( nldj_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN     !!cc bande du sud style ORCA2
785                     IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN
786                        je_2 = mje_crs(2)
787                        DO jk = 1, jpk           
788                           DO ji = nistr, niend, nn_factx
789                              ii   = ( ji - mis_crs(2) ) * rfactx_r + 2       
790                              zflcrs =  &
791                                & MAX( p_fld(ji  ,je_2,jk) * zmask(ji  ,je_2,jk) - ( 1.- zmask(ji  ,je_2,jk) ) * r_inf ,  &
792                                &      p_fld(ji+1,je_2,jk) * zmask(ji+1,je_2,jk) - ( 1.- zmask(ji+1,je_2,jk) ) * r_inf ,  &
793                                &      p_fld(ji+2,je_2,jk) * zmask(ji+2,je_2,jk) - ( 1.- zmask(ji+2,je_2,jk) ) * r_inf  )
794                              !
795                              p_fld_crs(ii,2,jk) = zflcrs
796                           ENDDO
797                        ENDDO
798                      ENDIF
799                  ELSE
800                     je_2 = mjs_crs(2)
801                     DO jk = 1, jpk           
802                        DO ji = nistr, niend, nn_factx
803                           ii   = ( ji - mis_crs(2) ) * rfactx_r + 2   
804                           zflcrs =  &
805                             & MAX( p_fld(ji  ,je_2  ,jk) * zmask(ji  ,je_2  ,jk) - ( 1.- zmask(ji  ,je_2  ,jk) ) * r_inf ,  &
806                             &      p_fld(ji+1,je_2  ,jk) * zmask(ji+1,je_2  ,jk) - ( 1.- zmask(ji+1,je_2  ,jk) ) * r_inf ,  &
807                             &      p_fld(ji+2,je_2  ,jk) * zmask(ji+2,je_2  ,jk) - ( 1.- zmask(ji+2,je_2  ,jk) ) * r_inf ,  &
808                             &      p_fld(ji  ,je_2+1,jk) * zmask(ji  ,je_2+1,jk) - ( 1.- zmask(ji  ,je_2+1,jk) ) * r_inf ,  &
809                             &      p_fld(ji+1,je_2+1,jk) * zmask(ji+1,je_2+1,jk) - ( 1.- zmask(ji+1,je_2+1,jk) ) * r_inf ,  &
810                             &      p_fld(ji+2,je_2+1,jk) * zmask(ji+2,je_2+1,jk) - ( 1.- zmask(ji+2,je_2+1,jk) ) * r_inf ,  &
811                             &      p_fld(ji  ,je_2+2,jk) * zmask(ji  ,je_2+2,jk) - ( 1.- zmask(ji  ,je_2+2,jk) ) * r_inf ,  &
812                             &      p_fld(ji+1,je_2+2,jk) * zmask(ji+1,je_2+2,jk) - ( 1.- zmask(ji+1,je_2+2,jk) ) * r_inf ,  &
813                             &      p_fld(ji+2,je_2+2,jk) * zmask(ji+2,je_2+2,jk) - ( 1.- zmask(ji+2,je_2+2,jk) ) * r_inf   )
814                           !
815                           p_fld_crs(ii,2,jk) = zflcrs
816                        ENDDO
817                     ENDDO
818                  ENDIF
819                  !
820                  DO jk = 1, jpk           
821                     DO jj  = njstr, njend, nn_facty
822                        DO ji = nistr, niend, nn_factx
823                           ii  = ( ji - mis_crs(2) ) * rfactx_r + 2                 ! cordinate in parent grid
824                           ij  = ( jj - njstr ) * rfacty_r + 3
825                           zflcrs =  &
826                             & MAX( p_fld(ji  ,jj  ,jk) * zmask(ji  ,jj  ,jk) - ( 1.- zmask(ji  ,jj  ,jk) ) * r_inf ,  &
827                             &      p_fld(ji+1,jj  ,jk) * zmask(ji+1,jj  ,jk) - ( 1.- zmask(ji+1,jj  ,jk) ) * r_inf ,  &
828                             &      p_fld(ji+2,jj  ,jk) * zmask(ji+2,jj  ,jk) - ( 1.- zmask(ji+2,jj  ,jk) ) * r_inf ,  &
829                             &      p_fld(ji  ,jj+1,jk) * zmask(ji  ,jj+1,jk) - ( 1.- zmask(ji  ,jj+1,jk) ) * r_inf ,  &
830                             &      p_fld(ji+1,jj+1,jk) * zmask(ji+1,jj+1,jk) - ( 1.- zmask(ji+1,jj+1,jk) ) * r_inf ,  &
831                             &      p_fld(ji+2,jj+1,jk) * zmask(ji+2,jj+1,jk) - ( 1.- zmask(ji+2,jj+1,jk) ) * r_inf ,  &
832                             &      p_fld(ji  ,jj+2,jk) * zmask(ji  ,jj+2,jk) - ( 1.- zmask(ji  ,jj+2,jk) ) * r_inf ,  &
833                             &      p_fld(ji+1,jj+2,jk) * zmask(ji+1,jj+2,jk) - ( 1.- zmask(ji+1,jj+2,jk) ) * r_inf ,  &
834                             &      p_fld(ji+2,jj+2,jk) * zmask(ji+2,jj+2,jk) - ( 1.- zmask(ji+2,jj+2,jk) ) * r_inf   )
835                           !
836                           p_fld_crs(ii,ij,jk) = zflcrs
837                           !
838                        ENDDO     
839                     ENDDO
840                  ENDDO   
841           
842               CASE( 'V' )
843
844                 IF( nldj_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN     !!cc bande du sud style ORCA2
845                     IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN
846                        ijje = mje_crs(2)
847                      ENDIF
848                  ELSE
849                     ijje = mjs_crs(2)
850                  ENDIF
851
852                  DO jk = 1, jpk
853                     DO ji = nistr, niend, nn_factx
854                        ii   = ( ji - mis_crs(2) ) * rfactx_r + 2     
855                        zflcrs = &
856                          & MAX( p_fld(ji  ,ijje,jk) * p_mask(ji  ,ijje,jk) - ( 1.- p_mask(ji,ijje,jk) ) * r_inf ,  &
857                          &      p_fld(ji+1,ijje,jk) * p_mask(ji+1,ijje,jk) - ( 1.- p_mask(ji,ijje,jk) ) * r_inf ,  &
858                          &      p_fld(ji+2,ijje,jk) * p_mask(ji+2,ijje,jk) - ( 1.- p_mask(ji,ijje,jk) ) * r_inf )
859                          !
860                        p_fld_crs(ii,2,jk) = zflcrs
861                     ENDDO
862                  ENDDO
863                  !
864                  DO jk = 1, jpk           
865                     DO jj  = njstr, njend, nn_facty
866                        DO ji = nistr, niend, nn_factx
867                           ii  = ( ji - mis_crs(2) ) * rfactx_r + 2                 ! cordinate in parent grid
868                           ij  = ( jj - njstr ) * rfacty_r + 3
869                           ijje = mje_crs(ij)
870                           !                 
871                           zflcrs = &
872                             & MAX( p_fld(ji  ,ijje,jk) * p_mask(ji  ,ijje,jk) - ( 1.- p_mask(ji,ijje,jk) ) * r_inf ,  &
873                             &      p_fld(ji+1,ijje,jk) * p_mask(ji+1,ijje,jk) - ( 1.- p_mask(ji,ijje,jk) ) * r_inf ,  &
874                             &      p_fld(ji+2,ijje,jk) * p_mask(ji+2,ijje,jk) - ( 1.- p_mask(ji,ijje,jk) ) * r_inf )
875                           !
876                           p_fld_crs(ii,ij,jk) = zflcrs
877                           !
878                        ENDDO     
879                     ENDDO
880                  ENDDO   
881
882           
883               CASE( 'U' )
884
885                 IF( nldj_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN     !!cc bande du sud style ORCA2
886                     IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN
887                        je_2 = mje_crs(2)
888                        DO jk = 1, jpk           
889                           DO ji = nistr, niend, nn_factx
890                              ii   = ( ji - mis_crs(2) ) * rfactx_r + 2 
891                              ijie = mie_crs(ii)
892                              zflcrs = p_fld(ijie,je_2,jk) * p_mask(ijie,je_2,jk) - ( 1.- p_mask(ijie,je_2,jk) ) * r_inf 
893                              !
894                              p_fld_crs(ii,2,jk) = zflcrs
895                            ENDDO
896                        ENDDO
897                      ENDIF
898                  ELSE
899                     je_2 = mjs_crs(2)
900                     DO jk = 1, jpk           
901                        DO ji = nistr, niend, nn_factx
902                           ii   = ( ji - mis_crs(2) ) * rfactx_r + 2   
903                           ijie = mie_crs(ii)
904                           zflcrs = &
905                             & MAX( p_fld(ijie,je_2  ,jk) * p_mask(ijie,je_2  ,jk) - ( 1.- p_mask(ijie,je_2,jk) ) * r_inf ,  &
906                             &      p_fld(ijie,je_2+1,jk) * p_mask(ijie,je_2+1,jk) - ( 1.- p_mask(ijie,je_2,jk) ) * r_inf ,  &
907                             &      p_fld(ijie,je_2+2,jk) * p_mask(ijie,je_2+2,jk) - ( 1.- p_mask(ijie,je_2,jk) ) * r_inf  )
908                            !
909                           p_fld_crs(ii,2,jk) = zflcrs
910                        ENDDO
911                     ENDDO
912                  ENDIF
913                  !
914                  DO jk = 1, jpk           
915                     DO jj  = njstr, njend, nn_facty
916                        DO ji = nistr, niend, nn_factx
917                           ii   = ( ji - mis_crs(2) ) * rfactx_r + 2     
918                           ij   = ( jj - njstr ) * rfacty_r + 3
919                           ijie = mie_crs(ii)
920                           zflcrs =  &
921                             & MAX( p_fld(ijie,jj  ,jk) * p_mask(ijie,jj  ,jk) - ( 1.- p_mask(ijie,jj,jk) ) * r_inf ,  &
922                             &      p_fld(ijie,jj+1,jk) * p_mask(ijie,jj+1,jk) - ( 1.- p_mask(ijie,jj,jk) ) * r_inf ,  &
923                             &      p_fld(ijie,jj+2,jk) * p_mask(ijie,jj+2,jk) - ( 1.- p_mask(ijie,jj,jk) ) * r_inf  )
924                           !
925                           p_fld_crs(ii,ij,jk) = zflcrs
926                           !
927                        ENDDO     
928                     ENDDO
929                  ENDDO   
930
931              END SELECT
932
933              DEALLOCATE( zmask )
934
935         CASE ( 'MIN' )      !   Search the min of unmasked grid cells
936
937            ALLOCATE( zmask(jpi,jpj,jpk) )
938
939            SELECT CASE ( cd_type )
940              CASE( 'W' )
941                  zmask(:,:,1) = p_mask(:,:,1) 
942                  DO jk = 2, jpk
943                     zmask(:,:,jk) = p_mask(:,:,jk-1) 
944                  ENDDO
945              CASE ( 'T' )
946                  DO jk = 1, jpk
947                     zmask(:,:,jk) = p_mask(:,:,jk) 
948                  ENDDO
949            END SELECT
950
951            SELECT CASE ( cd_type )
952
953               CASE( 'T', 'W' )
954         
955                  IF( nldj_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN     !!cc bande du sud style ORCA2
956                     IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN
957                        je_2 = mje_crs(2)
958                        DO jk = 1, jpk           
959                           DO ji = nistr, niend, nn_factx
960                              ii   = ( ji - mis_crs(2) ) * rfactx_r + 2       
961                              zflcrs =  &
962                                & MIN( p_fld(ji  ,je_2,jk) * zmask(ji  ,je_2,jk) + ( 1.- zmask(ji  ,je_2,jk) ) * r_inf ,  &
963                                &      p_fld(ji+1,je_2,jk) * zmask(ji+1,je_2,jk) + ( 1.- zmask(ji+1,je_2,jk) ) * r_inf ,  &
964                                &      p_fld(ji+2,je_2,jk) * zmask(ji+2,je_2,jk) + ( 1.- zmask(ji+2,je_2,jk) ) * r_inf  )
965                              !
966                              p_fld_crs(ii,2,jk) = zflcrs
967                           ENDDO
968                        ENDDO
969                      ENDIF
970                  ELSE
971                     je_2 = mjs_crs(2)
972                     DO jk = 1, jpk           
973                        DO ji = nistr, niend, nn_factx
974                           ii   = ( ji - mis_crs(2) ) * rfactx_r + 2   
975                           zflcrs =  &
976                             & MIN( p_fld(ji  ,je_2  ,jk) * zmask(ji  ,je_2  ,jk) + ( 1.- zmask(ji  ,je_2  ,jk) ) * r_inf ,  &
977                             &      p_fld(ji+1,je_2  ,jk) * zmask(ji+1,je_2  ,jk) + ( 1.- zmask(ji+1,je_2  ,jk) ) * r_inf ,  &
978                             &      p_fld(ji+2,je_2  ,jk) * zmask(ji+2,je_2  ,jk) + ( 1.- zmask(ji+2,je_2  ,jk) ) * r_inf ,  &
979                             &      p_fld(ji  ,je_2+1,jk) * zmask(ji  ,je_2+1,jk) + ( 1.- zmask(ji  ,je_2+1,jk) ) * r_inf ,  &
980                             &      p_fld(ji+1,je_2+1,jk) * zmask(ji+1,je_2+1,jk) + ( 1.- zmask(ji+1,je_2+1,jk) ) * r_inf ,  &
981                             &      p_fld(ji+2,je_2+1,jk) * zmask(ji+2,je_2+1,jk) + ( 1.- zmask(ji+2,je_2+1,jk) ) * r_inf ,  &
982                             &      p_fld(ji  ,je_2+2,jk) * zmask(ji  ,je_2+2,jk) + ( 1.- zmask(ji  ,je_2+2,jk) ) * r_inf ,  &
983                             &      p_fld(ji+1,je_2+2,jk) * zmask(ji+1,je_2+2,jk) + ( 1.- zmask(ji+1,je_2+2,jk) ) * r_inf ,  &
984                             &      p_fld(ji+2,je_2+2,jk) * zmask(ji+2,je_2+2,jk) + ( 1.- zmask(ji+2,je_2+2,jk) ) * r_inf   )
985                           !
986                           p_fld_crs(ii,2,jk) = zflcrs
987                        ENDDO
988                     ENDDO
989                  ENDIF
990                  !
991                  DO jk = 1, jpk           
992                     DO jj  = njstr, njend, nn_facty
993                        DO ji = nistr, niend, nn_factx
994                           ii  = ( ji - mis_crs(2) ) * rfactx_r + 2                 ! cordinate in parent grid
995                           ij  = ( jj - njstr ) * rfacty_r + 3
996                           zflcrs =  &
997                             & MIN( p_fld(ji  ,jj  ,jk) * zmask(ji  ,jj  ,jk) + ( 1.- zmask(ji  ,jj  ,jk) ) * r_inf ,  &
998                             &      p_fld(ji+1,jj  ,jk) * zmask(ji+1,jj  ,jk) + ( 1.- zmask(ji+1,jj  ,jk) ) * r_inf ,  &
999                             &      p_fld(ji+2,jj  ,jk) * zmask(ji+2,jj  ,jk) + ( 1.- zmask(ji+2,jj  ,jk) ) * r_inf ,  &
1000                             &      p_fld(ji  ,jj+1,jk) * zmask(ji  ,jj+1,jk) + ( 1.- zmask(ji  ,jj+1,jk) ) * r_inf ,  &
1001                             &      p_fld(ji+1,jj+1,jk) * zmask(ji+1,jj+1,jk) + ( 1.- zmask(ji+1,jj+1,jk) ) * r_inf ,  &
1002                             &      p_fld(ji+2,jj+1,jk) * zmask(ji+2,jj+1,jk) + ( 1.- zmask(ji+2,jj+1,jk) ) * r_inf ,  &
1003                             &      p_fld(ji  ,jj+2,jk) * zmask(ji  ,jj+2,jk) + ( 1.- zmask(ji  ,jj+2,jk) ) * r_inf ,  &
1004                             &      p_fld(ji+1,jj+2,jk) * zmask(ji+1,jj+2,jk) + ( 1.- zmask(ji+1,jj+2,jk) ) * r_inf ,  &
1005                             &      p_fld(ji+2,jj+2,jk) * zmask(ji+2,jj+2,jk) + ( 1.- zmask(ji+2,jj+2,jk) ) * r_inf   )
1006                           !
1007                           p_fld_crs(ii,ij,jk) = zflcrs
1008                           !
1009                        ENDDO     
1010                     ENDDO
1011                  ENDDO   
1012           
1013               CASE( 'V' )
1014
1015                  IF( nldj_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN     !!cc bande du sud style ORCA2
1016                     IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN
1017                        ijje = mje_crs(2)
1018                      ENDIF
1019                  ELSE
1020                     ijje = mjs_crs(2)
1021                  ENDIF
1022
1023                  DO jk = 1, jpk
1024                     DO ji = nistr, niend, nn_factx
1025                        ii   = ( ji - mis_crs(2) ) * rfactx_r + 2     
1026                        zflcrs = &
1027                          & MIN( p_fld(ji  ,ijje,jk) * p_mask(ji  ,ijje,jk) + ( 1.- p_mask(ji,ijje,jk) ) * r_inf ,  &
1028                          &      p_fld(ji+1,ijje,jk) * p_mask(ji+1,ijje,jk) + ( 1.- p_mask(ji,ijje,jk) ) * r_inf ,  &
1029                          &      p_fld(ji+2,ijje,jk) * p_mask(ji+2,ijje,jk) + ( 1.- p_mask(ji,ijje,jk) ) * r_inf )
1030                          !
1031                        p_fld_crs(ii,2,jk) = zflcrs
1032                     ENDDO
1033                  ENDDO
1034                  !
1035                  DO jk = 1, jpk           
1036                     DO jj  = njstr, njend, nn_facty
1037                        DO ji = nistr, niend, nn_factx
1038                           ii  = ( ji - mis_crs(2) ) * rfactx_r + 2                 ! cordinate in parent grid
1039                           ij  = ( jj - njstr ) * rfacty_r + 3
1040                           ijje = mje_crs(ij)
1041                           zflcrs = &
1042                             & MIN( p_fld(ji  ,ijje,jk) * p_mask(ji  ,ijje,jk) + ( 1.- p_mask(ji,ijje,jk) ) * r_inf ,  &
1043                             &      p_fld(ji+1,ijje,jk) * p_mask(ji+1,ijje,jk) + ( 1.- p_mask(ji,ijje,jk) ) * r_inf ,  &
1044                             &      p_fld(ji+2,ijje,jk) * p_mask(ji+2,ijje,jk) + ( 1.- p_mask(ji,ijje,jk) ) * r_inf )
1045                           !
1046                           p_fld_crs(ii,ij,jk) = zflcrs
1047                           !
1048                        ENDDO     
1049                     ENDDO
1050                  ENDDO   
1051
1052           
1053               CASE( 'U' )
1054
1055                 IF( nldj_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN     !!cc bande du sud style ORCA2
1056                     IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN
1057                        je_2 = mje_crs(2)
1058                        DO jk = 1, jpk           
1059                           DO ji = nistr, niend, nn_factx
1060                              ii   = ( ji - mis_crs(2) ) * rfactx_r + 2 
1061                              ijie = mie_crs(ii)
1062                              zflcrs = p_fld(ijie,je_2,jk) * p_mask(ijie,je_2,jk) + ( 1.- p_mask(ijie,je_2,jk) ) * r_inf 
1063                              !
1064                              p_fld_crs(ii,2,jk) = zflcrs
1065                            ENDDO
1066                        ENDDO
1067                      ENDIF
1068                  ELSE
1069                     je_2 = mjs_crs(2)
1070                     DO jk = 1, jpk           
1071                        DO ji = nistr, niend, nn_factx
1072                           ii   = ( ji - mis_crs(2) ) * rfactx_r + 2   
1073                           ijie = mie_crs(ii)
1074                           zflcrs = &
1075                             & MIN( p_fld(ijie,je_2  ,jk) * p_mask(ijie,je_2  ,jk) + ( 1.- p_mask(ijie,je_2,jk) ) * r_inf ,  &
1076                             &      p_fld(ijie,je_2+1,jk) * p_mask(ijie,je_2+1,jk) + ( 1.- p_mask(ijie,je_2,jk) ) * r_inf ,  &
1077                             &      p_fld(ijie,je_2+2,jk) * p_mask(ijie,je_2+2,jk) + ( 1.- p_mask(ijie,je_2,jk) ) * r_inf  )
1078                            !
1079                           p_fld_crs(ii,2,jk) = zflcrs
1080                        ENDDO
1081                     ENDDO
1082                  ENDIF
1083                  !
1084                  DO jk = 1, jpk           
1085                     DO jj  = njstr, njend, nn_facty
1086                        DO ji = nistr, niend, nn_factx
1087                           ii   = ( ji - mis_crs(2) ) * rfactx_r + 2     
1088                           ij   = ( jj - njstr ) * rfacty_r + 3
1089                           ijie = mie_crs(ii)
1090                           zflcrs = &
1091                             & MIN( p_fld(ijie,jj  ,jk) * p_mask(ijie,jj  ,jk) + ( 1.- p_mask(ijie,jj,jk) ) * r_inf ,  &
1092                             &      p_fld(ijie,jj+1,jk) * p_mask(ijie,jj+1,jk) + ( 1.- p_mask(ijie,jj,jk) ) * r_inf ,  &
1093                             &      p_fld(ijie,jj+2,jk) * p_mask(ijie,jj+2,jk) + ( 1.- p_mask(ijie,jj,jk) ) * r_inf  )
1094                           !
1095                           p_fld_crs(ii,ij,jk) = zflcrs
1096                           !
1097                        ENDDO     
1098                     ENDDO
1099                  ENDDO   
1100         
1101            END SELECT
1102            !
1103            DEALLOCATE( zmask )
1104            !
1105         END SELECT
1106         !
1107         CALL crs_lbc_lnk( p_fld_crs, cd_type, psgn )
1108         !
1109    END SUBROUTINE crs_dom_ope_3d
1110
1111    SUBROUTINE crs_dom_ope_2d( p_fld, cd_op, cd_type, p_mask, p_fld_crs, p_e12, p_e3, p_surf_crs, p_mask_crs, psgn )
1112      !!----------------------------------------------------------------
1113      !!               *** SUBROUTINE crsfun_UV ***
1114      !! ** Purpose :  Average, area-weighted, of U or V on the east and north faces
1115      !!
1116      !! ** Method  :  The U and V velocities (3D) are determined as the area-weighted averages
1117      !!               on the east and north faces, respectively,
1118      !!               of the parent grid subset comprising the coarse grid box.
1119      !!               In the case of the V and F grid, the last jrow minus 1 is spurious.
1120      !! ** Inputs  : p_e1_e2     = parent grid e1 or e2 (t,u,v,f)
1121      !!              cd_type     = grid type (T,U,V,F) for scale factors; for velocities (U or V)
1122      !!              psgn        = sign change over north fold (See lbclnk.F90)
1123      !!              p_pmask     = parent grid mask (T,U,V,F) for scale factors;
1124      !!                                       for velocities (U or V)
1125      !!              p_e3      = parent grid vertical level thickness (e3u or e3v)
1126      !!              p_pfield    = U or V on the parent grid
1127      !!              p_surf_crs  = (Optional) Coarse grid weight for averaging
1128      !! ** Outputs : p_cfield3d = 3D field on coarse grid
1129      !!
1130      !! History.  29 May.  completed draft.
1131      !!            4 Jun.  Revision for WGT
1132      !!            5 Jun.  Streamline for area-weighted average only ; separate scale factor and weights.
1133      !!----------------------------------------------------------------
1134      REAL(wp), DIMENSION(jpi,jpj),             INTENT(in)           :: p_fld   ! T, U, V or W on parent grid
1135      CHARACTER(len=3),                         INTENT(in)           :: cd_op    ! Operation SUM, MAX or MIN
1136      CHARACTER(len=1),                         INTENT(in)           :: cd_type    ! grid type U,V
1137      REAL(wp), DIMENSION(jpi,jpj,jpk),         INTENT(in)           :: p_mask    ! Parent grid T,U,V mask
1138      REAL(wp), DIMENSION(jpi,jpj),             INTENT(in), OPTIONAL :: p_e12    ! Parent grid T,U,V scale factors (e1 or e2)
1139      REAL(wp), DIMENSION(jpi,jpj,jpk),         INTENT(in), OPTIONAL :: p_e3     ! Parent grid vertical level thickness (e3u, e3v)
1140      REAL(wp), DIMENSION(jpi_crs,jpj_crs)    , INTENT(in), OPTIONAL :: p_surf_crs ! Coarse grid area-weighting denominator   
1141      REAL(wp), DIMENSION(jpi_crs,jpj_crs,jpk), INTENT(in), OPTIONAL :: p_mask_crs    ! Coarse grid T,U,V mask
1142      REAL(wp),                                 INTENT(in)           :: psgn   
1143      REAL(wp), DIMENSION(jpi_crs,jpj_crs)    , INTENT(out)          :: p_fld_crs ! Coarse grid box 3D quantity
1144      !
1145      INTEGER  :: ji, jj, jk                 ! dummy loop indices
1146      INTEGER  :: ijie, ijje, ii, ij, je_2
1147      REAL(wp) :: zflcrs, zsfcrs   
1148      REAL(wp), DIMENSION(:,:), ALLOCATABLE :: zsurfmsk   
1149      !!---------------------------------------------------------------- 
1150      !
1151      p_fld_crs(:,:) = 0._wp
1152      !
1153      SELECT CASE ( cd_op )
1154     
1155        CASE ( 'VOL' )
1156     
1157            ALLOCATE( zsurfmsk(jpi,jpj) )
1158            zsurfmsk(:,:) =  p_e12(:,:) * p_e3(:,:,1) * p_mask(:,:,1)
1159
1160            IF( nldj_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN     !!cc bande du sud style ORCA2
1161               IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN
1162                  je_2 = mje_crs(2)
1163                  DO ji = nistr, niend, nn_factx
1164                     ii   = ( ji - mis_crs(2) ) * rfactx_r + 2       
1165                     zflcrs =  p_fld(ji  ,je_2) * zsurfmsk(ji  ,je_2)   &
1166                       &     + p_fld(ji+1,je_2) * zsurfmsk(ji+1,je_2)   &
1167                       &     + p_fld(ji+2,je_2) * zsurfmsk(ji+2,je_2) 
1168
1169                     zsfcrs =  zsurfmsk(ji,je_2) + zsurfmsk(ji+1,je_2) + zsurfmsk(ji+2,je_2) 
1170                     !
1171                     p_fld_crs(ii,2) = zflcrs
1172                     IF( zsfcrs /= 0.0 )  p_fld_crs(ii,2) = zflcrs / zsfcrs
1173                  ENDDO
1174               ENDIF
1175            ELSE
1176               je_2 = mjs_crs(2)
1177               DO ji = nistr, niend, nn_factx
1178                  ii   = ( ji - mis_crs(2) ) * rfactx_r + 2   
1179                  zflcrs =  p_fld(ji  ,je_2  ) * zsurfmsk(ji  ,je_2  ) &
1180                    &     + p_fld(ji+1,je_2  ) * zsurfmsk(ji+1,je_2  ) &
1181                    &     + p_fld(ji+2,je_2  ) * zsurfmsk(ji+2,je_2  ) &
1182                    &     + p_fld(ji  ,je_2+1) * zsurfmsk(ji  ,je_2+1) &
1183                    &     + p_fld(ji+1,je_2+1) * zsurfmsk(ji+1,je_2+1) &
1184                    &     + p_fld(ji+2,je_2+1) * zsurfmsk(ji+2,je_2+1) &
1185                    &     + p_fld(ji  ,je_2+2) * zsurfmsk(ji  ,je_2+2) &
1186                    &     + p_fld(ji+1,je_2+2) * zsurfmsk(ji+1,je_2+2) &
1187                    &     + p_fld(ji+2,je_2+2) * zsurfmsk(ji+2,je_2+2) 
1188
1189                   zsfcrs =  zsurfmsk(ji,je_2  ) + zsurfmsk(ji+1,je_2  ) + zsurfmsk(ji+2,je_2  ) &
1190                     &     + zsurfmsk(ji,je_2+1) + zsurfmsk(ji+1,je_2+1) + zsurfmsk(ji+2,je_2+1) &
1191                     &     + zsurfmsk(ji,je_2+2) + zsurfmsk(ji+1,je_2+2) + zsurfmsk(ji+2,je_2+2) 
1192                    !
1193                    p_fld_crs(ii,2) = zflcrs
1194                    IF( zsfcrs /= 0.0 )  p_fld_crs(ii,2) = zflcrs / zsfcrs
1195                ENDDO
1196            ENDIF
1197                  !
1198            DO jj  = njstr, njend, nn_facty
1199               DO ji = nistr, niend, nn_factx
1200                  ii  = ( ji - mis_crs(2) ) * rfactx_r + 2                 ! cordinate in parent grid
1201                  ij  = ( jj - njstr ) * rfacty_r + 3
1202                  zflcrs =  p_fld(ji  ,jj  ) * zsurfmsk(ji  ,jj  ) &
1203                    &     + p_fld(ji+1,jj  ) * zsurfmsk(ji+1,jj  ) &
1204                    &     + p_fld(ji+2,jj  ) * zsurfmsk(ji+2,jj  ) &
1205                    &     + p_fld(ji  ,jj+1) * zsurfmsk(ji  ,jj+1) &
1206                    &     + p_fld(ji+1,jj+1) * zsurfmsk(ji+1,jj+1) &
1207                    &     + p_fld(ji+2,jj+1) * zsurfmsk(ji+2,jj+1) &
1208                    &     + p_fld(ji  ,jj+2) * zsurfmsk(ji  ,jj+2) &
1209                    &     + p_fld(ji+1,jj+2) * zsurfmsk(ji+1,jj+2) &
1210                    &     + p_fld(ji+2,jj+2) * zsurfmsk(ji+2,jj+2) 
1211 
1212                  zsfcrs =  zsurfmsk(ji,jj  ) + zsurfmsk(ji+1,jj  ) + zsurfmsk(ji+2,jj  ) &
1213                    &     + zsurfmsk(ji,jj+1) + zsurfmsk(ji+1,jj+1) + zsurfmsk(ji+2,jj+1) &
1214                    &     + zsurfmsk(ji,jj+2) + zsurfmsk(ji+1,jj+2) + zsurfmsk(ji+2,jj+2) 
1215                   !
1216                  p_fld_crs(ii,ij) = zflcrs
1217                  IF( zsfcrs /= 0.0 )  p_fld_crs(ii,ij) = zflcrs / zsfcrs
1218               ENDDO     
1219            ENDDO
1220
1221            DEALLOCATE( zsurfmsk )
1222
1223         CASE ( 'SUM' )
1224         
1225            ALLOCATE( zsurfmsk(jpi,jpj) )
1226            IF( PRESENT( p_e3 ) ) THEN
1227               zsurfmsk(:,:) =  p_e12(:,:) * p_e3(:,:,1) * p_mask(:,:,1)
1228            ELSE
1229               zsurfmsk(:,:) =  p_e12(:,:) * p_mask(:,:,1)
1230            ENDIF
1231
1232            SELECT CASE ( cd_type )
1233
1234               CASE( 'T', 'W' )
1235
1236                   IF( nldj_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN     !!cc bande du sud style ORCA2
1237                      IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN
1238                         je_2 = mje_crs(2)
1239                         DO ji = nistr, niend, nn_factx
1240                            ii   = ( ji - mis_crs(2) ) * rfactx_r + 2     
1241                            zflcrs  =  p_fld(ji  ,je_2) * zsurfmsk(ji  ,je_2) &
1242                              &      + p_fld(ji+1,je_2) * zsurfmsk(ji+1,je_2) &
1243                              &      + p_fld(ji+2,je_2) * zsurfmsk(ji+2,je_2) 
1244                              !
1245                             p_fld_crs(ii,2) = zflcrs
1246                         ENDDO
1247                      ENDIF
1248                   ELSE
1249                      je_2 = mjs_crs(2)
1250                      DO ji = nistr, niend, nn_factx
1251                         ii   = ( ji - mis_crs(2) ) * rfactx_r + 2     
1252                         zflcrs  =  p_fld(ji  ,je_2  ) * zsurfmsk(ji  ,je_2  )  &
1253                           &      + p_fld(ji+1,je_2  ) * zsurfmsk(ji+1,je_2  )  &
1254                           &      + p_fld(ji+2,je_2  ) * zsurfmsk(ji+2,je_2  )  &
1255                           &      + p_fld(ji  ,je_2+1) * zsurfmsk(ji  ,je_2+1)  &
1256                           &      + p_fld(ji+1,je_2+1) * zsurfmsk(ji+1,je_2+1)  &
1257                           &      + p_fld(ji+2,je_2+1) * zsurfmsk(ji+2,je_2+1)  &
1258                           &      + p_fld(ji  ,je_2+2) * zsurfmsk(ji  ,je_2+2)  &
1259                           &      + p_fld(ji+1,je_2+2) * zsurfmsk(ji+1,je_2+2)  &
1260                           &      + p_fld(ji+2,je_2+2) * zsurfmsk(ji+2,je_2+2) 
1261                            !
1262                            p_fld_crs(ii,2) = zflcrs
1263                      ENDDO
1264                   ENDIF
1265                     !
1266                   DO jj = njstr, njend, nn_facty
1267                      DO ji = nistr, niend, nn_factx
1268                         ii   = ( ji - mis_crs(2) ) * rfactx_r + 2   
1269                         ij   = ( jj - njstr ) * rfacty_r + 3
1270                         zflcrs  =  p_fld(ji  ,jj  ) * zsurfmsk(ji  ,jj  )  &
1271                           &      + p_fld(ji+1,jj  ) * zsurfmsk(ji+1,jj  )  &
1272                           &      + p_fld(ji+2,jj  ) * zsurfmsk(ji+2,jj  )  &
1273                           &      + p_fld(ji  ,jj+1) * zsurfmsk(ji  ,jj+1)  &
1274                           &      + p_fld(ji+1,jj+1) * zsurfmsk(ji+1,jj+1)  &
1275                           &      + p_fld(ji+2,jj+1) * zsurfmsk(ji+2,jj+1)  &
1276                           &      + p_fld(ji  ,jj+2) * zsurfmsk(ji  ,jj+2)  &
1277                           &      + p_fld(ji+1,jj+2) * zsurfmsk(ji+1,jj+2)  &
1278                           &      + p_fld(ji+2,jj+2) * zsurfmsk(ji+2,jj+2) 
1279                           !
1280                          p_fld_crs(ii,ij) = zflcrs
1281                          !
1282                      ENDDO     
1283                   ENDDO
1284           
1285               CASE( 'V' )
1286
1287                  IF( nldj_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN     !!cc bande du sud style ORCA2
1288                     IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN
1289                        ijje = mje_crs(2)
1290                      ENDIF
1291                  ELSE
1292                     ijje = mjs_crs(2)
1293                  ENDIF
1294
1295                  DO ji = nistr, niend, nn_factx
1296                     ii   = ( ji - mis_crs(2) ) * rfactx_r + 2     
1297                     zflcrs  =  p_fld(ji  ,ijje) * zsurfmsk(ji  ,ijje) &
1298                       &      + p_fld(ji+1,ijje) * zsurfmsk(ji+1,ijje) &
1299                       &      + p_fld(ji+2,ijje) * zsurfmsk(ji+2,ijje) 
1300                            !
1301                     p_fld_crs(ii,2) = zflcrs
1302                  ENDDO
1303
1304                  DO jj = njstr, njend, nn_facty
1305                     DO ji = nistr, niend, nn_factx
1306                        ii   = ( ji - mis_crs(2) ) * rfactx_r + 2     
1307                        ij   = ( jj - njstr ) * rfacty_r + 3
1308                        ijje = mje_crs(ij)
1309                        zflcrs  =  p_fld(ji  ,ijje) * zsurfmsk(ji  ,ijje) &
1310                          &      + p_fld(ji+1,ijje) * zsurfmsk(ji+1,ijje) &
1311                          &      + p_fld(ji+2,ijje) * zsurfmsk(ji+2,ijje) 
1312                          !
1313                        p_fld_crs(ii,ij) = zflcrs
1314                        !
1315                     ENDDO     
1316                  ENDDO
1317           
1318               CASE( 'U' )
1319
1320                  IF( nldj_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN     !!cc bande du sud style ORCA2
1321                     IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN
1322                        je_2 = mje_crs(2)
1323                        DO ji = nistr, niend, nn_factx
1324                           ii   = ( ji - mis_crs(2) ) * rfactx_r + 2   
1325                           ijie = mie_crs(ii)
1326                           zflcrs  =  p_fld(ijie,je_2) * zsurfmsk(ijie,je_2) 
1327                           p_fld_crs(ii,2) = zflcrs
1328                        ENDDO
1329                     ENDIF
1330                  ELSE
1331                     je_2 = mjs_crs(2)
1332                     DO ji = nistr, niend, nn_factx
1333                        ii   = ( ji - mis_crs(2) ) * rfactx_r + 2   
1334                        ijie = mie_crs(ii)
1335                        zflcrs =  p_fld(ijie,je_2  ) * zsurfmsk(ijie,je_2  )  &
1336                          &     + p_fld(ijie,je_2+1) * zsurfmsk(ijie,je_2+1)  &
1337                          &     + p_fld(ijie,je_2+2) * zsurfmsk(ijie,je_2+2) 
1338   
1339                        p_fld_crs(ii,2) = zflcrs
1340                     ENDDO
1341                 ENDIF
1342
1343                 DO jj = njstr, njend, nn_facty
1344                    DO ji = nistr, niend, nn_factx
1345                       ii   = ( ji - mis_crs(2) ) * rfactx_r + 2     
1346                       ij   = ( jj - njstr ) * rfacty_r + 3
1347                       ijie = mie_crs(ii)
1348                       zflcrs =  p_fld(ijie,jj  ) * zsurfmsk(ijie,jj  )  &
1349                          &    + p_fld(ijie,jj+1) * zsurfmsk(ijie,jj+1)  &
1350                          &    + p_fld(ijie,jj+2) * zsurfmsk(ijie,jj+2) 
1351                         !
1352                       p_fld_crs(ii,ij) = zflcrs
1353                       !
1354                    ENDDO     
1355                 ENDDO
1356
1357              END SELECT
1358
1359              IF( PRESENT( p_surf_crs ) ) THEN
1360                 WHERE ( p_surf_crs /= 0.0 ) p_fld_crs(:,:) = p_fld_crs(:,:) / p_surf_crs(:,:)
1361              ENDIF
1362
1363              DEALLOCATE( zsurfmsk )
1364
1365         CASE ( 'MAX' )
1366
1367            SELECT CASE ( cd_type )
1368           
1369               CASE( 'T', 'W' )
1370 
1371                   IF( nldj_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN     !!cc bande du sud style ORCA2
1372                      IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN
1373                         je_2 = mje_crs(2)
1374                         DO ji = nistr, niend, nn_factx
1375                            ii   = ( ji - mis_crs(2) ) * rfactx_r + 2     
1376                            zflcrs =  &
1377                              & MAX( p_fld(ji  ,je_2) * p_mask(ji  ,je_2,1) - ( 1.- p_mask(ji  ,je_2,1) ) * r_inf ,  &
1378                             &       p_fld(ji+1,je_2) * p_mask(ji+1,je_2,1) - ( 1.- p_mask(ji+1,je_2,1) ) * r_inf ,  &
1379                             &       p_fld(ji+2,je_2) * p_mask(ji+2,je_2,1) - ( 1.- p_mask(ji+2,je_2,1) ) * r_inf  )
1380                            !
1381                            p_fld_crs(ii,2) = zflcrs
1382                         ENDDO
1383                      ENDIF
1384                   ELSE
1385                      je_2 = mjs_crs(2) 
1386                      zflcrs =  &
1387                        &  MAX( p_fld(ji  ,je_2  ) * p_mask(ji  ,je_2  ,1) - ( 1.- p_mask(ji  ,je_2  ,1) ) * r_inf ,  &
1388                        &       p_fld(ji+1,je_2  ) * p_mask(ji+1,je_2  ,1) - ( 1.- p_mask(ji+1,je_2  ,1) ) * r_inf ,  &
1389                        &       p_fld(ji+2,je_2  ) * p_mask(ji+2,je_2  ,1) - ( 1.- p_mask(ji+2,je_2  ,1) ) * r_inf ,  &
1390                        &       p_fld(ji  ,je_2+1) * p_mask(ji  ,je_2+1,1) - ( 1.- p_mask(ji  ,je_2+1,1) ) * r_inf ,  &
1391                        &       p_fld(ji+1,je_2+1) * p_mask(ji+1,je_2+1,1) - ( 1.- p_mask(ji+1,je_2+1,1) ) * r_inf ,  &
1392                        &       p_fld(ji+2,je_2+1) * p_mask(ji+2,je_2+1,1) - ( 1.- p_mask(ji+2,je_2+1,1) ) * r_inf ,  &
1393                        &       p_fld(ji  ,je_2+2) * p_mask(ji  ,je_2+2,1) - ( 1.- p_mask(ji  ,je_2+2,1) ) * r_inf ,  &
1394                        &       p_fld(ji+1,je_2+2) * p_mask(ji+1,je_2+2,1) - ( 1.- p_mask(ji+1,je_2+2,1) ) * r_inf ,  &
1395                        &       p_fld(ji+2,je_2+2) * p_mask(ji+2,je_2+2,1) - ( 1.- p_mask(ji+2,je_2+2,1) ) * r_inf   )
1396                      !
1397                      p_fld_crs(ii,2) = zflcrs
1398                   ENDIF
1399
1400                   DO jj = njstr, njend, nn_facty
1401                      DO ji = nistr, niend, nn_factx
1402                         ii   = ( ji - mis_crs(2) ) * rfactx_r + 2     
1403                         ij   = ( jj - njstr ) * rfacty_r + 3
1404                         zflcrs = &
1405                          &  MAX( p_fld(ji  ,jj  ) * p_mask(ji  ,jj  ,1) - ( 1.- p_mask(ji  ,jj  ,1) ) * r_inf ,  &
1406                          &       p_fld(ji+1,jj  ) * p_mask(ji+1,jj  ,1) - ( 1.- p_mask(ji+1,jj  ,1) ) * r_inf ,  &
1407                          &       p_fld(ji+2,jj  ) * p_mask(ji+2,jj  ,1) - ( 1.- p_mask(ji+2,jj  ,1) ) * r_inf ,  &
1408                          &       p_fld(ji  ,jj+1) * p_mask(ji  ,jj+1,1) - ( 1.- p_mask(ji  ,jj+1,1) ) * r_inf ,  &
1409                          &       p_fld(ji+1,jj+1) * p_mask(ji+1,jj+1,1) - ( 1.- p_mask(ji+1,jj+1,1) ) * r_inf ,  &
1410                          &       p_fld(ji+2,jj+1) * p_mask(ji+2,jj+1,1) - ( 1.- p_mask(ji+2,jj+1,1) ) * r_inf ,  &
1411                          &       p_fld(ji  ,jj+2) * p_mask(ji  ,jj+2,1) - ( 1.- p_mask(ji  ,jj+2,1) ) * r_inf ,  &
1412                          &       p_fld(ji+1,jj+2) * p_mask(ji+1,jj+2,1) - ( 1.- p_mask(ji+1,jj+2,1) ) * r_inf ,  &
1413                          &       p_fld(ji+2,jj+2) * p_mask(ji+2,jj+2,1) - ( 1.- p_mask(ji+2,jj+2,1) ) * r_inf   )
1414                         !
1415                         p_fld_crs(ii,ij) = zflcrs
1416                         !
1417                      ENDDO     
1418                   ENDDO
1419           
1420               CASE( 'V' )
1421
1422                  IF( nldj_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN     !!cc bande du sud style ORCA2
1423                     IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN
1424                        ijje = mje_crs(2)
1425                      ENDIF
1426                  ELSE
1427                     ijje = mjs_crs(2)
1428                  ENDIF
1429
1430                  DO ji = nistr, niend, nn_factx
1431                     ii   = ( ji - mis_crs(2) ) * rfactx_r + 2   
1432                     zflcrs = MAX( p_fld(ji  ,ijje) * p_mask(ji  ,ijje,1) - ( 1.- p_mask(ji,ijje,1) ) * r_inf ,  &
1433                       &           p_fld(ji+1,ijje) * p_mask(ji+1,ijje,1) - ( 1.- p_mask(ji,ijje,1) ) * r_inf ,  &
1434                       &           p_fld(ji+2,ijje) * p_mask(ji+2,ijje,1) - ( 1.- p_mask(ji,ijje,1) ) * r_inf )
1435                       !
1436                     p_fld_crs(ii,2) = zflcrs
1437                  ENDDO     
1438                  DO jj = njstr, njend, nn_facty
1439                     DO ji = nistr, niend, nn_factx
1440                        ii   = ( ji - mis_crs(2) ) * rfactx_r + 2   
1441                        ij   = ( jj - njstr ) * rfacty_r + 3               
1442                        ijje = mje_crs(ij) 
1443                        !                 
1444                        zflcrs = MAX( p_fld(ji  ,ijje) * p_mask(ji  ,ijje,1) - ( 1.- p_mask(ji,ijje,1) ) * r_inf ,  &
1445                          &           p_fld(ji+1,ijje) * p_mask(ji+1,ijje,1) - ( 1.- p_mask(ji,ijje,1) ) * r_inf ,  &
1446                          &           p_fld(ji+2,ijje) * p_mask(ji+2,ijje,1) - ( 1.- p_mask(ji,ijje,1) ) * r_inf )
1447                        !
1448                        p_fld_crs(ii,ij) = zflcrs
1449                        !
1450                     ENDDO     
1451                  ENDDO
1452           
1453               CASE( 'U' )
1454
1455                 IF( nldj_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN     !!cc bande du sud style ORCA2
1456                     IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN
1457                        je_2 = mje_crs(2)
1458                        DO ji = nistr, niend, nn_factx
1459                           ii   = ( ji - mis_crs(2) ) * rfactx_r + 2   
1460                           ijie = mie_crs(ii)
1461                           zflcrs  =  p_fld(ijie,je_2) * p_mask(ijie,je_2,1) - ( 1.- p_mask(ijie,je_2,1) ) * r_inf 
1462                           p_fld_crs(ii,2) = zflcrs
1463                        ENDDO
1464                     ENDIF
1465                 ELSE
1466                     je_2 = mjs_crs(2)
1467                     DO ji = nistr, niend, nn_factx
1468                        ii   = ( ji - mis_crs(2) ) * rfactx_r + 2   
1469                        ijie = mie_crs(ii)
1470                        zflcrs =  &
1471                          &  MAX( p_fld(ijie,je_2  ) * p_mask(ijie,je_2  ,1) - ( 1.- p_mask(ijie,je_2,1) ) * r_inf ,  &
1472                          &       p_fld(ijie,je_2+1) * p_mask(ijie,je_2+1,1) - ( 1.- p_mask(ijie,je_2,1) ) * r_inf ,  &
1473                          &       p_fld(ijie,je_2+2) * p_mask(ijie,je_2+2,1) - ( 1.- p_mask(ijie,je_2,1) ) * r_inf  )
1474                        p_fld_crs(ii,2) = zflcrs
1475                     ENDDO
1476                 ENDIF
1477                 DO jj = njstr, njend, nn_facty
1478                    DO ji = nistr, niend, nn_factx
1479                       ii   = ( ji - mis_crs(2) ) * rfactx_r + 2     
1480                       ij   = ( jj - njstr ) * rfacty_r + 3
1481                       ijie = mie_crs(ii)
1482                       zflcrs =  &
1483                         &  MAX( p_fld(ijie,jj  ) * p_mask(ijie,jj  ,1) - ( 1.- p_mask(ijie,jj,1) ) * r_inf ,  &
1484                         &       p_fld(ijie,jj+1) * p_mask(ijie,jj+1,1) - ( 1.- p_mask(ijie,jj,1) ) * r_inf ,  &
1485                          &      p_fld(ijie,jj+2) * p_mask(ijie,jj+2,1) - ( 1.- p_mask(ijie,jj,1) ) * r_inf  )
1486                        p_fld_crs(ii,ij) = zflcrs
1487                        !
1488                     ENDDO     
1489                  ENDDO
1490
1491              END SELECT
1492
1493         CASE ( 'MIN' )      !   Search the min of unmasked grid cells
1494
1495           SELECT CASE ( cd_type )
1496
1497              CASE( 'T', 'W' )
1498 
1499                   IF( nldj_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN     !!cc bande du sud style ORCA2
1500                      IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN
1501                         je_2 = mje_crs(2)
1502                         DO ji = nistr, niend, nn_factx
1503                            ii   = ( ji - mis_crs(2) ) * rfactx_r + 2     
1504                            zflcrs =  &
1505                              & MIN( p_fld(ji  ,je_2) * p_mask(ji  ,je_2,1) + ( 1.- p_mask(ji  ,je_2,1) ) * r_inf ,  &
1506                             &       p_fld(ji+1,je_2) * p_mask(ji+1,je_2,1) + ( 1.- p_mask(ji+1,je_2,1) ) * r_inf ,  &
1507                             &       p_fld(ji+2,je_2) * p_mask(ji+2,je_2,1) + ( 1.- p_mask(ji+2,je_2,1) ) * r_inf  )
1508                            !
1509                            p_fld_crs(ii,2) = zflcrs
1510                         ENDDO
1511                      ENDIF
1512                   ELSE
1513                      je_2 = mjs_crs(2) 
1514                      zflcrs =  &
1515                        &  MIN( p_fld(ji  ,je_2  ) * p_mask(ji  ,je_2  ,1) + ( 1.- p_mask(ji  ,je_2  ,1) ) * r_inf ,  &
1516                        &       p_fld(ji+1,je_2  ) * p_mask(ji+1,je_2  ,1) + ( 1.- p_mask(ji+1,je_2  ,1) ) * r_inf ,  &
1517                        &       p_fld(ji+2,je_2  ) * p_mask(ji+2,je_2  ,1) + ( 1.- p_mask(ji+2,je_2  ,1) ) * r_inf ,  &
1518                        &       p_fld(ji  ,je_2+1) * p_mask(ji  ,je_2+1,1) + ( 1.- p_mask(ji  ,je_2+1,1) ) * r_inf ,  &
1519                        &       p_fld(ji+1,je_2+1) * p_mask(ji+1,je_2+1,1) + ( 1.- p_mask(ji+1,je_2+1,1) ) * r_inf ,  &
1520                        &       p_fld(ji+2,je_2+1) * p_mask(ji+2,je_2+1,1) + ( 1.- p_mask(ji+2,je_2+1,1) ) * r_inf ,  &
1521                        &       p_fld(ji  ,je_2+2) * p_mask(ji  ,je_2+2,1) + ( 1.- p_mask(ji  ,je_2+2,1) ) * r_inf ,  &
1522                        &       p_fld(ji+1,je_2+2) * p_mask(ji+1,je_2+2,1) + ( 1.- p_mask(ji+1,je_2+2,1) ) * r_inf ,  &
1523                        &       p_fld(ji+2,je_2+2) * p_mask(ji+2,je_2+2,1) + ( 1.- p_mask(ji+2,je_2+2,1) ) * r_inf   )
1524                      !
1525                      p_fld_crs(ii,2) = zflcrs
1526                   ENDIF
1527
1528                   DO jj = njstr, njend, nn_facty
1529                      DO ji = nistr, niend, nn_factx
1530                         ii   = ( ji - mis_crs(2) ) * rfactx_r + 2     
1531                         ij   = ( jj - njstr ) * rfacty_r + 3
1532                         zflcrs = &
1533                          &  MIN( p_fld(ji  ,jj  ) * p_mask(ji  ,jj  ,1) + ( 1.- p_mask(ji  ,jj  ,1) ) * r_inf ,  &
1534                          &       p_fld(ji+1,jj  ) * p_mask(ji+1,jj  ,1) + ( 1.- p_mask(ji+1,jj  ,1) ) * r_inf ,  &
1535                          &       p_fld(ji+2,jj  ) * p_mask(ji+2,jj  ,1) + ( 1.- p_mask(ji+2,jj  ,1) ) * r_inf ,  &
1536                          &       p_fld(ji  ,jj+1) * p_mask(ji  ,jj+1,1) + ( 1.- p_mask(ji  ,jj+1,1) ) * r_inf ,  &
1537                          &       p_fld(ji+1,jj+1) * p_mask(ji+1,jj+1,1) + ( 1.- p_mask(ji+1,jj+1,1) ) * r_inf ,  &
1538                          &       p_fld(ji+2,jj+1) * p_mask(ji+2,jj+1,1) + ( 1.- p_mask(ji+2,jj+1,1) ) * r_inf ,  &
1539                          &       p_fld(ji  ,jj+2) * p_mask(ji  ,jj+2,1) + ( 1.- p_mask(ji  ,jj+2,1) ) * r_inf ,  &
1540                          &       p_fld(ji+1,jj+2) * p_mask(ji+1,jj+2,1) + ( 1.- p_mask(ji+1,jj+2,1) ) * r_inf ,  &
1541                          &       p_fld(ji+2,jj+2) * p_mask(ji+2,jj+2,1) + ( 1.- p_mask(ji+2,jj+2,1) ) * r_inf   )
1542                         !
1543                         p_fld_crs(ii,ij) = zflcrs
1544                         !
1545                      ENDDO     
1546                   ENDDO
1547           
1548               CASE( 'V' )
1549
1550                  IF( nldj_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN     !!cc bande du sud style ORCA2
1551                     IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN
1552                        ijje = mje_crs(2)
1553                      ENDIF
1554                  ELSE
1555                     ijje = mjs_crs(2)
1556                  ENDIF
1557
1558                  DO ji = nistr, niend, nn_factx
1559                     ii   = ( ji - mis_crs(2) ) * rfactx_r + 2   
1560                     zflcrs = MIN( p_fld(ji  ,ijje) * p_mask(ji  ,ijje,1) + ( 1.- p_mask(ji,ijje,1) ) * r_inf ,  &
1561                       &           p_fld(ji+1,ijje) * p_mask(ji+1,ijje,1) + ( 1.- p_mask(ji,ijje,1) ) * r_inf ,  &
1562                       &           p_fld(ji+2,ijje) * p_mask(ji+2,ijje,1) + ( 1.- p_mask(ji,ijje,1) ) * r_inf )
1563                       !
1564                     p_fld_crs(ii,2) = zflcrs
1565                  ENDDO     
1566                  DO jj = njstr, njend, nn_facty
1567                     DO ji = nistr, niend, nn_factx
1568                        ii   = ( ji - mis_crs(2) ) * rfactx_r + 2   
1569                        ij   = ( jj - njstr ) * rfacty_r + 3               
1570                        ijje = mje_crs(ij) 
1571                        !                 
1572                        zflcrs = MIN( p_fld(ji  ,ijje) * p_mask(ji  ,ijje,1) + ( 1.- p_mask(ji,ijje,1) ) * r_inf ,  &
1573                          &           p_fld(ji+1,ijje) * p_mask(ji+1,ijje,1) + ( 1.- p_mask(ji,ijje,1) ) * r_inf ,  &
1574                          &           p_fld(ji+2,ijje) * p_mask(ji+2,ijje,1) + ( 1.- p_mask(ji,ijje,1) ) * r_inf )
1575                        !
1576                        p_fld_crs(ii,ij) = zflcrs
1577                        !
1578                     ENDDO     
1579                  ENDDO
1580           
1581               CASE( 'U' )
1582
1583                 IF( nldj_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN     !!cc bande du sud style ORCA2
1584                     IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN
1585                        je_2 = mje_crs(2)
1586                        DO ji = nistr, niend, nn_factx
1587                           ii   = ( ji - mis_crs(2) ) * rfactx_r + 2   
1588                           ijie = mie_crs(ii)
1589                           zflcrs  =  p_fld(ijie,je_2) * p_mask(ijie,je_2,1) + ( 1.- p_mask(ijie,je_2,1) ) * r_inf 
1590 
1591                           p_fld_crs(ii,2) = zflcrs
1592                        ENDDO
1593                     ENDIF
1594                 ELSE
1595                     je_2 = mjs_crs(2)
1596                     DO ji = nistr, niend, nn_factx
1597                        ii   = ( ji - mis_crs(2) ) * rfactx_r + 2   
1598                        ijie = mie_crs(ii)
1599                        zflcrs =  &
1600                          &  MIN( p_fld(ijie,je_2  ) * p_mask(ijie,je_2  ,1) + ( 1.- p_mask(ijie,je_2,1) ) * r_inf ,  &
1601                          &       p_fld(ijie,je_2+1) * p_mask(ijie,je_2+1,1) + ( 1.- p_mask(ijie,je_2,1) ) * r_inf ,  &
1602                          &       p_fld(ijie,je_2+2) * p_mask(ijie,je_2+2,1) + ( 1.- p_mask(ijie,je_2,1) ) * r_inf  )
1603                        p_fld_crs(ii,2) = zflcrs
1604                     ENDDO
1605                 ENDIF
1606                 DO jj = njstr, njend, nn_facty
1607                    DO ji = nistr, niend, nn_factx
1608                       ii   = ( ji - mis_crs(2) ) * rfactx_r + 2     
1609                       ij   = ( jj - njstr ) * rfacty_r + 3
1610                       ijie = mie_crs(ii)
1611                       zflcrs =  &
1612                         &  MIN( p_fld(ijie,jj  ) * p_mask(ijie,jj  ,1) + ( 1.- p_mask(ijie,jj,1) ) * r_inf ,  &
1613                         &       p_fld(ijie,jj+1) * p_mask(ijie,jj+1,1) + ( 1.- p_mask(ijie,jj,1) ) * r_inf ,  &
1614                          &      p_fld(ijie,jj+2) * p_mask(ijie,jj+2,1) + ( 1.- p_mask(ijie,jj,1) ) * r_inf  )
1615                        p_fld_crs(ii,ij) = zflcrs
1616                        !
1617                     ENDDO     
1618                  ENDDO
1619
1620              END SELECT
1621             !
1622         END SELECT
1623         !
1624         CALL crs_lbc_lnk( p_fld_crs, cd_type, psgn )
1625         !
1626   END SUBROUTINE crs_dom_ope_2d
1627
1628   SUBROUTINE crs_dom_e3( p_e1, p_e2, p_e3, p_sfc_crs, cd_type, p_mask, p_e3_crs, p_e3_max_crs)
1629      !!---------------------------------------------------------------- 
1630      !!  Arguments
1631      CHARACTER(len=1),                         INTENT(in) :: cd_type      ! grid type T, W ( U, V, F)
1632      REAL(wp), DIMENSION(jpi,jpj,jpk),         INTENT(in) :: p_mask       ! Parent grid T mask
1633      REAL(wp), DIMENSION(jpi,jpj)    ,         INTENT(in) :: p_e1, p_e2   ! 2D tracer T or W on parent grid
1634      REAL(wp), DIMENSION(jpi,jpj,jpk),         INTENT(in) :: p_e3         ! 3D tracer T or W on parent grid
1635      REAL(wp), DIMENSION(jpi_crs,jpj_crs,jpk), INTENT(in) :: p_sfc_crs ! Coarse grid box east or north face quantity
1636      REAL(wp), DIMENSION(jpi_crs,jpj_crs,jpk), INTENT(inout) :: p_e3_crs ! Coarse grid box east or north face quantity
1637      REAL(wp), DIMENSION(jpi_crs,jpj_crs,jpk), INTENT(inout) :: p_e3_max_crs ! Coarse grid box east or north face quantity
1638
1639      !! Local variables
1640      INTEGER ::  ji, jj, jk                   ! dummy loop indices
1641      INTEGER ::  ijie, ijje, ii, ij, je_2
1642      REAL(wp) :: ze3crs 
1643      REAL(wp), DIMENSION(jpi,jpj,jpk) :: zmask, zsurf   
1644
1645      !!---------------------------------------------------------------- 
1646
1647       p_e3_crs    (:,:,:) = 0.
1648       p_e3_max_crs(:,:,:) = 1.
1649   
1650
1651       SELECT CASE ( cd_type )
1652          CASE( 'W' )
1653              zmask(:,:,1) = p_mask(:,:,1) 
1654              DO jk = 2, jpk
1655                 zmask(:,:,jk) = p_mask(:,:,jk-1) 
1656              ENDDO
1657           CASE DEFAULT
1658              DO jk = 1, jpk
1659                 zmask(:,:,jk) = p_mask(:,:,jk) 
1660              ENDDO
1661       END SELECT
1662
1663       DO jk = 1, jpk
1664          zsurf(:,:,jk) = p_e1(:,:) * p_e2(:,:) * p_e3(:,:,jk) 
1665       ENDDO
1666
1667       IF( nldj_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN     !!cc bande du sud style ORCA2
1668          IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN
1669             je_2 = mje_crs(2)
1670             DO jk = 1 , jpk
1671                DO ji = nistr, niend, nn_factx
1672                   ii   = ( ji - mis_crs(2) ) * rfactx_r + 2     
1673                   ze3crs =   zsurf(ji  ,je_2,jk) * zmask(ji  ,je_2,jk)   &
1674                        &   + zsurf(ji+1,je_2,jk) * zmask(ji+1,je_2,jk)   &
1675                        &   + zsurf(ji+2,je_2,jk) * zmask(ji+2,je_2,jk) 
1676
1677                   p_e3_crs(ii,2,jk) = ze3crs / p_sfc_crs(ii,ij,jk)
1678                   !
1679                   ze3crs = MAX( p_e3(ji  ,je_2,jk) * zmask(ji  ,je_2,jk),  &
1680                      &          p_e3(ji+1,je_2,jk) * zmask(ji+1,je_2,jk),  &
1681                      &          p_e3(ji+2,je_2,jk) * zmask(ji+2,je_2,jk)  )
1682                   !
1683                   p_e3_max_crs(ii,2,jk) = ze3crs
1684                ENDDO
1685             ENDDO
1686          ENDIF
1687       ELSE
1688          je_2 = mjs_crs(2)
1689          DO jk = 1 , jpk
1690             DO ji = nistr, niend, nn_factx
1691                ii   = ( ji - mis_crs(2) ) * rfactx_r + 2     
1692                ze3crs =  zsurf(ji  ,je_2  ,jk) * zmask(ji  ,je_2  ,jk)   &
1693                   &    + zsurf(ji+1,je_2  ,jk) * zmask(ji+1,je_2  ,jk)   &
1694                   &    + zsurf(ji+2,je_2  ,jk) * zmask(ji+2,je_2  ,jk)   &
1695                   &    + zsurf(ji  ,je_2+1,jk) * zmask(ji  ,je_2+1,jk)   &
1696                   &    + zsurf(ji+1,je_2+1,jk) * zmask(ji+1,je_2+1,jk)   &
1697                   &    + zsurf(ji+2,je_2+1,jk) * zmask(ji+2,je_2+1,jk)   &
1698                   &    + zsurf(ji  ,je_2+2,jk) * zmask(ji  ,je_2+2,jk)   &
1699                   &    + zsurf(ji+1,je_2+2,jk) * zmask(ji+1,je_2+2,jk)   &
1700                   &    + zsurf(ji+2,je_2+2,jk) * zmask(ji+2,je_2+2,jk)
1701
1702                p_e3_crs(ii,2,jk) = ze3crs / p_sfc_crs(ii,2,jk)
1703                !
1704                ze3crs = MAX( p_e3(ji  ,je_2  ,jk) * zmask(ji  ,je_2  ,jk),  &
1705                   &          p_e3(ji+1,je_2  ,jk) * zmask(ji+1,je_2  ,jk),  &
1706                   &          p_e3(ji+2,je_2  ,jk) * zmask(ji+2,je_2  ,jk),  &
1707                   &          p_e3(ji  ,je_2+1,jk) * zmask(ji  ,je_2+1,jk),  &
1708                   &          p_e3(ji+1,je_2+1,jk) * zmask(ji+1,je_2+1,jk),  &
1709                   &          p_e3(ji+2,je_2+1,jk) * zmask(ji+2,je_2+1,jk),  &
1710                   &          p_e3(ji  ,je_2+2,jk) * zmask(ji  ,je_2+2,jk),  &
1711                   &          p_e3(ji+1,je_2+2,jk) * zmask(ji+1,je_2+2,jk),  &
1712                   &          p_e3(ji+2,je_2+2,jk) * zmask(ji+2,je_2+2,jk) )
1713               
1714                p_e3_max_crs(ii,2,jk) = ze3crs
1715                ENDDO
1716             ENDDO
1717          ENDIF
1718          DO jk = 1 , jpk
1719             DO jj = njstr, njend, nn_facty
1720                DO ji = nistr, niend, nn_factx
1721                   ii   = ( ji - mis_crs(2) ) * rfactx_r + 2         
1722                   ij   = ( jj - njstr ) * rfacty_r + 3
1723                   ze3crs =   zsurf(ji  ,jj  ,jk) * zmask(ji  ,jj  ,jk)   &
1724                   &        + zsurf(ji+1,jj  ,jk) * zmask(ji+1,jj  ,jk)   &
1725                   &        + zsurf(ji+2,jj  ,jk) * zmask(ji+2,jj  ,jk)   &
1726                   &        + zsurf(ji  ,jj+1,jk) * zmask(ji  ,jj+1,jk)   &
1727                   &        + zsurf(ji+1,jj+1,jk) * zmask(ji+1,jj+1,jk)   &
1728                   &        + zsurf(ji+2,jj+1,jk) * zmask(ji+2,jj+1,jk)   &
1729                   &        + zsurf(ji  ,jj+2,jk) * zmask(ji  ,jj+2,jk)   &
1730                   &        + zsurf(ji+1,jj+2,jk) * zmask(ji+1,jj+2,jk)   &
1731                   &        + zsurf(ji+2,jj+2,jk) * zmask(ji+2,jj+2,jk)
1732
1733                p_e3_crs(ii,ij,jk) = ze3crs / p_sfc_crs(ii,ij,jk)
1734                !
1735                ze3crs = MAX( p_e3(ji  ,jj  ,jk) * zmask(ji  ,jj  ,jk),  &
1736                   &          p_e3(ji+1,jj  ,jk) * zmask(ji+1,jj  ,jk),  &
1737                   &          p_e3(ji+2,jj  ,jk) * zmask(ji+2,jj  ,jk),  &
1738                   &          p_e3(ji  ,jj+1,jk) * zmask(ji  ,jj+1,jk),  &
1739                   &          p_e3(ji+1,jj+1,jk) * zmask(ji+1,jj+1,jk),  &
1740                   &          p_e3(ji+2,jj+1,jk) * zmask(ji+2,jj+1,jk),  &
1741                   &          p_e3(ji  ,jj+2,jk) * zmask(ji  ,jj+2,jk),  &
1742                   &          p_e3(ji+1,jj+2,jk) * zmask(ji+1,jj+2,jk),  &
1743                   &          p_e3(ji+2,jj+2,jk) * zmask(ji+2,jj+2,jk) )
1744               
1745                p_e3_max_crs(ii,ij,jk) = ze3crs
1746             ENDDO
1747          ENDDO
1748       ENDDO
1749                 
1750       CALL crs_lbc_lnk( p_e3_crs    , cd_type, 1.0, pfillval=1.0 ) 
1751       CALL crs_lbc_lnk( p_e3_max_crs, cd_type, 1.0, pfillval=1.0 ) 
1752       !             
1753       !
1754   END SUBROUTINE crs_dom_e3
1755
1756   SUBROUTINE crs_dom_sfc( p_mask, cd_type, p_surf_crs, p_surf_crs_msk,  p_e1, p_e2, p_e3 )
1757
1758      !!  Arguments
1759      CHARACTER(len=1),                         INTENT(in)           :: cd_type      ! grid type T, W ( U, V, F)
1760      REAL(wp), DIMENSION(jpi,jpj,jpk)        , INTENT(in)           :: p_mask       ! Parent grid T mask
1761      REAL(wp), DIMENSION(jpi,jpj)            , INTENT(in), OPTIONAL :: p_e1, p_e2         ! 3D tracer T or W on parent grid
1762      REAL(wp), DIMENSION(jpi,jpj,jpk)        , INTENT(in), OPTIONAL :: p_e3         ! 3D tracer T or W on parent grid
1763      REAL(wp), DIMENSION(jpi_crs,jpj_crs,jpk), INTENT(out)          :: p_surf_crs ! Coarse grid box east or north face quantity
1764      REAL(wp), DIMENSION(jpi_crs,jpj_crs,jpk), INTENT(out)          :: p_surf_crs_msk ! Coarse grid box east or north face quantity
1765
1766      !! Local variables
1767      INTEGER  :: ji, jj, jk                   ! dummy loop indices
1768      INTEGER  :: ii, ij, je_2
1769      REAL(wp), DIMENSION(jpi,jpj,jpk) :: zsurf, zsurfmsk   
1770      !!---------------------------------------------------------------- 
1771      ! Initialize
1772
1773      !
1774      SELECT CASE ( cd_type )
1775     
1776         CASE ('W')   
1777            DO jk = 1, jpk
1778               zsurf(:,:,jk) = p_e1(:,:) * p_e2(:,:) 
1779            ENDDO
1780            zsurfmsk(:,:,1) = zsurf(:,:,1) * p_mask(:,:,1) 
1781            DO jk = 2, jpk
1782               zsurfmsk(:,:,jk) = zsurf(:,:,jk) * p_mask(:,:,jk-1) 
1783            ENDDO
1784
1785         CASE ('V')     
1786            DO jk = 1, jpk
1787               zsurf(:,:,jk) = p_e1(:,:) * p_e3(:,:,jk) 
1788            ENDDO
1789            DO jk = 1, jpk
1790               zsurfmsk(:,:,jk) = zsurf(:,:,jk) * p_mask(:,:,jk) 
1791            ENDDO
1792
1793         CASE ('U')     
1794            DO jk = 1, jpk
1795               zsurf(:,:,jk) = p_e2(:,:) * p_e3(:,:,jk) 
1796            ENDDO
1797            DO jk = 1, jpk
1798               zsurfmsk(:,:,jk) = zsurf(:,:,jk) * p_mask(:,:,jk) 
1799            ENDDO
1800
1801         CASE DEFAULT
1802            DO jk = 1, jpk
1803               zsurf(:,:,jk) = p_e1(:,:) * p_e2(:,:) 
1804            ENDDO
1805            DO jk = 1, jpk
1806               zsurfmsk(:,:,jk) = zsurf(:,:,jk) * p_mask(:,:,jk) 
1807            ENDDO
1808      END SELECT
1809
1810      IF( nldj_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN     !!cc bande du sud style ORCA2
1811         IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN
1812            je_2 = mje_crs(2)
1813            DO jk = 1, jpk
1814               DO ji = nistr, niend, nn_factx
1815                  ii   = ( ji - mis_crs(2) ) * rfactx_r + 2 
1816                  !   
1817                  p_surf_crs    (ii,2,jk) =  zsurf(ji,je_2  ,jk) + zsurf(ji+1,je_2  ,jk) + zsurf(ji+2,je_2  ,jk) &
1818                    &                      + zsurf(ji,je_2-1,jk) + zsurf(ji+1,je_2-1,jk) + zsurf(ji+2,je_2-1,jk)  ! Why ?????
1819                  !
1820                  p_surf_crs_msk(ii,2,jk) =  zsurfmsk(ji,je_2,jk) + zsurfmsk(ji+1,je_2,jk) + zsurfmsk(ji+2,je_2,jk) 
1821                  !
1822               ENDDO
1823            ENDDO
1824         ENDIF
1825      ELSE
1826         je_2 = mjs_crs(2)
1827         DO jk = 1, jpk
1828            DO ji = nistr, niend, nn_factx
1829               ii   = ( ji - mis_crs(2) ) * rfactx_r + 2 
1830               
1831               p_surf_crs    (ii,2,jk) =  zsurf(ji,je_2  ,jk) + zsurf(ji+1,je_2  ,jk) + zsurf(ji+2,je_2  ,jk)  &
1832                    &                   + zsurf(ji,je_2+1,jk) + zsurf(ji+1,je_2+1,jk) + zsurf(ji+2,je_2+1,jk)  &
1833                    &                   + zsurf(ji,je_2+2,jk) + zsurf(ji+1,je_2+2,jk) + zsurf(ji+2,je_2+2,jk) 
1834
1835               p_surf_crs_msk(ii,2,jk) =  zsurfmsk(ji,je_2  ,jk) + zsurfmsk(ji+1,je_2  ,jk) + zsurfmsk(ji+2,je_2  ,jk)  &
1836                    &                   + zsurfmsk(ji,je_2+1,jk) + zsurfmsk(ji+1,je_2+1,jk) + zsurfmsk(ji+2,je_2+1,jk)  &
1837                    &                   + zsurfmsk(ji,je_2+2,jk) + zsurfmsk(ji+1,je_2+2,jk) + zsurfmsk(ji+2,je_2+2,jk) 
1838                ENDDO
1839            ENDDO
1840      ENDIF
1841         
1842      DO jk = 1, jpk
1843         DO jj = njstr, njend, nn_facty
1844            DO ji = nistr, niend, nn_factx
1845               ii = ( ji - mis_crs(2) ) * rfactx_r + 2 
1846               ij = ( jj - njstr ) * rfacty_r + 3
1847               !
1848               p_surf_crs    (ii,ij,jk) =  zsurf(ji,jj  ,jk) + zsurf(ji+1,jj  ,jk) + zsurf(ji+2,jj  ,jk)  &
1849                    &                    + zsurf(ji,jj+1,jk) + zsurf(ji+1,jj+1,jk) + zsurf(ji+2,jj+1,jk)  &
1850                    &                    + zsurf(ji,jj+2,jk) + zsurf(ji+1,jj+2,jk) + zsurf(ji+2,jj+2,jk) 
1851
1852               p_surf_crs_msk(ii,ij,jk) =  zsurfmsk(ji,jj  ,jk) + zsurfmsk(ji+1,jj  ,jk) + zsurfmsk(ji+2,jj  ,jk)  &
1853                    &                    + zsurfmsk(ji,jj+1,jk) + zsurfmsk(ji+1,jj+1,jk) + zsurfmsk(ji+2,jj+1,jk)  &
1854                    &                    + zsurfmsk(ji,jj+2,jk) + zsurfmsk(ji+1,jj+2,jk) + zsurfmsk(ji+2,jj+2,jk) 
1855            ENDDO     
1856         ENDDO
1857      ENDDO   
1858
1859      CALL crs_lbc_lnk( p_surf_crs    , cd_type, 1.0, pfillval=1.0 )
1860      CALL crs_lbc_lnk( p_surf_crs_msk, cd_type, 1.0, pfillval=1.0 )
1861
1862   END SUBROUTINE crs_dom_sfc
1863   
1864   SUBROUTINE crs_dom_def
1865      !!----------------------------------------------------------------
1866      !!               *** SUBROUTINE crs_dom_def ***
1867      !! ** Purpose :  Three applications.
1868      !!               1) Define global domain indice of the croasening grid
1869      !!               2) Define local domain indice of the croasening grid
1870      !!               3) Define the processor domain indice for a croasening grid
1871      !!----------------------------------------------------------------
1872      !!
1873      !!  local variables
1874   
1875      INTEGER  :: ji,jj,jk,ijjgloT,ijis,ijie,ijjs,ijje,jn      ! dummy indices
1876      INTEGER  :: ierr                                ! allocation error status
1877 
1878 
1879     ! 1.a. Define global domain indices  : take into account the interior domain only ( removes i/j=1 , i/j=jpiglo/jpjglo ) then add 2/3 grid points
1880      jpiglo_crs   = INT( (jpiglo - 2) / nn_factx ) + 2
1881  !    jpjglo_crs   = INT( (jpjglo - 2) / nn_facty ) + 2  ! the -2 removes j=1, j=jpj
1882  !    jpjglo_crs   = INT( (jpjglo - 2) / nn_facty ) + 3
1883      jpjglo_crs   = INT( (jpjglo - MOD(jpjglo, nn_facty)) / nn_facty ) + 3
1884      jpiglo_crsm1 = jpiglo_crs - 1
1885      jpjglo_crsm1 = jpjglo_crs - 1 
1886
1887      jpi_crs = ( jpiglo_crs   - 2 * nn_hls + (jpni-1) ) / jpni + 2 * nn_hls
1888      jpj_crs = ( jpjglo_crsm1 - 2 * nn_hls + (jpnj-1) ) / jpnj + 2 * nn_hls   
1889             
1890      IF( noso < 0 ) jpj_crs = jpj_crs + 1    ! add a local band on southern processors 
1891       
1892      jpi_crsm1   = jpi_crs - 1
1893      jpj_crsm1   = jpj_crs - 1
1894      nperio_crs  = jperio
1895      npolj_crs   = npolj
1896     
1897      ierr = crs_dom_alloc()          ! allocate most coarse grid arrays
1898
1899      ! 2.a Define processor domain
1900      IF( .NOT. lk_mpp ) THEN
1901         nimpp_crs  = 1
1902         njmpp_crs  = 1
1903         nlci_crs   = jpi_crs
1904         nlcj_crs   = jpj_crs
1905         nldi_crs   = 1
1906         nldj_crs   = 1
1907         nlei_crs   = jpi_crs
1908         nlej_crs   = jpj_crs
1909      ELSE
1910         ! Initialisation of most local variables -
1911         nimpp_crs  = 1
1912         njmpp_crs  = 1
1913         nlci_crs   = jpi_crs
1914         nlcj_crs   = jpj_crs
1915         nldi_crs   = 1
1916         nldj_crs   = 1
1917         nlei_crs   = jpi_crs
1918         nlej_crs   = jpj_crs
1919         
1920        ! Calculs suivant une découpage en j
1921        DO jn = 1, jpnij, jpni
1922           IF( jn < ( jpnij - jpni + 1 ) ) THEN
1923              nlejt_crs(jn) = AINT( REAL( ( jpjglo - (njmppt(jn     ) - 1) ) / nn_facty, wp ) ) &
1924                       &    - AINT( REAL( ( jpjglo - (njmppt(jn+jpni) - 1) ) / nn_facty, wp ) )
1925           ELSE                                             
1926              nlejt_crs(jn) = AINT( REAL(  nlejt(jn) / nn_facty, wp ) ) + 1           
1927           ENDIF
1928           IF( noso < 0 ) nlejt_crs(jn) = nlejt_crs(jn) + 1             
1929           SELECT CASE( ibonjt(jn) )
1930              CASE ( -1 )
1931                IF( MOD( jpjglo - njmppt(jn), nn_facty) > 0 )  nlejt_crs(jn) = nlejt_crs(jn) + 1
1932                nlcjt_crs(jn) = nlejt_crs(jn) + nn_hls
1933                nldjt_crs(jn) = nldjt(jn)
1934             
1935              CASE ( 0 )
1936             
1937                nldjt_crs(jn) = nldjt(jn)
1938                IF( nldjt(jn) == 1 )  nlejt_crs(jn) = nlejt_crs(jn) + 1
1939                nlejt_crs(jn) = nlejt_crs(jn) + nn_hls
1940                nlcjt_crs(jn) = nlejt_crs(jn) + nn_hls
1941               
1942              CASE ( 1, 2 )
1943             
1944                nlejt_crs(jn) = nlejt_crs(jn) + nn_hls
1945                nlcjt_crs(jn) = nlejt_crs(jn)
1946                nldjt_crs(jn) = nldjt(jn)
1947               
1948              CASE DEFAULT
1949                 CALL ctl_stop( 'STOP', 'error from crs_dom_def, you should not be there (1) ...' )
1950           END SELECT
1951           IF( nlcjt_crs(jn) > jpj_crs )     jpj_crs = jpj_crs + 1
1952
1953           IF(nldjt_crs(jn) == 1 ) THEN
1954              njmppt_crs(jn) = 1
1955           ELSE
1956              njmppt_crs(jn) = 2 + ANINT(REAL((njmppt(jn) + 1 - MOD( jpjglo , nn_facty )) / nn_facty, wp ) )
1957           ENDIF           
1958           
1959           DO jj = jn + 1, jn + jpni - 1
1960              nlejt_crs(jj) = nlejt_crs(jn) 
1961              nlcjt_crs(jj) = nlcjt_crs(jn)
1962              nldjt_crs(jj) = nldjt_crs(jn)
1963              njmppt_crs(jj)= njmppt_crs(jn)
1964           ENDDO
1965        ENDDO 
1966        nlej_crs  = nlejt_crs(nproc + 1) 
1967        nlcj_crs  = nlcjt_crs(nproc + 1)
1968        nldj_crs  = nldjt_crs(nproc + 1)
1969        njmpp_crs = njmppt_crs(nproc + 1)
1970
1971        ! Calcul suivant un decoupage en i
1972        DO jn = 1, jpni
1973           IF( jn == 1 ) THEN         
1974              nleit_crs(jn) = AINT( REAL( ( nimppt(jn  ) - 1 + nlcit(jn  ) )  / nn_factx, wp) )
1975           ELSE
1976              nleit_crs(jn) = AINT( REAL( ( nimppt(jn  ) - 1 + nlcit(jn  ) )  / nn_factx, wp) ) &
1977                 &          - AINT( REAL( ( nimppt(jn-1) - 1 + nlcit(jn-1) )  / nn_factx, wp) )
1978           ENDIF
1979
1980           SELECT CASE( ibonit(jn) )
1981              CASE ( -1 )
1982                 nleit_crs(jn) = nleit_crs(jn) + nn_hls           
1983                 nlcit_crs(jn) = nleit_crs(jn) + nn_hls
1984                 nldit_crs(jn) = nldit(jn) 
1985             
1986              CASE ( 0 )
1987                 nleit_crs(jn) = nleit_crs(jn) + nn_hls
1988                 nlcit_crs(jn) = nleit_crs(jn) + nn_hls
1989                 nldit_crs(jn) = nldit(jn) 
1990               
1991              CASE ( 1, 2 )
1992                 IF( MOD( jpiglo - nimppt(jn), nn_factx) > 0 )  nleit_crs(jn) = nleit_crs(jn) + 1
1993                 nleit_crs(jn) = nleit_crs(jn) + nn_hls
1994                 nlcit_crs(jn) = nleit_crs(jn)
1995                 nldit_crs(jn) = nldit(jn) 
1996
1997              CASE DEFAULT
1998                 CALL ctl_stop( 'STOP', 'error from crs_dom_def, you should not be there (2) ...' )
1999           END SELECT
2000
2001           nimppt_crs(jn) = ANINT( REAL( (nimppt(jn) + 1 ) / nn_factx, wp ) ) + 1
2002           DO jj = jn + jpni , jpnij, jpni
2003              nleit_crs(jj) = nleit_crs(jn) 
2004              nlcit_crs(jj) = nlcit_crs(jn)
2005              nldit_crs(jj) = nldit_crs(jn)
2006              nimppt_crs(jj)= nimppt_crs(jn)
2007           ENDDO
2008         ENDDO 
2009       
2010         nlei_crs  = nleit_crs(nproc + 1) 
2011         nlci_crs  = nlcit_crs(nproc + 1)
2012         nldi_crs  = nldit_crs(nproc + 1)
2013         nimpp_crs = nimppt_crs(nproc + 1)
2014
2015         DO ji = 1, jpi_crs
2016            mig_crs(ji) = ji + nimpp_crs - 1
2017         ENDDO
2018         DO jj = 1, jpj_crs
2019            mjg_crs(jj) = jj + njmpp_crs - 1!
2020         ENDDO
2021       
2022         DO ji = 1, jpiglo_crs
2023            mi0_crs(ji) = MAX( 1, MIN( ji - nimpp_crs + 1 , jpi_crs + 1 ) )
2024            mi1_crs(ji) = MAX( 0, MIN( ji - nimpp_crs + 1 , jpi_crs     ) )
2025         ENDDO
2026         
2027         DO jj = 1, jpjglo_crs
2028            mj0_crs(jj) = MAX( 1, MIN( jj - njmpp_crs + 1 , jpj_crs + 1 ) )
2029            mj1_crs(jj) = MAX( 0, MIN( jj - njmpp_crs + 1 , jpj_crs     ) )
2030         ENDDO
2031
2032      ENDIF
2033     
2034      !                         Save the parent grid information
2035      jpi_full    = jpi
2036      jpj_full    = jpj
2037      jpim1_full  = jpim1
2038      jpjm1_full  = jpjm1
2039      nperio_full = jperio
2040
2041      npolj_full  = npolj
2042      jpiglo_full = jpiglo
2043      jpjglo_full = jpjglo
2044
2045      nlcj_full   = nlcj
2046      nlci_full   = nlci
2047      nldi_full   = nldi
2048      nldj_full   = nldj
2049      nlei_full   = nlei
2050      nlej_full   = nlej
2051      nimpp_full  = nimpp     
2052      njmpp_full  = njmpp
2053     
2054      nlcit_full(:)  = nlcit(:)
2055      nldit_full(:)  = nldit(:)
2056      nleit_full(:)  = nleit(:)
2057      nimppt_full(:) = nimppt(:)
2058      nlcjt_full(:)  = nlcjt(:)
2059      nldjt_full(:)  = nldjt(:)
2060      nlejt_full(:)  = nlejt(:)
2061      njmppt_full(:) = njmppt(:)
2062     
2063      CALL dom_grid_crs  !swich de grille
2064     
2065
2066      IF(lwp) THEN
2067         WRITE(numout,*)
2068         WRITE(numout,*) 'crs_init : coarse grid dimensions'
2069         WRITE(numout,*) '~~~~~~~   coarse domain global j-dimension           jpjglo = ', jpjglo
2070         WRITE(numout,*) '~~~~~~~   coarse domain global i-dimension           jpiglo = ', jpiglo
2071         WRITE(numout,*) '~~~~~~~   coarse domain local  i-dimension              jpi = ', jpi
2072         WRITE(numout,*) '~~~~~~~   coarse domain local  j-dimension              jpj = ', jpj
2073         WRITE(numout,*)
2074         WRITE(numout,*) ' nproc  = '     , nproc
2075         WRITE(numout,*) ' nlci   = '     , nlci
2076         WRITE(numout,*) ' nlcj   = '     , nlcj
2077         WRITE(numout,*) ' nldi   = '     , nldi
2078         WRITE(numout,*) ' nldj   = '     , nldj
2079         WRITE(numout,*) ' nlei   = '     , nlei
2080         WRITE(numout,*) ' nlej   = '     , nlej
2081         WRITE(numout,*) ' nlei_full='    , nlei_full
2082         WRITE(numout,*) ' nldi_full='    , nldi_full
2083         WRITE(numout,*) ' nimpp  = '     , nimpp
2084         WRITE(numout,*) ' njmpp  = '     , njmpp
2085         WRITE(numout,*) ' njmpp_full  = ', njmpp_full
2086         WRITE(numout,*)
2087      ENDIF
2088     
2089      CALL dom_grid_glo
2090     
2091      mxbinctr   = INT( nn_factx * 0.5 )
2092      mybinctr   = INT( nn_facty * 0.5 )
2093
2094      nrestx = MOD( nn_factx, 2 )   ! check if even- or odd- numbered reduction factor
2095      nresty = MOD( nn_facty, 2 )
2096
2097      IF ( nrestx == 0 ) THEN
2098         mxbinctr = mxbinctr - 1
2099      ENDIF
2100
2101      IF ( nresty == 0 ) THEN
2102         mybinctr = mybinctr - 1
2103         IF ( jperio == 3 .OR. jperio == 4 )  nperio_crs = jperio + 2
2104         IF ( jperio == 5 .OR. jperio == 6 )  nperio_crs = jperio - 2 
2105
2106         IF ( npolj == 3 ) npolj_crs = 5
2107         IF ( npolj == 5 ) npolj_crs = 3
2108      ENDIF     
2109     
2110      rfactxy = nn_factx * nn_facty
2111     
2112      ! 2.b. Set up bins for coarse grid, horizontal only.
2113      ierr = crs_dom_alloc2()
2114     
2115      mis2_crs(:) = 0      ;      mie2_crs(:) = 0
2116      mjs2_crs(:) = 0      ;      mje2_crs(:) = 0
2117
2118     
2119      SELECT CASE ( nn_binref )
2120
2121      CASE ( 0 ) 
2122
2123         SELECT CASE ( jperio )
2124     
2125 
2126        CASE ( 0, 1, 3, 4 )    !   3, 4 : T-Pivot at North Fold
2127       
2128            DO ji = 2, jpiglo_crsm1
2129               ijie = ( ji * nn_factx ) - nn_factx   !cc
2130               ijis = ijie - nn_factx + 1
2131               mis2_crs(ji) = ijis
2132               mie2_crs(ji) = ijie
2133            ENDDO
2134            IF ( jpiglo - 1 - mie2_crs(jpiglo_crsm1) <= nn_factx ) mie2_crs(jpiglo_crsm1) = jpiglo - 2 
2135
2136            ! Handle first the northernmost bin
2137            IF ( nn_facty == 2 ) THEN   ;    ijjgloT = jpjglo - 1 
2138            ELSE                        ;    ijjgloT = jpjglo
2139            ENDIF
2140
2141            DO jj = 2, jpjglo_crs
2142                ijje = ijjgloT - nn_facty * ( jj - 3 )
2143                ijjs = ijje - nn_facty + 1                   
2144                mjs2_crs(jpjglo_crs-jj+2) = ijjs
2145                mje2_crs(jpjglo_crs-jj+2) = ijje
2146            ENDDO
2147
2148         CASE ( 2 ) 
2149            WRITE(numout,*)  'crs_init, jperio=2 not supported' 
2150       
2151         CASE ( 5, 6 )    ! F-pivot at North Fold
2152
2153            DO ji = 2, jpiglo_crsm1
2154               ijie = ( ji * nn_factx ) - nn_factx 
2155               ijis = ijie - nn_factx + 1
2156               mis2_crs(ji) = ijis
2157               mie2_crs(ji) = ijie
2158            ENDDO
2159            IF ( jpiglo - 1 - mie2_crs(jpiglo_crsm1) <= nn_factx ) mie_crs(jpiglo_crsm1)  = jpiglo - 2 
2160
2161            ! Treat the northernmost bin separately.
2162            jj = 2
2163            ijje = jpj - nn_facty * ( jj - 2 )
2164            IF ( nn_facty == 3 ) THEN   ;  ijjs = ijje - 1 
2165            ELSE                        ;  ijjs = ijje - nn_facty + 1
2166            ENDIF
2167            mjs2_crs(jpj_crs-jj+1) = ijjs
2168            mje2_crs(jpj_crs-jj+1) = ijje
2169
2170            ! Now bin the rest, any remainder at the south is lumped in the southern bin
2171            DO jj = 3, jpjglo_crsm1
2172                ijje = jpjglo - nn_facty * ( jj - 2 )
2173                ijjs = ijje - nn_facty + 1                 
2174                IF ( ijjs <= nn_facty )  ijjs = 2
2175                mjs2_crs(jpj_crs-jj+1)   = ijjs
2176                mje2_crs(jpj_crs-jj+1)   = ijje
2177            ENDDO
2178
2179         CASE DEFAULT
2180            WRITE(numout,*) 'crs_init. Only jperio = 0, 1, 3, 4, 5, 6 supported' 
2181 
2182         END SELECT
2183
2184      CASE (1 )
2185         WRITE(numout,*) 'crs_init.  Equator-centered bins option not yet available' 
2186
2187      END SELECT
2188
2189     ! Pad the boundaries, do not know if it is necessary
2190      mis2_crs(2) = 1             ;  mis2_crs(jpiglo_crs) = mie2_crs(jpiglo_crs - 1) + 1   
2191      mie2_crs(2) = nn_factx      ;  mie2_crs(jpiglo_crs) = jpiglo                         
2192      !
2193      mjs2_crs(1) = 1
2194      mje2_crs(1) = 1
2195      !
2196      mje2_crs(2) = mjs2_crs(3)-1 ;  mje2_crs(jpjglo_crs) = jpjglo
2197      mjs2_crs(2) = 1             ;  mjs2_crs(jpjglo_crs) = mje2_crs(jpjglo_crs) - nn_facty + 1 
2198 
2199      IF( .NOT. lk_mpp ) THEN     
2200        mis_crs(:) = mis2_crs(:) 
2201        mie_crs(:) = mie2_crs(:)
2202        mjs_crs(:) = mjs2_crs(:) 
2203        mje_crs(:) = mje2_crs(:) 
2204      ELSE
2205        DO jj = 1, nlej_crs
2206           mjs_crs(jj) = mjs2_crs(mjg_crs(jj)) - njmpp + 1
2207           mje_crs(jj) = mje2_crs(mjg_crs(jj)) - njmpp + 1
2208        ENDDO
2209        DO ji = 1, nlei_crs
2210           mis_crs(ji) = mis2_crs(mig_crs(ji)) - nimpp + 1
2211           mie_crs(ji) = mie2_crs(mig_crs(ji)) - nimpp + 1
2212        ENDDO
2213      ENDIF
2214      !
2215      nistr = mis_crs(2)  ;   niend = mis_crs(nlci_crs - 1)
2216      njstr = mjs_crs(3)  ;   njend = mjs_crs(nlcj_crs - 1)
2217      !
2218   END SUBROUTINE crs_dom_def
2219   
2220   SUBROUTINE crs_dom_bat
2221      !!----------------------------------------------------------------
2222      !!               *** SUBROUTINE crs_dom_bat ***
2223      !! ** Purpose :  coarsenig bathy
2224      !!----------------------------------------------------------------
2225      !!
2226      !!  local variables
2227      INTEGER  :: ji,jj,jk      ! dummy indices
2228      REAL(wp), DIMENSION(jpi_crs, jpj_crs) :: zmbk
2229      !!----------------------------------------------------------------
2230   
2231      mbathy_crs(:,:) = jpkm1
2232      mbkt_crs(:,:) = 1
2233      mbku_crs(:,:) = 1
2234      mbkv_crs(:,:) = 1
2235
2236
2237      DO jj = 1, jpj_crs
2238         DO ji = 1, jpi_crs
2239            jk = 0
2240            DO WHILE( tmask_crs(ji,jj,jk+1) > 0.)
2241               jk = jk + 1
2242            ENDDO
2243            mbathy_crs(ji,jj) = float( jk )
2244         ENDDO
2245      ENDDO
2246     
2247      zmbk(:,:) = 0.0
2248      zmbk(:,:) = REAL( mbathy_crs(:,:), wp ) ;   CALL crs_lbc_lnk(zmbk,'T',1.0)   ;   mbathy_crs(:,:) = NINT( zmbk(:,:) )
2249
2250
2251      !
2252      IF(lwp) WRITE(numout,*)
2253      IF(lwp) WRITE(numout,*) '    crsini : mbkt is ocean bottom k-index of T-, U-, V- and W-levels '
2254      IF(lwp) WRITE(numout,*) '    ~~~~~~~~~~~~~'
2255      !
2256      mbkt_crs(:,:) = MAX( mbathy_crs(:,:) , 1 )    ! bottom k-index of T-level (=1 over land)
2257      !                                     ! bottom k-index of W-level = mbkt+1
2258
2259      DO jj = 1, jpj_crsm1                      ! bottom k-index of u- (v-) level
2260         DO ji = 1, jpi_crsm1
2261            mbku_crs(ji,jj) = MIN(  mbkt_crs(ji+1,jj  ) , mbkt_crs(ji,jj)  )
2262            mbkv_crs(ji,jj) = MIN(  mbkt_crs(ji  ,jj+1) , mbkt_crs(ji,jj)  )
2263         END DO
2264      END DO
2265
2266      ! convert into REAL to use lbc_lnk ; impose a min value of 1 as a zero can be set in lbclnk
2267      zmbk(:,:) = 1.e0;   
2268      zmbk(:,:) = REAL( mbku_crs(:,:), wp )   ;   CALL crs_lbc_lnk(zmbk,'U',1.0) ; mbku_crs  (:,:) = MAX( NINT( zmbk(:,:) ), 1 ) 
2269      zmbk(:,:) = REAL( mbkv_crs(:,:), wp )   ;   CALL crs_lbc_lnk(zmbk,'V',1.0) ; mbkv_crs  (:,:) = MAX( NINT( zmbk(:,:) ), 1 ) 
2270      !
2271   END SUBROUTINE crs_dom_bat
2272
2273
2274END MODULE crsdom
Note: See TracBrowser for help on using the repository browser.