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

source: branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/CRS/crsdom.F90 @ 5602

Last change on this file since 5602 was 5602, checked in by cbricaud, 9 years ago

merge change from trunk rev 5003 to 5519 ( rev where branche 3.6_stable were created )

  • Property svn:keywords set to Id
File size: 145.0 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),PUBLIC :: r_inf = 1e+7 !cbr 1e+36
55
56   !! Substitutions
57#  include "domzgr_substitute.h90"
58   
59   !! $Id$
60CONTAINS
61
62
63   SUBROUTINE crs_dom_msk
64     
65      INTEGER  ::  ji, jj, jk                   ! dummy loop indices
66      INTEGER  ::  ijie,ijis,ijje,ijjs,ij,je_2
67      INTEGER  ::  iji, ijj
68      REAL(wp) ::  zmask
69     
70      ! Initialize
71      tmask_crs(:,:,:) = 0.0
72      vmask_crs(:,:,:) = 0.0
73      umask_crs(:,:,:) = 0.0
74      fmask_crs(:,:,:) = 0.0
75      !
76      DO jk = 1, jpkm1
77         DO ji = 2, nlei_crs
78            ijie = mie_crs(ji)
79            ijis = mis_crs(ji)
80
81            IF( nldj_crs == 1 .AND. (( mje_crs(2) - mjs_crs(2) ) < 2) )THEN     !!cc bande du sud style ORCA2
82
83               IF( mje_crs(2) - mjs_crs(2) == 1 )THEN
84
85                  jj = mje_crs(2)
86
87                  zmask = 0.0
88                  zmask = SUM( tmask(ijis:ijie,jj,jk) )
89                  IF ( zmask > 0.0 ) tmask_crs(ji,2,jk) = 1.0
90
91                  zmask = 0.0
92                  zmask = SUM( vmask(ijis:ijie,jj     ,jk) )
93                  IF ( zmask > 0.0 ) vmask_crs(ji,2,jk) = 1.0
94
95                  zmask = 0.0
96                  zmask = umask(ijie     ,jj,jk)
97                  IF( zmask > 0.0 )umask_crs(ji,2,jk) = 1.0
98
99                  fmask_crs(ji,jj,jk) = fmask(ijie,2,jk)
100               ENDIF
101            ELSE
102
103               jj   = mje_crs(2)
104               ij   = mjs_crs(2)
105
106               zmask = 0.0
107               zmask = SUM( tmask(ijis:ijie,ij:jj,jk) )
108               IF ( zmask > 0.0 ) tmask_crs(ji,2,jk) = 1.0
109
110               zmask = 0.0
111               zmask = SUM( vmask(ijis:ijie,jj     ,jk) )
112               IF ( zmask > 0.0 ) vmask_crs(ji,2,jk) = 1.0
113
114               zmask = 0.0
115               zmask = SUM(umask(ijie,ij:jj,jk))
116               IF ( zmask > 0.0 ) umask_crs(ji,2,jk) = 1.0
117
118               fmask_crs(ji,jj,jk) = fmask(ijie,2,jk)
119
120            ENDIF
121 
122            DO jj = 3, nlej_crs
123               ijje = mje_crs(jj)
124               ijjs = mjs_crs(jj)
125
126               !iji=117 ; ijj=211
127               !iji=iji-nimpp_crs+1 ; ijj=ijj-njmpp_crs+1
128               !IF( ji ==iji .AND. jj==ijj .AND. jk==74 )THEN
129               !write(narea+5000,*)"mask ",ji,jj
130               !write(narea+5000,*)"mask ",ijie,ijis,ijjs,ijje
131               !ENDIF
132
133               !IF( ijje .GT. jpj )WRITE(narea+200,*)"BUG",jj,ijjs,ijje,SHAPE(tmask) ; call flush(narea+200)
134               zmask = 0.0
135               zmask = SUM( tmask(ijis:ijie,ijjs:ijje,jk) )
136               IF ( zmask > 0.0 ) tmask_crs(ji,jj,jk) = 1.0
137
138               zmask = 0.0
139               zmask = SUM( vmask(ijis:ijie,ijje     ,jk) )
140               IF ( zmask > 0.0 ) vmask_crs(ji,jj,jk) = 1.0
141
142               zmask = 0.0
143               zmask = SUM( umask(ijie     ,ijjs:ijje,jk) )
144               IF ( zmask > 0.0 ) umask_crs(ji,jj,jk) = 1.0
145
146               fmask_crs(ji,jj,jk) = fmask(ijie,ijje,jk)
147
148            ENDDO
149         ENDDO
150      ENDDO
151      CALL crs_lbc_lnk( tmask_crs, 'T', 1.0 )
152      !cbr
153      !DO ji=1,jpi_crs-1
154      !DO jj=1,jpj_crs-1
155      !DO jk=1,jpk
156      !   umask_crs(ji,jj,jk) = tmask_crs(ji  ,jj  ,jk) * tmask_crs(ji+1,jj  ,jk)
157      !   vmask_crs(ji,jj,jk) = tmask_crs(ji  ,jj  ,jk) * tmask_crs(ji  ,jj+1,jk)
158      !   fmask_crs(ji,jj,jk) = tmask_crs(ji  ,jj  ,jk) * tmask_crs(ji  ,jj+1,jk) *  tmask_crs(ji+1,jj  ,jk) *   tmask_crs(ji+1,jj+1,jk)
159      !ENDDO
160      !ENDDO
161      !ENDDO
162      !
163      CALL crs_lbc_lnk( vmask_crs, 'V', 1.0 )
164      CALL crs_lbc_lnk( umask_crs, 'U', 1.0 )
165      CALL crs_lbc_lnk( fmask_crs, 'F', 1.0 )
166      !
167      !cbr
168      !DO ji=2,jpi_crs-1
169      !DO jj=2,jpj_crs-1
170      !DO jk=1,jpk
171      !   IF( tmask(ji-1,jj  ,jk)==1. .AND. tmask(ji  ,jj  ,jk)==1. .AND. umask(ji-1,jj  ,jk)==0. )WRITE(narea+5000,*)"MASK1",ji,jj,jk
172      !   IF( tmask(ji  ,jj  ,jk)==1. .AND. tmask(ji+1,jj  ,jk)==1. .AND. umask(ji  ,jj  ,jk)==0. )WRITE(narea+5000,*)"MASK2",ji,jj,jk
173      !   IF( tmask(ji  ,jj-1,jk)==1. .AND. tmask(ji  ,jj  ,jk)==1. .AND. vmask(ji  ,jj-1,jk)==0. )WRITE(narea+5000,*)"MASK3",ji,jj,jk
174      !   IF( tmask(ji  ,jj  ,jk)==1. .AND. tmask(ji  ,jj+1,jk)==1. .AND. vmask(ji  ,jj  ,jk)==0. )WRITE(narea+5000,*)"MASK4",ji,jj,jk
175      !   IF( umask(ji-1,jj  ,jk)==1. .AND. ( tmask(ji-1,jj  ,jk)==0. .OR. tmask(ji  ,jj  ,jk)==0. ) )WRITE(narea+5000,*)"MASK5",ji,jj,jk
176      !   IF( umask(ji  ,jj  ,jk)==1. .AND. ( tmask(ji  ,jj  ,jk)==0. .OR. tmask(ji+1,jj  ,jk)==0. ) )WRITE(narea+5000,*)"MASK6",ji,jj,jk
177      !   IF( vmask(ji  ,jj-1,jk)==1. .AND. ( tmask(ji  ,jj-1,jk)==0. .OR. tmask(ji  ,jj  ,jk)==0. ) )WRITE(narea+5000,*)"MASK7",ji,jj,jk
178      !   IF( vmask(ji  ,jj  ,jk)==1. .AND. ( tmask(ji  ,jj  ,jk)==0. .OR. tmask(ji  ,jj+1,jk)==0. ) )WRITE(narea+5000,*)"MASK8",ji,jj,jk
179      !ENDDO
180      !ENDDO
181      !ENDDO
182      !
183   END SUBROUTINE crs_dom_msk
184
185   SUBROUTINE crs_dom_coordinates( p_gphi, p_glam, cd_type, p_gphi_crs, p_glam_crs )
186      !!----------------------------------------------------------------
187      !!               *** SUBROUTINE crs_coordinates ***
188      !! ** Purpose :  Determine the coordinates for the coarse grid
189      !!
190      !! ** Method  :  From the parent grid subset, search for the central
191      !!               point.  For an odd-numbered reduction factor,
192      !!               the coordinate will be that of the central T-cell.
193      !!               For an even-numbered reduction factor, of a non-square
194      !!               coarse grid box, the coordinate will be that of
195      !!               the east or north face or more likely.  For a square
196      !!               coarse grid box, the coordinate will be that of
197      !!               the central f-corner.
198      !!
199      !! ** Input   :  p_gphi = parent grid gphi[t|u|v|f]
200      !!               p_glam = parent grid glam[t|u|v|f]
201      !!               cd_type  = grid type (T,U,V,F)
202      !! ** Output  :  p_gphi_crs = coarse grid gphi[t|u|v|f]
203      !!               p_glam_crs = coarse grid glam[t|u|v|f]
204      !!             
205      !! History. 1 Jun.
206      !!----------------------------------------------------------------
207      !! Arguments
208      REAL(wp), DIMENSION(jpi,jpj)        , INTENT(in)  :: p_gphi  ! Parent grid latitude
209      REAL(wp), DIMENSION(jpi,jpj)        , INTENT(in)  :: p_glam  ! Parent grid longitude
210      CHARACTER(len=1),                     INTENT(in)  :: cd_type   ! grid type (T,U,V,F)
211      REAL(wp), DIMENSION(jpi_crs,jpj_crs), INTENT(out) :: p_gphi_crs  ! Coarse grid latitude
212      REAL(wp), DIMENSION(jpi_crs,jpj_crs), INTENT(out) :: p_glam_crs  ! Coarse grid longitude
213
214      !! Local variables
215      INTEGER :: ji, jj, jk                   ! dummy loop indices
216      INTEGER :: ijis, ijjs
217
218 
219      SELECT CASE ( cd_type )
220         CASE ( 'T' )
221            DO jj =  nldj_crs, nlej_crs
222               ijjs = mjs_crs(jj) + mybinctr
223               DO ji = 2, nlei_crs
224                  ijis = mis_crs(ji) + mxbinctr 
225                  p_gphi_crs(ji,jj) = p_gphi(ijis,ijjs)
226                  p_glam_crs(ji,jj) = p_glam(ijis,ijjs)
227               ENDDO
228            ENDDO
229         CASE ( 'U' )
230            DO jj =  nldj_crs, nlej_crs
231               ijjs = mjs_crs(jj) + mybinctr                 
232               DO ji = 2, nlei_crs
233                  ijis = mis_crs(ji)
234                  p_gphi_crs(ji,jj) = p_gphi(ijis,ijjs)
235                  p_glam_crs(ji,jj) = p_glam(ijis,ijjs)
236               ENDDO
237            ENDDO
238         CASE ( 'V' )
239            DO jj =  nldj_crs, nlej_crs
240               ijjs = mjs_crs(jj)
241               DO ji = 2, nlei_crs
242                  ijis = mis_crs(ji) + mxbinctr 
243                  p_gphi_crs(ji,jj) = p_gphi(ijis,ijjs)
244                  p_glam_crs(ji,jj) = p_glam(ijis,ijjs)
245               ENDDO
246            ENDDO
247         CASE ( 'F' )
248            DO jj =  nldj_crs, nlej_crs
249               ijjs = mjs_crs(jj)
250               DO ji = 2, nlei_crs
251                  ijis = mis_crs(ji)
252                  p_gphi_crs(ji,jj) = p_gphi(ijis,ijjs)
253                  p_glam_crs(ji,jj) = p_glam(ijis,ijjs)
254               ENDDO
255            ENDDO
256      END SELECT
257
258      ! Retroactively add back the boundary halo cells.
259      CALL crs_lbc_lnk( p_gphi_crs, cd_type, 1.0 )
260      CALL crs_lbc_lnk( p_glam_crs, cd_type, 1.0 )
261         
262      ! Fill up jrow=1 which is zeroed out or not handled by lbc_lnk and lbc_nfd
263      SELECT CASE ( cd_type )
264         CASE ( 'T', 'V' )
265            DO ji = 2, nlei_crs
266               ijis = mis_crs(ji) + mxbinctr 
267               p_gphi_crs(ji,1) = p_gphi(ijis,1)
268               p_glam_crs(ji,1) = p_glam(ijis,1)
269            ENDDO
270         CASE ( 'U', 'F' )
271            DO ji = 2, nlei_crs
272               ijis = mis_crs(ji) 
273               p_gphi_crs(ji,1) = p_gphi(ijis,1)
274               p_glam_crs(ji,1) = p_glam(ijis,1)
275            ENDDO
276      END SELECT
277      !
278   END SUBROUTINE crs_dom_coordinates
279
280  SUBROUTINE crs_dom_hgr( p_e1, p_e2, cd_type, p_e1_crs, p_e2_crs )
281      !!----------------------------------------------------------------
282      !!               *** SUBROUTINE crs_dom_hgr ***
283      !!
284      !! ** Purpose :  Get coarse grid horizontal scale factors and unmasked fraction
285      !!
286      !! ** Method  :  For grid types T,U,V,Fthe 2D scale factors of
287      !!               the coarse grid are the sum of the east or north faces of the
288      !!               parent grid subset comprising the coarse grid box.     
289      !!               - e1,e2 Scale factors
290      !!                 Valid arguments:
291      !! ** Inputs  : p_e1, p_e2  = parent grid e1 or e2 (t,u,v,f)
292      !!              cd_type     = grid type (T,U,V,F) for scale factors; for velocities (U or V)
293      !! ** Outputs : p_e1_crs, p_e2_crs  = parent grid e1 or e2 (t,u,v,f)
294      !!
295      !! History.     4 Jun.  Write for WGT and scale factors only
296      !!----------------------------------------------------------------
297      !!
298      !!  Arguments
299      REAL(wp), DIMENSION(jpi,jpj)        , INTENT(in)  :: p_e1     ! Parent grid U,V scale factors (e1)
300      REAL(wp), DIMENSION(jpi,jpj)        , INTENT(in)  :: p_e2     ! Parent grid U,V scale factors (e2)
301      CHARACTER(len=1)                    , INTENT(in)  :: cd_type  ! grid type U,V
302
303      REAL(wp), DIMENSION(jpi_crs,jpj_crs), INTENT(out) :: p_e1_crs ! Coarse grid box 2D quantity
304      REAL(wp), DIMENSION(jpi_crs,jpj_crs), INTENT(out) :: p_e2_crs ! Coarse grid box 2D quantity
305
306      !! Local variables
307      INTEGER :: ji, jj, jk     ! dummy loop indices
308      INTEGER :: ijie,ijje,ijrs
309 
310      !!---------------------------------------------------------------- 
311      ! Initialize     
312
313      DO jk = 1, jpk   
314         DO ji = 2, nlei_crs
315            ijie = mie_crs(ji)
316            DO jj = nldj_crs, nlej_crs
317               ijje = mje_crs(jj)   ;   ijrs =  mje_crs(jj) - mjs_crs(jj)
318               ! Only for a factro 3 coarsening
319               SELECT CASE ( cd_type )
320                   CASE ( 'T' )
321                      IF( ijrs == 0 .OR. ijrs == 1 ) THEN
322                        ! Si à la frontière sud on a pas assez de maille de la grille mère
323                         p_e1_crs(ji,jj) = p_e1(ijie-1,ijje) * nn_factx
324                         p_e2_crs(ji,jj) = p_e2(ijie-1,ijje) * nn_facty
325                      ELSE
326                         p_e1_crs(ji,jj) = p_e1(ijie-1,ijje-1) * nn_factx
327                         p_e2_crs(ji,jj) = p_e2(ijie-1,ijje-1) * nn_facty
328                      ENDIF
329                   CASE ( 'U' )
330                      IF( ijrs == 0 .OR. ijrs == 1 ) THEN
331                         ! Si à la frontière sud on a pas assez de maille de la grille mère
332                         p_e1_crs(ji,jj) = p_e1(ijie,ijje) * nn_factx                           
333                         p_e2_crs(ji,jj) = p_e2(ijie,ijje) * nn_facty
334                      ELSE
335                         p_e1_crs(ji,jj) = p_e1(ijie,ijje-1) * nn_factx
336                         p_e2_crs(ji,jj) = p_e2(ijie,ijje-1) * nn_facty
337                      ENDIF
338                   CASE ( 'V' )
339                         p_e1_crs(ji,jj) = p_e1(ijie-1,ijje) * nn_factx                           
340                         p_e2_crs(ji,jj) = p_e2(ijie-1,ijje) * nn_facty
341                   CASE ( 'F' )
342                         p_e1_crs(ji,jj) = p_e1(ijie,ijje) * nn_factx                           
343                         p_e2_crs(ji,jj) = p_e2(ijie,ijje) * nn_facty
344               END SELECT
345            ENDDO
346         ENDDO
347      ENDDO
348
349      CALL crs_lbc_lnk( p_e1_crs, cd_type, 1.0, pval=1.0 )
350      CALL crs_lbc_lnk( p_e2_crs, cd_type, 1.0, pval=1.0 )
351
352   END SUBROUTINE crs_dom_hgr
353
354
355   SUBROUTINE crs_dom_facvol( p_mask, cd_type, p_e1, p_e2, p_e3, p_fld1_crs, p_fld2_crs )
356      !!----------------------------------------------------------------
357      !!               *** SUBROUTINE crsfun_wgt ***
358      !! ** Purpose :  Three applications.
359      !!               1) SUM. Get coarse grid horizontal scale factors and unmasked fraction
360      !!               2) VOL. Get coarse grid box volumes
361      !!               3) WGT. Weighting multiplier for volume-weighted and/or
362      !!                       area-weighted averages.
363      !!                       Weights (i.e. the denominator) calculated here
364      !!                       to avoid IF-tests and division.
365      !! ** Method  :  1) SUM.  For grid types T,U,V,F (and W) the 2D scale factors of
366      !!               the coarse grid are the sum of the east or north faces of the
367      !!               parent grid subset comprising the coarse grid box. 
368      !!               The fractions of masked:total surface (3D) on the east,
369      !!               north and top faces is, optionally, also output.
370      !!               - Top face area sum
371      !!                 Valid arguments: cd_type, cd_op='W', p_pmask, p_e1, p_e2
372      !!               - Top face ocean surface fraction
373      !!                 Valid arguments: cd_type, cd_op='W', p_pmask, p_e1, p_e2       
374      !!               - e1,e2 Scale factors
375      !!                 Valid arguments:
376      !!               2) VOL.  For grid types W and T, the coarse grid box
377      !!               volumes are output. Also optionally, the fraction of 
378      !!               masked:total volume of the parent grid subset is output (i.e. facvol).
379      !!               3) WGT. Based on the grid type, the denominator is pre-determined here to 
380      !!               perform area- or volume- weighted averages,
381      !!               to avoid IF-tests and divisions.
382      !! ** Inputs  : p_e1, p_e2  = parent grid e1 or e2 (t,u,v,f)
383      !!              p_pmask     = parent grid mask (T,U,V,F)
384      !!              cd_type     = grid type (T,U,V,F) for scale factors; for velocities (U or V)
385      !!              cd_op       = applied operation (SUM, VOL, WGT)
386      !!              p_fse3      = (Optional) parent grid vertical level thickness (fse3u or fse3v)
387      !! ** Outputs : p_cfield2d_1 = (Optional) 2D field on coarse grid
388      !!              p_cfield2d_2 = (Optional) 2D field on coarse grid
389      !!              p_cfield3d_1 = (Optional) 3D field on coarse grid
390      !!              p_cfield3d_2 = (Optional) 3D field on coarse grid
391      !!
392      !! History.     4 Jun.  Write for WGT and scale factors only
393      !!----------------------------------------------------------------
394      !!
395      !!  Arguments
396      CHARACTER(len=1),                         INTENT(in)  :: cd_type  ! grid type U,V
397      REAL(wp), DIMENSION(jpi,jpj,jpk)        , INTENT(in)  :: p_mask  ! Parent grid U,V mask
398      REAL(wp), DIMENSION(jpi,jpj)            , INTENT(in)  :: p_e1     ! Parent grid U,V scale factors (e1)
399      REAL(wp), DIMENSION(jpi,jpj)            , INTENT(in)  :: p_e2     ! Parent grid U,V scale factors (e2)
400      REAL(wp), DIMENSION(jpi,jpj,jpk)        , INTENT(in)  :: p_e3     ! Parent grid vertical level thickness (fse3u, fse3v)
401
402      REAL(wp), DIMENSION(jpi_crs,jpj_crs,jpk), INTENT(out) :: p_fld1_crs ! Coarse grid box 3D quantity
403      REAL(wp), DIMENSION(jpi_crs,jpj_crs,jpk), INTENT(out) :: p_fld2_crs ! Coarse grid box 3D quantity
404
405      !! Local variables
406      REAL(wp)                                :: zdAm
407      INTEGER                                 :: ji, jj, jk , ii, ij, je_2
408
409      REAL(wp), DIMENSION(:,:,:), POINTER     :: zvol, zmask     
410      !!---------------------------------------------------------------- 
411   
412      CALL wrk_alloc( jpi, jpj, jpk, zvol, zmask )
413
414      p_fld1_crs(:,:,:) = 0.0
415      p_fld2_crs(:,:,:) = 0.0
416
417      DO jk = 1, jpk
418         zvol(:,:,jk) =  p_e1(:,:) * p_e2(:,:) * p_e3(:,:,jk) 
419      ENDDO
420
421      zmask(:,:,:) = 0.0
422      !IF( cd_type == 'W' ) THEN
423      !   zmask(:,:,1) = p_mask(:,:,1)
424      !   DO jk = 2, jpk
425      !      zmask(:,:,jk) = p_mask(:,:,jk-1)
426      !   ENDDO
427      !ELSE
428         DO jk = 1, jpk
429             zmask(:,:,jk) = p_mask(:,:,jk) 
430         ENDDO
431      !ENDIF
432
433      IF( nldj_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN     !!cc bande du sud style ORCA2
434         IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN
435            je_2 = mje_crs(2)
436            DO jk = 1, jpk           
437               DO ji = nistr, niend, nn_factx
438                  ii   = ( ji - mis_crs(2) ) * rfactx_r + 2                 ! cordinate in parent grid
439                  p_fld1_crs(ii,2,jk) =  zvol(ji,je_2  ,jk) + zvol(ji+1,je_2  ,jk) + zvol(ji+2,je_2  ,jk)  &
440                     &                 + zvol(ji,je_2-1,jk) + zvol(ji+1,je_2-1,jk) + zvol(ji+2,je_2-1,jk) 
441                  !
442                  zdAm =  zvol(ji  ,je_2,jk) * zmask(ji  ,je_2,jk)  &
443                    &   + zvol(ji+1,je_2,jk) * zmask(ji+1,je_2,jk)  &
444                    &   + zvol(ji+2,je_2,jk) * zmask(ji+2,je_2,jk) 
445                  !
446                  p_fld2_crs(ii,2,jk) = zdAm / p_fld1_crs(ii,2,jk) 
447               ENDDO
448            ENDDO
449         ENDIF
450      ELSE
451         je_2 = mjs_crs(2)
452         DO jk = 1, jpk           
453            DO ji = nistr, niend, nn_factx
454               ii   = ( ji - mis_crs(2) ) * rfactx_r + 2   
455               p_fld1_crs(ii,2,jk) =  zvol(ji,je_2  ,jk) + zvol(ji+1,je_2  ,jk) + zvol(ji+2,je_2  ,jk)  &
456                   &                + zvol(ji,je_2+1,jk) + zvol(ji+1,je_2+1,jk) + zvol(ji+2,je_2+1,jk)  &
457                   &                + zvol(ji,je_2+2,jk) + zvol(ji+1,je_2+2,jk) + zvol(ji+2,je_2+2,jk) 
458              !
459               zdAm = zvol(ji  ,je_2  ,jk) * zmask(ji  ,je_2  ,jk)  &
460                 &  + zvol(ji+1,je_2  ,jk) * zmask(ji+1,je_2  ,jk)  &
461                 &  + zvol(ji+2,je_2  ,jk) * zmask(ji+2,je_2  ,jk)  &
462                 &  + zvol(ji  ,je_2+1,jk) * zmask(ji  ,je_2+1,jk)  &
463                 &  + zvol(ji+1,je_2+1,jk) * zmask(ji+1,je_2+1,jk)  &
464                 &  + zvol(ji+2,je_2+1,jk) * zmask(ji+2,je_2+1,jk)  &
465                 &  + zvol(ji  ,je_2+2,jk) * zmask(ji  ,je_2+2,jk)  &
466                 &  + zvol(ji+1,je_2+2,jk) * zmask(ji+1,je_2+2,jk)  &
467                 &  + zvol(ji+2,je_2+2,jk) * zmask(ji+2,je_2+2,jk)
468                 !
469                 p_fld2_crs(ii,2,jk) = zdAm / p_fld1_crs(ii,2,jk) 
470            ENDDO
471         ENDDO
472      ENDIF
473
474      DO jk = 1, jpk           
475         DO jj  = njstr, njend, nn_facty
476            DO ji = nistr, niend, nn_factx
477               ii  = ( ji - mis_crs(2) ) * rfactx_r + 2                 ! cordinate in parent grid
478               ij  = ( jj - njstr ) * rfacty_r + 3
479               !
480               p_fld1_crs(ii,ij,jk) =  zvol(ji,jj  ,jk) + zvol(ji+1,jj  ,jk) + zvol(ji+2,jj  ,jk)  &
481                   &                 + zvol(ji,jj+1,jk) + zvol(ji+1,jj+1,jk) + zvol(ji+2,jj+1,jk)  &
482                   &                 + zvol(ji,jj+2,jk) + zvol(ji+1,jj+2,jk) + zvol(ji+2,jj+2,jk) 
483               !
484               zdAm =  zvol(ji  ,jj  ,jk) * zmask(ji  ,jj  ,jk)  &
485                 &   + zvol(ji+1,jj  ,jk) * zmask(ji+1,jj  ,jk)  &
486                 &   + zvol(ji+2,jj  ,jk) * zmask(ji+2,jj  ,jk)  &
487                 &   + zvol(ji  ,jj+1,jk) * zmask(ji  ,jj+1,jk)  &
488                 &   + zvol(ji+1,jj+1,jk) * zmask(ji+1,jj+1,jk)  &
489                 &   + zvol(ji+2,jj+1,jk) * zmask(ji+2,jj+1,jk)  &
490                 &   + zvol(ji  ,jj+2,jk) * zmask(ji  ,jj+2,jk)  &
491                 &   + zvol(ji+1,jj+2,jk) * zmask(ji+1,jj+2,jk)  &
492                 &   + zvol(ji+2,jj+2,jk) * zmask(ji+2,jj+2,jk)
493                 !
494                p_fld2_crs(ii,ij,jk) = zdAm / p_fld1_crs(ii,ij,jk) 
495            ENDDO
496         ENDDO
497      ENDDO
498      !                                             !  Retroactively add back the boundary halo cells.
499      CALL crs_lbc_lnk( p_fld1_crs, cd_type, 1.0 ) 
500      CALL crs_lbc_lnk( p_fld2_crs, cd_type, 1.0 ) 
501      !
502      CALL wrk_dealloc( jpi, jpj, jpk, zvol, zmask )
503      !
504   END SUBROUTINE crs_dom_facvol
505
506
507   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 )
508      !!----------------------------------------------------------------
509      !!               *** SUBROUTINE crsfun_UV ***
510      !! ** Purpose :  Average, area-weighted, of U or V on the east and north faces
511      !!
512      !! ** Method  :  The U and V velocities (3D) are determined as the area-weighted averages
513      !!               on the east and north faces, respectively,
514      !!               of the parent grid subset comprising the coarse grid box.
515      !!               In the case of the V and F grid, the last jrow minus 1 is spurious.
516      !! ** Inputs  : p_e1_e2     = parent grid e1 or e2 (t,u,v,f)
517      !!              cd_type     = grid type (T,U,V,F) for scale factors; for velocities (U or V)
518      !!              psgn        = sign change over north fold (See lbclnk.F90)
519      !!              p_pmask     = parent grid mask (T,U,V,F) for scale factors;
520      !!                                       for velocities (U or V)
521      !!              p_fse3      = parent grid vertical level thickness (fse3u or fse3v)
522      !!              p_pfield    = U or V on the parent grid
523      !!              p_surf_crs  = (Optional) Coarse grid weight for averaging
524      !! ** Outputs : p_cfield3d = 3D field on coarse grid
525      !!
526      !! History.  29 May.  completed draft.
527      !!            4 Jun.  Revision for WGT
528      !!            5 Jun.  Streamline for area-weighted average only ; separate scale factor and weights.
529      !!----------------------------------------------------------------
530      !!
531      !!  Arguments
532      REAL(wp), DIMENSION(jpi,jpj,jpk),         INTENT(in)           :: p_fld   ! T, U, V or W on parent grid
533      CHARACTER(len=3),                         INTENT(in)           :: cd_op    ! Operation SUM, MAX or MIN
534      CHARACTER(len=1),                         INTENT(in)           :: cd_type    ! grid type U,V
535      REAL(wp), DIMENSION(jpi,jpj,jpk),         INTENT(in)           :: p_mask    ! Parent grid T,U,V mask
536      REAL(wp), DIMENSION(jpi,jpj),             INTENT(in), OPTIONAL :: p_e12    ! Parent grid T,U,V scale factors (e1 or e2)
537      REAL(wp), DIMENSION(jpi,jpj,jpk),         INTENT(in), OPTIONAL :: p_e3     ! Parent grid vertical level thickness (fse3u, fse3v)
538      REAL(wp), DIMENSION(jpi_crs,jpj_crs,jpk), INTENT(in), OPTIONAL :: p_surf_crs ! Coarse grid area-weighting denominator   
539      REAL(wp), DIMENSION(jpi_crs,jpj_crs,jpk), INTENT(in), OPTIONAL :: p_mask_crs    ! Coarse grid T,U,V maska
540      REAL(wp),                                 INTENT(in)           :: psgn    ! sign
541
542
543      REAL(wp), DIMENSION(jpi_crs,jpj_crs,jpk), INTENT(out)          :: p_fld_crs ! Coarse grid box 3D quantity
544
545      !! Local variables
546      INTEGER  :: ji, jj, jk 
547      INTEGER  :: ii, ij, ijie, ijje, je_2
548      REAL(wp) :: zflcrs, zsfcrs   
549      REAL(wp), DIMENSION(:,:,:), POINTER :: zsurf, zsurfmsk, zmask 
550      INTEGER  :: iji, ijj
551      !!---------------------------------------------------------------- 
552   
553      p_fld_crs(:,:,:) = 0.0
554
555      SELECT CASE ( cd_op )
556     
557         CASE ( 'VOL' )
558     
559            CALL wrk_alloc( jpi, jpj, jpk, zsurf, zsurfmsk )
560         
561            SELECT CASE ( cd_type )
562           
563               CASE( 'T', 'W' )
564                  !IF( cd_type == 'T' ) THEN
565                     DO jk = 1, jpk
566                        zsurf   (:,:,jk) =  p_e12(:,:) * p_e3(:,:,jk) *  p_mask(:,:,jk) 
567                        zsurfmsk(:,:,jk) =  zsurf(:,:,jk) 
568                    ENDDO
569                  !ELSE
570                  !  !cbr ????????????????????????????????
571                  !   zsurf   (:,:,1) =  p_e12(:,:) * p_e3(:,:,1)
572                  !   zsurfmsk(:,:,1) =  zsurf(:,:,1) *  p_mask(:,:,1)
573                  !   DO jk = 2, jpk
574                  !      zsurf   (:,:,jk) =  p_e12(:,:) * p_e3(:,:,jk)
575                  !      zsurfmsk(:,:,jk) =  zsurf(:,:,jk) * p_mask(:,:,jk-1)
576                  !   ENDDO
577                  !ENDIF
578         
579                  IF( nldj_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN     !!cc bande du sud style ORCA2
580                     IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN
581                        je_2 = mje_crs(2)
582                        DO jk = 1, jpk           
583                           DO ji = nistr, niend, nn_factx
584                              ii   = ( ji - mis_crs(2) ) * rfactx_r + 2       
585                              zflcrs =  p_fld(ji  ,je_2,jk) * zsurfmsk(ji  ,je_2,jk)   &
586                                &     + p_fld(ji+1,je_2,jk) * zsurfmsk(ji+1,je_2,jk)   &
587                                &     + p_fld(ji+2,je_2,jk) * zsurfmsk(ji+2,je_2,jk) 
588 
589                              zsfcrs =  zsurf(ji,je_2,jk) + zsurf(ji+1,je_2,jk) + zsurf(ji+2,je_2,jk) 
590                              !
591                              p_fld_crs(ii,2,jk) = zflcrs
592                              IF( zsfcrs /= 0.0 )  p_fld_crs(ii,2,jk) = zflcrs / zsfcrs
593                           ENDDO
594                        ENDDO
595                     ENDIF
596                  ELSE
597                     je_2 = mjs_crs(2)
598                     DO jk = 1, jpk           
599                        DO ji = nistr, niend, nn_factx
600                           ii   = ( ji - mis_crs(2) ) * rfactx_r + 2   
601                           zflcrs =  p_fld(ji  ,je_2  ,jk) * zsurfmsk(ji  ,je_2  ,jk) &
602                             &     + p_fld(ji+1,je_2  ,jk) * zsurfmsk(ji+1,je_2  ,jk) &
603                             &     + p_fld(ji+2,je_2  ,jk) * zsurfmsk(ji+2,je_2  ,jk) &
604                             &     + p_fld(ji  ,je_2+1,jk) * zsurfmsk(ji  ,je_2+1,jk) &
605                             &     + p_fld(ji+1,je_2+1,jk) * zsurfmsk(ji+1,je_2+1,jk) &
606                             &     + p_fld(ji+2,je_2+1,jk) * zsurfmsk(ji+2,je_2+1,jk) &
607                             &     + p_fld(ji  ,je_2+2,jk) * zsurfmsk(ji  ,je_2+2,jk) &
608                             &     + p_fld(ji+1,je_2+2,jk) * zsurfmsk(ji+1,je_2+2,jk) &
609                             &     + p_fld(ji+2,je_2+2,jk) * zsurfmsk(ji+2,je_2+2,jk) 
610
611                           zsfcrs =  zsurf(ji,je_2  ,jk) + zsurf(ji+1,je_2  ,jk) + zsurf(ji+2,je_2  ,jk) &
612                             &     + zsurf(ji,je_2+1,jk) + zsurf(ji+1,je_2+1,jk) + zsurf(ji+2,je_2+1,jk) &
613                             &     + zsurf(ji,je_2+2,jk) + zsurf(ji+1,je_2+2,jk) + zsurf(ji+2,je_2+2,jk) 
614                            !
615                            p_fld_crs(ii,2,jk) = zflcrs
616                            IF( zsfcrs /= 0.0 )  p_fld_crs(ii,2,jk) = zflcrs / zsfcrs
617                        ENDDO
618                     ENDDO
619                  ENDIF
620                  !
621                  DO jk = 1, jpk           
622                     DO jj  = njstr, njend, nn_facty
623                        DO ji = nistr, niend, nn_factx
624                           ii = ( ji - mis_crs(2) ) * rfactx_r + 2                 ! cordinate in parent grid
625                           ij = ( jj - njstr ) * rfacty_r + 3
626                           zflcrs =  p_fld(ji  ,jj  ,jk) * zsurfmsk(ji  ,jj  ,jk) &
627                             &     + p_fld(ji+1,jj  ,jk) * zsurfmsk(ji+1,jj  ,jk) &
628                             &     + p_fld(ji+2,jj  ,jk) * zsurfmsk(ji+2,jj  ,jk) &
629                             &     + p_fld(ji  ,jj+1,jk) * zsurfmsk(ji  ,jj+1,jk) &
630                             &     + p_fld(ji+1,jj+1,jk) * zsurfmsk(ji+1,jj+1,jk) &
631                             &     + p_fld(ji+2,jj+1,jk) * zsurfmsk(ji+2,jj+1,jk) &
632                             &     + p_fld(ji  ,jj+2,jk) * zsurfmsk(ji  ,jj+2,jk) &
633                             &     + p_fld(ji+1,jj+2,jk) * zsurfmsk(ji+1,jj+2,jk) &
634                             &     + p_fld(ji+2,jj+2,jk) * zsurfmsk(ji+2,jj+2,jk) 
635
636                           zsfcrs =  zsurf(ji,jj  ,jk) + zsurf(ji+1,jj  ,jk) + zsurf(ji+2,jj  ,jk) &
637                             &     + zsurf(ji,jj+1,jk) + zsurf(ji+1,jj+1,jk) + zsurf(ji+2,jj+1,jk) &
638                             &     + zsurf(ji,jj+2,jk) + zsurf(ji+1,jj+2,jk) + zsurf(ji+2,jj+2,jk) 
639                            !
640                           p_fld_crs(ii,ij,jk) = zflcrs
641                           IF( zsfcrs /= 0.0 )  p_fld_crs(ii,ij,jk) = zflcrs / zsfcrs
642                        ENDDO     
643                     ENDDO
644                  ENDDO 
645               CASE DEFAULT
646                    STOP
647               END SELECT
648
649              CALL wrk_dealloc( jpi, jpj, jpk, zsurf, zsurfmsk )
650
651         CASE ( 'SUM' )
652         
653            CALL wrk_alloc( jpi, jpj, jpk, zsurfmsk )
654
655            SELECT CASE ( cd_type )
656              CASE( 'W' )
657                  IF( PRESENT( p_e3 ) ) THEN
658                    !cbr ?????????????
659                    !zsurfmsk(:,:,1) =  p_e12(:,:) * p_e3(:,:,1) * p_mask(:,:,1)
660                    !DO jk = 2, jpk
661                    !  zsurfmsk(:,:,jk) =  p_e12(:,:) * p_e3(:,:,jk) * p_mask(:,:,jk-1)
662                    !ENDDO
663                    DO jk = 1, jpk
664                      zsurfmsk(:,:,jk) =  p_e12(:,:) * p_e3(:,:,jk) * p_mask(:,:,jk) 
665                    ENDDO
666                 ELSE
667                    !zsurfmsk(:,:,1) =  p_e12(:,:) * p_mask(:,:,1)
668                    !DO jk = 2, jpk
669                    !  zsurfmsk(:,:,jk) =  p_e12(:,:) * p_mask(:,:,jk-1)
670                    !ENDDO
671                    DO jk = 1, jpk
672                      zsurfmsk(:,:,jk) =  p_e12(:,:) * p_mask(:,:,jk) 
673                    ENDDO
674                 ENDIF
675              CASE DEFAULT
676                 IF( PRESENT( p_e3 ) ) THEN
677                    DO jk = 1, jpk
678                      zsurfmsk(:,:,jk) =  p_e12(:,:) * p_e3(:,:,jk) * p_mask(:,:,jk) 
679                    ENDDO
680                 ELSE
681                    DO jk = 1, jpk
682                      zsurfmsk(:,:,jk) =  p_e12(:,:) * p_mask(:,:,jk) 
683                    ENDDO
684                 ENDIF
685              END SELECT
686
687            SELECT CASE ( cd_type )
688           
689               CASE( 'T', 'W' )
690         
691                  IF( nldj_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN     !!cc bande du sud style ORCA2
692                     IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN
693                        je_2 = mje_crs(2)
694                        DO jk = 1, jpk           
695                           DO ji = nistr, niend, nn_factx
696                              ii   = ( ji - mis_crs(2) ) * rfactx_r + 2         
697                              zflcrs  =  p_fld(ji  ,je_2,jk) * zsurfmsk(ji  ,je_2,jk) &
698                                &      + p_fld(ji+1,je_2,jk) * zsurfmsk(ji+1,je_2,jk) &
699                                &      + p_fld(ji+2,je_2,jk) * zsurfmsk(ji+2,je_2,jk) 
700                               !
701                              p_fld_crs(ii,2,jk) = zflcrs
702                           ENDDO
703                        ENDDO
704                      ENDIF
705                  ELSE
706                     je_2 = mjs_crs(2)
707                     DO jk = 1, jpk           
708                        DO ji = nistr, niend, nn_factx
709                           ii   = ( ji - mis_crs(2) ) * rfactx_r + 2   
710                           zflcrs  =  p_fld(ji  ,je_2  ,jk) * zsurfmsk(ji  ,je_2  ,jk)  &
711                             &      + p_fld(ji+1,je_2  ,jk) * zsurfmsk(ji+1,je_2  ,jk)  &
712                             &      + p_fld(ji+2,je_2  ,jk) * zsurfmsk(ji+2,je_2  ,jk)  &
713                             &      + p_fld(ji  ,je_2+1,jk) * zsurfmsk(ji  ,je_2+1,jk)  &
714                             &      + p_fld(ji+1,je_2+1,jk) * zsurfmsk(ji+1,je_2+1,jk)  &
715                             &      + p_fld(ji+2,je_2+1,jk) * zsurfmsk(ji+2,je_2+1,jk)  &
716                             &      + p_fld(ji  ,je_2+2,jk) * zsurfmsk(ji  ,je_2+2,jk)  &
717                             &      + p_fld(ji+1,je_2+2,jk) * zsurfmsk(ji+1,je_2+2,jk)  &
718                             &      + p_fld(ji+2,je_2+2,jk) * zsurfmsk(ji+2,je_2+2,jk) 
719                            !
720                            p_fld_crs(ii,2,jk) = zflcrs
721                        ENDDO
722                     ENDDO
723                  ENDIF
724                  !
725                  DO jk = 1, jpk           
726                     DO jj  = njstr, njend, nn_facty
727                        DO ji = nistr, niend, nn_factx
728                           ii  = ( ji - mis_crs(2) ) * rfactx_r + 2                 ! cordinate in parent grid
729                           ij  = ( jj - njstr ) * rfacty_r + 3
730                           zflcrs  =  p_fld(ji  ,jj  ,jk) * zsurfmsk(ji  ,jj  ,jk)  &
731                             &      + p_fld(ji+1,jj  ,jk) * zsurfmsk(ji+1,jj  ,jk)  &
732                             &      + p_fld(ji+2,jj  ,jk) * zsurfmsk(ji+2,jj  ,jk)  &
733                             &      + p_fld(ji  ,jj+1,jk) * zsurfmsk(ji  ,jj+1,jk)  &
734                             &      + p_fld(ji+1,jj+1,jk) * zsurfmsk(ji+1,jj+1,jk)  &
735                             &      + p_fld(ji+2,jj+1,jk) * zsurfmsk(ji+2,jj+1,jk)  &
736                             &      + p_fld(ji  ,jj+2,jk) * zsurfmsk(ji  ,jj+2,jk)  &
737                             &      + p_fld(ji+1,jj+2,jk) * zsurfmsk(ji+1,jj+2,jk)  &
738                             &      + p_fld(ji+2,jj+2,jk) * zsurfmsk(ji+2,jj+2,jk) 
739                            !
740                            p_fld_crs(ii,ij,jk) = zflcrs
741                            !
742                        ENDDO     
743                     ENDDO
744                  ENDDO   
745           
746               CASE( 'V' )
747
748                  DO jk = 1, jpk
749                     DO ji = nistr, niend, nn_factx
750                        ii   = ( ji - mis_crs(2) ) * rfactx_r + 2
751                        IF( nldj_crs == 1 .AND. (( mje_crs(2) - mjs_crs(2) ) < 2) )THEN     !!cc bande du sud style ORCA2
752                           IF( mje_crs(2) - mjs_crs(2) == 1 )THEN
753                              jj = mje_crs(2)
754                              zflcrs  = p_fld(ji  ,jj  ,jk) * zsurfmsk(ji  ,jj  ,jk) &
755                               &      + p_fld(ji+1,jj  ,jk) * zsurfmsk(ji+1,jj  ,jk) &
756                               &      + p_fld(ji+2,jj  ,jk) * zsurfmsk(ji+2,jj  ,jk)
757
758                              !zsfcrs = zsurfmsk(ji  ,jj  ,jk) &
759                              ! &     + zsurfmsk(ji+1,jj  ,jk) &
760                              ! &     + zsurfmsk(ji+2,jj  ,jk)
761
762                              !IF( zsfcrs == 0 ) THEN  ; p_fld_crs(ii,2,jk) = zflcrs
763                              !ELSE                    ; p_fld_crs(ii,2,jk) = zflcrs / zsfcrs
764                              !ENDIF
765                           ENDIF
766                        ELSE
767                           ijje = mje_crs(2)
768                           zflcrs  =  p_fld(ji  ,ijje,jk) * zsurfmsk(ji  ,ijje,jk) &
769                             &      + p_fld(ji+1,ijje,jk) * zsurfmsk(ji+1,ijje,jk) &
770                             &      + p_fld(ji+2,ijje,jk) * zsurfmsk(ji+2,ijje,jk)
771                           !
772                           !zsfcrs =  zsurfmsk(ji  ,ijje,jk) &
773                           !  &     + zsurfmsk(ji+1,ijje,jk) &
774                           !  &     + zsurfmsk(ji+2,ijje,jk)
775
776                           p_fld_crs(ii,2,jk) = zflcrs
777                           !IF( zsfcrs == 0 ) THEN ; p_fld_crs(ii,2,jk) = zflcrs
778                           !ELSE                   ; p_fld_crs(ii,2,jk) = zflcrs / zsfcrs
779                           !ENDIF
780
781                        ENDIF
782
783                        DO jj = njstr, njend, nn_facty
784                           ii   = ( ji - mis_crs(2) ) * rfactx_r + 2
785                           ij   = ( jj - njstr ) * rfacty_r + 3
786                           ijje = mje_crs(ij)
787                           ijie = mie_crs(ii)
788                           !                 
789                           zflcrs  =  p_fld(ji  ,ijje,jk) * zsurfmsk(ji  ,ijje,jk) &
790                             &      + p_fld(ji+1,ijje,jk) * zsurfmsk(ji+1,ijje,jk) &
791                             &      + p_fld(ji+2,ijje,jk) * zsurfmsk(ji+2,ijje,jk) 
792                           !
793                           !zsfcrs =  zsurfmsk(ji  ,ijje,jk)  &
794                           !  &     + zsurfmsk(ji+1,ijje,jk)  &
795                           !  &     + zsurfmsk(ji+2,ijje,jk)
796
797                           p_fld_crs(ii,ij,jk) = zflcrs
798                           !cbr1
799               !iji=117 ; ijj=210
800               !iji=iji-nimpp_crs+1 ; ijj=ijj-njmpp_crs+1
801               !IF( ii==iji .AND. ij==ijj .AND. jk==74 )THEN
802               !WRITE(narea+5000,*)"OPE V =======> "
803               !WRITE(narea+5000,*)ii,ij,jk
804               !WRITE(narea+5000,*)ji,jj,ijje
805               !WRITE(narea+5000,*)p_fld(ji  ,ijje,jk)
806               !WRITE(narea+5000,*)p_fld(ji+1,ijje,jk)
807               !WRITE(narea+5000,*)p_fld(ji+2,ijje,jk)
808               !WRITE(narea+5000,*)zflcrs
809               !ENDIF
810
811                           !IF( zsfcrs == 0 ) THEN ; p_fld_crs(ii,ij,jk) = zflcrs
812                           !ELSE                   ; p_fld_crs(ii,ij,jk) = zflcrs / zsfcrs
813                           !ENDIF
814                           !
815               !IF( ii==iji .AND. ij==ijj .AND. jk==74 )WRITE(narea+5000,*)" p_fld_crs(ii,ij,jk) = ", p_fld_crs(ii,ij,jk)
816                        ENDDO
817                     ENDDO
818                  ENDDO
819 
820               CASE( 'U' )
821
822                  IF( nldj_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN     !!cc bande du sud style ORCA2
823                     IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN
824                        je_2 = mje_crs(2)
825                        DO jk = 1, jpk           
826                           DO ji = nistr, niend, nn_factx
827                              ii   = ( ji - mis_crs(2) ) * rfactx_r + 2 
828                              ijie = mie_crs(ii)
829                              zflcrs  =  p_fld(ijie,je_2,jk) * zsurfmsk(ijie,je_2,jk) 
830                              p_fld_crs(ii,2,jk) = zflcrs
831                           ENDDO
832                        ENDDO
833                      ENDIF
834                  ELSE
835                     je_2 = mjs_crs(2)
836                     DO jk = 1, jpk           
837                        DO ji = nistr, niend, nn_factx
838                           ii   = ( ji - mis_crs(2) ) * rfactx_r + 2   
839                           ijie = mie_crs(ii)
840                           zflcrs =  p_fld(ijie,je_2  ,jk) * zsurfmsk(ijie,je_2  ,jk)  &
841                             &     + p_fld(ijie,je_2+1,jk) * zsurfmsk(ijie,je_2+1,jk)  &
842                             &     + p_fld(ijie,je_2+2,jk) * zsurfmsk(ijie,je_2+2,jk) 
843
844                           p_fld_crs(ii,2,jk) = zflcrs
845                        ENDDO
846                     ENDDO
847                  ENDIF
848                  !
849                  DO jk = 1, jpk           
850                     DO jj  = njstr, njend, nn_facty
851                        DO ji = nistr, niend, nn_factx
852                           ii   = ( ji - mis_crs(2) ) * rfactx_r + 2     
853                           ij   = ( jj - njstr ) * rfacty_r + 3
854                           ijie = mie_crs(ii)
855                           zflcrs =  p_fld(ijie,jj  ,jk) * zsurfmsk(ijie,jj  ,jk)  &
856                              &    + p_fld(ijie,jj+1,jk) * zsurfmsk(ijie,jj+1,jk)  &
857                              &    + p_fld(ijie,jj+2,jk) * zsurfmsk(ijie,jj+2,jk) 
858                             !
859                           p_fld_crs(ii,ij,jk) = zflcrs
860                           !
861                        ENDDO     
862                     ENDDO
863                  ENDDO   
864
865              END SELECT
866
867              IF( PRESENT( p_surf_crs ) ) THEN
868                 WHERE ( p_surf_crs /= 0.0 ) p_fld_crs(:,:,:) = p_fld_crs(:,:,:) / p_surf_crs(:,:,:)
869              ENDIF
870
871         !IF(narea==267)WRITE(5000+narea,*)"vn_crs(17,5,74) end SUM = ",p_fld(17,5,74)
872              CALL wrk_dealloc( jpi, jpj, jpk, zsurfmsk )
873
874         CASE ( 'MAX' )    !  search the max of unmasked grid cells
875
876            CALL wrk_alloc( jpi, jpj, jpk, zmask )
877
878            SELECT CASE ( cd_type )
879              CASE( 'W' )
880                  zmask(:,:,1) = p_mask(:,:,1) 
881                  DO jk = 2, jpk
882                     zmask(:,:,jk) = p_mask(:,:,jk-1) 
883                  ENDDO
884              CASE ( 'T' )
885                  DO jk = 1, jpk
886                     zmask(:,:,jk) = p_mask(:,:,jk) 
887                  ENDDO
888            END SELECT
889
890            SELECT CASE ( cd_type )
891           
892               CASE( 'T', 'W' )
893         
894                  IF( nldj_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN     !!cc bande du sud style ORCA2
895                     IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN
896                        je_2 = mje_crs(2)
897                        DO jk = 1, jpk           
898                           DO ji = nistr, niend, nn_factx
899                              ii   = ( ji - mis_crs(2) ) * rfactx_r + 2       
900                              zflcrs =  &
901                                & MAX( p_fld(ji  ,je_2,jk) * zmask(ji  ,je_2,jk) - ( 1.- zmask(ji  ,je_2,jk) ) * r_inf ,  &
902                                &      p_fld(ji+1,je_2,jk) * zmask(ji+1,je_2,jk) - ( 1.- zmask(ji+1,je_2,jk) ) * r_inf ,  &
903                                &      p_fld(ji+2,je_2,jk) * zmask(ji+2,je_2,jk) - ( 1.- zmask(ji+2,je_2,jk) ) * r_inf  )
904                              !
905                              p_fld_crs(ii,2,jk) = zflcrs
906                           ENDDO
907                        ENDDO
908                      ENDIF
909                  ELSE
910                     je_2 = mjs_crs(2)
911                     DO jk = 1, jpk           
912                        DO ji = nistr, niend, nn_factx
913                           ii   = ( ji - mis_crs(2) ) * rfactx_r + 2   
914                           zflcrs =  &
915                             & MAX( p_fld(ji  ,je_2  ,jk) * zmask(ji  ,je_2  ,jk) - ( 1.- zmask(ji  ,je_2  ,jk) ) * r_inf ,  &
916                             &      p_fld(ji+1,je_2  ,jk) * zmask(ji+1,je_2  ,jk) - ( 1.- zmask(ji+1,je_2  ,jk) ) * r_inf ,  &
917                             &      p_fld(ji+2,je_2  ,jk) * zmask(ji+2,je_2  ,jk) - ( 1.- zmask(ji+2,je_2  ,jk) ) * r_inf ,  &
918                             &      p_fld(ji  ,je_2+1,jk) * zmask(ji  ,je_2+1,jk) - ( 1.- zmask(ji  ,je_2+1,jk) ) * r_inf ,  &
919                             &      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 ,  &
920                             &      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 ,  &
921                             &      p_fld(ji  ,je_2+2,jk) * zmask(ji  ,je_2+2,jk) - ( 1.- zmask(ji  ,je_2+2,jk) ) * r_inf ,  &
922                             &      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 ,  &
923                             &      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   )
924                           !
925                           p_fld_crs(ii,2,jk) = zflcrs
926                        ENDDO
927                     ENDDO
928                  ENDIF
929                  !
930                  DO jk = 1, jpk           
931                     DO jj  = njstr, njend, nn_facty
932                        DO ji = nistr, niend, nn_factx
933                           ii  = ( ji - mis_crs(2) ) * rfactx_r + 2                 ! cordinate in parent grid
934                           ij  = ( jj - njstr ) * rfacty_r + 3
935                           zflcrs =  &
936                             & MAX( p_fld(ji  ,jj  ,jk) * zmask(ji  ,jj  ,jk) - ( 1.- zmask(ji  ,jj  ,jk) ) * r_inf ,  &
937                             &      p_fld(ji+1,jj  ,jk) * zmask(ji+1,jj  ,jk) - ( 1.- zmask(ji+1,jj  ,jk) ) * r_inf ,  &
938                             &      p_fld(ji+2,jj  ,jk) * zmask(ji+2,jj  ,jk) - ( 1.- zmask(ji+2,jj  ,jk) ) * r_inf ,  &
939                             &      p_fld(ji  ,jj+1,jk) * zmask(ji  ,jj+1,jk) - ( 1.- zmask(ji  ,jj+1,jk) ) * r_inf ,  &
940                             &      p_fld(ji+1,jj+1,jk) * zmask(ji+1,jj+1,jk) - ( 1.- zmask(ji+1,jj+1,jk) ) * r_inf ,  &
941                             &      p_fld(ji+2,jj+1,jk) * zmask(ji+2,jj+1,jk) - ( 1.- zmask(ji+2,jj+1,jk) ) * r_inf ,  &
942                             &      p_fld(ji  ,jj+2,jk) * zmask(ji  ,jj+2,jk) - ( 1.- zmask(ji  ,jj+2,jk) ) * r_inf ,  &
943                             &      p_fld(ji+1,jj+2,jk) * zmask(ji+1,jj+2,jk) - ( 1.- zmask(ji+1,jj+2,jk) ) * r_inf ,  &
944                             &      p_fld(ji+2,jj+2,jk) * zmask(ji+2,jj+2,jk) - ( 1.- zmask(ji+2,jj+2,jk) ) * r_inf   )
945                           !
946                           p_fld_crs(ii,ij,jk) = zflcrs
947                           !
948                        ENDDO     
949                     ENDDO
950                  ENDDO   
951           
952               CASE( 'V' )
953
954!                 IF( nldj_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN     !!cc bande du sud style ORCA2
955!                     IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN
956!                        ijje = mje_crs(2)
957!                      ENDIF
958!                  ELSE
959!                     ijje = mjs_crs(2)
960!                  ENDIF
961!
962!                  DO jk = 1, jpk
963!                     DO ji = nistr, niend, nn_factx
964!                        ii   = ( ji - mis_crs(2) ) * rfactx_r + 2     
965!                        zflcrs = &
966!                          & MAX( p_fld(ji  ,ijje,jk) * p_mask(ji  ,ijje,jk) - ( 1.- p_mask(ji,ijje,jk) ) * r_inf ,  &
967!                          &      p_fld(ji+1,ijje,jk) * p_mask(ji+1,ijje,jk) - ( 1.- p_mask(ji,ijje,jk) ) * r_inf ,  &
968!                          &      p_fld(ji+2,ijje,jk) * p_mask(ji+2,ijje,jk) - ( 1.- p_mask(ji,ijje,jk) ) * r_inf )
969!                          !
970!                        p_fld_crs(ii,2,jk) = zflcrs
971!                     ENDDO
972!                  ENDDO
973!                  !
974!                  DO jk = 1, jpk           
975!                     DO jj  = njstr, njend, nn_facty
976!                        DO ji = nistr, niend, nn_factx
977!                           ii  = ( ji - mis_crs(2) ) * rfactx_r + 2                 ! cordinate in parent grid
978!                           ij  = ( jj - njstr ) * rfacty_r + 3
979!                           ijje = mje_crs(ij)
980!                           !                 
981!                           zflcrs = &
982!                             & MAX( p_fld(ji  ,ijje,jk) * p_mask(ji  ,ijje,jk) - ( 1.- p_mask(ji,ijje,jk) ) * r_inf ,  &
983!                             &      p_fld(ji+1,ijje,jk) * p_mask(ji+1,ijje,jk) - ( 1.- p_mask(ji,ijje,jk) ) * r_inf ,  &
984!                             &      p_fld(ji+2,ijje,jk) * p_mask(ji+2,ijje,jk) - ( 1.- p_mask(ji,ijje,jk) ) * r_inf )
985!                           !
986!                           p_fld_crs(ii,ij,jk) = zflcrs
987!                           !
988!                        ENDDO     
989!                     ENDDO
990!                  ENDDO   
991                  CALL ctl_stop('MAX operator and V case not available')
992           
993               CASE( 'U' )
994
995!                 IF( nldj_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN     !!cc bande du sud style ORCA2
996!                     IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN
997!                        je_2 = mje_crs(2)
998!                        DO jk = 1, jpk           
999!                           DO ji = nistr, niend, nn_factx
1000!                              ii   = ( ji - mis_crs(2) ) * rfactx_r + 2 
1001!                              ijie = mie_crs(ii)
1002!                              zflcrs = p_fld(ijie,je_2,jk) * p_mask(ijie,je_2,jk) - ( 1.- p_mask(ijie,je_2,jk) ) * r_inf
1003!                              !
1004!                              p_fld_crs(ii,2,jk) = zflcrs
1005!                            ENDDO
1006!                        ENDDO
1007!                      ENDIF
1008!                  ELSE
1009!                     je_2 = mjs_crs(2)
1010!                     DO jk = 1, jpk           
1011!                        DO ji = nistr, niend, nn_factx
1012!                           ii   = ( ji - mis_crs(2) ) * rfactx_r + 2   
1013!                           ijie = mie_crs(ii)
1014!                           zflcrs = &
1015!                             & MAX( p_fld(ijie,je_2  ,jk) * p_mask(ijie,je_2  ,jk) - ( 1.- p_mask(ijie,je_2,jk) ) * r_inf ,  &
1016!                             &      p_fld(ijie,je_2+1,jk) * p_mask(ijie,je_2+1,jk) - ( 1.- p_mask(ijie,je_2,jk) ) * r_inf ,  &
1017!                             &      p_fld(ijie,je_2+2,jk) * p_mask(ijie,je_2+2,jk) - ( 1.- p_mask(ijie,je_2,jk) ) * r_inf  )
1018!                            !
1019!                           p_fld_crs(ii,2,jk) = zflcrs
1020!                        ENDDO
1021!                     ENDDO
1022!                  ENDIF
1023!                  !
1024!                  DO jk = 1, jpk           
1025!                     DO jj  = njstr, njend, nn_facty
1026!                        DO ji = nistr, niend, nn_factx
1027!                           ii   = ( ji - mis_crs(2) ) * rfactx_r + 2     
1028!                           ij   = ( jj - njstr ) * rfacty_r + 3
1029!                           ijie = mie_crs(ii)
1030!                           zflcrs =  &
1031!                             & MAX( p_fld(ijie,jj  ,jk) * p_mask(ijie,jj  ,jk) - ( 1.- p_mask(ijie,jj,jk) ) * r_inf ,  &
1032!                             &      p_fld(ijie,jj+1,jk) * p_mask(ijie,jj+1,jk) - ( 1.- p_mask(ijie,jj,jk) ) * r_inf ,  &
1033!                             &      p_fld(ijie,jj+2,jk) * p_mask(ijie,jj+2,jk) - ( 1.- p_mask(ijie,jj,jk) ) * r_inf  )
1034!                           !
1035!                           p_fld_crs(ii,ij,jk) = zflcrs
1036!                           !
1037!                        ENDDO     
1038!                     ENDDO
1039!                  ENDDO   
1040                  CALL ctl_stop('MAX operator and U case not available')
1041
1042              END SELECT
1043
1044              CALL wrk_dealloc( jpi, jpj, jpk, zmask )
1045
1046         CASE ( 'MIN' )      !   Search the min of unmasked grid cells
1047
1048            CALL wrk_alloc( jpi, jpj, jpk, zmask )
1049
1050            !SELECT CASE ( cd_type )
1051            !  CASE( 'W' )
1052            !      !cbr ?????????????????????????????
1053            !      zmask(:,:,1) = p_mask(:,:,1)
1054            !      DO jk = 2, jpk
1055            !         zmask(:,:,jk) = p_mask(:,:,jk-1)
1056            !      ENDDO
1057            !  CASE ( 'T' )
1058                  DO jk = 1, jpk
1059                     zmask(:,:,jk) = p_mask(:,:,jk) 
1060                  ENDDO
1061            !END SELECT
1062
1063            SELECT CASE ( cd_type )
1064
1065               CASE( 'T', 'W' )
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                              zflcrs =  &
1074                                & MIN( p_fld(ji  ,je_2,jk) * zmask(ji  ,je_2,jk) + ( 1.- zmask(ji  ,je_2,jk) ) * r_inf ,  &
1075                                &      p_fld(ji+1,je_2,jk) * zmask(ji+1,je_2,jk) + ( 1.- zmask(ji+1,je_2,jk) ) * r_inf ,  &
1076                                &      p_fld(ji+2,je_2,jk) * zmask(ji+2,je_2,jk) + ( 1.- zmask(ji+2,je_2,jk) ) * r_inf  )
1077                              !
1078                              p_fld_crs(ii,2,jk) = zflcrs
1079                           ENDDO
1080                        ENDDO
1081                      ENDIF
1082                  ELSE
1083                     je_2 = mjs_crs(2)
1084                     DO jk = 1, jpk           
1085                        DO ji = nistr, niend, nn_factx
1086                           ii   = ( ji - mis_crs(2) ) * rfactx_r + 2   
1087                           zflcrs =  &
1088                             & MIN( p_fld(ji  ,je_2  ,jk) * zmask(ji  ,je_2  ,jk) + ( 1.- zmask(ji  ,je_2  ,jk) ) * r_inf ,  &
1089                             &      p_fld(ji+1,je_2  ,jk) * zmask(ji+1,je_2  ,jk) + ( 1.- zmask(ji+1,je_2  ,jk) ) * r_inf ,  &
1090                             &      p_fld(ji+2,je_2  ,jk) * zmask(ji+2,je_2  ,jk) + ( 1.- zmask(ji+2,je_2  ,jk) ) * r_inf ,  &
1091                             &      p_fld(ji  ,je_2+1,jk) * zmask(ji  ,je_2+1,jk) + ( 1.- zmask(ji  ,je_2+1,jk) ) * r_inf ,  &
1092                             &      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 ,  &
1093                             &      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 ,  &
1094                             &      p_fld(ji  ,je_2+2,jk) * zmask(ji  ,je_2+2,jk) + ( 1.- zmask(ji  ,je_2+2,jk) ) * r_inf ,  &
1095                             &      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 ,  &
1096                             &      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   )
1097                           !
1098                           p_fld_crs(ii,2,jk) = zflcrs
1099                        ENDDO
1100                     ENDDO
1101                  ENDIF
1102                  !
1103                  DO jk = 1, jpk           
1104                     DO jj  = njstr, njend, nn_facty
1105                        DO ji = nistr, niend, nn_factx
1106                           ii  = ( ji - mis_crs(2) ) * rfactx_r + 2                 ! cordinate in parent grid
1107                           ij  = ( jj - njstr ) * rfacty_r + 3
1108                           zflcrs =  &
1109                             & MIN( p_fld(ji  ,jj  ,jk) * zmask(ji  ,jj  ,jk) + ( 1.- zmask(ji  ,jj  ,jk) ) * r_inf ,  &
1110                             &      p_fld(ji+1,jj  ,jk) * zmask(ji+1,jj  ,jk) + ( 1.- zmask(ji+1,jj  ,jk) ) * r_inf ,  &
1111                             &      p_fld(ji+2,jj  ,jk) * zmask(ji+2,jj  ,jk) + ( 1.- zmask(ji+2,jj  ,jk) ) * r_inf ,  &
1112                             &      p_fld(ji  ,jj+1,jk) * zmask(ji  ,jj+1,jk) + ( 1.- zmask(ji  ,jj+1,jk) ) * r_inf ,  &
1113                             &      p_fld(ji+1,jj+1,jk) * zmask(ji+1,jj+1,jk) + ( 1.- zmask(ji+1,jj+1,jk) ) * r_inf ,  &
1114                             &      p_fld(ji+2,jj+1,jk) * zmask(ji+2,jj+1,jk) + ( 1.- zmask(ji+2,jj+1,jk) ) * r_inf ,  &
1115                             &      p_fld(ji  ,jj+2,jk) * zmask(ji  ,jj+2,jk) + ( 1.- zmask(ji  ,jj+2,jk) ) * r_inf ,  &
1116                             &      p_fld(ji+1,jj+2,jk) * zmask(ji+1,jj+2,jk) + ( 1.- zmask(ji+1,jj+2,jk) ) * r_inf ,  &
1117                             &      p_fld(ji+2,jj+2,jk) * zmask(ji+2,jj+2,jk) + ( 1.- zmask(ji+2,jj+2,jk) ) * r_inf   )
1118                           !
1119                           p_fld_crs(ii,ij,jk) = zflcrs
1120                           !
1121                        ENDDO     
1122                     ENDDO
1123                  ENDDO   
1124           
1125               CASE( 'V' )
1126
1127!                  IF( nldj_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN     !!cc bande du sud style ORCA2
1128!                     IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN
1129!                        ijje = mje_crs(2)
1130!                      ENDIF
1131!                  ELSE
1132!                     ijje = mjs_crs(2)
1133!                  ENDIF
1134!
1135!                  DO jk = 1, jpk
1136!                     DO ji = nistr, niend, nn_factx
1137!                        ii   = ( ji - mis_crs(2) ) * rfactx_r + 2     
1138!                        zflcrs = &
1139!                          & MIN( p_fld(ji  ,ijje,jk) * p_mask(ji  ,ijje,jk) + ( 1.- p_mask(ji,ijje,jk) ) * r_inf ,  &
1140!                          &      p_fld(ji+1,ijje,jk) * p_mask(ji+1,ijje,jk) + ( 1.- p_mask(ji,ijje,jk) ) * r_inf ,  &
1141!                          &      p_fld(ji+2,ijje,jk) * p_mask(ji+2,ijje,jk) + ( 1.- p_mask(ji,ijje,jk) ) * r_inf )
1142!                          !
1143!                        p_fld_crs(ii,2,jk) = zflcrs
1144!                     ENDDO
1145!                  ENDDO
1146!                  !
1147!                  DO jk = 1, jpk           
1148!                     DO jj  = njstr, njend, nn_facty
1149!                        DO ji = nistr, niend, nn_factx
1150!                           ii  = ( ji - mis_crs(2) ) * rfactx_r + 2                 ! cordinate in parent grid
1151!                           ij  = ( jj - njstr ) * rfacty_r + 3
1152!                           ijje = mje_crs(ij)
1153!                           zflcrs = &
1154!                             & MIN( p_fld(ji  ,ijje,jk) * p_mask(ji  ,ijje,jk) + ( 1.- p_mask(ji,ijje,jk) ) * r_inf ,  &
1155!                             &      p_fld(ji+1,ijje,jk) * p_mask(ji+1,ijje,jk) + ( 1.- p_mask(ji,ijje,jk) ) * r_inf ,  &
1156!                             &      p_fld(ji+2,ijje,jk) * p_mask(ji+2,ijje,jk) + ( 1.- p_mask(ji,ijje,jk) ) * r_inf )
1157!                           !
1158!                           p_fld_crs(ii,ij,jk) = zflcrs
1159!                           !
1160!                        ENDDO     
1161!                     ENDDO
1162!                  ENDDO   
1163                  CALL ctl_stop('MIN operator and V case not available')
1164
1165           
1166               CASE( 'U' )
1167
1168!                 IF( nldj_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN     !!cc bande du sud style ORCA2
1169!                     IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN
1170!                        je_2 = mje_crs(2)
1171!                        DO jk = 1, jpk           
1172!                           DO ji = nistr, niend, nn_factx
1173!                              ii   = ( ji - mis_crs(2) ) * rfactx_r + 2 
1174!                              ijie = mie_crs(ii)
1175!                              zflcrs = p_fld(ijie,je_2,jk) * p_mask(ijie,je_2,jk) + ( 1.- p_mask(ijie,je_2,jk) ) * r_inf
1176!                              !
1177!                              p_fld_crs(ii,2,jk) = zflcrs
1178!                            ENDDO
1179!                        ENDDO
1180!                      ENDIF
1181!                  ELSE
1182!                     je_2 = mjs_crs(2)
1183!                     DO jk = 1, jpk           
1184!                        DO ji = nistr, niend, nn_factx
1185!                           ii   = ( ji - mis_crs(2) ) * rfactx_r + 2   
1186!                           ijie = mie_crs(ii)
1187!                           zflcrs = &
1188!                             & MIN( p_fld(ijie,je_2  ,jk) * p_mask(ijie,je_2  ,jk) + ( 1.- p_mask(ijie,je_2,jk) ) * r_inf ,  &
1189!                             &      p_fld(ijie,je_2+1,jk) * p_mask(ijie,je_2+1,jk) + ( 1.- p_mask(ijie,je_2,jk) ) * r_inf ,  &
1190!                             &      p_fld(ijie,je_2+2,jk) * p_mask(ijie,je_2+2,jk) + ( 1.- p_mask(ijie,je_2,jk) ) * r_inf  )
1191!                            !
1192!                           p_fld_crs(ii,2,jk) = zflcrs
1193!                        ENDDO
1194!                     ENDDO
1195!                  ENDIF
1196!                  !
1197!                  DO jk = 1, jpk           
1198!                     DO jj  = njstr, njend, nn_facty
1199!                        DO ji = nistr, niend, nn_factx
1200!                           ii   = ( ji - mis_crs(2) ) * rfactx_r + 2     
1201!                           ij   = ( jj - njstr ) * rfacty_r + 3
1202!                           ijie = mie_crs(ii)
1203!                           zflcrs = &
1204!                             & MIN( p_fld(ijie,jj  ,jk) * p_mask(ijie,jj  ,jk) + ( 1.- p_mask(ijie,jj,jk) ) * r_inf ,  &
1205!                             &      p_fld(ijie,jj+1,jk) * p_mask(ijie,jj+1,jk) + ( 1.- p_mask(ijie,jj,jk) ) * r_inf ,  &
1206!                             &      p_fld(ijie,jj+2,jk) * p_mask(ijie,jj+2,jk) + ( 1.- p_mask(ijie,jj,jk) ) * r_inf  )
1207!                           !
1208!                           p_fld_crs(ii,ij,jk) = zflcrs
1209!                           !
1210!                        ENDDO     
1211!                     ENDDO
1212!                  ENDDO   
1213                  CALL ctl_stop('MIN operator and U case not available')
1214         
1215            END SELECT
1216            !
1217            CALL wrk_dealloc( jpi, jpj, jpk, zmask )
1218            !
1219         END SELECT
1220         !
1221         !IF(narea==267)WRITE(5000+narea,*)"vn_crs(17,5,74) avt lbc = ",p_fld(17,5,74)
1222         CALL crs_lbc_lnk( p_fld_crs, cd_type, psgn )
1223         !IF(narea==267)WRITE(5000+narea,*)"vn_crs(17,5,74) apr lbc = ",p_fld(17,5,74)
1224         !
1225    END SUBROUTINE crs_dom_ope_3d
1226
1227    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 )
1228      !!----------------------------------------------------------------
1229      !!               *** SUBROUTINE crsfun_UV ***
1230      !! ** Purpose :  Average, area-weighted, of U or V on the east and north faces
1231      !!
1232      !! ** Method  :  The U and V velocities (3D) are determined as the area-weighted averages
1233      !!               on the east and north faces, respectively,
1234      !!               of the parent grid subset comprising the coarse grid box.
1235      !!               In the case of the V and F grid, the last jrow minus 1 is spurious.
1236      !! ** Inputs  : p_e1_e2     = parent grid e1 or e2 (t,u,v,f)
1237      !!              cd_type     = grid type (T,U,V,F) for scale factors; for velocities (U or V)
1238      !!              psgn        = sign change over north fold (See lbclnk.F90)
1239      !!              p_pmask     = parent grid mask (T,U,V,F) for scale factors;
1240      !!                                       for velocities (U or V)
1241      !!              p_fse3      = parent grid vertical level thickness (fse3u or fse3v)
1242      !!              p_pfield    = U or V on the parent grid
1243      !!              p_surf_crs  = (Optional) Coarse grid weight for averaging
1244      !! ** Outputs : p_cfield3d = 3D field on coarse grid
1245      !!
1246      !! History.  29 May.  completed draft.
1247      !!            4 Jun.  Revision for WGT
1248      !!            5 Jun.  Streamline for area-weighted average only ; separate scale factor and weights.
1249      !!----------------------------------------------------------------
1250      !!
1251      !!  Arguments
1252      REAL(wp), DIMENSION(jpi,jpj),             INTENT(in)           :: p_fld   ! T, U, V or W on parent grid
1253      CHARACTER(len=3),                         INTENT(in)           :: cd_op    ! Operation SUM, MAX or MIN
1254      CHARACTER(len=1),                         INTENT(in)           :: cd_type    ! grid type U,V
1255      REAL(wp), DIMENSION(jpi,jpj,jpk),         INTENT(in)           :: p_mask    ! Parent grid T,U,V mask
1256      REAL(wp), DIMENSION(jpi,jpj),             INTENT(in), OPTIONAL :: p_e12    ! Parent grid T,U,V scale factors (e1 or e2)
1257      REAL(wp), DIMENSION(jpi,jpj,jpk),         INTENT(in), OPTIONAL :: p_e3     ! Parent grid vertical level thickness (fse3u, fse3v)
1258      REAL(wp), DIMENSION(jpi_crs,jpj_crs)    , INTENT(in), OPTIONAL :: p_surf_crs ! Coarse grid area-weighting denominator   
1259      REAL(wp), DIMENSION(jpi_crs,jpj_crs,jpk), INTENT(in), OPTIONAL :: p_mask_crs    ! Coarse grid T,U,V mask
1260      REAL(wp),                                 INTENT(in)           :: psgn   
1261
1262      REAL(wp), DIMENSION(jpi_crs,jpj_crs)    , INTENT(out)          :: p_fld_crs ! Coarse grid box 3D quantity
1263
1264      !! Local variables
1265      INTEGER  :: ji, jj, jk                 ! dummy loop indices
1266      INTEGER  :: ijie, ijje, ii, ij, je_2
1267      REAL(wp) :: zflcrs, zsfcrs   
1268      REAL(wp), DIMENSION(:,:), POINTER :: zsurfmsk   
1269
1270      !!---------------------------------------------------------------- 
1271 
1272      p_fld_crs(:,:) = 0.0
1273
1274      SELECT CASE ( cd_op )
1275     
1276        CASE ( 'VOL' )
1277     
1278            CALL wrk_alloc( jpi, jpj, zsurfmsk )
1279            zsurfmsk(:,:) =  p_e12(:,:) * p_e3(:,:,1) * p_mask(:,:,1)
1280
1281            IF( nldj_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN     !!cc bande du sud style ORCA2
1282               IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN
1283                  je_2 = mje_crs(2)
1284                  DO ji = nistr, niend, nn_factx
1285                     ii   = ( ji - mis_crs(2) ) * rfactx_r + 2       
1286                     zflcrs =  p_fld(ji  ,je_2) * zsurfmsk(ji  ,je_2)   &
1287                       &     + p_fld(ji+1,je_2) * zsurfmsk(ji+1,je_2)   &
1288                       &     + p_fld(ji+2,je_2) * zsurfmsk(ji+2,je_2) 
1289
1290                     zsfcrs =  zsurfmsk(ji,je_2) + zsurfmsk(ji+1,je_2) + zsurfmsk(ji+2,je_2) 
1291                     !
1292                     p_fld_crs(ii,2) = zflcrs
1293                     IF( zsfcrs /= 0.0 )  p_fld_crs(ii,2) = zflcrs / zsfcrs
1294                  ENDDO
1295               ENDIF
1296            ELSE
1297               je_2 = mjs_crs(2)
1298               DO ji = nistr, niend, nn_factx
1299                  ii   = ( ji - mis_crs(2) ) * rfactx_r + 2   
1300                  zflcrs =  p_fld(ji  ,je_2  ) * zsurfmsk(ji  ,je_2  ) &
1301                    &     + p_fld(ji+1,je_2  ) * zsurfmsk(ji+1,je_2  ) &
1302                    &     + p_fld(ji+2,je_2  ) * zsurfmsk(ji+2,je_2  ) &
1303                    &     + p_fld(ji  ,je_2+1) * zsurfmsk(ji  ,je_2+1) &
1304                    &     + p_fld(ji+1,je_2+1) * zsurfmsk(ji+1,je_2+1) &
1305                    &     + p_fld(ji+2,je_2+1) * zsurfmsk(ji+2,je_2+1) &
1306                    &     + p_fld(ji  ,je_2+2) * zsurfmsk(ji  ,je_2+2) &
1307                    &     + p_fld(ji+1,je_2+2) * zsurfmsk(ji+1,je_2+2) &
1308                    &     + p_fld(ji+2,je_2+2) * zsurfmsk(ji+2,je_2+2) 
1309
1310                   zsfcrs =  zsurfmsk(ji,je_2  ) + zsurfmsk(ji+1,je_2  ) + zsurfmsk(ji+2,je_2  ) &
1311                     &     + zsurfmsk(ji,je_2+1) + zsurfmsk(ji+1,je_2+1) + zsurfmsk(ji+2,je_2+1) &
1312                     &     + zsurfmsk(ji,je_2+2) + zsurfmsk(ji+1,je_2+2) + zsurfmsk(ji+2,je_2+2) 
1313                    !
1314                    p_fld_crs(ii,2) = zflcrs
1315                    IF( zsfcrs /= 0.0 )  p_fld_crs(ii,2) = zflcrs / zsfcrs
1316                ENDDO
1317            ENDIF
1318                  !
1319            DO jj  = njstr, njend, nn_facty
1320               DO ji = nistr, niend, nn_factx
1321                  ii  = ( ji - mis_crs(2) ) * rfactx_r + 2                 ! cordinate in parent grid
1322                  ij  = ( jj - njstr ) * rfacty_r + 3
1323                  zflcrs =  p_fld(ji  ,jj  ) * zsurfmsk(ji  ,jj  ) &
1324                    &     + p_fld(ji+1,jj  ) * zsurfmsk(ji+1,jj  ) &
1325                    &     + p_fld(ji+2,jj  ) * zsurfmsk(ji+2,jj  ) &
1326                    &     + p_fld(ji  ,jj+1) * zsurfmsk(ji  ,jj+1) &
1327                    &     + p_fld(ji+1,jj+1) * zsurfmsk(ji+1,jj+1) &
1328                    &     + p_fld(ji+2,jj+1) * zsurfmsk(ji+2,jj+1) &
1329                    &     + p_fld(ji  ,jj+2) * zsurfmsk(ji  ,jj+2) &
1330                    &     + p_fld(ji+1,jj+2) * zsurfmsk(ji+1,jj+2) &
1331                    &     + p_fld(ji+2,jj+2) * zsurfmsk(ji+2,jj+2) 
1332 
1333                  zsfcrs =  zsurfmsk(ji,jj  ) + zsurfmsk(ji+1,jj  ) + zsurfmsk(ji+2,jj  ) &
1334                    &     + zsurfmsk(ji,jj+1) + zsurfmsk(ji+1,jj+1) + zsurfmsk(ji+2,jj+1) &
1335                    &     + zsurfmsk(ji,jj+2) + zsurfmsk(ji+1,jj+2) + zsurfmsk(ji+2,jj+2) 
1336                   !
1337                  p_fld_crs(ii,ij) = zflcrs
1338                  IF( zsfcrs /= 0.0 )  p_fld_crs(ii,ij) = zflcrs / zsfcrs
1339               ENDDO     
1340            ENDDO
1341
1342            CALL wrk_dealloc( jpi, jpj, zsurfmsk )
1343
1344         CASE ( 'SUM' )
1345         
1346            CALL wrk_alloc( jpi, jpj, zsurfmsk )
1347            IF( PRESENT( p_e3 ) ) THEN
1348               zsurfmsk(:,:) =  p_e12(:,:) * p_e3(:,:,1) * p_mask(:,:,1)
1349            ELSE
1350               zsurfmsk(:,:) =  p_e12(:,:) * p_mask(:,:,1)
1351            ENDIF
1352
1353            SELECT CASE ( cd_type )
1354
1355               CASE( 'T', 'W' )
1356
1357                   IF( nldj_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN     !!cc bande du sud style ORCA2
1358                      IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN
1359                         je_2 = mje_crs(2)
1360                         DO ji = nistr, niend, nn_factx
1361                            ii   = ( ji - mis_crs(2) ) * rfactx_r + 2     
1362                            zflcrs  =  p_fld(ji  ,je_2) * zsurfmsk(ji  ,je_2) &
1363                              &      + p_fld(ji+1,je_2) * zsurfmsk(ji+1,je_2) &
1364                              &      + p_fld(ji+2,je_2) * zsurfmsk(ji+2,je_2) 
1365                              !
1366                             p_fld_crs(ii,2) = zflcrs
1367                         ENDDO
1368                      ENDIF
1369                   ELSE
1370                      je_2 = mjs_crs(2)
1371                      DO ji = nistr, niend, nn_factx
1372                         ii   = ( ji - mis_crs(2) ) * rfactx_r + 2     
1373                         zflcrs  =  p_fld(ji  ,je_2  ) * zsurfmsk(ji  ,je_2  )  &
1374                           &      + p_fld(ji+1,je_2  ) * zsurfmsk(ji+1,je_2  )  &
1375                           &      + p_fld(ji+2,je_2  ) * zsurfmsk(ji+2,je_2  )  &
1376                           &      + p_fld(ji  ,je_2+1) * zsurfmsk(ji  ,je_2+1)  &
1377                           &      + p_fld(ji+1,je_2+1) * zsurfmsk(ji+1,je_2+1)  &
1378                           &      + p_fld(ji+2,je_2+1) * zsurfmsk(ji+2,je_2+1)  &
1379                           &      + p_fld(ji  ,je_2+2) * zsurfmsk(ji  ,je_2+2)  &
1380                           &      + p_fld(ji+1,je_2+2) * zsurfmsk(ji+1,je_2+2)  &
1381                           &      + p_fld(ji+2,je_2+2) * zsurfmsk(ji+2,je_2+2) 
1382                            !
1383                            p_fld_crs(ii,2) = zflcrs
1384                      ENDDO
1385                   ENDIF
1386                   !
1387                   DO jj = njstr, njend, nn_facty
1388                      DO ji = nistr, niend, nn_factx
1389                         ii   = ( ji - mis_crs(2) ) * rfactx_r + 2   
1390                         ij   = ( jj - njstr ) * rfacty_r + 3
1391                         zflcrs  =  p_fld(ji  ,jj  ) * zsurfmsk(ji  ,jj  )  &
1392                           &      + p_fld(ji+1,jj  ) * zsurfmsk(ji+1,jj  )  &
1393                           &      + p_fld(ji+2,jj  ) * zsurfmsk(ji+2,jj  )  &
1394                           &      + p_fld(ji  ,jj+1) * zsurfmsk(ji  ,jj+1)  &
1395                           &      + p_fld(ji+1,jj+1) * zsurfmsk(ji+1,jj+1)  &
1396                           &      + p_fld(ji+2,jj+1) * zsurfmsk(ji+2,jj+1)  &
1397                           &      + p_fld(ji  ,jj+2) * zsurfmsk(ji  ,jj+2)  &
1398                           &      + p_fld(ji+1,jj+2) * zsurfmsk(ji+1,jj+2)  &
1399                           &      + p_fld(ji+2,jj+2) * zsurfmsk(ji+2,jj+2) 
1400                          !
1401                          p_fld_crs(ii,ij) = zflcrs
1402                          !
1403                      ENDDO     
1404                   ENDDO
1405           
1406               CASE( 'V' )
1407                   DO ji = nistr, niend, nn_factx
1408                      ii  = ( ji - mis_crs(2) ) * rfactx_r + 2
1409                      IF( nldj_crs == 1 .AND. (( mje_crs(2) - mjs_crs(2) ) < 2) )THEN     !!cc bande du sud style ORCA2
1410                         IF( mje_crs(2) - mjs_crs(2) == 1 )THEN
1411                            jj = mje_crs(2)
1412                            zflcrs  = p_fld(ji  ,jj  ) * zsurfmsk(ji  ,jj  )  &
1413                             &      + p_fld(ji+1,jj  ) * zsurfmsk(ji+1,jj  )  &
1414                             &      + p_fld(ji+2,jj  ) * zsurfmsk(ji+2,jj  )
1415                            p_fld_crs(ii,2) = zflcrs
1416                         ENDIF
1417                      ELSE
1418                         ijje = mje_crs(2)
1419                         zflcrs  = p_fld(ji  ,ijje) * zsurfmsk(ji  ,ijje)  &
1420                           &     + p_fld(ji+1,ijje) * zsurfmsk(ji+1,ijje)  &
1421                           &     + p_fld(ji+2,ijje) * zsurfmsk(ji+2,ijje)
1422                         !
1423                         p_fld_crs(ii,2) = zflcrs
1424                      ENDIF
1425
1426                      DO jj = njstr, njend, nn_facty
1427                         ii   = ( ji - mis_crs(2) ) * rfactx_r + 2
1428                         ij   = ( jj - njstr ) * rfacty_r + 3
1429                         ijje = mje_crs(ij)
1430                         ijie = mie_crs(ii)
1431                         !                 
1432                         zflcrs  = p_fld(ji  ,ijje) * zsurfmsk(ji  ,ijje)  &
1433                          &      + p_fld(ji+1,ijje) * zsurfmsk(ji+1,ijje)  &
1434                          &      + p_fld(ji+2,ijje) * zsurfmsk(ji+2,ijje)
1435                         !
1436                         p_fld_crs(ii,ij) = zflcrs
1437                         !
1438                      ENDDO
1439                   ENDDO
1440           
1441               CASE( 'U' )
1442
1443                  IF( nldj_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN     !!cc bande du sud style ORCA2
1444                     IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN
1445                        je_2 = mje_crs(2)
1446                        DO ji = nistr, niend, nn_factx
1447                           ii   = ( ji - mis_crs(2) ) * rfactx_r + 2   
1448                           ijie = mie_crs(ii)
1449                           zflcrs  =  p_fld(ijie,je_2) * zsurfmsk(ijie,je_2) 
1450                           p_fld_crs(ii,2) = zflcrs
1451                        ENDDO
1452                     ENDIF
1453                  ELSE
1454                     je_2 = mjs_crs(2)
1455                     DO ji = nistr, niend, nn_factx
1456                        ii   = ( ji - mis_crs(2) ) * rfactx_r + 2   
1457                        ijie = mie_crs(ii)
1458                        zflcrs =  p_fld(ijie,je_2  ) * zsurfmsk(ijie,je_2  )  &
1459                          &     + p_fld(ijie,je_2+1) * zsurfmsk(ijie,je_2+1)  &
1460                          &     + p_fld(ijie,je_2+2) * zsurfmsk(ijie,je_2+2) 
1461   
1462                        p_fld_crs(ii,2) = zflcrs
1463                     ENDDO
1464                 ENDIF
1465
1466                 DO jj = njstr, njend, nn_facty
1467                    DO ji = nistr, niend, nn_factx
1468                       ii   = ( ji - mis_crs(2) ) * rfactx_r + 2     
1469                       ij   = ( jj - njstr ) * rfacty_r + 3
1470                       ijie = mie_crs(ii)
1471                       zflcrs =  p_fld(ijie,jj  ) * zsurfmsk(ijie,jj  )  &
1472                          &    + p_fld(ijie,jj+1) * zsurfmsk(ijie,jj+1)  &
1473                          &    + p_fld(ijie,jj+2) * zsurfmsk(ijie,jj+2) 
1474                         !
1475                       p_fld_crs(ii,ij) = zflcrs
1476                       !
1477                    ENDDO     
1478                 ENDDO
1479
1480              END SELECT
1481
1482              IF( PRESENT( p_surf_crs ) ) THEN
1483                 WHERE ( p_surf_crs /= 0.0 ) p_fld_crs(:,:) = p_fld_crs(:,:) / p_surf_crs(:,:)
1484              ENDIF
1485
1486              CALL wrk_dealloc( jpi, jpj, zsurfmsk )
1487
1488         CASE ( 'MAX' )
1489
1490            SELECT CASE ( cd_type )
1491           
1492               CASE( 'T', 'W' )
1493 
1494                   DO ji = nistr, niend, nn_factx
1495                      ii   = ( ji - mis_crs(2) ) * rfactx_r + 2     
1496                      IF( nldj_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN     !!cc bande du sud style ORCA2
1497                         IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN
1498                            je_2 = mje_crs(2)
1499                            zflcrs =  &
1500                              & MAX( p_fld(ji  ,je_2) * p_mask(ji  ,je_2,1) - ( 1.- p_mask(ji  ,je_2,1) ) * r_inf ,  &
1501                              &      p_fld(ji+1,je_2) * p_mask(ji+1,je_2,1) - ( 1.- p_mask(ji+1,je_2,1) ) * r_inf ,  &
1502                              &      p_fld(ji+2,je_2) * p_mask(ji+2,je_2,1) - ( 1.- p_mask(ji+2,je_2,1) ) * r_inf  )
1503                            !
1504                            p_fld_crs(ii,2) = zflcrs
1505                         ENDIF
1506                      ELSE
1507                         je_2 = mjs_crs(2) 
1508                         zflcrs =  &
1509                           &  MAX( p_fld(ji  ,je_2  ) * p_mask(ji  ,je_2  ,1) - ( 1.- p_mask(ji  ,je_2  ,1) ) * r_inf ,  &
1510                           &       p_fld(ji+1,je_2  ) * p_mask(ji+1,je_2  ,1) - ( 1.- p_mask(ji+1,je_2  ,1) ) * r_inf ,  &
1511                           &       p_fld(ji+2,je_2  ) * p_mask(ji+2,je_2  ,1) - ( 1.- p_mask(ji+2,je_2  ,1) ) * r_inf ,  &
1512                           &       p_fld(ji  ,je_2+1) * p_mask(ji  ,je_2+1,1) - ( 1.- p_mask(ji  ,je_2+1,1) ) * r_inf ,  &
1513                           &       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 ,  &
1514                           &       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 ,  &
1515                           &       p_fld(ji  ,je_2+2) * p_mask(ji  ,je_2+2,1) - ( 1.- p_mask(ji  ,je_2+2,1) ) * r_inf ,  &
1516                           &       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 ,  &
1517                           &       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   )
1518                         !
1519                         p_fld_crs(ii,2) = zflcrs
1520                      ENDIF
1521
1522                      DO jj = njstr, njend, nn_facty
1523                         ii   = ( ji - mis_crs(2) ) * rfactx_r + 2     
1524                         ij   = ( jj - njstr ) * rfacty_r + 3
1525                         zflcrs = &
1526                          &  MAX( p_fld(ji  ,jj  ) * p_mask(ji  ,jj  ,1) - ( 1.- p_mask(ji  ,jj  ,1) ) * r_inf ,  &
1527                          &       p_fld(ji+1,jj  ) * p_mask(ji+1,jj  ,1) - ( 1.- p_mask(ji+1,jj  ,1) ) * r_inf ,  &
1528                          &       p_fld(ji+2,jj  ) * p_mask(ji+2,jj  ,1) - ( 1.- p_mask(ji+2,jj  ,1) ) * r_inf ,  &
1529                          &       p_fld(ji  ,jj+1) * p_mask(ji  ,jj+1,1) - ( 1.- p_mask(ji  ,jj+1,1) ) * r_inf ,  &
1530                          &       p_fld(ji+1,jj+1) * p_mask(ji+1,jj+1,1) - ( 1.- p_mask(ji+1,jj+1,1) ) * r_inf ,  &
1531                          &       p_fld(ji+2,jj+1) * p_mask(ji+2,jj+1,1) - ( 1.- p_mask(ji+2,jj+1,1) ) * r_inf ,  &
1532                          &       p_fld(ji  ,jj+2) * p_mask(ji  ,jj+2,1) - ( 1.- p_mask(ji  ,jj+2,1) ) * r_inf ,  &
1533                          &       p_fld(ji+1,jj+2) * p_mask(ji+1,jj+2,1) - ( 1.- p_mask(ji+1,jj+2,1) ) * r_inf ,  &
1534                          &       p_fld(ji+2,jj+2) * p_mask(ji+2,jj+2,1) - ( 1.- p_mask(ji+2,jj+2,1) ) * r_inf   )
1535                         !
1536                         p_fld_crs(ii,ij) = zflcrs
1537                         !
1538                      ENDDO     
1539                   ENDDO
1540           
1541               CASE( 'V' )
1542
1543!                  IF( nldj_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN     !!cc bande du sud style ORCA2
1544!                     IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN
1545!                        ijje = mje_crs(2)
1546!                      ENDIF
1547!                  ELSE
1548!                     ijje = mjs_crs(2)
1549!                  ENDIF
1550!
1551!                  DO ji = nistr, niend, nn_factx
1552!                     ii   = ( ji - mis_crs(2) ) * rfactx_r + 2   
1553!                     zflcrs = MAX( p_fld(ji  ,ijje) * p_mask(ji  ,ijje,1) - ( 1.- p_mask(ji,ijje,1) ) * r_inf ,  &
1554!                       &           p_fld(ji+1,ijje) * p_mask(ji+1,ijje,1) - ( 1.- p_mask(ji,ijje,1) ) * r_inf ,  &
1555!                       &           p_fld(ji+2,ijje) * p_mask(ji+2,ijje,1) - ( 1.- p_mask(ji,ijje,1) ) * r_inf )
1556!                       !
1557!                     p_fld_crs(ii,2) = zflcrs
1558!                  ENDDO     
1559!                  DO jj = njstr, njend, nn_facty
1560!                     DO ji = nistr, niend, nn_factx
1561!                        ii   = ( ji - mis_crs(2) ) * rfactx_r + 2   
1562!                        ij   = ( jj - njstr ) * rfacty_r + 3               
1563!                        ijje = mje_crs(ij)
1564!                        !                 
1565!                        zflcrs = MAX( p_fld(ji  ,ijje) * p_mask(ji  ,ijje,1) - ( 1.- p_mask(ji,ijje,1) ) * r_inf ,  &
1566!                          &           p_fld(ji+1,ijje) * p_mask(ji+1,ijje,1) - ( 1.- p_mask(ji,ijje,1) ) * r_inf ,  &
1567!                          &           p_fld(ji+2,ijje) * p_mask(ji+2,ijje,1) - ( 1.- p_mask(ji,ijje,1) ) * r_inf )
1568!                        !
1569!                        p_fld_crs(ii,ij) = zflcrs
1570!                        !
1571!                     ENDDO     
1572!                  ENDDO
1573                  CALL ctl_stop('MAX operator and V case not available')
1574           
1575               CASE( 'U' )
1576
1577!                 IF( nldj_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN     !!cc bande du sud style ORCA2
1578!                     IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN
1579!                        je_2 = mje_crs(2)
1580!                        DO ji = nistr, niend, nn_factx
1581!                           ii   = ( ji - mis_crs(2) ) * rfactx_r + 2   
1582!                           ijie = mie_crs(ii)
1583!                           zflcrs  =  p_fld(ijie,je_2) * p_mask(ijie,je_2,1) - ( 1.- p_mask(ijie,je_2,1) ) * r_inf
1584!                           p_fld_crs(ii,2) = zflcrs
1585!                        ENDDO
1586!                     ENDIF
1587!                 ELSE
1588!                     je_2 = mjs_crs(2)
1589!                     DO ji = nistr, niend, nn_factx
1590!                        ii   = ( ji - mis_crs(2) ) * rfactx_r + 2   
1591!                        ijie = mie_crs(ii)
1592!                        zflcrs =  &
1593!                          &  MAX( p_fld(ijie,je_2  ) * p_mask(ijie,je_2  ,1) - ( 1.- p_mask(ijie,je_2,1) ) * r_inf ,  &
1594!                          &       p_fld(ijie,je_2+1) * p_mask(ijie,je_2+1,1) - ( 1.- p_mask(ijie,je_2,1) ) * r_inf ,  &
1595!                          &       p_fld(ijie,je_2+2) * p_mask(ijie,je_2+2,1) - ( 1.- p_mask(ijie,je_2,1) ) * r_inf  )
1596!                        p_fld_crs(ii,2) = zflcrs
1597!                     ENDDO
1598!                 ENDIF
1599!                 DO jj = njstr, njend, nn_facty
1600!                    DO ji = nistr, niend, nn_factx
1601!                       ii   = ( ji - mis_crs(2) ) * rfactx_r + 2     
1602!                       ij   = ( jj - njstr ) * rfacty_r + 3
1603!                       ijie = mie_crs(ii)
1604!                       zflcrs =  &
1605!                         &  MAX( p_fld(ijie,jj  ) * p_mask(ijie,jj  ,1) - ( 1.- p_mask(ijie,jj,1) ) * r_inf ,  &
1606!                         &       p_fld(ijie,jj+1) * p_mask(ijie,jj+1,1) - ( 1.- p_mask(ijie,jj,1) ) * r_inf ,  &
1607!                          &      p_fld(ijie,jj+2) * p_mask(ijie,jj+2,1) - ( 1.- p_mask(ijie,jj,1) ) * r_inf  )
1608!                        p_fld_crs(ii,ij) = zflcrs
1609!                        !
1610!                     ENDDO     
1611!                  ENDDO
1612                  CALL ctl_stop('MAX operator and U case not available')
1613
1614              END SELECT
1615
1616         CASE ( 'MIN' )      !   Search the min of unmasked grid cells
1617
1618           SELECT CASE ( cd_type )
1619
1620              CASE( 'T', 'W' )
1621 
1622                   IF( nldj_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN     !!cc bande du sud style ORCA2
1623                      IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN
1624                         je_2 = mje_crs(2)
1625                         DO ji = nistr, niend, nn_factx
1626                            ii   = ( ji - mis_crs(2) ) * rfactx_r + 2     
1627                            zflcrs =  &
1628                              & MIN( p_fld(ji  ,je_2) * p_mask(ji  ,je_2,1) + ( 1.- p_mask(ji  ,je_2,1) ) * r_inf ,  &
1629                             &       p_fld(ji+1,je_2) * p_mask(ji+1,je_2,1) + ( 1.- p_mask(ji+1,je_2,1) ) * r_inf ,  &
1630                             &       p_fld(ji+2,je_2) * p_mask(ji+2,je_2,1) + ( 1.- p_mask(ji+2,je_2,1) ) * r_inf  )
1631                            !
1632                            p_fld_crs(ii,2) = zflcrs
1633                         ENDDO
1634                      ENDIF
1635                   ELSE
1636                      DO ji = nistr, niend, nn_factx
1637                      ii   = ( ji - mis_crs(2) ) * rfactx_r + 2     
1638                      je_2 = mjs_crs(2) 
1639                      zflcrs =  &
1640                        &  MIN( p_fld(ji  ,je_2  ) * p_mask(ji  ,je_2  ,1) + ( 1.- p_mask(ji  ,je_2  ,1) ) * r_inf ,  &
1641                        &       p_fld(ji+1,je_2  ) * p_mask(ji+1,je_2  ,1) + ( 1.- p_mask(ji+1,je_2  ,1) ) * r_inf ,  &
1642                        &       p_fld(ji+2,je_2  ) * p_mask(ji+2,je_2  ,1) + ( 1.- p_mask(ji+2,je_2  ,1) ) * r_inf ,  &
1643                        &       p_fld(ji  ,je_2+1) * p_mask(ji  ,je_2+1,1) + ( 1.- p_mask(ji  ,je_2+1,1) ) * r_inf ,  &
1644                        &       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 ,  &
1645                        &       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 ,  &
1646                        &       p_fld(ji  ,je_2+2) * p_mask(ji  ,je_2+2,1) + ( 1.- p_mask(ji  ,je_2+2,1) ) * r_inf ,  &
1647                        &       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 ,  &
1648                        &       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   )
1649                      !
1650                      p_fld_crs(ii,2) = zflcrs
1651                      ENDDO
1652                   ENDIF
1653
1654                   DO jj = njstr, njend, nn_facty
1655                      DO ji = nistr, niend, nn_factx
1656                         ii   = ( ji - mis_crs(2) ) * rfactx_r + 2     
1657                         ij   = ( jj - njstr ) * rfacty_r + 3
1658                         zflcrs = &
1659                          &  MIN( p_fld(ji  ,jj  ) * p_mask(ji  ,jj  ,1) + ( 1.- p_mask(ji  ,jj  ,1) ) * r_inf ,  &
1660                          &       p_fld(ji+1,jj  ) * p_mask(ji+1,jj  ,1) + ( 1.- p_mask(ji+1,jj  ,1) ) * r_inf ,  &
1661                          &       p_fld(ji+2,jj  ) * p_mask(ji+2,jj  ,1) + ( 1.- p_mask(ji+2,jj  ,1) ) * r_inf ,  &
1662                          &       p_fld(ji  ,jj+1) * p_mask(ji  ,jj+1,1) + ( 1.- p_mask(ji  ,jj+1,1) ) * r_inf ,  &
1663                          &       p_fld(ji+1,jj+1) * p_mask(ji+1,jj+1,1) + ( 1.- p_mask(ji+1,jj+1,1) ) * r_inf ,  &
1664                          &       p_fld(ji+2,jj+1) * p_mask(ji+2,jj+1,1) + ( 1.- p_mask(ji+2,jj+1,1) ) * r_inf ,  &
1665                          &       p_fld(ji  ,jj+2) * p_mask(ji  ,jj+2,1) + ( 1.- p_mask(ji  ,jj+2,1) ) * r_inf ,  &
1666                          &       p_fld(ji+1,jj+2) * p_mask(ji+1,jj+2,1) + ( 1.- p_mask(ji+1,jj+2,1) ) * r_inf ,  &
1667                          &       p_fld(ji+2,jj+2) * p_mask(ji+2,jj+2,1) + ( 1.- p_mask(ji+2,jj+2,1) ) * r_inf   )
1668                         !
1669                         p_fld_crs(ii,ij) = zflcrs
1670                         !
1671                      ENDDO     
1672                   ENDDO
1673           
1674               CASE( 'V' )
1675
1676!                  IF( nldj_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN     !!cc bande du sud style ORCA2
1677!                     IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN
1678!                        ijje = mje_crs(2)
1679!                      ENDIF
1680!                  ELSE
1681!                     ijje = mjs_crs(2)
1682!                  ENDIF
1683!
1684!                  DO ji = nistr, niend, nn_factx
1685!                     ii   = ( ji - mis_crs(2) ) * rfactx_r + 2   
1686!                     zflcrs = MIN( p_fld(ji  ,ijje) * p_mask(ji  ,ijje,1) + ( 1.- p_mask(ji,ijje,1) ) * r_inf ,  &
1687!                       &           p_fld(ji+1,ijje) * p_mask(ji+1,ijje,1) + ( 1.- p_mask(ji,ijje,1) ) * r_inf ,  &
1688!                       &           p_fld(ji+2,ijje) * p_mask(ji+2,ijje,1) + ( 1.- p_mask(ji,ijje,1) ) * r_inf )
1689!                       !
1690!                     p_fld_crs(ii,2) = zflcrs
1691!                  ENDDO     
1692!                  DO jj = njstr, njend, nn_facty
1693!                     DO ji = nistr, niend, nn_factx
1694!                        ii   = ( ji - mis_crs(2) ) * rfactx_r + 2   
1695!                        ij   = ( jj - njstr ) * rfacty_r + 3               
1696!                        ijje = mje_crs(ij)
1697!                        !                 
1698!                        zflcrs = MIN( p_fld(ji  ,ijje) * p_mask(ji  ,ijje,1) + ( 1.- p_mask(ji,ijje,1) ) * r_inf ,  &
1699!                          &           p_fld(ji+1,ijje) * p_mask(ji+1,ijje,1) + ( 1.- p_mask(ji,ijje,1) ) * r_inf ,  &
1700!                          &           p_fld(ji+2,ijje) * p_mask(ji+2,ijje,1) + ( 1.- p_mask(ji,ijje,1) ) * r_inf )
1701!                        !
1702!                        p_fld_crs(ii,ij) = zflcrs
1703!                        !
1704!                     ENDDO     
1705!                  ENDDO
1706                  CALL ctl_stop('MIN operator and V case not available')
1707           
1708               CASE( 'U' )
1709
1710!                 IF( nldj_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN     !!cc bande du sud style ORCA2
1711!                     IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN
1712!                        je_2 = mje_crs(2)
1713!                        DO ji = nistr, niend, nn_factx
1714!                           ii   = ( ji - mis_crs(2) ) * rfactx_r + 2   
1715!                           ijie = mie_crs(ii)
1716!                           zflcrs  =  p_fld(ijie,je_2) * p_mask(ijie,je_2,1) + ( 1.- p_mask(ijie,je_2,1) ) * r_inf
1717!
1718!                           p_fld_crs(ii,2) = zflcrs
1719!                        ENDDO
1720!                     ENDIF
1721!                 ELSE
1722!                     je_2 = mjs_crs(2)
1723!                     DO ji = nistr, niend, nn_factx
1724!                        ii   = ( ji - mis_crs(2) ) * rfactx_r + 2   
1725!                        ijie = mie_crs(ii)
1726!                        zflcrs =  &
1727!                          &  MIN( p_fld(ijie,je_2  ) * p_mask(ijie,je_2  ,1) + ( 1.- p_mask(ijie,je_2,1) ) * r_inf ,  &
1728!                          &       p_fld(ijie,je_2+1) * p_mask(ijie,je_2+1,1) + ( 1.- p_mask(ijie,je_2,1) ) * r_inf ,  &
1729!                          &       p_fld(ijie,je_2+2) * p_mask(ijie,je_2+2,1) + ( 1.- p_mask(ijie,je_2,1) ) * r_inf  )
1730!                        p_fld_crs(ii,2) = zflcrs
1731!                     ENDDO
1732!                 ENDIF
1733!                 DO jj = njstr, njend, nn_facty
1734!                    DO ji = nistr, niend, nn_factx
1735!                       ii   = ( ji - mis_crs(2) ) * rfactx_r + 2     
1736!                       ij   = ( jj - njstr ) * rfacty_r + 3
1737!                       ijie = mie_crs(ii)
1738!                       zflcrs =  &
1739!                         &  MIN( p_fld(ijie,jj  ) * p_mask(ijie,jj  ,1) + ( 1.- p_mask(ijie,jj,1) ) * r_inf ,  &
1740!                         &       p_fld(ijie,jj+1) * p_mask(ijie,jj+1,1) + ( 1.- p_mask(ijie,jj,1) ) * r_inf ,  &
1741!                          &      p_fld(ijie,jj+2) * p_mask(ijie,jj+2,1) + ( 1.- p_mask(ijie,jj,1) ) * r_inf  )
1742!                        p_fld_crs(ii,ij) = zflcrs
1743!                        !
1744!                     ENDDO     
1745!                  ENDDO
1746                  CALL ctl_stop('MIN operator and U case not available')
1747
1748              END SELECT
1749             !
1750         END SELECT
1751         !
1752         CALL crs_lbc_lnk( p_fld_crs, cd_type, psgn )
1753         !
1754   END SUBROUTINE crs_dom_ope_2d
1755
1756   SUBROUTINE crs_dom_e3( p_e1, p_e2, p_e3, p_sfc_crs, cd_type, p_mask, p_e3_crs, p_e3_max_crs)
1757      !!---------------------------------------------------------------- 
1758      !!  Arguments
1759      CHARACTER(len=1),                         INTENT(in) :: cd_type      ! grid type T, W ( U, V, F)
1760      REAL(wp), DIMENSION(jpi,jpj,jpk),         INTENT(in) :: p_mask       ! Parent grid T mask
1761      REAL(wp), DIMENSION(jpi,jpj)    ,         INTENT(in) :: p_e1, p_e2   ! 2D tracer T or W on parent grid
1762      REAL(wp), DIMENSION(jpi,jpj,jpk),         INTENT(in) :: p_e3         ! 3D tracer T or W on parent grid
1763      REAL(wp), DIMENSION(jpi_crs,jpj_crs,jpk), INTENT(in) :: p_sfc_crs ! Coarse grid box east or north face quantity
1764      REAL(wp), DIMENSION(jpi_crs,jpj_crs,jpk), INTENT(inout) :: p_e3_crs ! Coarse grid box east or north face quantity
1765      REAL(wp), DIMENSION(jpi_crs,jpj_crs,jpk), INTENT(inout) :: p_e3_max_crs ! Coarse grid box east or north face quantity
1766
1767      !! Local variables
1768      INTEGER ::  ji, jj, jk                   ! dummy loop indices
1769      INTEGER ::  ijie, ijje, ii, ij, je_2
1770      REAL(wp) :: ze3crs 
1771      !REAL(wp), DIMENSION(:,:,:), POINTER :: zmask, zsurf   
1772
1773      !!---------------------------------------------------------------- 
1774
1775       p_e3_crs    (:,:,:) = 0.
1776       p_e3_max_crs(:,:,:) = 1.
1777   
1778
1779       !CALL wrk_alloc( jpi, jpj, jpk, zmask, zsurf )
1780
1781       SELECT CASE ( cd_type )
1782
1783         CASE ('T')
1784
1785            DO jk = 1 , jpk
1786               DO ji = nistr, niend, nn_factx
1787
1788                  ii   = ( ji - mis_crs(2) ) * rfactx_r + 2
1789                  IF (nldj_crs == 1 .AND. (( mje_crs(2) - mjs_crs(2) ) < 2)) THEN     !!cc bande du sud style ORCA2
1790
1791                  IF ( mje_crs(2) - mjs_crs(2) == 1 ) THEN
1792
1793                    jj = mje_crs(2)
1794
1795
1796                    ze3crs = MAX(  p_e3(ji  ,jj  ,jk) * p_mask(ji  ,jj  ,jk),  &
1797                        &          p_e3(ji+1,jj  ,jk) * p_mask(ji+1,jj  ,jk),  &
1798                        &          p_e3(ji+2,jj  ,jk) * p_mask(ji+2,jj  ,jk))
1799
1800                    p_e3_max_crs(ii,2,jk) = ze3crs
1801
1802                    ze3crs =  p_e3(ji  ,jj  ,jk) * p_e1(ji  ,jj  ) * p_e2(ji  ,jj  ) * p_mask(ji  ,jj  ,jk) +  &
1803                        &     p_e3(ji+1,jj  ,jk) * p_e1(ji+1,jj  ) * p_e2(ji+1,jj  ) * p_mask(ji+1,jj  ,jk) +  &
1804                        &     p_e3(ji+2,jj  ,jk) * p_e1(ji+2,jj  ) * p_e2(ji+2,jj  ) * p_mask(ji+2,jj  ,jk)
1805
1806
1807                    p_e3_crs(ii,2,jk) = ze3crs / p_sfc_crs(ii,2,jk)
1808                  ENDIF
1809                  ELSE
1810                     jj = mjs_crs(2)
1811
1812                     ze3crs = MAX( p_e3(ji  ,jj  ,jk) * p_mask(ji  ,jj  ,jk),  &
1813                        &          p_e3(ji+1,jj  ,jk) * p_mask(ji+1,jj  ,jk),  &
1814                        &          p_e3(ji+2,jj  ,jk) * p_mask(ji+2,jj  ,jk),  &
1815                        &          p_e3(ji  ,jj+1,jk) * p_mask(ji  ,jj+1,jk),  &
1816                        &          p_e3(ji+1,jj+1,jk) * p_mask(ji+1,jj+1,jk),  &
1817                        &          p_e3(ji+2,jj+1,jk) * p_mask(ji+2,jj+1,jk),  &
1818                        &          p_e3(ji  ,jj+2,jk) * p_mask(ji  ,jj+2,jk),  &
1819                        &          p_e3(ji+1,jj+2,jk) * p_mask(ji+1,jj+2,jk),  &
1820                        &          p_e3(ji+2,jj+2,jk) * p_mask(ji+2,jj+2,jk) )
1821
1822                     p_e3_max_crs(ii,2,jk) = ze3crs
1823
1824                     ze3crs =  p_e3(ji  ,jj  ,jk) * p_e1(ji  ,jj  ) * p_e2(ji  ,jj  ) * p_mask(ji  ,jj  ,jk) +  &
1825                        &      p_e3(ji+1,jj  ,jk) * p_e1(ji+1,jj  ) * p_e2(ji+1,jj  ) * p_mask(ji+1,jj  ,jk) +  &
1826                        &      p_e3(ji+2,jj  ,jk) * p_e1(ji+2,jj  ) * p_e2(ji+2,jj  ) * p_mask(ji+2,jj  ,jk) +  &
1827                        &      p_e3(ji  ,jj+1,jk) * p_e1(ji  ,jj+1) * p_e2(ji  ,jj+1) * p_mask(ji  ,jj+1,jk) +  &
1828                        &      p_e3(ji+1,jj+1,jk) * p_e1(ji+1,jj+1) * p_e2(ji+1,jj+1) * p_mask(ji+1,jj+1,jk) +  &
1829                        &      p_e3(ji+2,jj+1,jk) * p_e1(ji+2,jj+1) * p_e2(ji+2,jj+1) * p_mask(ji+2,jj+1,jk) +  &
1830                        &      p_e3(ji  ,jj+2,jk) * p_e1(ji  ,jj+2) * p_e2(ji  ,jj+2) * p_mask(ji  ,jj+2,jk) +  &
1831                        &      p_e3(ji+1,jj+2,jk) * p_e1(ji+1,jj+2) * p_e2(ji+1,jj+2) * p_mask(ji+1,jj+2,jk) +  &
1832                        &      p_e3(ji+2,jj+2,jk) * p_e1(ji+2,jj+2) * p_e2(ji+2,jj+2) * p_mask(ji+2,jj+2,jk)
1833
1834                       p_e3_crs(ii,2,jk) = ze3crs / p_sfc_crs(ii,2,jk)
1835                  ENDIF
1836
1837                  DO jj = njstr, njend, nn_facty
1838                     ii   = ( ji - mis_crs(2) ) * rfactx_r + 2                 ! cordinate in parent grid
1839                     ij   = ( jj - njstr ) * rfacty_r + 3
1840                     ijje = mje_crs(ij)
1841                     ijie = mie_crs(ii)
1842                     ! 
1843                     ze3crs = MAX( p_e3(ji  ,jj  ,jk) * p_mask(ji  ,jj  ,jk),  &
1844                        &          p_e3(ji+1,jj  ,jk) * p_mask(ji+1,jj  ,jk),  &
1845                        &          p_e3(ji+2,jj  ,jk) * p_mask(ji+2,jj  ,jk),  &
1846                        &          p_e3(ji  ,jj+1,jk) * p_mask(ji  ,jj+1,jk),  &
1847                        &          p_e3(ji+1,jj+1,jk) * p_mask(ji+1,jj+1,jk),  &
1848                        &          p_e3(ji+2,jj+1,jk) * p_mask(ji+2,jj+1,jk),  &
1849                        &          p_e3(ji  ,jj+2,jk) * p_mask(ji  ,jj+2,jk),  &
1850                        &          p_e3(ji+1,jj+2,jk) * p_mask(ji+1,jj+2,jk),  &
1851                        &          p_e3(ji+2,jj+2,jk) * p_mask(ji+2,jj+2,jk) )
1852
1853                     p_e3_max_crs(ii,ij,jk) = ze3crs
1854                     ze3crs =  p_e3(ji  ,jj  ,jk) * p_e1(ji  ,jj  ) * p_e2(ji  ,jj  ) * p_mask(ji  ,jj  ,jk) +  &
1855                        &      p_e3(ji+1,jj  ,jk) * p_e1(ji+1,jj  ) * p_e2(ji+1,jj  ) * p_mask(ji+1,jj  ,jk) +  &
1856                        &      p_e3(ji+2,jj  ,jk) * p_e1(ji+2,jj  ) * p_e2(ji+2,jj  ) * p_mask(ji+2,jj  ,jk) +  &
1857                        &      p_e3(ji  ,jj+1,jk) * p_e1(ji  ,jj+1) * p_e2(ji  ,jj+1) * p_mask(ji  ,jj+1,jk) +  &
1858                        &      p_e3(ji+1,jj+1,jk) * p_e1(ji+1,jj+1) * p_e2(ji+1,jj+1) * p_mask(ji+1,jj+1,jk) +  &
1859                        &      p_e3(ji+2,jj+1,jk) * p_e1(ji+2,jj+1) * p_e2(ji+2,jj+1) * p_mask(ji+2,jj+1,jk) +  &
1860                        &      p_e3(ji  ,jj+2,jk) * p_e1(ji  ,jj+2) * p_e2(ji  ,jj+2) * p_mask(ji  ,jj+2,jk) +  &
1861                        &      p_e3(ji+1,jj+2,jk) * p_e1(ji+1,jj+2) * p_e2(ji+1,jj+2) * p_mask(ji+1,jj+2,jk) +  &
1862                        &      p_e3(ji+2,jj+2,jk) * p_e1(ji+2,jj+2) * p_e2(ji+2,jj+2) * p_mask(ji+2,jj+2,jk)
1863
1864                       p_e3_crs(ii,ij,jk) = ze3crs / p_sfc_crs(ii,ij,jk)
1865
1866                  ENDDO
1867               ENDDO
1868            ENDDO
1869
1870         CASE ('U')
1871
1872         DO jk = 1 , jpk
1873               DO ji = nistr, niend, nn_factx
1874                 ii   = ( ji - mis_crs(2) ) * rfactx_r + 2
1875                  IF (nldj_crs == 1 .AND. (( mje_crs(2) - mjs_crs(2) ) < 2)) THEN     !!cc bande du sud style ORCA2
1876
1877                     IF ( mje_crs(2) - mjs_crs(2) == 1 ) THEN
1878
1879                    jj = mje_crs(2)
1880
1881
1882                    ze3crs = p_e3(ji+2,jj  ,jk) * p_mask(ji+2,jj  ,jk)
1883
1884                    p_e3_max_crs(ii,2,jk) = ze3crs
1885
1886                    ze3crs =  p_e3(ji+2,jj  ,jk) * p_e1(ji+2,jj  ) * p_e2(ji+2,jj  ) * p_mask(ji+2,jj  ,jk)
1887
1888
1889                     p_e3_crs(ii,2,jk) = ze3crs / p_sfc_crs(ii,2,jk)
1890                     ENDIF
1891                  ELSE
1892                     jj = mjs_crs(2)
1893
1894                     ze3crs = MAX( p_e3(ji+2,jj  ,jk) * p_mask(ji+2,jj  ,jk),  &
1895                                   p_e3(ji+2,jj+1,jk) * p_mask(ji+2,jj+1,jk),  &
1896                                   p_e3(ji+2,jj+2,jk) * p_mask(ji+2,jj+2,jk) )
1897
1898                     p_e3_max_crs(ii,2,jk) = ze3crs
1899
1900                     ze3crs =  p_e3(ji+2,jj  ,jk) * p_e1(ji+2,jj  ) * p_e2(ji+2,jj  ) * p_mask(ji+2,jj  ,jk) +  &
1901                        &      p_e3(ji+2,jj+1,jk) * p_e1(ji+2,jj+1) * p_e2(ji+2,jj+1) * p_mask(ji+2,jj+1,jk) +  &
1902                        &      p_e3(ji+2,jj+2,jk) * p_e1(ji+2,jj+2) * p_e2(ji+2,jj+2) * p_mask(ji+2,jj+2,jk)
1903
1904                       p_e3_crs(ii,2,jk) = ze3crs / p_sfc_crs(ii,2,jk)
1905                  ENDIF
1906                  DO jj = njstr, njend, nn_facty
1907                     ii   = ( ji - mis_crs(2) ) * rfactx_r + 2                 ! cordinate in parent grid
1908                     ij   = ( jj - njstr ) * rfacty_r + 3
1909                     ijje = mje_crs(ij)
1910                     ijie = mie_crs(ii)
1911                     ! 
1912                     ze3crs = MAX( p_e3(ji+2,jj  ,jk) * p_mask(ji+2,jj  ,jk),  &
1913                        &          p_e3(ji+2,jj+1,jk) * p_mask(ji+2,jj+1,jk),  &
1914                        &          p_e3(ji+2,jj+2,jk) * p_mask(ji+2,jj+2,jk) )
1915
1916                     p_e3_max_crs(ii,ij,jk) = ze3crs
1917
1918                     ze3crs =  p_e3(ji+2,jj  ,jk) * p_e1(ji+2,jj  ) * p_e2(ji+2,jj  ) * p_mask(ji+2,jj  ,jk) +  &
1919                        &      p_e3(ji+2,jj+1,jk) * p_e1(ji+2,jj+1) * p_e2(ji+2,jj+1) * p_mask(ji+2,jj+1,jk) +  &
1920                        &      p_e3(ji+2,jj+2,jk) * p_e1(ji+2,jj+2) * p_e2(ji+2,jj+2) * p_mask(ji+2,jj+2,jk)
1921
1922                       p_e3_crs(ii,ij,jk) = ze3crs / p_sfc_crs(ii,ij,jk)
1923
1924                  ENDDO
1925               ENDDO
1926            ENDDO
1927
1928         CASE ('V')
1929         DO jk = 1 , jpk
1930               DO ji = nistr, niend, nn_factx
1931
1932                  ii   = ( ji - mis_crs(2) ) * rfactx_r + 2
1933                  IF (nldj_crs == 1 .AND. (( mje_crs(2) - mjs_crs(2) ) < 2)) THEN     !!cc bande du sud style ORCA2
1934
1935                     IF ( mje_crs(2) - mjs_crs(2) == 1 ) THEN
1936
1937                    jj = mje_crs(2)
1938
1939
1940                    ze3crs = MAX(  p_e3(ji  ,jj  ,jk) * p_mask(ji  ,jj  ,jk),  &
1941                        &          p_e3(ji+1,jj  ,jk) * p_mask(ji+1,jj  ,jk),  &
1942                        &          p_e3(ji+2,jj  ,jk) * p_mask(ji+2,jj  ,jk))
1943
1944                    p_e3_max_crs(ii,2,jk) = ze3crs
1945
1946                    ze3crs =  p_e3(ji  ,jj  ,jk) * p_e1(ji  ,jj  ) * p_e2(ji  ,jj  ) * p_mask(ji  ,jj  ,jk) +  &
1947                        &     p_e3(ji+1,jj  ,jk) * p_e1(ji+1,jj  ) * p_e2(ji+1,jj  ) * p_mask(ji+1,jj  ,jk) +  &
1948                        &     p_e3(ji+2,jj  ,jk) * p_e1(ji+2,jj  ) * p_e2(ji+2,jj  ) * p_mask(ji+2,jj  ,jk)
1949
1950
1951                     p_e3_crs(ii,2,jk) = ze3crs / p_sfc_crs(ii,2,jk)
1952                     ENDIF
1953                  ELSE
1954                     jj = mjs_crs(2)
1955
1956                     ze3crs = MAX( p_e3(ji  ,jj+2,jk) * p_mask(ji  ,jj+2,jk),  &
1957                        &          p_e3(ji+1,jj+2,jk) * p_mask(ji+1,jj+2,jk),  &
1958                        &          p_e3(ji+2,jj+2,jk) * p_mask(ji+2,jj+2,jk) )
1959
1960                     p_e3_max_crs(ii,2,jk) = ze3crs
1961
1962                     ze3crs =  p_e3(ji  ,jj+2,jk) * p_e1(ji  ,jj+2) * p_e2(ji  ,jj+2) * p_mask(ji  ,jj+2,jk) +  &
1963                        &      p_e3(ji+1,jj+2,jk) * p_e1(ji+1,jj+2) * p_e2(ji+1,jj+2) * p_mask(ji+1,jj+2,jk) +  &
1964                        &      p_e3(ji+2,jj+2,jk) * p_e1(ji+2,jj+2) * p_e2(ji+2,jj+2) * p_mask(ji+2,jj+2,jk)
1965
1966                       p_e3_crs(ii,2,jk) = ze3crs / p_sfc_crs(ii,2,jk)
1967                  ENDIF
1968
1969                  DO jj = njstr, njend, nn_facty
1970                     ii   = ( ji - mis_crs(2) ) * rfactx_r + 2                 ! cordinate in parent grid
1971                     ij   = ( jj - njstr ) * rfacty_r + 3
1972                     ijje = mje_crs(ij)
1973                     ijie = mie_crs(ii)
1974                     ! 
1975                     ze3crs = MAX( p_e3(ji  ,jj+2,jk) * p_mask(ji  ,jj+2,jk),  &
1976                        &          p_e3(ji+1,jj+2,jk) * p_mask(ji+1,jj+2,jk),  &
1977                        &          p_e3(ji+2,jj+2,jk) * p_mask(ji+2,jj+2,jk) )
1978
1979                     p_e3_max_crs(ii,ij,jk) = ze3crs
1980
1981                     ze3crs =  p_e3(ji  ,jj+2,jk) * p_e1(ji  ,jj+2) * p_e2(ji  ,jj+2) * p_mask(ji  ,jj+2,jk) +  &
1982                        &      p_e3(ji+1,jj+2,jk) * p_e1(ji+1,jj+2) * p_e2(ji+1,jj+2) * p_mask(ji+1,jj+2,jk) +  &
1983                        &      p_e3(ji+2,jj+2,jk) * p_e1(ji+2,jj+2) * p_e2(ji+2,jj+2) * p_mask(ji+2,jj+2,jk)
1984
1985                       p_e3_crs(ii,ij,jk) = ze3crs / p_sfc_crs(ii,ij,jk)
1986
1987                  ENDDO
1988               ENDDO
1989            ENDDO
1990         CASE ('W')
1991
1992            DO jk = 2 , jpk
1993               DO ji = nistr, niend, nn_factx
1994               ii   = ( ji - mis_crs(2) ) * rfactx_r + 2
1995               IF (nldj_crs == 1 .AND. (( mje_crs(2) - mjs_crs(2) ) < 2)) THEN     !!cc bande du sud style ORCA2
1996
1997                 IF ( mje_crs(2) - mjs_crs(2) == 1 ) THEN
1998
1999                    jj = mje_crs(2)
2000
2001
2002                    ze3crs = MAX(  p_e3(ji  ,jj  ,jk) * p_mask(ji  ,jj  ,jk-1),  &
2003                        &          p_e3(ji+1,jj  ,jk) * p_mask(ji+1,jj  ,jk-1),  &
2004                        &          p_e3(ji+2,jj  ,jk) * p_mask(ji+2,jj  ,jk-1))
2005
2006                     p_e3_max_crs(ii,2,jk) = ze3crs
2007
2008                     ze3crs =  p_e3(ji  ,jj  ,jk) * p_e1(ji  ,jj  ) * p_e2(ji  ,jj  ) * p_mask(ji  ,jj  ,jk-1) +  &
2009                        &      p_e3(ji+1,jj  ,jk) * p_e1(ji+1,jj  ) * p_e2(ji+1,jj  ) * p_mask(ji+1,jj  ,jk-1) +  &
2010                        &      p_e3(ji+2,jj  ,jk) * p_e1(ji+2,jj  ) * p_e2(ji+2,jj  ) * p_mask(ji+2,jj  ,jk-1)
2011
2012
2013                       p_e3_crs(ii,2,jk) = ze3crs / p_sfc_crs(ii,2,jk)
2014                  ENDIF
2015               ELSE
2016                  jj = mjs_crs(2)
2017
2018                  ze3crs = MAX( p_e3(ji  ,jj  ,jk) * p_mask(ji  ,jj  ,jk-1),  &
2019                     &          p_e3(ji+1,jj  ,jk) * p_mask(ji+1,jj  ,jk-1),  &
2020                     &          p_e3(ji+2,jj  ,jk) * p_mask(ji+2,jj  ,jk-1),  &
2021                     &          p_e3(ji  ,jj+1,jk) * p_mask(ji  ,jj+1,jk-1),  &
2022                     &          p_e3(ji+1,jj+1,jk) * p_mask(ji+1,jj+1,jk-1),  &
2023                     &          p_e3(ji+2,jj+1,jk) * p_mask(ji+2,jj+1,jk-1),  &
2024                     &          p_e3(ji  ,jj+2,jk) * p_mask(ji  ,jj+2,jk-1),  &
2025                     &          p_e3(ji+1,jj+2,jk) * p_mask(ji+1,jj+2,jk-1),  &
2026                     &          p_e3(ji+2,jj+2,jk) * p_mask(ji+2,jj+2,jk-1) )
2027
2028                  p_e3_max_crs(ii,2,jk) = ze3crs
2029                  ze3crs =  p_e3(ji  ,jj  ,jk) * p_e1(ji  ,jj  ) * p_e2(ji  ,jj  ) * p_mask(ji  ,jj  ,jk-1) +  &
2030                     &      p_e3(ji+1,jj  ,jk) * p_e1(ji+1,jj  ) * p_e2(ji+1,jj  ) * p_mask(ji+1,jj  ,jk-1) +  &
2031                     &      p_e3(ji+2,jj  ,jk) * p_e1(ji+2,jj  ) * p_e2(ji+2,jj  ) * p_mask(ji+2,jj  ,jk-1) +  &
2032                     &      p_e3(ji  ,jj+1,jk) * p_e1(ji  ,jj+1) * p_e2(ji  ,jj+1) * p_mask(ji  ,jj+1,jk-1) +  &
2033                     &      p_e3(ji+1,jj+1,jk) * p_e1(ji+1,jj+1) * p_e2(ji+1,jj+1) * p_mask(ji+1,jj+1,jk-1) +  &
2034                     &      p_e3(ji+2,jj+1,jk) * p_e1(ji+2,jj+1) * p_e2(ji+2,jj+1) * p_mask(ji+2,jj+1,jk-1) +  &
2035                     &      p_e3(ji  ,jj+2,jk) * p_e1(ji  ,jj+2) * p_e2(ji  ,jj+2) * p_mask(ji  ,jj+2,jk-1) +  &
2036                     &      p_e3(ji+1,jj+2,jk) * p_e1(ji+1,jj+2) * p_e2(ji+1,jj+2) * p_mask(ji+1,jj+2,jk-1) +  &
2037                     &      p_e3(ji+2,jj+2,jk) * p_e1(ji+2,jj+2) * p_e2(ji+2,jj+2) * p_mask(ji+2,jj+2,jk-1)
2038
2039                  p_e3_crs(ii,2,jk) = ze3crs / p_sfc_crs(ii,2,jk)
2040               ENDIF
2041
2042
2043                  DO jj = njstr, njend, nn_facty
2044                     ii   = ( ji - mis_crs(2) ) * rfactx_r + 2                 ! cordinate in parent grid
2045                     ij   = ( jj - njstr ) * rfacty_r + 3
2046                     ijje = mje_crs(ij)
2047                     ijie = mie_crs(ii)
2048                     ! 
2049                     ze3crs = MAX( p_e3(ji  ,jj  ,jk) * p_mask(ji  ,jj  ,jk-1),  &
2050                        &          p_e3(ji+1,jj  ,jk) * p_mask(ji+1,jj  ,jk-1),  &
2051                        &          p_e3(ji+2,jj  ,jk) * p_mask(ji+2,jj  ,jk-1),  &
2052                        &          p_e3(ji  ,jj+1,jk) * p_mask(ji  ,jj+1,jk-1),  &
2053                        &          p_e3(ji+1,jj+1,jk) * p_mask(ji+1,jj+1,jk-1),  &
2054                        &          p_e3(ji+2,jj+1,jk) * p_mask(ji+2,jj+1,jk-1),  &
2055                        &          p_e3(ji  ,jj+2,jk) * p_mask(ji  ,jj+2,jk-1),  &
2056                        &          p_e3(ji+1,jj+2,jk) * p_mask(ji+1,jj+2,jk-1),  &
2057                        &          p_e3(ji+2,jj+2,jk) * p_mask(ji+2,jj+2,jk-1) )
2058
2059                     p_e3_max_crs(ii,ij,jk) = ze3crs
2060
2061                     ze3crs =  p_e3(ji  ,jj  ,jk) * p_e1(ji  ,jj  ) * p_e2(ji  ,jj  ) * p_mask(ji  ,jj  ,jk-1) +  &
2062                        &      p_e3(ji+1,jj  ,jk) * p_e1(ji+1,jj  ) * p_e2(ji+1,jj  ) * p_mask(ji+1,jj  ,jk-1) +  &
2063                        &      p_e3(ji+2,jj  ,jk) * p_e1(ji+2,jj  ) * p_e2(ji+2,jj  ) * p_mask(ji+2,jj  ,jk-1) +  &
2064                        &      p_e3(ji  ,jj+1,jk) * p_e1(ji  ,jj+1) * p_e2(ji  ,jj+1) * p_mask(ji  ,jj+1,jk-1) +  &
2065                        &      p_e3(ji+1,jj+1,jk) * p_e1(ji+1,jj+1) * p_e2(ji+1,jj+1) * p_mask(ji+1,jj+1,jk-1) +  &
2066                        &      p_e3(ji+2,jj+1,jk) * p_e1(ji+2,jj+1) * p_e2(ji+2,jj+1) * p_mask(ji+2,jj+1,jk-1) +  &
2067                        &      p_e3(ji  ,jj+2,jk) * p_e1(ji  ,jj+2) * p_e2(ji  ,jj+2) * p_mask(ji  ,jj+2,jk-1) +  &
2068                        &      p_e3(ji+1,jj+2,jk) * p_e1(ji+1,jj+2) * p_e2(ji+1,jj+2) * p_mask(ji+1,jj+2,jk-1) +  &
2069                        &      p_e3(ji+2,jj+2,jk) * p_e1(ji+2,jj+2) * p_e2(ji+2,jj+2) * p_mask(ji+2,jj+2,jk-1)
2070
2071                       p_e3_crs(ii,ij,jk) = ze3crs / p_sfc_crs(ii,ij,jk)
2072
2073                  ENDDO
2074               ENDDO
2075            ENDDO
2076
2077
2078            !first level
2079            DO ji = nistr, niend, nn_factx
2080               ii   = ( ji - mis_crs(2) ) * rfactx_r + 2
2081               IF (nldj_crs == 1 .AND. (( mje_crs(2) - mjs_crs(2) ) < 2)) THEN     !!cc bande du sud style ORCA2
2082
2083                 IF ( mje_crs(2) - mjs_crs(2) == 1 ) THEN
2084
2085                    jj = mje_crs(2)
2086
2087                    ze3crs = MAX(  p_e3(ji  ,jj  ,1) * p_mask(ji  ,jj  ,1),  &
2088                        &          p_e3(ji+1,jj  ,1) * p_mask(ji+1,jj  ,1),  &
2089                        &          p_e3(ji+2,jj  ,1) * p_mask(ji+2,jj  ,1))
2090
2091                    p_e3_max_crs(ii,2,1) = ze3crs
2092
2093                    ze3crs =  p_e3(ji  ,jj  ,1) * p_e1(ji  ,jj  ) * p_e2(ji  ,jj  ) * p_mask(ji  ,jj  ,1) +  &
2094                        &      p_e3(ji+1,jj  ,1) * p_e1(ji+1,jj  ) * p_e2(ji+1,jj  ) * p_mask(ji+1,jj  ,1) +  &
2095                        &      p_e3(ji+2,jj  ,1) * p_e1(ji+2,jj  ) * p_e2(ji+2,jj  ) * p_mask(ji+2,jj  ,1)
2096
2097                    p_e3_crs(ii,2,1) = ze3crs / p_sfc_crs(ii,2,1)
2098                  ENDIF
2099               ELSE
2100                  jj = mjs_crs(2)
2101
2102                  ze3crs = MAX( p_e3(ji  ,jj  ,1) * p_mask(ji  ,jj  ,1),  &
2103                     &          p_e3(ji+1,jj  ,1) * p_mask(ji+1,jj  ,1),  &
2104                     &          p_e3(ji+2,jj  ,1) * p_mask(ji+2,jj  ,1),  &
2105                     &          p_e3(ji  ,jj+1,1) * p_mask(ji  ,jj+1,1),  &
2106                     &          p_e3(ji+1,jj+1,1) * p_mask(ji+1,jj+1,1),  &
2107                     &          p_e3(ji+2,jj+1,1) * p_mask(ji+2,jj+1,1),  &
2108                     &          p_e3(ji  ,jj+2,1) * p_mask(ji  ,jj+2,1),  &
2109                     &          p_e3(ji+1,jj+2,1) * p_mask(ji+1,jj+2,1),  &
2110                     &          p_e3(ji+2,jj+2,1) * p_mask(ji+2,jj+2,1) )
2111
2112                  p_e3_max_crs(ii,2,1) = ze3crs
2113                  ze3crs =  p_e3(ji  ,jj  ,1) * p_e1(ji  ,jj  ) * p_e2(ji  ,jj  ) * p_mask(ji  ,jj  ,1) +  &
2114                        &    p_e3(ji+1,jj  ,1) * p_e1(ji+1,jj  ) * p_e2(ji+1,jj  ) * p_mask(ji+1,jj  ,1) +  &
2115                        &    p_e3(ji+2,jj  ,1) * p_e1(ji+2,jj  ) * p_e2(ji+2,jj  ) * p_mask(ji+2,jj  ,1) +  &
2116                        &    p_e3(ji  ,jj+1,1) * p_e1(ji  ,jj+1) * p_e2(ji  ,jj+1) * p_mask(ji  ,jj+1,1) +  &
2117                        &    p_e3(ji+1,jj+1,1) * p_e1(ji+1,jj+1) * p_e2(ji+1,jj+1) * p_mask(ji+1,jj+1,1) +  &
2118                        &    p_e3(ji+2,jj+1,1) * p_e1(ji+2,jj+1) * p_e2(ji+2,jj+1) * p_mask(ji+2,jj+1,1) +  &
2119                        &    p_e3(ji  ,jj+2,1) * p_e1(ji  ,jj+2) * p_e2(ji  ,jj+2) * p_mask(ji  ,jj+2,1) +  &
2120                        &    p_e3(ji+1,jj+2,1) * p_e1(ji+1,jj+2) * p_e2(ji+1,jj+2) * p_mask(ji+1,jj+2,1) +  &
2121                        &    p_e3(ji+2,jj+2,1) * p_e1(ji+2,jj+2) * p_e2(ji+2,jj+2) * p_mask(ji+2,jj+2,1)
2122
2123                   p_e3_crs(ii,2,1) = ze3crs / p_sfc_crs(ii,2,1)
2124
2125               ENDIF
2126               DO jj = njstr, njend, nn_facty
2127                  ii   = ( ji - mis_crs(2) ) * rfactx_r + 2                 ! cordinate in parent grid
2128                  ij   = ( jj - njstr ) * rfacty_r + 3
2129                  ijje = mje_crs(ij)
2130                  ijie = mie_crs(ii)
2131                  ! 
2132                  ze3crs = MAX( p_e3(ji  ,jj  ,1) * p_mask(ji  ,jj  ,1),  &
2133                     &          p_e3(ji+1,jj  ,1) * p_mask(ji+1,jj  ,1),  &
2134                     &          p_e3(ji+2,jj  ,1) * p_mask(ji+2,jj  ,1),  &
2135                     &          p_e3(ji  ,jj+1,1) * p_mask(ji  ,jj+1,1),  &
2136                     &          p_e3(ji+1,jj+1,1) * p_mask(ji+1,jj+1,1),  &
2137                     &          p_e3(ji+2,jj+1,1) * p_mask(ji+2,jj+1,1),  &
2138                     &          p_e3(ji  ,jj+2,1) * p_mask(ji  ,jj+2,1),  &
2139                     &          p_e3(ji+1,jj+2,1) * p_mask(ji+1,jj+2,1),  &
2140                     &          p_e3(ji+2,jj+2,1) * p_mask(ji+2,jj+2,1) )
2141
2142                  p_e3_max_crs(ii,ij,1) = ze3crs
2143
2144                   ze3crs =  p_e3(ji  ,jj  ,1) * p_e1(ji  ,jj  ) * p_e2(ji  ,jj  ) * p_mask(ji  ,jj  ,1) +  &
2145                        &    p_e3(ji+1,jj  ,1) * p_e1(ji+1,jj  ) * p_e2(ji+1,jj  ) * p_mask(ji+1,jj  ,1) +  &
2146                        &    p_e3(ji+2,jj  ,1) * p_e1(ji+2,jj  ) * p_e2(ji+2,jj  ) * p_mask(ji+2,jj  ,1) +  &
2147                        &    p_e3(ji  ,jj+1,1) * p_e1(ji  ,jj+1) * p_e2(ji  ,jj+1) * p_mask(ji  ,jj+1,1) +  &
2148                        &    p_e3(ji+1,jj+1,1) * p_e1(ji+1,jj+1) * p_e2(ji+1,jj+1) * p_mask(ji+1,jj+1,1) +  &
2149                        &    p_e3(ji+2,jj+1,1) * p_e1(ji+2,jj+1) * p_e2(ji+2,jj+1) * p_mask(ji+2,jj+1,1) +  &
2150                        &    p_e3(ji  ,jj+2,1) * p_e1(ji  ,jj+2) * p_e2(ji  ,jj+2) * p_mask(ji  ,jj+2,1) +  &
2151                        &    p_e3(ji+1,jj+2,1) * p_e1(ji+1,jj+2) * p_e2(ji+1,jj+2) * p_mask(ji+1,jj+2,1) +  &
2152                        &    p_e3(ji+2,jj+2,1) * p_e1(ji+2,jj+2) * p_e2(ji+2,jj+2) * p_mask(ji+2,jj+2,1)
2153
2154                       p_e3_crs(ii,ij,1) = ze3crs / p_sfc_crs(ii,ij,1)
2155
2156               ENDDO
2157            ENDDO
2158        !             
2159       END SELECT
2160
2161         CALL crs_lbc_lnk( p_e3_max_crs, cd_type, 1.0, pval=1.0 )
2162         CALL crs_lbc_lnk( p_e3_crs    , cd_type, 1.0, pval=1.0 )
2163       !             
2164       !CALL wrk_dealloc( jpi, jpj, jpk, zsurf, zmask )
2165       !
2166   END SUBROUTINE crs_dom_e3
2167
2168   SUBROUTINE crs_dom_sfc( p_mask, cd_type, p_surf_crs, p_surf_crs_msk,  p_e1, p_e2, p_e3 )
2169
2170      !!  Arguments
2171      CHARACTER(len=1),                         INTENT(in)           :: cd_type      ! grid type T, W ( U, V, F)
2172      REAL(wp), DIMENSION(jpi,jpj,jpk)        , INTENT(in)           :: p_mask       ! Parent grid T mask
2173      REAL(wp), DIMENSION(jpi,jpj)            , INTENT(in), OPTIONAL :: p_e1, p_e2         ! 3D tracer T or W on parent grid
2174      REAL(wp), DIMENSION(jpi,jpj,jpk)        , INTENT(in), OPTIONAL :: p_e3         ! 3D tracer T or W on parent grid
2175      REAL(wp), DIMENSION(jpi_crs,jpj_crs,jpk), INTENT(out)          :: p_surf_crs ! Coarse grid box east or north face quantity
2176      REAL(wp), DIMENSION(jpi_crs,jpj_crs,jpk), INTENT(out)          :: p_surf_crs_msk ! Coarse grid box east or north face quantity
2177
2178      !! Local variables
2179      INTEGER  :: ji, jj, jk                   ! dummy loop indices
2180      INTEGER  :: ii, ij, je_2
2181      INTEGER  :: iji,ijj
2182      REAL(wp), DIMENSION(:,:,:), POINTER :: zsurf, zsurfmsk   
2183      !!---------------------------------------------------------------- 
2184      ! Initialize
2185      p_surf_crs(:,:,:)=0._wp
2186      p_surf_crs_msk(:,:,:)=0._wp
2187
2188      CALL wrk_alloc( jpi, jpj, jpk, zsurf, zsurfmsk )
2189      !
2190      SELECT CASE ( cd_type )
2191     
2192         CASE ('W')   
2193            DO jk = 1, jpk
2194               zsurf(:,:,jk) = p_e1(:,:) * p_e2(:,:) 
2195            ENDDO
2196            !zsurfmsk(:,:,1) = zsurf(:,:,1) * p_mask(:,:,1)
2197            !cbr DO jk = 2, jpk
2198            DO jk = 1, jpk
2199               !cbr zsurfmsk(:,:,jk) = zsurf(:,:,jk) * p_mask(:,:,jk-1)
2200               zsurfmsk(:,:,jk) = zsurf(:,:,jk) * p_mask(:,:,jk) 
2201            ENDDO
2202
2203         CASE ('V')     
2204            DO jk = 1, jpk
2205               zsurf(:,:,jk) = p_e1(:,:) * p_e3(:,:,jk) 
2206            ENDDO
2207            DO jk = 1, jpk
2208               zsurfmsk(:,:,jk) = zsurf(:,:,jk) * p_mask(:,:,jk) 
2209            ENDDO
2210
2211         CASE ('U')     
2212            DO jk = 1, jpk
2213               zsurf(:,:,jk) = p_e2(:,:) * p_e3(:,:,jk) 
2214            ENDDO
2215            DO jk = 1, jpk
2216               zsurfmsk(:,:,jk) = zsurf(:,:,jk) * p_mask(:,:,jk) 
2217            ENDDO
2218
2219         CASE DEFAULT
2220            DO jk = 1, jpk
2221               zsurf(:,:,jk) = p_e1(:,:) * p_e2(:,:) 
2222            ENDDO
2223            DO jk = 1, jpk
2224               zsurfmsk(:,:,jk) = zsurf(:,:,jk) * p_mask(:,:,jk) 
2225            ENDDO
2226      END SELECT
2227
2228      !WRITE(narea+200,*)"TOTO",nldj_crs,mjs_crs(1), mje_crs(1),mjs_crs(2), mje_crs(2),mjs_crs(3), mje_crs(3),mjs_crs(4), mje_crs(4) ; CALL FLUSH(narea+200)
2229
2230      SELECT CASE ( cd_type )
2231
2232      CASE ('W')
2233
2234      IF( nldj_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN     !!cc bande du sud style ORCA2
2235         IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN
2236            je_2 = mje_crs(2)
2237            DO jk = 1, jpk
2238               DO ji = nistr, niend, nn_factx
2239                  ii   = ( ji - mis_crs(2) ) * rfactx_r + 2 
2240                  !   
2241                  p_surf_crs    (ii,2,jk) =  zsurf(ji,je_2  ,jk) + zsurf(ji+1,je_2  ,jk) + zsurf(ji+2,je_2  ,jk) &
2242                    &                      + zsurf(ji,je_2-1,jk) + zsurf(ji+1,je_2-1,jk) + zsurf(ji+2,je_2-1,jk)  ! Why ?????
2243                  !
2244                  p_surf_crs_msk(ii,2,jk) =  zsurfmsk(ji,je_2,jk) + zsurfmsk(ji+1,je_2,jk) + zsurfmsk(ji+2,je_2,jk) 
2245                  !
2246               ENDDO
2247            ENDDO
2248         ENDIF
2249      ELSE
2250         je_2 = mjs_crs(2)
2251         DO jk = 1, jpk
2252            DO ji = nistr, niend, nn_factx
2253               ii   = ( ji - mis_crs(2) ) * rfactx_r + 2 
2254               ! 
2255               p_surf_crs    (ii,2,jk) =  zsurf(ji,je_2  ,jk) + zsurf(ji+1,je_2  ,jk) + zsurf(ji+2,je_2  ,jk)  &
2256                    &                   + zsurf(ji,je_2+1,jk) + zsurf(ji+1,je_2+1,jk) + zsurf(ji+2,je_2+1,jk)  &
2257                    &                   + zsurf(ji,je_2+2,jk) + zsurf(ji+1,je_2+2,jk) + zsurf(ji+2,je_2+2,jk) 
2258
2259               p_surf_crs_msk(ii,2,jk) =  zsurfmsk(ji,je_2  ,jk) + zsurfmsk(ji+1,je_2  ,jk) + zsurfmsk(ji+2,je_2  ,jk)  &
2260                    &                   + zsurfmsk(ji,je_2+1,jk) + zsurfmsk(ji+1,je_2+1,jk) + zsurfmsk(ji+2,je_2+1,jk)  &
2261                    &                   + zsurfmsk(ji,je_2+2,jk) + zsurfmsk(ji+1,je_2+2,jk) + zsurfmsk(ji+2,je_2+2,jk) 
2262                ENDDO
2263            ENDDO
2264      ENDIF
2265         
2266      DO jk = 1, jpk
2267         DO jj = njstr, njend, nn_facty
2268            DO ji = nistr, niend, nn_factx
2269               ii = ( ji - mis_crs(2) ) * rfactx_r + 2 
2270               ij = ( jj - njstr ) * rfacty_r + 3
2271               !
2272               p_surf_crs    (ii,ij,jk) =  zsurf(ji,jj  ,jk) + zsurf(ji+1,jj  ,jk) + zsurf(ji+2,jj  ,jk)  &
2273                    &                    + zsurf(ji,jj+1,jk) + zsurf(ji+1,jj+1,jk) + zsurf(ji+2,jj+1,jk)  &
2274                    &                    + zsurf(ji,jj+2,jk) + zsurf(ji+1,jj+2,jk) + zsurf(ji+2,jj+2,jk) 
2275               p_surf_crs_msk(ii,ij,jk) =  zsurfmsk(ji,jj  ,jk) + zsurfmsk(ji+1,jj  ,jk) + zsurfmsk(ji+2,jj  ,jk)  &
2276                    &                    + zsurfmsk(ji,jj+1,jk) + zsurfmsk(ji+1,jj+1,jk) + zsurfmsk(ji+2,jj+1,jk)  &
2277                    &                    + zsurfmsk(ji,jj+2,jk) + zsurfmsk(ji+1,jj+2,jk) + zsurfmsk(ji+2,jj+2,jk) 
2278
2279            ENDDO     
2280         ENDDO
2281      ENDDO   
2282
2283      CASE ('U')
2284
2285     IF( nldj_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN     !!cc bande du sud style ORCA2
2286         IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN
2287            je_2 = mje_crs(2)
2288            DO jk = 1, jpk
2289               DO ji = nistr, niend, nn_factx
2290                  ii   = ( ji - mis_crs(2) ) * rfactx_r + 2
2291                  !   
2292                  p_surf_crs    (ii,2,jk) =  zsurf(ji+2,je_2  ,jk)
2293                  !
2294                  p_surf_crs_msk(ii,2,jk) =  zsurfmsk(ji+2,je_2,jk)
2295                  !
2296               ENDDO
2297            ENDDO
2298         ENDIF
2299      ELSE
2300         je_2 = mjs_crs(2)
2301         DO jk = 1, jpk
2302            DO ji = nistr, niend, nn_factx
2303               ii   = ( ji - mis_crs(2) ) * rfactx_r + 2
2304               ! 
2305               p_surf_crs    (ii,2,jk) =  zsurf(ji+2,je_2  ,jk)  &
2306                    &                   + zsurf(ji+2,je_2+1,jk)  &
2307                    &                   + zsurf(ji+2,je_2+2,jk)
2308
2309               p_surf_crs_msk(ii,2,jk) =  zsurfmsk(ji+2,je_2  ,jk)  &
2310                    &                   + zsurfmsk(ji+2,je_2+1,jk)  &
2311                    &                   + zsurfmsk(ji+2,je_2+2,jk)
2312                ENDDO
2313            ENDDO
2314      ENDIF
2315
2316      DO jk = 1, jpk
2317         DO jj = njstr, njend, nn_facty
2318            DO ji = nistr, niend, nn_factx
2319               ii = ( ji - mis_crs(2) ) * rfactx_r + 2
2320               ij = ( jj - njstr ) * rfacty_r + 3
2321               !
2322               p_surf_crs    (ii,ij,jk) =  zsurf(ji+2,jj  ,jk)  &
2323                    &                    + zsurf(ji+2,jj+1,jk)  &
2324                    &                    + zsurf(ji+2,jj+2,jk)
2325               p_surf_crs_msk(ii,ij,jk) =  zsurfmsk(ji+2,jj  ,jk)  &
2326                    &                    + zsurfmsk(ji+2,jj+1,jk)  &
2327                    &                    + zsurfmsk(ji+2,jj+2,jk)
2328            ENDDO
2329         ENDDO
2330      ENDDO
2331
2332      CASE ('V')
2333
2334      IF( nldj_crs == 1 .AND. ( ( mje_crs(2) - mjs_crs(2) ) < 2 ) ) THEN     !!cc bande du sud style ORCA2
2335         IF( mje_crs(2) - mjs_crs(2) == 1 ) THEN
2336            je_2 = mje_crs(2)
2337            DO jk = 1, jpk
2338               DO ji = nistr, niend, nn_factx
2339                  ii   = ( ji - mis_crs(2) ) * rfactx_r + 2
2340                  !   
2341                  p_surf_crs    (ii,2,jk) =  zsurf(ji,je_2  ,jk) + zsurf(ji+1,je_2  ,jk) + zsurf(ji+2,je_2  ,jk)
2342                  !
2343                  p_surf_crs_msk(ii,2,jk) =  zsurfmsk(ji,je_2,jk) + zsurfmsk(ji+1,je_2,jk) + zsurfmsk(ji+2,je_2,jk)
2344                  !
2345               ENDDO
2346            ENDDO
2347         ENDIF
2348      ELSE
2349         je_2 = mjs_crs(2)
2350         DO jk = 1, jpk
2351            DO ji = nistr, niend, nn_factx
2352               ii   = ( ji - mis_crs(2) ) * rfactx_r + 2
2353               ! 
2354               p_surf_crs    (ii,2,jk) = zsurf(ji,je_2+2,jk) + zsurf(ji+1,je_2+2,jk) + zsurf(ji+2,je_2+2,jk)
2355               p_surf_crs_msk(ii,2,jk) = zsurfmsk(ji,je_2+2,jk) + zsurfmsk(ji+1,je_2+2,jk) + zsurfmsk(ji+2,je_2+2,jk)
2356            ENDDO
2357         ENDDO
2358      ENDIF
2359
2360      DO jk = 1, jpk
2361         DO jj = njstr, njend, nn_facty
2362            DO ji = nistr, niend, nn_factx
2363               ii = ( ji - mis_crs(2) ) * rfactx_r + 2
2364               ij = ( jj - njstr ) * rfacty_r + 3
2365               !
2366               p_surf_crs    (ii,ij,jk) =  zsurf(ji,jj+2,jk) + zsurf(ji+1,jj+2,jk) + zsurf(ji+2,jj+2,jk)
2367               p_surf_crs_msk(ii,ij,jk) =  zsurfmsk(ji,jj+2,jk) + zsurfmsk(ji+1,jj+2,jk) + zsurfmsk(ji+2,jj+2,jk)
2368               !iji=117 ; ijj=210
2369               !iji=iji-nimpp_crs+1 ; ijj=ijj-njmpp_crs+1
2370               !IF( ii==iji .AND. ij==ijj .AND. jk==74 )THEN
2371               !WRITE(narea+5000,*)"SFC V =======> "
2372               !WRITE(narea+5000,*)ii,ij,jk
2373               !WRITE(narea+5000,*)ji,jj
2374               !WRITE(narea+5000,*)zsurfmsk(ji,jj+2,jk),zsurfmsk(ji+1,jj+2,jk),zsurfmsk(ji+2,jj+2,jk)
2375               !WRITE(narea+5000,*)p_surf_crs    (ii,ij,jk),p_surf_crs_msk(ii,ij,jk)
2376               !ENDIF
2377            ENDDO
2378         ENDDO
2379      ENDDO
2380
2381     END SELECT
2382      !DO jk=1,jpk
2383      !DO ji=1,jpi_crs
2384      !DO jj=1,jpj_crs
2385      !   IF( p_surf_crs_msk(ji,jj,jk) .NE. p_surf_crs_msk(ji,jj,jk) )WRITE(narea+200,*)"SFC 4 ",ji,jj,jk,p_surf_crs_msk(ji,jj,jk)  ; call flush(narea+200)
2386      !ENDDO
2387      !ENDDO
2388      !ENDDO
2389      CALL crs_lbc_lnk( p_surf_crs    , cd_type, 1.0, pval=1.0 )
2390      CALL crs_lbc_lnk( p_surf_crs_msk, cd_type, 1.0, pval=1.0 )
2391
2392      CALL wrk_dealloc( jpi, jpj, jpk, zsurfmsk, zsurf )
2393
2394   END SUBROUTINE crs_dom_sfc
2395   
2396   SUBROUTINE crs_dom_def
2397      !!----------------------------------------------------------------
2398      !!               *** SUBROUTINE crs_dom_def ***
2399      !! ** Purpose :  Three applications.
2400      !!               1) Define global domain indice of the croasening grid
2401      !!               2) Define local domain indice of the croasening grid
2402      !!               3) Define the processor domain indice for a croasening grid
2403      !!----------------------------------------------------------------
2404      !!
2405      !!  local variables
2406   
2407      INTEGER  :: ji,jj,jk,ijjgloT,ijis,ijie,ijjs,ijje,jn      ! dummy indices
2408      INTEGER  :: ierr                                ! allocation error status
2409      INTEGER :: ii,ij,iproc,iprocno,iprocso,iimppt_crs
2410 
2411 
2412     ! 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
2413      jpiglo_crs   = INT( (jpiglo - 2) / nn_factx ) + 2
2414  !    jpjglo_crs   = INT( (jpjglo - 2) / nn_facty ) + 2  ! the -2 removes j=1, j=jpj
2415  !    jpjglo_crs   = INT( (jpjglo - 2) / nn_facty ) + 3
2416      jpjglo_crs   = INT( (jpjglo - MOD(jpjglo, nn_facty)) / nn_facty ) + 3
2417      jpiglo_crsm1 = jpiglo_crs - 1
2418      jpjglo_crsm1 = jpjglo_crs - 1 
2419
2420      jpi_crs = ( jpiglo_crs   - 2 * jpreci + (jpni-1) ) / jpni + 2 * jpreci
2421      jpj_crs = ( jpjglo_crsm1 - 2 * jprecj + (jpnj-1) ) / jpnj + 2 * jprecj   
2422      !WRITE(narea+200,*)"jpj_crs noso = ", jpj_crs , noso       
2423      IF( noso < 0 ) jpj_crs = jpj_crs + 1    ! add a local band on southern processors   ! celle qui est faite de zeros
2424      !WRITE(narea+200,*)"jpj_crs = ", jpj_crs
2425       
2426      jpi_crsm1   = jpi_crs - 1
2427      jpj_crsm1   = jpj_crs - 1
2428      nperio_crs  = jperio
2429      npolj_crs   = npolj
2430     
2431      ierr = crs_dom_alloc()          ! allocate most coarse grid arrays
2432
2433      ! 2.a Define processor domain
2434      IF( .NOT. lk_mpp ) THEN
2435         nimpp_crs  = 1
2436         njmpp_crs  = 1
2437         nlci_crs   = jpi_crs
2438         nlcj_crs   = jpj_crs
2439         nldi_crs   = 1
2440         nldj_crs   = 1
2441         nlei_crs   = jpi_crs
2442         nlej_crs   = jpj_crs
2443      ELSE
2444         ! Initialisation of most local variables -
2445         nimpp_crs  = 1
2446         njmpp_crs  = 1
2447         nlci_crs   = jpi_crs
2448         nlcj_crs   = jpj_crs
2449         nldi_crs   = 1
2450         nldj_crs   = 1
2451         nlei_crs   = jpi_crs
2452         nlej_crs   = jpj_crs
2453
2454        !==============================================================================================
2455        ! mpp_ini2
2456        !==============================================================================================
2457
2458        !cbr
2459        DO jn = 1, jpnij
2460           !WRITE(narea+200,*)"=====> jn",jn  ; call flush(narea+200)
2461
2462           !proc jn
2463           DO ji = 1 , jpni
2464              DO jj = 1 ,jpnj
2465                 IF( nfipproc(ji,jj)  == jn-1 )THEN
2466                    ii=ji
2467                    ij=jj
2468                 ENDIF
2469              ENDDO 
2470           ENDDO 
2471           iproc =  ii + jpni * ( ij-1 ) - 1
2472           ! mppini : 
2473           !iprocso =  ii + jpni * ( ij-2 ) - 1
2474           ! mppini2:         
2475           IF( ij .GT. 1 )THEN ; iprocso =  nfipproc(ii,ij-1)
2476           ELSE                ; iprocso =  -1
2477           ENDIF
2478 
2479           !WRITE(narea+200,*)ii,ij  ; call flush(narea+200)
2480           !WRITE(narea+200,*)"iproc iprocso ",iproc,iprocso
2481           !WRITE(narea+200,*)"jpiglo jpjglo ",jpiglo,jpjglo
2482           !WRITE(narea+200,*)"ibonit(jn) ibonjt(jn) ",ibonit(jn),ibonjt(jn) ; call flush(narea+200)
2483           !WRITE(narea+200,*)"nimppt(jn) njmppt(jn) ",nimppt(jn),njmppt(jn) ; call flush(narea+200)
2484           !WRITE(narea+200,*)"loc jpj nldjt(jn),nlejt(jn),nlcjt(jn) ",jpj, nldjt(jn),nlejt(jn),nlcjt(jn) ; call flush(narea+200)
2485           !WRITE(narea+200,*)"glo jpj nldjt(jn),nlejt(jn),nlcjt(jn) ",jpj, nldjt(jn)+njmppt(jn)-1,nlejt(jn)+njmppt(jn)-1,nlcjt(jn) ; call flush(narea+200)
2486
2487           !dimension selon j
2488           !-------------------
2489           IF( ibonjt(jn) .NE. 1 )THEN !on a besoin de savoir si jn est au nord
2490              !iprocno=nfipproc(ii,ij+1)
2491                 !iprocno=iprocno+1
2492                 !WRITE(narea+200,*)"ii,ij+1 ",ii,ij+1; call flush(narea+200)
2493                 !WRITE(narea+200,*)"njmppt  jn njmpptno(jn) ",njmppt(jn),njmpptno(jn); call flush(narea+200)
2494                 !WRITE(narea+200,*)"jpjglo",jpjglo ; call flush(narea+200)
2495
2496                 !WRITE(narea+200,*)REAL( ( jpjglo - (njmppt  (jn) - 1) ) / nn_facty, wp ),REAL( ( jpjglo - (njmpptno(jn) - 1) ) / nn_facty, wp ); call flush(narea+200)
2497                 !WRITE(narea+200,*)AINT( REAL( ( jpjglo - (njmppt  (jn) - 1) ) / nn_facty, wp ) ),AINT( REAL( ( jpjglo - (njmpptno(jn) - 1) ) / nn_facty, wp ) ); call flush(narea+200)
2498
2499                 nlejt_crs(jn) = AINT( REAL( ( jpjglo - (njmppt  (jn) - 1) ) / nn_facty, wp ) ) &
2500                      &        - AINT( REAL( ( jpjglo - (njmpptno(jn) - 1) ) / nn_facty, wp ) )
2501           ELSE ! ibonjt=1 : au nord
2502              nlejt_crs(jn) = AINT( REAL(  nlejt(jn) / nn_facty, wp ) ) + 1
2503           ENDIF
2504           !==> nbondj = -1 au sud, 0 au milieu, 1 au nord, 2 si jpnj=1
2505           !WRITE(narea+200,*)"nlejt_crs(jn) ",nlejt_crs(jn) ; call flush(narea+200)
2506           !!!noso== nbre de proc sud du proc sur lequel on tourne !!!! ; dangeureux car on est ds une boucle sur jn
2507           IF( iprocso < 0 .AND. ibonjt(jn) == -1 ) nlejt_crs(jn) = nlejt_crs(jn) + 1
2508           SELECT CASE( ibonjt(jn) )
2509              CASE ( -1 )
2510                !WRITE(narea+200,*)"MOD( jpjglo - njmppt(jn), nn_facty)",MOD( jpjglo - njmppt(jn), nn_facty) ; call flush(narea+200)
2511                IF( MOD( jpjglo - njmppt(jn), nn_facty) > 0 )  nlejt_crs(jn) = nlejt_crs(jn) + 1  ! au cas où il reste des lignes en bas
2512                IF( nldjt(jn) == 1 )  nlejt_crs(jn) = nlejt_crs(jn) + 1
2513                nlcjt_crs(jn) = nlejt_crs(jn) + jprecj
2514                nldjt_crs(jn) = nldjt(jn)
2515                !???nlejt_crs(jn) = nlejt_crs(jn) + 1 ! 2 !cbr 
2516              CASE ( 0 )
2517
2518                nldjt_crs(jn) = nldjt(jn)
2519                IF( nldjt(jn) == 1 )  nlejt_crs(jn) = nlejt_crs(jn) + 1
2520                nlejt_crs(jn) = nlejt_crs(jn) + jprecj
2521                nlcjt_crs(jn) = nlejt_crs(jn) + jprecj
2522
2523              CASE ( 1, 2 )
2524   
2525                nlejt_crs(jn) = nlejt_crs(jn) + jprecj
2526                nlcjt_crs(jn) = nlejt_crs(jn)
2527                nldjt_crs(jn) = nldjt(jn)
2528              CASE DEFAULT
2529                 STOP
2530           END SELECT
2531           !WRITE(narea+200,*)"jpj_crs, nldjt_crs(jn),nlejt_crs(jn),nlcjt_crs(jn) " ; call flush(narea+200)
2532           !WRITE(narea+200,*) jpj_crs, nldjt_crs(jn),nlejt_crs(jn),nlcjt_crs(jn) ; call flush(narea+200)
2533           IF( nlcjt_crs(jn) > jpj_crs )THEN
2534              jpj_crs = jpj_crs + 1
2535              nlejt_crs(jn) = nlejt_crs(jn) + 1
2536           ENDIF
2537           !cbr pas bon !!!!
2538           !on augmente la taille des domaines alors que les tblx st deja alloués
2539           !du coup on alloue les tblx apres:
2540           IF(nldjt_crs(jn) == 1 ) THEN
2541              njmppt_crs(jn) = 1
2542           ELSE
2543              njmppt_crs(jn) = 2 + ANINT(REAL((njmppt(jn) + 1 - MOD( jpjglo , nn_facty )) / nn_facty, wp ) )
2544           ENDIF
2545           !WRITE(narea+200,*)"tutu loc ",jn,jpj_crs, nldjt_crs(jn),nlejt_crs(jn),nlcjt_crs(jn) ; call flush(narea+200)
2546           !WRITE(narea+200,*)"tutu glo ",jn,jpj_crs, nldjt_crs(jn)+njmppt_crs(jn)-1,nlejt_crs(jn)+njmppt_crs(jn)-1,nlcjt_crs(jn)+njmppt_crs(jn)-1 ; call flush(narea+200)
2547
2548
2549           !dimensions selon i
2550           !-------------------
2551           !IF( jn == 1 ) THEN
2552           !IF( ibonit(jn)==-1 )THEN !on a besoin de savoir si jn est un proc west
2553           IF( ii==1 )THEN !on a besoin de savoir si jn est un proc west
2554              nleit_crs(jn) = AINT( REAL( ( nimppt(jn  ) - 1 + nlcit(jn  ) )  / nn_factx, wp) )
2555           ELSE
2556              !WRITE(narea+200,*)"njmppt  jn njmpptea(jn) ",nimppt(jn),nimpptea(jn); call flush(narea+200)
2557              !WRITE(narea+200,*)"nlcit  (jn) nlcitea(jn) ) ",nlcit  (jn),nlcitea(jn); call flush(narea+200)
2558              nleit_crs(jn) = AINT( REAL( ( nimppt  (jn) - 1 + nlcit  (jn) )  / nn_factx, wp) ) &
2559                 &          - AINT( REAL( ( nimpptea(jn) - 1 + nlcitea(jn) )  / nn_factx, wp) )
2560           ENDIF
2561           !WRITE(narea+200,*)"nleji_crs(jn),noso ",nleit_crs(jn); call flush(narea+200)
2562
2563
2564           SELECT CASE( ibonit(jn) )
2565              CASE ( -1 )
2566                 nleit_crs(jn) = nleit_crs(jn) + jpreci
2567                 nlcit_crs(jn) = nleit_crs(jn) + jpreci
2568                 nldit_crs(jn) = nldit(jn)
2569
2570              CASE ( 0 )
2571                 nleit_crs(jn) = nleit_crs(jn) + jpreci
2572                 nlcit_crs(jn) = nleit_crs(jn) + jpreci
2573                 nldit_crs(jn) = nldit(jn)
2574
2575              CASE ( 1, 2 )
2576                 IF( MOD( jpiglo - nimppt(jn), nn_factx) > 0 )  nleit_crs(jn) = nleit_crs(jn) + 1
2577                 nleit_crs(jn) = nleit_crs(jn) + jpreci
2578                 nlcit_crs(jn) = nleit_crs(jn)
2579                 nldit_crs(jn) = nldit(jn)
2580
2581              CASE DEFAULT
2582                 STOP
2583           END SELECT
2584           !WRITE(narea+200,*)"jpi_crs, nldit_crs(jn),nleit_crs(jn),nlcit_crs(jn) ",jpi_crs, nldit_crs(jn),nleit_crs(jn),nlcit_crs(jn) ; call flush(narea+200)
2585           nimppt_crs(jn) = ANINT( REAL( (nimppt(jn) + 1 ) / nn_factx, wp ) ) + 1
2586
2587           !WRITE(narea+200,*)"tutu loc ",jn,jpi_crs, nldit_crs(jn),nleit_crs(jn),nlcit_crs(jn) ; call flush(narea+200)
2588           !WRITE(narea+200,*)"tutu glo ",jn,jpi_crs, nldit_crs(jn)+nimppt_crs(jn)-1,nleit_crs(jn)+nimppt_crs(jn)-1,nlcit_crs(jn)+nimppt_crs(jn)-1 ; call flush(narea+200)
2589
2590           nfiimpp_crs(ii,ij) = nimppt_crs(jn)
2591           !WRITE(narea+200,*)"tutu nimppt_crs(jn) ",ii,ij,nimppt_crs(jn) ; call flush(narea+200)
2592         
2593        ENDDO
2594
2595        DO ji = 1 , jpni
2596           DO jj = 1 ,jpnj
2597              jn=nfipproc(ji,jj)+1
2598              iimppt_crs = ANINT( REAL( (nfiimpp(ji,jj) + 1 ) / nn_factx, wp ) ) + 1
2599              nfiimpp_crs(ji,jj) = iimppt_crs
2600              IF( jn .GE. 1 )nimppt_crs(jn) = iimppt_crs
2601              !PRINT*," nfiimpp_crs(ji,jj) ",ji,jj,jn,nfiimpp(ji,jj),nfiimpp_crs(ji,jj)
2602           ENDDO
2603        ENDDO
2604
2605        nlej_crs  = nlejt_crs(nproc + 1)
2606        nlcj_crs  = nlcjt_crs(nproc + 1)
2607        nldj_crs  = nldjt_crs(nproc + 1)
2608        njmpp_crs = njmppt_crs(nproc + 1)
2609
2610        nlei_crs  = nleit_crs(nproc + 1)
2611        nlci_crs  = nlcit_crs(nproc + 1)
2612        nldi_crs  = nldit_crs(nproc + 1)
2613        nimpp_crs = nimppt_crs(nproc + 1)
2614
2615        !nogather=T
2616        nfsloop_crs = 1
2617        nfeloop_crs = nlci_crs
2618        DO jn = 2,jpni-1
2619           IF(nfipproc(jn,jpnj) .eq. (narea - 1)) THEN
2620              IF (nfipproc(jn - 1 ,jpnj) .eq. -1) THEN
2621                 nfsloop_crs = nldi_crs
2622              ENDIF
2623              IF (nfipproc(jn + 1,jpnj) .eq. -1) THEN
2624                 nfeloop_crs = nlei_crs
2625              ENDIF
2626           ENDIF
2627        END DO
2628
2629        !==============================================================================================
2630         !write(narea+200,*)"jpi_crs,nldi_crs,nlei_crs,nlci_crs,nimpp_crs,nldi_crs+nimpp_crs-1,nlei_crs+nimpp_crs-1" ; call flush(narea+200)
2631         !write(narea+200,*)jpi_crs,nldi_crs,nlei_crs,nlci_crs,nimpp_crs,nldi_crs+nimpp_crs-1,nlei_crs+nimpp_crs-1 ; call flush(narea+200)
2632         !write(narea+200,*)"jpj_crs,nldj_crs,nlej_crs,nlcj_crs,njmpp_crs,nldj_crs+njmpp_crs-1,nlej_crs+njmpp_crs-1" ; call flush(narea+200)
2633         !write(narea+200,*)jpj_crs,nldj_crs,nlej_crs,nlcj_crs,njmpp_crs,nldj_crs+njmpp_crs-1,nlej_crs+njmpp_crs-1 ; call flush(narea+200)
2634         !write(narea+200,*)"nfsloop_crs nfeloop_crs ",nfsloop_crs,nfeloop_crs ; call flush(narea+200)
2635
2636         ! No coarsening with zoom
2637         IF( jpizoom /= 1 .OR. jpjzoom /= 1)    STOP 
2638
2639         !cbr
2640         ierr = crs_dom_alloc1() 
2641
2642         DO ji = 1, jpi_crs
2643            mig_crs(ji) = ji + nimpp_crs - 1
2644            !WRITE(narea+200,*)"fifi ",ji,mig_crs(ji)  ; call flush(narea+200)
2645         ENDDO
2646         DO jj = 1, jpj_crs
2647            mjg_crs(jj) = jj + njmpp_crs - 1!
2648            !WRITE(narea+200,*)"fufu ",jj,mjg_crs(jj)  ; call flush(narea+200)
2649         ENDDO
2650       
2651         DO ji = 1, jpiglo_crs
2652            mi0_crs(ji) = MAX( 1, MIN( ji - nimpp_crs + 1 , jpi_crs + 1 ) )
2653            mi1_crs(ji) = MAX( 0, MIN( ji - nimpp_crs + 1 , jpi_crs     ) )
2654            !WRITE(narea+200,*)"mi ",ji,mi0_crs(ji),mi1_crs(ji)  ; call flush(narea+200)
2655         ENDDO
2656         
2657         DO jj = 1, jpjglo_crs
2658            mj0_crs(jj) = MAX( 1, MIN( jj - njmpp_crs + 1 , jpj_crs + 1 ) )
2659            mj1_crs(jj) = MAX( 0, MIN( jj - njmpp_crs + 1 , jpj_crs     ) )
2660            !WRITE(narea+200,*)"mj ",jj, mj0_crs(jj),mj1_crs(jj) ; call flush(narea+200)
2661         ENDDO
2662
2663      ENDIF
2664     
2665      !                         Save the parent grid information
2666      jpi_full    = jpi
2667      jpj_full    = jpj
2668      jpim1_full  = jpim1
2669      jpjm1_full  = jpjm1
2670      nperio_full = nperio
2671
2672      npolj_full  = npolj
2673      jpiglo_full = jpiglo
2674      jpjglo_full = jpjglo
2675
2676      nlcj_full   = nlcj
2677      nlci_full   = nlci
2678      nldi_full   = nldi
2679      nldj_full   = nldj
2680      nlei_full   = nlei
2681      nlej_full   = nlej
2682      nimpp_full  = nimpp     
2683      njmpp_full  = njmpp
2684     
2685      nlcit_full(:)  = nlcit(:)
2686      nldit_full(:)  = nldit(:)
2687      nleit_full(:)  = nleit(:)
2688      nimppt_full(:) = nimppt(:)
2689      nlcjt_full(:)  = nlcjt(:)
2690      nldjt_full(:)  = nldjt(:)
2691      nlejt_full(:)  = nlejt(:)
2692      njmppt_full(:) = njmppt(:)
2693     
2694      nfsloop_full = nfsloop
2695      nfeloop_full = nfeloop
2696
2697      nfiimpp_full(:,:) = nfiimpp(:,:) 
2698
2699
2700      CALL dom_grid_crs  !swich de grille
2701     
2702
2703      IF(lwp) THEN
2704         WRITE(numout,*)
2705         WRITE(numout,*) 'crs_init : coarse grid dimensions'
2706         WRITE(numout,*) '~~~~~~~   coarse domain global j-dimension           jpjglo = ', jpjglo
2707         WRITE(numout,*) '~~~~~~~   coarse domain global i-dimension           jpiglo = ', jpiglo
2708         WRITE(numout,*) '~~~~~~~   coarse domain local  i-dimension              jpi = ', jpi
2709         WRITE(numout,*) '~~~~~~~   coarse domain local  j-dimension              jpj = ', jpj
2710         WRITE(numout,*)
2711         WRITE(numout,*) ' nproc  = '     , nproc
2712         WRITE(numout,*) ' nlci   = '     , nlci
2713         WRITE(numout,*) ' nlcj   = '     , nlcj
2714         WRITE(numout,*) ' nldi   = '     , nldi
2715         WRITE(numout,*) ' nldj   = '     , nldj
2716         WRITE(numout,*) ' nlei   = '     , nlei
2717         WRITE(numout,*) ' nlej   = '     , nlej
2718         WRITE(numout,*) ' nlei_full='    , nlei_full
2719         WRITE(numout,*) ' nldi_full='    , nldi_full
2720         WRITE(numout,*) ' nimpp  = '     , nimpp
2721         WRITE(numout,*) ' njmpp  = '     , njmpp
2722         WRITE(numout,*) ' njmpp_full  = ', njmpp_full
2723         WRITE(numout,*)
2724      ENDIF
2725     
2726      CALL dom_grid_glo
2727     
2728      mxbinctr   = INT( nn_factx * 0.5 )
2729      mybinctr   = INT( nn_facty * 0.5 )
2730
2731      nrestx = MOD( nn_factx, 2 )   ! check if even- or odd- numbered reduction factor
2732      nresty = MOD( nn_facty, 2 )
2733
2734      IF ( nrestx == 0 ) THEN
2735         mxbinctr = mxbinctr - 1
2736      ENDIF
2737
2738      IF ( nresty == 0 ) THEN
2739         mybinctr = mybinctr - 1
2740         IF ( jperio == 3 .OR. jperio == 4 )  nperio_crs = jperio + 2
2741         IF ( jperio == 5 .OR. jperio == 6 )  nperio_crs = jperio - 2 
2742
2743         IF ( npolj == 3 ) npolj_crs = 5
2744         IF ( npolj == 5 ) npolj_crs = 3
2745      ENDIF     
2746     
2747      rfactxy = nn_factx * nn_facty
2748     
2749      ! 2.b. Set up bins for coarse grid, horizontal only.
2750      ierr = crs_dom_alloc2()
2751     
2752      mis2_crs(:) = 0      ;      mie2_crs(:) = 0
2753      mjs2_crs(:) = 0      ;      mje2_crs(:) = 0
2754
2755     
2756      SELECT CASE ( nn_binref )
2757
2758      CASE ( 0 ) 
2759
2760         SELECT CASE ( nperio )
2761     
2762 
2763        CASE ( 0, 1, 3, 4 )    !   3, 4 : T-Pivot at North Fold
2764       
2765            DO ji = 2, jpiglo_crsm1
2766               ijie = ( ji * nn_factx ) - nn_factx   !cc
2767               ijis = ijie - nn_factx + 1
2768               mis2_crs(ji) = ijis
2769               mie2_crs(ji) = ijie
2770            ENDDO
2771            IF ( jpiglo - 1 - mie2_crs(jpiglo_crsm1) <= nn_factx ) mie2_crs(jpiglo_crsm1) = jpiglo - 2 
2772
2773            ! Handle first the northernmost bin
2774            IF ( nn_facty == 2 ) THEN   ;    ijjgloT = jpjglo - 1 
2775            ELSE                        ;    ijjgloT = jpjglo
2776            ENDIF
2777
2778            DO jj = 2, jpjglo_crs
2779                ijje = ijjgloT - nn_facty * ( jj - 3 )
2780                ijjs = ijje - nn_facty + 1                   
2781                mjs2_crs(jpjglo_crs-jj+2) = ijjs
2782                mje2_crs(jpjglo_crs-jj+2) = ijje
2783               !WRITE(narea+200,*)"jpjglo_crs-jj+2,ijje,ijjs ",jpjglo_crs-jj+2,ijjs,ijje ; call flush(narea+200)
2784            ENDDO
2785
2786         CASE ( 2 ) 
2787            WRITE(numout,*)  'crs_init, jperio=2 not supported' 
2788       
2789         CASE ( 5, 6 )    ! F-pivot at North Fold
2790
2791            DO ji = 2, jpiglo_crsm1
2792               ijie = ( ji * nn_factx ) - nn_factx 
2793               ijis = ijie - nn_factx + 1
2794               mis2_crs(ji) = ijis
2795               mie2_crs(ji) = ijie
2796            ENDDO
2797            IF ( jpiglo - 1 - mie2_crs(jpiglo_crsm1) <= nn_factx ) mie_crs(jpiglo_crsm1)  = jpiglo - 2 
2798
2799            ! Treat the northernmost bin separately.
2800            jj = 2
2801            ijje = jpj - nn_facty * ( jj - 2 )
2802            IF ( nn_facty == 3 ) THEN   ;  ijjs = ijje - 1 
2803            ELSE                        ;  ijjs = ijje - nn_facty + 1
2804            ENDIF
2805            mjs2_crs(jpj_crs-jj+1) = ijjs
2806            mje2_crs(jpj_crs-jj+1) = ijje
2807
2808            ! Now bin the rest, any remainder at the south is lumped in the southern bin
2809            DO jj = 3, jpjglo_crsm1
2810                ijje = jpjglo - nn_facty * ( jj - 2 )
2811                ijjs = ijje - nn_facty + 1                 
2812                IF ( ijjs <= nn_facty )  ijjs = 2
2813                WRITE(narea+200,*)"fufu",jj,ijjs,ijje ; call flush(narea+200)
2814                mjs2_crs(jpj_crs-jj+1)   = ijjs
2815                mje2_crs(jpj_crs-jj+1)   = ijje
2816            ENDDO
2817
2818         CASE DEFAULT
2819            WRITE(numout,*) 'crs_init. Only jperio = 0, 1, 3, 4, 5, 6 supported' 
2820 
2821         END SELECT
2822
2823      CASE (1 )
2824         WRITE(numout,*) 'crs_init.  Equator-centered bins option not yet available' 
2825
2826      END SELECT
2827
2828     ! Pad the boundaries, do not know if it is necessary
2829      mis2_crs(2) = 1             ;  mis2_crs(jpiglo_crs) = mie2_crs(jpiglo_crs - 1) + 1   
2830      mie2_crs(2) = nn_factx      ;  mie2_crs(jpiglo_crs) = jpiglo                         
2831      !
2832      mjs2_crs(1) = 1
2833      mje2_crs(1) = 1
2834      !
2835      mje2_crs(2) = mjs2_crs(3)-1 ;  mje2_crs(jpjglo_crs) = jpjglo
2836      mjs2_crs(2) = 1             ;  mjs2_crs(jpjglo_crs) = mje2_crs(jpjglo_crs) - nn_facty + 1 
2837 
2838      IF( .NOT. lk_mpp ) THEN     
2839        mis_crs(:) = mis2_crs(:) 
2840        mie_crs(:) = mie2_crs(:)
2841        mjs_crs(:) = mjs2_crs(:) 
2842        mje_crs(:) = mje2_crs(:) 
2843      ELSE
2844       !write(narea+200,*)"njmpp ",njmpp
2845        DO jj = 1, nlej_crs
2846           !write(narea+200,*)jj,"mjs2_crs mje2_crs ",mjg_crs(jj),mjs2_crs(mjg_crs(jj)),mje2_crs(mjg_crs(jj)) ; call flush(narea+200)
2847           mjs_crs(jj) = mjs2_crs(mjg_crs(jj)) - njmpp + 1
2848           mje_crs(jj) = mje2_crs(mjg_crs(jj)) - njmpp + 1
2849           !write(narea+200,*)"mjs_crs mje_crs ",mjs_crs(jj),mje_crs(jj) ; call flush(narea+200)
2850        ENDDO
2851        !write(narea+200,*)"nimpp ",nimpp
2852        DO ji = 1, nlei_crs
2853           !write(narea+200,*)ji,"mis2_crs mie2_crs ",mig_crs(ji),mis2_crs(mig_crs(ji)),mie2_crs(mig_crs(ji)) ; call flush(narea+200)
2854           mis_crs(ji) = mis2_crs(mig_crs(ji)) - nimpp + 1
2855           mie_crs(ji) = mie2_crs(mig_crs(ji)) - nimpp + 1
2856           !write(narea+200,*)"mis_crs mie_crs ",mis_crs(jj),mie_crs(jj) ; call flush(narea+200)
2857        ENDDO
2858      ENDIF
2859      !
2860      !IF( nlcj_crs -1 .GT. nlej_crs )WRITE(narea+200,*)"tutututu",nlcj_crs,nlej_crs ; call flush(narea+200)
2861      nistr = mis_crs(2)  ;   niend = mis_crs(nlci_crs - 1)
2862      njstr = mjs_crs(3)  ;   njend = mjs_crs(nlcj_crs - 1)
2863      !
2864   END SUBROUTINE crs_dom_def
2865   
2866   SUBROUTINE crs_dom_bat
2867      !!----------------------------------------------------------------
2868      !!               *** SUBROUTINE crs_dom_bat ***
2869      !! ** Purpose :  coarsenig bathy
2870      !!----------------------------------------------------------------
2871      !!
2872      !!  local variables
2873      INTEGER  :: ji,jj,jk      ! dummy indices
2874      REAL(wp), DIMENSION(:,:)  , POINTER :: zmbk
2875      !!----------------------------------------------------------------
2876   
2877      CALL wrk_alloc( jpi_crs, jpj_crs, zmbk )
2878   
2879      mbathy_crs(:,:) = jpkm1
2880      mbkt_crs(:,:) = 1
2881      mbku_crs(:,:) = 1
2882      mbkv_crs(:,:) = 1
2883
2884
2885      DO jj = 1, jpj_crs
2886         DO ji = 1, jpi_crs
2887            jk = 0
2888            DO WHILE( tmask_crs(ji,jj,jk+1) > 0.)
2889               jk = jk + 1
2890            ENDDO
2891            mbathy_crs(ji,jj) = float( jk )
2892         ENDDO
2893      ENDDO
2894     
2895      zmbk(:,:) = 0.0
2896      zmbk(:,:) = REAL( mbathy_crs(:,:), wp ) ;   CALL crs_lbc_lnk(zmbk,'T',1.0)   ;   mbathy_crs(:,:) = INT( zmbk(:,:) )
2897
2898
2899      !
2900      IF(lwp) WRITE(numout,*)
2901      IF(lwp) WRITE(numout,*) '    crsini : mbkt is ocean bottom k-index of T-, U-, V- and W-levels '
2902      IF(lwp) WRITE(numout,*) '    ~~~~~~~~~~~~~'
2903      !
2904      mbkt_crs(:,:) = MAX( mbathy_crs(:,:) , 1 )    ! bottom k-index of T-level (=1 over land)
2905      !                                     ! bottom k-index of W-level = mbkt+1
2906
2907      DO jj = 1, jpj_crsm1                      ! bottom k-index of u- (v-) level
2908         DO ji = 1, jpi_crsm1
2909            mbku_crs(ji,jj) = MIN(  mbkt_crs(ji+1,jj  ) , mbkt_crs(ji,jj)  )
2910            mbkv_crs(ji,jj) = MIN(  mbkt_crs(ji  ,jj+1) , mbkt_crs(ji,jj)  )
2911         END DO
2912      END DO
2913
2914      ! convert into REAL to use lbc_lnk ; impose a min value of 1 as a zero can be set in lbclnk
2915      zmbk(:,:) = 1.e0;   
2916      zmbk(:,:) = REAL( mbku_crs(:,:), wp )   ;   CALL crs_lbc_lnk(zmbk,'U',1.0) ; mbku_crs  (:,:) = MAX( INT( zmbk(:,:) ), 1 ) 
2917      zmbk(:,:) = REAL( mbkv_crs(:,:), wp )   ;   CALL crs_lbc_lnk(zmbk,'V',1.0) ; mbkv_crs  (:,:) = MAX( INT( zmbk(:,:) ), 1 ) 
2918      !
2919      CALL wrk_dealloc( jpi_crs, jpj_crs, zmbk )
2920      !
2921   END SUBROUTINE crs_dom_bat
2922
2923
2924END MODULE crsdom
Note: See TracBrowser for help on using the repository browser.