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/branches/2019/dev_r11351_fldread_with_XIOS/src/OCE/CRS – NEMO

source: NEMO/branches/2019/dev_r11351_fldread_with_XIOS/src/OCE/CRS/crsdom.F90 @ 13463

Last change on this file since 13463 was 13463, checked in by andmirek, 4 years ago

Ticket #2195:update to trunk 13461

  • Property svn:keywords set to Id
File size: 111.1 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( Njs0_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, Nie0_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_wp
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_wp
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_wp
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, Nie0_crs 
104            ijis = mis_crs(ji)     ;   ijie = mie_crs(ji)       
105            DO jj = 3, Nje0_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_wp
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_wp
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_wp
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_wp )
127      CALL crs_lbc_lnk( vmask_crs, 'V', 1.0_wp )
128      CALL crs_lbc_lnk( umask_crs, 'U', 1.0_wp )
129      CALL crs_lbc_lnk( fmask_crs, 'F', 1.0_wp )
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 =  Njs0_crs, Nje0_crs
171               ijjs = mjs_crs(jj) + mybinctr
172               DO ji = 2, Nie0_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 =  Njs0_crs, Nje0_crs
180               ijjs = mjs_crs(jj) + mybinctr                 
181               DO ji = 2, Nie0_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 =  Njs0_crs, Nje0_crs
189               ijjs = mjs_crs(jj)
190               DO ji = 2, Nie0_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 =  Njs0_crs, Nje0_crs
198               ijjs = mjs_crs(jj)
199               DO ji = 2, Nie0_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_wp )
209      CALL crs_lbc_lnk( p_glam_crs, cd_type, 1.0_wp )
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, Nie0_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, Nie0_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, Nie0_crs
264            ijie = mie_crs(ji)
265            DO jj = Njs0_crs, Nje0_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_wp, pfillval=1.0_wp )
299      CALL crs_lbc_lnk( p_e2_crs, cd_type, 1.0_wp, pfillval=1.0_wp )
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( Njs0_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_wp ) 
443      CALL crs_lbc_lnk( p_fld2_crs, cd_type, 1.0_wp ) 
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( Njs0_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( Njs0_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( Njs0_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( Njs0_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( Njs0_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( Njs0_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( Njs0_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( Njs0_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( Njs0_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( Njs0_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( Njs0_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( Njs0_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( Njs0_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( Njs0_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( Njs0_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( Njs0_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( Njs0_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( Njs0_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( Njs0_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( Njs0_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( Njs0_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_wp, pfillval=1.0_wp ) 
1751       CALL crs_lbc_lnk( p_e3_max_crs, cd_type, 1.0_wp, pfillval=1.0_wp ) 
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( Njs0_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_wp, pfillval=1.0_wp )
1860      CALL crs_lbc_lnk( p_surf_crs_msk, cd_type, 1.0_wp, pfillval=1.0_wp )
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         Nis0_crs  = 1
1904         Njs0_crs  = 1
1905         Nie0_crs  = jpi_crs
1906         Nje0_crs  = jpj_crs
1907      ELSE
1908         ! Initialisation of most local variables -
1909         nimpp_crs = 1
1910         njmpp_crs = 1
1911         Nis0_crs  = 1
1912         Njs0_crs  = 1
1913         Nie0_crs  = jpi_crs
1914         Nje0_crs  = jpj_crs
1915         
1916        ! Calculs suivant une découpage en j
1917        DO jn = 1, jpnij, jpni
1918           IF( jn < ( jpnij - jpni + 1 ) ) THEN
1919              nje0all_crs(jn) = AINT( REAL( ( jpjglo - (njmppt(jn     ) - 1) ) / nn_facty, wp ) ) &
1920                       &    - AINT( REAL( ( jpjglo - (njmppt(jn+jpni) - 1) ) / nn_facty, wp ) )
1921           ELSE                                             
1922              nje0all_crs(jn) = AINT( REAL(  nje0all(jn) / nn_facty, wp ) ) + 1           
1923           ENDIF
1924           IF( noso < 0 ) nje0all_crs(jn) = nje0all_crs(jn) + 1             
1925           SELECT CASE( ibonjt(jn) )
1926              CASE ( -1 )
1927                IF( MOD( jpjglo - njmppt(jn), nn_facty) > 0 )  nje0all_crs(jn) = nje0all_crs(jn) + 1
1928                jpjall_crs (jn) = nje0all_crs(jn) + nn_hls
1929                njs0all_crs(jn) = njs0all(jn)
1930             
1931              CASE ( 0 )
1932             
1933                njs0all_crs(jn) = njs0all(jn)
1934                IF( njs0all(jn) == 1 )  nje0all_crs(jn) = nje0all_crs(jn) + 1
1935                nje0all_crs(jn) = nje0all_crs(jn) + nn_hls
1936                jpjall_crs (jn) = nje0all_crs(jn) + nn_hls
1937               
1938              CASE ( 1, 2 )
1939             
1940                nje0all_crs(jn) = nje0all_crs(jn) + nn_hls
1941                jpjall_crs (jn) = nje0all_crs(jn)
1942                njs0all_crs(jn) = njs0all(jn)
1943               
1944              CASE DEFAULT
1945                 CALL ctl_stop( 'STOP', 'error from crs_dom_def, you should not be there (1) ...' )
1946           END SELECT
1947           IF( jpjall_crs(jn) > jpj_crs )     jpj_crs = jpj_crs + 1
1948
1949           IF(njs0all_crs(jn) == 1 ) THEN
1950              njmppt_crs(jn) = 1
1951           ELSE
1952              njmppt_crs(jn) = 2 + ANINT(REAL((njmppt(jn) + 1 - MOD( jpjglo , nn_facty )) / nn_facty, wp ) )
1953           ENDIF           
1954           
1955           DO jj = jn + 1, jn + jpni - 1
1956              nje0all_crs(jj) = nje0all_crs(jn) 
1957              jpjall_crs (jj) = jpjall_crs(jn)
1958              njs0all_crs(jj) = njs0all_crs(jn)
1959              njmppt_crs (jj) = njmppt_crs(jn)
1960           ENDDO
1961        ENDDO 
1962        Nje0_crs  = nje0all_crs(nproc + 1) 
1963        jpj_crs   = jpjall_crs (nproc + 1)
1964        Njs0_crs  = njs0all_crs(nproc + 1)
1965        njmpp_crs = njmppt_crs (nproc + 1)
1966
1967        ! Calcul suivant un decoupage en i
1968        DO jn = 1, jpni
1969           IF( jn == 1 ) THEN         
1970              nie0all_crs(jn) = AINT( REAL( ( nimppt(jn  ) - 1 + jpiall(jn  ) )  / nn_factx, wp) )
1971           ELSE
1972              nie0all_crs(jn) = AINT( REAL( ( nimppt(jn  ) - 1 + jpiall(jn  ) )  / nn_factx, wp) ) &
1973                 &            - AINT( REAL( ( nimppt(jn-1) - 1 + jpiall(jn-1) )  / nn_factx, wp) )
1974           ENDIF
1975
1976           SELECT CASE( ibonit(jn) )
1977              CASE ( -1 )
1978                 nie0all_crs(jn) = nie0all_crs(jn) + nn_hls           
1979                 jpiall_crs (jn) = nie0all_crs(jn) + nn_hls
1980                 nis0all_crs(jn) = nis0all(jn) 
1981             
1982              CASE ( 0 )
1983                 nie0all_crs(jn) = nie0all_crs(jn) + nn_hls
1984                 jpiall_crs (jn) = nie0all_crs(jn) + nn_hls
1985                 nis0all_crs(jn) = nis0all(jn) 
1986               
1987              CASE ( 1, 2 )
1988                 IF( MOD( jpiglo - nimppt(jn), nn_factx) > 0 )  nie0all_crs(jn) = nie0all_crs(jn) + 1
1989                 nie0all_crs(jn) = nie0all_crs(jn) + nn_hls
1990                 jpiall_crs (jn) = nie0all_crs(jn)
1991                 nis0all_crs(jn) = nis0all(jn) 
1992
1993              CASE DEFAULT
1994                 CALL ctl_stop( 'STOP', 'error from crs_dom_def, you should not be there (2) ...' )
1995           END SELECT
1996
1997           nimppt_crs(jn) = ANINT( REAL( (nimppt(jn) + 1 ) / nn_factx, wp ) ) + 1
1998           DO jj = jn + jpni , jpnij, jpni
1999              nie0all_crs(jj) = nie0all_crs(jn) 
2000              jpiall_crs (jj) = jpiall_crs (jn)
2001              nis0all_crs(jj) = nis0all_crs(jn)
2002              nimppt_crs (jj) = nimppt_crs (jn)
2003           ENDDO
2004         ENDDO 
2005       
2006         Nie0_crs  = nie0all_crs(nproc + 1) 
2007         jpi_crs   = jpiall_crs (nproc + 1)
2008         Nis0_crs  = nis0all_crs(nproc + 1)
2009         nimpp_crs = nimppt_crs (nproc + 1)
2010
2011         DO ji = 1, jpi_crs
2012            mig_crs(ji) = ji + nimpp_crs - 1
2013         ENDDO
2014         DO jj = 1, jpj_crs
2015            mjg_crs(jj) = jj + njmpp_crs - 1!
2016         ENDDO
2017       
2018         DO ji = 1, jpiglo_crs
2019            mi0_crs(ji) = MAX( 1, MIN( ji - nimpp_crs + 1 , jpi_crs + 1 ) )
2020            mi1_crs(ji) = MAX( 0, MIN( ji - nimpp_crs + 1 , jpi_crs     ) )
2021         ENDDO
2022         
2023         DO jj = 1, jpjglo_crs
2024            mj0_crs(jj) = MAX( 1, MIN( jj - njmpp_crs + 1 , jpj_crs + 1 ) )
2025            mj1_crs(jj) = MAX( 0, MIN( jj - njmpp_crs + 1 , jpj_crs     ) )
2026         ENDDO
2027
2028      ENDIF
2029     
2030      !                         Save the parent grid information
2031      jpi_full    = jpi
2032      jpj_full    = jpj
2033      jpim1_full  = jpim1
2034      jpjm1_full  = jpjm1
2035      nperio_full = jperio
2036
2037      npolj_full  = npolj
2038      jpiglo_full = jpiglo
2039      jpjglo_full = jpjglo
2040
2041      jpj_full   = jpj
2042      jpi_full   = jpi
2043      Nis0_full  = Nis0
2044      Njs0_full  = Njs0
2045      Nie0_full  = Nie0
2046      Nje0_full  = Nje0
2047      nimpp_full = nimpp     
2048      njmpp_full = njmpp
2049     
2050      jpiall_full (:) = jpiall (:)
2051      nis0all_full(:) = nis0all(:)
2052      nie0all_full(:) = nie0all(:)
2053      nimppt_full (:) = nimppt (:)
2054      jpjall_full (:) = jpjall (:)
2055      njs0all_full(:) = njs0all(:)
2056      nje0all_full(:) = nje0all(:)
2057      njmppt_full (:) = njmppt (:)
2058     
2059      CALL dom_grid_crs  !swich de grille
2060     
2061
2062      IF(lwp) THEN
2063         WRITE(numout,*)
2064         WRITE(numout,*) 'crs_init : coarse grid dimensions'
2065         WRITE(numout,*) '~~~~~~~   coarse domain global j-dimension           jpjglo = ', jpjglo
2066         WRITE(numout,*) '~~~~~~~   coarse domain global i-dimension           jpiglo = ', jpiglo
2067         WRITE(numout,*) '~~~~~~~   coarse domain local  i-dimension              jpi = ', jpi
2068         WRITE(numout,*) '~~~~~~~   coarse domain local  j-dimension              jpj = ', jpj
2069         WRITE(numout,*)
2070         WRITE(numout,*) ' nproc  = '     , nproc
2071         WRITE(numout,*) ' jpi    = '     , jpi
2072         WRITE(numout,*) ' jpj    = '     , jpj
2073         WRITE(numout,*) ' Nis0   = '     , Nis0
2074         WRITE(numout,*) ' Njs0   = '     , Njs0
2075         WRITE(numout,*) ' Nie0   = '     , Nie0
2076         WRITE(numout,*) ' Nje0   = '     , Nje0
2077         WRITE(numout,*) ' Nie0_full='    , Nie0_full
2078         WRITE(numout,*) ' Nis0_full='    , Nis0_full
2079         WRITE(numout,*) ' nimpp  = '     , nimpp
2080         WRITE(numout,*) ' njmpp  = '     , njmpp
2081         WRITE(numout,*) ' njmpp_full  = ', njmpp_full
2082         WRITE(numout,*)
2083      ENDIF
2084     
2085      CALL dom_grid_glo
2086     
2087      mxbinctr   = INT( nn_factx * 0.5 )
2088      mybinctr   = INT( nn_facty * 0.5 )
2089
2090      nrestx = MOD( nn_factx, 2 )   ! check if even- or odd- numbered reduction factor
2091      nresty = MOD( nn_facty, 2 )
2092
2093      IF ( nrestx == 0 ) THEN
2094         mxbinctr = mxbinctr - 1
2095      ENDIF
2096
2097      IF ( nresty == 0 ) THEN
2098         mybinctr = mybinctr - 1
2099         IF ( jperio == 3 .OR. jperio == 4 )  nperio_crs = jperio + 2
2100         IF ( jperio == 5 .OR. jperio == 6 )  nperio_crs = jperio - 2 
2101
2102         IF ( npolj == 3 ) npolj_crs = 5
2103         IF ( npolj == 5 ) npolj_crs = 3
2104      ENDIF     
2105     
2106      rfactxy = nn_factx * nn_facty
2107     
2108      ! 2.b. Set up bins for coarse grid, horizontal only.
2109      ierr = crs_dom_alloc2()
2110     
2111      mis2_crs(:) = 0      ;      mie2_crs(:) = 0
2112      mjs2_crs(:) = 0      ;      mje2_crs(:) = 0
2113
2114     
2115      SELECT CASE ( nn_binref )
2116
2117      CASE ( 0 ) 
2118
2119         SELECT CASE ( jperio )
2120     
2121 
2122        CASE ( 0, 1, 3, 4 )    !   3, 4 : T-Pivot at North Fold
2123       
2124            DO ji = 2, jpiglo_crsm1
2125               ijie = ( ji * nn_factx ) - nn_factx   !cc
2126               ijis = ijie - nn_factx + 1
2127               mis2_crs(ji) = ijis
2128               mie2_crs(ji) = ijie
2129            ENDDO
2130            IF ( jpiglo - 1 - mie2_crs(jpiglo_crsm1) <= nn_factx ) mie2_crs(jpiglo_crsm1) = jpiglo - 2 
2131
2132            ! Handle first the northernmost bin
2133            IF ( nn_facty == 2 ) THEN   ;    ijjgloT = jpjglo - 1 
2134            ELSE                        ;    ijjgloT = jpjglo
2135            ENDIF
2136
2137            DO jj = 2, jpjglo_crs
2138                ijje = ijjgloT - nn_facty * ( jj - 3 )
2139                ijjs = ijje - nn_facty + 1                   
2140                mjs2_crs(jpjglo_crs-jj+2) = ijjs
2141                mje2_crs(jpjglo_crs-jj+2) = ijje
2142            ENDDO
2143
2144         CASE ( 2 ) 
2145            WRITE(numout,*)  'crs_init, jperio=2 not supported' 
2146       
2147         CASE ( 5, 6 )    ! F-pivot at North Fold
2148
2149            DO ji = 2, jpiglo_crsm1
2150               ijie = ( ji * nn_factx ) - nn_factx 
2151               ijis = ijie - nn_factx + 1
2152               mis2_crs(ji) = ijis
2153               mie2_crs(ji) = ijie
2154            ENDDO
2155            IF ( jpiglo - 1 - mie2_crs(jpiglo_crsm1) <= nn_factx ) mie_crs(jpiglo_crsm1)  = jpiglo - 2 
2156
2157            ! Treat the northernmost bin separately.
2158            jj = 2
2159            ijje = jpj - nn_facty * ( jj - 2 )
2160            IF ( nn_facty == 3 ) THEN   ;  ijjs = ijje - 1 
2161            ELSE                        ;  ijjs = ijje - nn_facty + 1
2162            ENDIF
2163            mjs2_crs(jpj_crs-jj+1) = ijjs
2164            mje2_crs(jpj_crs-jj+1) = ijje
2165
2166            ! Now bin the rest, any remainder at the south is lumped in the southern bin
2167            DO jj = 3, jpjglo_crsm1
2168                ijje = jpjglo - nn_facty * ( jj - 2 )
2169                ijjs = ijje - nn_facty + 1                 
2170                IF ( ijjs <= nn_facty )  ijjs = 2
2171                mjs2_crs(jpj_crs-jj+1)   = ijjs
2172                mje2_crs(jpj_crs-jj+1)   = ijje
2173            ENDDO
2174
2175         CASE DEFAULT
2176            WRITE(numout,*) 'crs_init. Only jperio = 0, 1, 3, 4, 5, 6 supported' 
2177 
2178         END SELECT
2179
2180      CASE (1 )
2181         WRITE(numout,*) 'crs_init.  Equator-centered bins option not yet available' 
2182
2183      END SELECT
2184
2185     ! Pad the boundaries, do not know if it is necessary
2186      mis2_crs(2) = 1             ;  mis2_crs(jpiglo_crs) = mie2_crs(jpiglo_crs - 1) + 1   
2187      mie2_crs(2) = nn_factx      ;  mie2_crs(jpiglo_crs) = jpiglo                         
2188      !
2189      mjs2_crs(1) = 1
2190      mje2_crs(1) = 1
2191      !
2192      mje2_crs(2) = mjs2_crs(3)-1 ;  mje2_crs(jpjglo_crs) = jpjglo
2193      mjs2_crs(2) = 1             ;  mjs2_crs(jpjglo_crs) = mje2_crs(jpjglo_crs) - nn_facty + 1 
2194 
2195      IF( .NOT. lk_mpp ) THEN     
2196        mis_crs(:) = mis2_crs(:) 
2197        mie_crs(:) = mie2_crs(:)
2198        mjs_crs(:) = mjs2_crs(:) 
2199        mje_crs(:) = mje2_crs(:) 
2200      ELSE
2201        DO jj = 1, Nje0_crs
2202           mjs_crs(jj) = mjs2_crs(mjg_crs(jj)) - njmpp + 1
2203           mje_crs(jj) = mje2_crs(mjg_crs(jj)) - njmpp + 1
2204        ENDDO
2205        DO ji = 1, Nie0_crs
2206           mis_crs(ji) = mis2_crs(mig_crs(ji)) - nimpp + 1
2207           mie_crs(ji) = mie2_crs(mig_crs(ji)) - nimpp + 1
2208        ENDDO
2209      ENDIF
2210      !
2211      nistr = mis_crs(2)  ;   niend = mis_crs(jpi_crs - 1)
2212      njstr = mjs_crs(3)  ;   njend = mjs_crs(jpj_crs - 1)
2213      !
2214   END SUBROUTINE crs_dom_def
2215   
2216   SUBROUTINE crs_dom_bat
2217      !!----------------------------------------------------------------
2218      !!               *** SUBROUTINE crs_dom_bat ***
2219      !! ** Purpose :  coarsenig bathy
2220      !!----------------------------------------------------------------
2221      !!
2222      !!  local variables
2223      INTEGER  :: ji,jj,jk      ! dummy indices
2224      REAL(wp), DIMENSION(jpi_crs, jpj_crs) :: zmbk
2225      !!----------------------------------------------------------------
2226   
2227      mbathy_crs(:,:) = jpkm1
2228      mbkt_crs(:,:) = 1
2229      mbku_crs(:,:) = 1
2230      mbkv_crs(:,:) = 1
2231
2232
2233      DO jj = 1, jpj_crs
2234         DO ji = 1, jpi_crs
2235            jk = 0
2236            DO WHILE( tmask_crs(ji,jj,jk+1) > 0.)
2237               jk = jk + 1
2238            ENDDO
2239            mbathy_crs(ji,jj) = float( jk )
2240         ENDDO
2241      ENDDO
2242     
2243      zmbk(:,:) = 0.0
2244      zmbk(:,:) = REAL( mbathy_crs(:,:), wp ) ;   CALL crs_lbc_lnk(zmbk,'T',1.0_wp)   ;   mbathy_crs(:,:) = NINT( zmbk(:,:) )
2245
2246
2247      !
2248      IF(lwp) WRITE(numout,*)
2249      IF(lwp) WRITE(numout,*) '    crsini : mbkt is ocean bottom k-index of T-, U-, V- and W-levels '
2250      IF(lwp) WRITE(numout,*) '    ~~~~~~~~~~~~~'
2251      !
2252      mbkt_crs(:,:) = MAX( mbathy_crs(:,:) , 1 )    ! bottom k-index of T-level (=1 over land)
2253      !                                     ! bottom k-index of W-level = mbkt+1
2254
2255      DO jj = 1, jpj_crsm1                      ! bottom k-index of u- (v-) level
2256         DO ji = 1, jpi_crsm1
2257            mbku_crs(ji,jj) = MIN(  mbkt_crs(ji+1,jj  ) , mbkt_crs(ji,jj)  )
2258            mbkv_crs(ji,jj) = MIN(  mbkt_crs(ji  ,jj+1) , mbkt_crs(ji,jj)  )
2259         END DO
2260      END DO
2261
2262      ! convert into REAL to use lbc_lnk ; impose a min value of 1 as a zero can be set in lbclnk
2263      zmbk(:,:) = 1.e0;   
2264      zmbk(:,:) = REAL( mbku_crs(:,:), wp )   ;   CALL crs_lbc_lnk(zmbk,'U',1.0_wp) ; mbku_crs  (:,:) = MAX( NINT( zmbk(:,:) ), 1 ) 
2265      zmbk(:,:) = REAL( mbkv_crs(:,:), wp )   ;   CALL crs_lbc_lnk(zmbk,'V',1.0_wp) ; mbkv_crs  (:,:) = MAX( NINT( zmbk(:,:) ), 1 ) 
2266      !
2267   END SUBROUTINE crs_dom_bat
2268
2269
2270END MODULE crsdom
Note: See TracBrowser for help on using the repository browser.