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 trunk/NEMOGCM/NEMO/OPA_SRC/CRS – NEMO

source: trunk/NEMOGCM/NEMO/OPA_SRC/CRS/crsdom.F90 @ 5302

Last change on this file since 5302 was 5302, checked in by smasson, 9 years ago

wrk_alloc/dealloc check

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