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 branches/UKMO/dev_r8183_ICEMODEL_svn_removed/NEMOGCM/NEMO/OPA_SRC/CRS – NEMO

source: branches/UKMO/dev_r8183_ICEMODEL_svn_removed/NEMOGCM/NEMO/OPA_SRC/CRS/crsdom.F90 @ 8733

Last change on this file since 8733 was 8733, checked in by dancopsey, 6 years ago

Remove svn keywords.

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