New URL for NEMO forge!   http://forge.nemo-ocean.eu

Since March 2022 along with NEMO 4.2 release, the code development moved to a self-hosted GitLab.
This present forge is now archived and remained online for history.
crsdom.F90 in branches/UKMO/dev_r5107_hadgem3_mct/NEMOGCM/NEMO/OPA_SRC/CRS – NEMO

source: branches/UKMO/dev_r5107_hadgem3_mct/NEMOGCM/NEMO/OPA_SRC/CRS/crsdom.F90 @ 5279

Last change on this file since 5279 was 4314, checked in by cetlod, 10 years ago

v3.6_alpha : fix to compile without FPP key key_mpp_mpi, see ticket #1188

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