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 @ 5105

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

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