source: branches/2013/dev_LOCEAN_CMCC_INGV_MERC_UKMO_2013/NEMOGCM/NEMO/OPA_SRC/CRS/crsdom.F90 @ 4247

Last change on this file since 4247 was 4247, checked in by cetlod, 8 years ago

dev_locean_cmcc_ingv_merc_ukmo : minor bugs corrections

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