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

Last change on this file since 7312 was 7312, checked in by cbricaud, 8 years ago

CRS branch: adaptation for regional configuration
  • Property svn:keywords set to Id
File size: 67.2 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:
8
9   !!  References:  Aumont, O., J.C. Orr, D. Jamous, P. Monfray
10   !!               O. Marti and G. Madec, 1998. A degradation
11   !!               approach to accelerate simulations to steady-state
12   !!               in a 3-D tracer transport model of the global ocean.
13   !!               Climate Dynamics, 14:101-116.
14   !!  History:
15   !!       Original.   May 2012.  (J. Simeon, C. Calone, G. Madec, C. Ethe)
16   !!===================================================================
17
18   USE dom_oce        ! ocean space and time domain and to get jperio
19   USE wrk_nemo       ! work arrays
20   USE crs            ! domain for coarse grid
21   USE in_out_manager 
22   USE par_kind
23   USE crslbclnk
24   USE lib_mpp
25   USE ieee_arithmetic   
26
27   IMPLICIT NONE
28
29   PRIVATE
30
31   PUBLIC crs_dom_ope
32   PUBLIC crs_dom_e3, crs_dom_sfc, crs_dom_msk, crs_dom_hgr, crs_dom_coordinates
33   PUBLIC crs_dom_facvol, crs_dom_def, crs_dom_bat
34
35   INTERFACE crs_dom_ope
36      MODULE PROCEDURE crs_dom_ope_3d, crs_dom_ope_2d
37   END INTERFACE
38
39   REAL(wp),PUBLIC :: r_inf = 1e+7 !cbr 1e+36
40
41   !! Substitutions
42#  include "domzgr_substitute.h90"
43   
44CONTAINS
45
46
47   SUBROUTINE crs_dom_msk
48   !!===================================================================
49   !
50   !
51   !
52   !!===================================================================
53   INTEGER  ::  ji, jj, jk                   ! dummy loop indices
54   INTEGER  ::  ijis,ijie,ijjs,ijje
55   REAL(wp) ::  zmask
56   !!-------------------------------------------------------------------
57     
58   ! Initialize
59   tmask_crs(:,:,:) = 0.0
60   vmask_crs(:,:,:) = 0.0
61   umask_crs(:,:,:) = 0.0
62   fmask_crs(:,:,:) = 0.0
63   !
64   DO jk = 1, jpkm1
65      DO ji = nldi_crs, nlei_crs
66
67         ijis = mis_crs(ji)
68         ijie = mie_crs(ji)
69
70         DO jj = nldj_crs, nlej_crs
71
72            ijjs = mjs_crs(jj)
73            ijje = mje_crs(jj)
74
75            zmask = 0.0
76            zmask = SUM( tmask(ijis:ijie,ijjs:ijje,jk) )
77            IF ( zmask > 0.0 ) tmask_crs(ji,jj,jk) = 1.0
78
79            zmask = 0.0
80            zmask = SUM( vmask(ijis:ijie,ijje     ,jk) )
81            IF ( zmask > 0.0 ) vmask_crs(ji,jj,jk) = 1.0
82
83            zmask = 0.0
84            zmask = SUM( umask(ijie     ,ijjs:ijje,jk) )
85            IF ( zmask > 0.0 ) umask_crs(ji,jj,jk) = 1.0
86
87            fmask_crs(ji,jj,jk) = fmask(ijie,ijje,jk)
88
89         ENDDO
90      ENDDO
91   ENDDO
92
93   CALL crs_lbc_lnk( tmask_crs, 'T', 1.0 )
94   CALL crs_lbc_lnk( vmask_crs, 'V', 1.0 )
95   CALL crs_lbc_lnk( umask_crs, 'U', 1.0 )
96   CALL crs_lbc_lnk( fmask_crs, 'F', 1.0 )
97   !
98   END SUBROUTINE crs_dom_msk
99
100   SUBROUTINE crs_dom_coordinates( p_gphi, p_glam, cd_type, p_gphi_crs, p_glam_crs )
101      !!----------------------------------------------------------------
102      !!               *** SUBROUTINE crs_coordinates ***
103      !! ** Purpose :  Determine the coordinates for the coarse grid
104      !!
105      !! ** Method  :  From the parent grid subset, search for the central
106      !!               point.  For an odd-numbered reduction factor,
107      !!               the coordinate will be that of the central T-cell.
108      !!               For an even-numbered reduction factor, of a non-square
109      !!               coarse grid box, the coordinate will be that of
110      !!               the east or north face or more likely.  For a square
111      !!               coarse grid box, the coordinate will be that of
112      !!               the central f-corner.
113      !!
114      !! ** Input   :  p_gphi = parent grid gphi[t|u|v|f]
115      !!               p_glam = parent grid glam[t|u|v|f]
116      !!               cd_type  = grid type (T,U,V,F)
117      !! ** Output  :  p_gphi_crs = coarse grid gphi[t|u|v|f]
118      !!               p_glam_crs = coarse grid glam[t|u|v|f]
119      !!             
120      !! History. 1 Jun.
121      !!----------------------------------------------------------------
122      !! Arguments
123      REAL(wp), DIMENSION(jpi,jpj)        , INTENT(in)  :: p_gphi  ! Parent grid latitude
124      REAL(wp), DIMENSION(jpi,jpj)        , INTENT(in)  :: p_glam  ! Parent grid longitude
125      CHARACTER(len=1),                     INTENT(in)  :: cd_type   ! grid type (T,U,V,F)
126      REAL(wp), DIMENSION(jpi_crs,jpj_crs), INTENT(out) :: p_gphi_crs  ! Coarse grid latitude
127      REAL(wp), DIMENSION(jpi_crs,jpj_crs), INTENT(out) :: p_glam_crs  ! Coarse grid longitude
128
129      !! Local variables
130      INTEGER :: ji, jj, jk                   ! dummy loop indices
131      INTEGER :: iji, ijj
132      INTEGER  :: ir,jr
133      !!----------------------------------------------------------------
134      p_gphi_crs(:,:)=0._wp
135      p_glam_crs(:,:)=0._wp
136
137 
138      SELECT CASE ( cd_type )
139         CASE ( 'T' )
140            DO jj =  nldj_crs, nlej_crs
141               ijj = mjs_crs(jj) + 1
142               DO ji = nldi_crs, nlei_crs
143                  iji = mis_crs(ji) + 1
144                  IF( ijj .GT. jpj )WRITE(narea+8000-1,*)"BUG ijj ",jj,mjs_crs(jj);CALL FLUSH(narea+8000-1)
145                  p_gphi_crs(ji,jj) = p_gphi(iji,ijj)
146                  p_glam_crs(ji,jj) = p_glam(iji,ijj)
147               ENDDO
148            ENDDO
149         CASE ( 'U' )
150            DO jj =  nldj_crs, nlej_crs
151               ijj = mjs_crs(jj) + 1
152               DO ji = nldi_crs, nlei_crs
153                  iji = mie_crs(ji)
154                  p_gphi_crs(ji,jj) = p_gphi(iji,ijj)
155                  p_glam_crs(ji,jj) = p_glam(iji,ijj)
156 
157               ENDDO
158            ENDDO
159         CASE ( 'V' )
160            DO jj =  nldj_crs, nlej_crs
161               ijj = mje_crs(jj)
162               DO ji = nldi_crs, nlei_crs
163                  iji = mis_crs(ji) + 1
164                  p_gphi_crs(ji,jj) = p_gphi(iji,ijj)
165                  p_glam_crs(ji,jj) = p_glam(iji,ijj)
166               ENDDO
167            ENDDO
168         CASE ( 'F' )
169            DO jj =  nldj_crs, nlej_crs
170               ijj = mje_crs(jj)
171               DO ji = nldi_crs, nlei_crs
172                  iji = mie_crs(ji)
173                  p_gphi_crs(ji,jj) = p_gphi(iji,ijj)
174                  p_glam_crs(ji,jj) = p_glam(iji,ijj)
175               ENDDO
176            ENDDO
177      END SELECT
178
179      ! Retroactively add back the boundary halo cells.
180      CALL crs_lbc_lnk( p_gphi_crs, cd_type, 1.0 )
181      CALL crs_lbc_lnk( p_glam_crs, cd_type, 1.0 )
182      !
183   END SUBROUTINE crs_dom_coordinates
184
185  SUBROUTINE crs_dom_hgr( p_e1, p_e2, cd_type, p_e1_crs, p_e2_crs )
186      !!----------------------------------------------------------------
187      !!               *** SUBROUTINE crs_dom_hgr ***
188      !!
189      !! ** Purpose :  Get coarse grid horizontal scale factors and unmasked fraction
190      !!
191      !! ** Method  :  For grid types T,U,V,Fthe 2D scale factors of
192      !!               the coarse grid are the sum of the east or north faces of the
193      !!               parent grid subset comprising the coarse grid box.     
194      !!               - e1,e2 Scale factors
195      !!                 Valid arguments:
196      !! ** Inputs  : p_e1, p_e2  = parent grid e1 or e2 (t,u,v,f)
197      !!              cd_type     = grid type (T,U,V,F) for scale factors; for velocities (U or V)
198      !! ** Outputs : p_e1_crs, p_e2_crs  = parent grid e1 or e2 (t,u,v,f)
199      !!
200      !! History.     4 Jun.  Write for WGT and scale factors only
201      !!----------------------------------------------------------------
202      !!
203      !!  Arguments
204      REAL(wp), DIMENSION(jpi,jpj)        , INTENT(in)  :: p_e1     ! Parent grid U,V scale factors (e1)
205      REAL(wp), DIMENSION(jpi,jpj)        , INTENT(in)  :: p_e2     ! Parent grid U,V scale factors (e2)
206      CHARACTER(len=1)                    , INTENT(in)  :: cd_type  ! grid type U,V
207
208      REAL(wp), DIMENSION(jpi_crs,jpj_crs), INTENT(out) :: p_e1_crs ! Coarse grid box 2D quantity
209      REAL(wp), DIMENSION(jpi_crs,jpj_crs), INTENT(out) :: p_e2_crs ! Coarse grid box 2D quantity
210
211      !! Local variables
212      INTEGER :: ji, jj, jk     ! dummy loop indices
213      INTEGER :: ijis,ijie,ijjs,ijje
214      INTEGER :: ji1, jj1
215 
216      !!---------------------------------------------------------------- 
217      ! Initialize     
218
219         DO ji = nldi_crs, nlei_crs
220
221            ijis = mis_crs(ji)
222            ijie = mie_crs(ji)
223
224            DO jj = nldj_crs, nlej_crs
225
226               ijjs = mjs_crs(jj)
227               ijje = mje_crs(jj)
228
229               ! Only for a factro 3 coarsening
230               SELECT CASE ( cd_type )
231                   CASE ( 'T' )
232                      p_e1_crs(ji,jj) = REAL(nn_factx,wp)*p_e1(ijis+1,ijjs+1)
233                      p_e2_crs(ji,jj) = REAL(nn_facty,wp)*p_e2(ijis+1,ijjs+1)
234                   CASE ( 'U' )
235                      p_e1_crs(ji,jj) = REAL(nn_factx,wp)*p_e1(ijis+1,ijjs+1       ) 
236                      p_e2_crs(ji,jj) = REAL(nn_facty,wp)*p_e2(ijie  ,ijjs+1       ) 
237
238                   CASE ( 'V' )
239                      p_e1_crs(ji,jj) = REAL(nn_factx,wp)*p_e1(ijis+1,ijje       ) 
240                      p_e2_crs(ji,jj) = REAL(nn_facty,wp)*p_e2(ijis+1,ijjs+1     ) 
241                   CASE ( 'F' )
242                      p_e1_crs(ji,jj) = REAL(nn_factx,wp)*p_e1(ijis+1,ijje       ) 
243                      p_e2_crs(ji,jj) = REAL(nn_facty,wp)*p_e2(ijie  ,ijjs+1     ) 
244               END SELECT
245            ENDDO
246         ENDDO
247
248
249      CALL crs_lbc_lnk( p_e1_crs, cd_type, 1.0 )
250      CALL crs_lbc_lnk( p_e2_crs, cd_type, 1.0 )
251
252   END SUBROUTINE crs_dom_hgr
253
254
255   SUBROUTINE crs_dom_facvol( p_mask, cd_type, p_e1, p_e2, p_e3, p_fld1_crs, p_fld2_crs )
256      !!----------------------------------------------------------------
257      !!               *** SUBROUTINE crsfun_wgt ***
258      !! ** Purpose :  Three applications.
259      !!               1) SUM. Get coarse grid horizontal scale factors and unmasked fraction
260      !!               2) VOL. Get coarse grid box volumes
261      !!               3) WGT. Weighting multiplier for volume-weighted and/or
262      !!                       area-weighted averages.
263      !!                       Weights (i.e. the denominator) calculated here
264      !!                       to avoid IF-tests and division.
265      !! ** Method  :  1) SUM.  For grid types T,U,V,F (and W) the 2D scale factors of
266      !!               the coarse grid are the sum of the east or north faces of the
267      !!               parent grid subset comprising the coarse grid box. 
268      !!               The fractions of masked:total surface (3D) on the east,
269      !!               north and top faces is, optionally, also output.
270      !!               - Top face area sum
271      !!                 Valid arguments: cd_type, cd_op='W', p_pmask, p_e1, p_e2
272      !!               - Top face ocean surface fraction
273      !!                 Valid arguments: cd_type, cd_op='W', p_pmask, p_e1, p_e2       
274      !!               - e1,e2 Scale factors
275      !!                 Valid arguments:
276      !!               2) VOL.  For grid types W and T, the coarse grid box
277      !!               volumes are output. Also optionally, the fraction of 
278      !!               masked:total volume of the parent grid subset is output (i.e. facvol).
279      !!               3) WGT. Based on the grid type, the denominator is pre-determined here to 
280      !!               perform area- or volume- weighted averages,
281      !!               to avoid IF-tests and divisions.
282      !! ** Inputs  : p_e1, p_e2  = parent grid e1 or e2 (t,u,v,f)
283      !!              p_pmask     = parent grid mask (T,U,V,F)
284      !!              cd_type     = grid type (T,U,V,F) for scale factors; for velocities (U or V)
285      !!              cd_op       = applied operation (SUM, VOL, WGT)
286      !!              p_fse3      = (Optional) parent grid vertical level thickness (fse3u or fse3v)
287      !! ** Outputs : p_cfield2d_1 = (Optional) 2D field on coarse grid
288      !!              p_cfield2d_2 = (Optional) 2D field on coarse grid
289      !!              p_cfield3d_1 = (Optional) 3D field on coarse grid
290      !!              p_cfield3d_2 = (Optional) 3D field on coarse grid
291      !!
292      !! History.     4 Jun.  Write for WGT and scale factors only
293      !!----------------------------------------------------------------
294      !!
295      !!  Arguments
296      CHARACTER(len=1),                         INTENT(in)  :: cd_type  ! grid type U,V
297      REAL(wp), DIMENSION(jpi,jpj,jpk)        , INTENT(in)  :: p_mask  ! Parent grid U,V mask
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      REAL(wp), DIMENSION(jpi,jpj,jpk)        , INTENT(in)  :: p_e3     ! Parent grid vertical level thickness (fse3u, fse3v)
301
302      REAL(wp), DIMENSION(jpi_crs,jpj_crs,jpk), INTENT(out) :: p_fld1_crs ! Coarse grid box 3D quantity
303      REAL(wp), DIMENSION(jpi_crs,jpj_crs,jpk), INTENT(out) :: p_fld2_crs ! Coarse grid box 3D quantity
304
305      !! Local variables
306      REAL(wp)                                :: zdAm
307      INTEGER                                 :: ji, jj, jk
308      INTEGER :: ijis,ijie,ijjs,ijje
309
310      REAL(wp), DIMENSION(:,:,:), POINTER     :: zvol, zmask     
311      !!---------------------------------------------------------------- 
312   
313      CALL wrk_alloc( jpi, jpj, jpk, zvol, zmask )
314
315      p_fld1_crs(:,:,:) = 0.0
316      p_fld2_crs(:,:,:) = 0.0
317
318      DO jk = 1, jpk
319         zvol (:,:,jk) = p_e1(:,:) * p_e2(:,:) * p_e3(:,:,jk) 
320         zmask(:,:,jk) = p_mask(:,:,jk) 
321      ENDDO
322
323      DO jk = 1, jpk
324         DO ji = nldi_crs, nlei_crs
325
326            ijis = mis_crs(ji)
327            ijie = mie_crs(ji)
328
329            DO jj = nldj_crs, nlej_crs
330
331               ijjs = mjs_crs(jj)
332               ijje = mje_crs(jj)
333
334               p_fld1_crs(ji,jj,jk) =  SUM( zvol(ijis:ijie,ijjs:ijje,jk) )
335               zdAm                 =  SUM( zvol(ijis:ijie,ijjs:ijje,jk) * zmask(ijis:ijie,ijjs:ijje,jk) )
336               p_fld2_crs(ji,jj,jk) = zdAm / p_fld1_crs(ji,jj,jk) 
337            ENDDO
338         ENDDO
339      ENDDO
340      !                                             !  Retroactively add back the boundary halo cells.
341      CALL crs_lbc_lnk( p_fld1_crs, cd_type, 1.0 ) 
342      CALL crs_lbc_lnk( p_fld2_crs, cd_type, 1.0 ) 
343      !
344      CALL wrk_dealloc( jpi, jpj, jpk, zvol, zmask )
345      !
346   END SUBROUTINE crs_dom_facvol
347
348
349   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 )
350      !!----------------------------------------------------------------
351      !!               *** SUBROUTINE crsfun_UV ***
352      !! ** Purpose :  Average, area-weighted, of U or V on the east and north faces
353      !!
354      !! ** Method  :  The U and V velocities (3D) are determined as the area-weighted averages
355      !!               on the east and north faces, respectively,
356      !!               of the parent grid subset comprising the coarse grid box.
357      !!               In the case of the V and F grid, the last jrow minus 1 is spurious.
358      !! ** Inputs  : p_e1_e2     = parent grid e1 or e2 (t,u,v,f)
359      !!              cd_type     = grid type (T,U,V,F) for scale factors; for velocities (U or V)
360      !!              psgn        = sign change over north fold (See lbclnk.F90)
361      !!              p_pmask     = parent grid mask (T,U,V,F) for scale factors;
362      !!                                       for velocities (U or V)
363      !!              p_fse3      = parent grid vertical level thickness (fse3u or fse3v)
364      !!              p_pfield    = U or V on the parent grid
365      !!              p_surf_crs  = (Optional) Coarse grid weight for averaging
366      !! ** Outputs : p_cfield3d = 3D field on coarse grid
367      !!
368      !! History.  29 May.  completed draft.
369      !!            4 Jun.  Revision for WGT
370      !!            5 Jun.  Streamline for area-weighted average only ; separate scale factor and weights.
371      !!----------------------------------------------------------------
372      !!
373      !!  Arguments
374      REAL(wp), DIMENSION(jpi,jpj,jpk),         INTENT(in)        :: p_fld   ! T, U, V or W on parent grid
375      CHARACTER(len=*),                         INTENT(in)           :: cd_op    ! Operation SUM, MAX or MIN
376      CHARACTER(len=1),                         INTENT(in)           :: cd_type    ! grid type U,V
377      REAL(wp), DIMENSION(jpi,jpj,jpk),         INTENT(in)           :: p_mask    ! Parent grid T,U,V mask
378      REAL(wp), DIMENSION(jpi,jpj),             INTENT(in), OPTIONAL :: p_e12    ! Parent grid T,U,V scale factors (e1 or e2)
379      REAL(wp), DIMENSION(jpi,jpj,jpk),         INTENT(in), OPTIONAL :: p_e3     ! Parent grid vertical level thickness (fse3u, fse3v)
380      REAL(wp), DIMENSION(jpi_crs,jpj_crs,jpk), INTENT(in), OPTIONAL :: p_surf_crs ! Coarse grid area-weighting denominator   
381      REAL(wp), DIMENSION(jpi_crs,jpj_crs,jpk), INTENT(in), OPTIONAL :: p_mask_crs    ! Coarse grid T,U,V maska
382      REAL(wp),                                 INTENT(in)           :: psgn    ! sign
383
384      REAL(wp), DIMENSION(jpi_crs,jpj_crs,jpk), INTENT(out)          :: p_fld_crs ! Coarse grid box 3D quantity
385
386      !! Local variables
387      INTEGER  :: ji, jj, jk 
388      INTEGER  :: ijis, ijie, ijjs, ijje
389      INTEGER  :: ini, inj
390      REAL(wp) :: zflcrs, zsfcrs   
391      REAL(wp), DIMENSION(:,:,:), POINTER :: zsurf, zsurfmsk, zmask,ztabtmp
392      INTEGER  :: ir,jr
393      REAL(wp), DIMENSION(nn_factx,nn_facty):: ztmp
394      REAL(wp), DIMENSION(nn_factx*nn_facty):: ztmp1
395      REAL(wp), DIMENSION(:), ALLOCATABLE   :: ztmp2
396      INTEGER , DIMENSION(1)  :: zdim1
397      REAL(wp) :: zmin,zmax
398      !!---------------------------------------------------------------- 
399   
400      p_fld_crs(:,:,:) = 0.0
401
402      SELECT CASE ( cd_op )
403 
404         CASE ( 'VOL' )
405     
406            CALL wrk_alloc( jpi, jpj, jpk, zsurf, zsurfmsk )
407         
408            SELECT CASE ( cd_type )
409           
410               CASE( 'T', 'W' )
411                  DO jk = 1, jpk
412                     zsurf   (:,:,jk) =  p_e12(:,:) * p_e3(:,:,jk) *  p_mask(:,:,jk) 
413                     zsurfmsk(:,:,jk) =  zsurf(:,:,jk) 
414                  ENDDO
415                  !
416                  DO jk = 1, jpk         
417                     DO jj  = nldj_crs,nlej_crs
418                        ijjs = mjs_crs(jj)
419                        ijje = mje_crs(jj)
420                        DO ji = nldi_crs, nlei_crs
421
422                           ijis = mis_crs(ji)
423                           ijie = mie_crs(ji)
424
425                           zflcrs = SUM( p_fld(ijis:ijie,ijjs:ijje,jk) * zsurfmsk(ijis:ijie,ijjs:ijje,jk) )
426                           zsfcrs = SUM(                                 zsurfmsk(ijis:ijie,ijjs:ijje,jk) )
427
428                           p_fld_crs(ji,jj,jk) = zflcrs
429                           IF( zsfcrs /= 0.0 )  p_fld_crs(ji,jj,jk) = zflcrs / zsfcrs
430                        ENDDO     
431                     ENDDO
432                  ENDDO 
433                  !
434               CASE DEFAULT
435                    STOP
436            END SELECT
437
438            CALL wrk_dealloc( jpi, jpj, jpk, zsurf, zsurfmsk )
439
440         CASE ( 'LOGVOL' )
441
442            CALL wrk_alloc( jpi, jpj, jpk, zsurf, zsurfmsk, ztabtmp )
443
444            ztabtmp(:,:,:)=0._wp
445            WHERE(p_fld* p_mask .NE. 0._wp ) ztabtmp =  LOG10(p_fld * p_mask)*p_mask
446            ztabtmp = ztabtmp * p_mask
447
448            SELECT CASE ( cd_type )
449
450               CASE( 'T', 'W' )
451
452                  DO jk = 1, jpk
453                     zsurf   (:,:,jk) =  p_e12(:,:) * p_e3(:,:,jk) *  p_mask(:,:,jk)
454                     zsurfmsk(:,:,jk) =  zsurf(:,:,jk)
455                  ENDDO
456                  !
457                  DO jk = 1, jpk
458                     DO jj  = nldj_crs,nlej_crs
459                        ijjs = mjs_crs(jj)
460                        ijje = mje_crs(jj)
461                        DO ji = nldi_crs, nlei_crs
462                           ijis = mis_crs(ji)
463                           ijie = mie_crs(ji)
464                           zflcrs = SUM( ztabtmp(ijis:ijie,ijjs:ijje,jk) * zsurfmsk(ijis:ijie,ijjs:ijje,jk) )
465                           zsfcrs = SUM(                                   zsurfmsk(ijis:ijie,ijjs:ijje,jk) )
466                           p_fld_crs(ji,jj,jk) = zflcrs
467                           IF( zsfcrs /= 0.0 )  p_fld_crs(ji,jj,jk) = zflcrs / zsfcrs
468                           p_fld_crs(ji,jj,jk) = 10 ** ( p_fld_crs(ji,jj,jk) *  p_mask_crs(ji,jj,jk) ) * p_mask_crs(ji,jj,jk)
469                        ENDDO
470                     ENDDO
471                  ENDDO
472               CASE DEFAULT
473                    STOP
474            END SELECT
475
476            CALL wrk_dealloc( jpi, jpj, jpk, zsurf, zsurfmsk ,ztabtmp )
477
478         CASE ( 'MED' )
479
480            CALL wrk_alloc( jpi, jpj, jpk, zsurf, zsurfmsk )
481
482            SELECT CASE ( cd_type )
483
484               CASE( 'T', 'W' )
485                  DO jk = 1, jpk
486                     zsurf   (:,:,jk) =  p_e12(:,:) * p_e3(:,:,jk) *  p_mask(:,:,jk)
487                     zsurfmsk(:,:,jk) =  zsurf(:,:,jk)
488                  ENDDO
489                  !
490                  DO jk = 1, jpk
491
492                     DO jj  = nldj_crs,nlej_crs
493
494                        ijjs = mjs_crs(jj)
495                        ijje = mje_crs(jj)
496                        inj  = ijje-ijjs+1
497
498                        DO ji = nldi_crs, nlei_crs
499                           ijis = mis_crs(ji)
500                           ijie = mie_crs(ji)
501                           ini  = ijie-ijis+1
502
503                           ztmp(1:ini,1:inj)= p_fld(ijis:ijie,ijjs:ijje,jk)
504                           zdim1(1) = nn_factx*nn_facty
505                           ztmp1(:) = RESHAPE( ztmp(:,:) , zdim1 )
506                           CALL PIKSRT(nn_factx*nn_facty,ztmp1)
507
508                           ir=0
509                           jr=1
510                           DO WHILE( jr .LE. nn_factx*nn_facty )
511                              IF( ztmp1(jr) == 0. ) THEN
512                                 ir=jr
513                                 jr=jr+1
514                              ELSE
515                                 EXIT
516                              ENDIF
517                           ENDDO
518                           IF( ir .LE. nn_factx*nn_facty-1 )THEN
519                              ALLOCATE( ztmp2(nn_factx*nn_facty-ir) )
520                              ztmp2(1:nn_factx*nn_facty-ir) = ztmp1(1+ir:nn_factx*nn_facty)
521                              jr=INT( 0.5 * REAL(nn_factx*nn_facty-ir,wp) )+1
522                              p_fld_crs(ji,jj,jk) = ztmp2(jr)
523                              DEALLOCATE( ztmp2 )
524                           ELSE
525                              p_fld_crs(ji,jj,jk) = 0._wp
526                           ENDIF
527
528                        ENDDO
529                     ENDDO
530                  ENDDO
531               CASE DEFAULT
532                    STOP
533            END SELECT
534
535           CALL wrk_dealloc( jpi, jpj, jpk, zsurf, zsurfmsk )
536 
537         CASE ( 'SUM' )
538         
539            CALL wrk_alloc( jpi, jpj, jpk, zsurfmsk )
540
541            IF( PRESENT( p_e3 ) ) THEN
542               DO jk = 1, jpk
543                  zsurfmsk(:,:,jk) =  p_e12(:,:) * p_e3(:,:,jk) * p_mask(:,:,jk) 
544               ENDDO
545            ELSE
546               DO jk = 1, jpk
547                  zsurfmsk(:,:,jk) =  p_e12(:,:) * p_mask(:,:,jk) 
548               ENDDO
549            ENDIF
550
551            SELECT CASE ( cd_type )
552           
553               CASE( 'T', 'W' )
554       
555                  DO jk = 1, jpk
556                     DO jj  = nldj_crs,nlej_crs
557                        ijjs = mjs_crs(jj)
558                        ijje = mje_crs(jj)
559                        DO ji = nldi_crs, nlei_crs
560                           ijis = mis_crs(ji)
561                           ijie = mie_crs(ji)
562
563                           p_fld_crs(ji,jj,jk) = SUM( p_fld(ijis:ijie,ijjs:ijje,jk) * zsurfmsk(ijis:ijie,ijjs:ijje,jk) )
564                        ENDDO
565                     ENDDO
566                  ENDDO
567
568               CASE( 'V' )
569
570
571                  DO jk = 1, jpk
572                     DO jj  = nldj_crs,nlej_crs
573                        ijjs = mjs_crs(jj)
574                        ijje = mje_crs(jj)
575                        DO ji = nldi_crs, nlei_crs
576                           ijis = mis_crs(ji)
577                           ijie = mie_crs(ji)
578
579                           p_fld_crs(ji,jj,jk) = SUM( p_fld(ijis:ijie,ijje,jk) * zsurfmsk(ijis:ijie,ijje,jk) )
580                        ENDDO
581                     ENDDO
582                  ENDDO
583
584               CASE( 'U' )
585
586                  DO jk = 1, jpk
587                     DO jj  = nldj_crs,nlej_crs
588                        ijjs = mjs_crs(jj)
589                        ijje = mje_crs(jj)
590                        DO ji = nldi_crs, nlei_crs
591                           ijis = mis_crs(ji)
592                           ijie = mie_crs(ji)
593
594                           p_fld_crs(ji,jj,jk) = SUM( p_fld(ijie,ijjs:ijje,jk) * zsurfmsk(ijie,ijjs:ijje,jk) )
595                        ENDDO
596                     ENDDO
597                  ENDDO
598
599              END SELECT
600
601              IF( PRESENT( p_surf_crs ) ) THEN
602                 WHERE ( p_surf_crs /= 0.0 ) p_fld_crs(:,:,:) = p_fld_crs(:,:,:) / p_surf_crs(:,:,:)
603              ENDIF
604
605              CALL wrk_dealloc( jpi, jpj, jpk, zsurfmsk )
606
607         CASE ( 'MAX' )    !  search the max of unmasked grid cells
608
609            CALL wrk_alloc( jpi, jpj, jpk, zmask )
610
611            DO jk = 1, jpk
612               zmask(:,:,jk) = p_mask(:,:,jk) 
613            ENDDO
614
615            SELECT CASE ( cd_type )
616           
617               CASE( 'T', 'W' )
618       
619                  DO jk = 1, jpk
620                     DO jj  = nldj_crs,nlej_crs
621                        ijjs = mjs_crs(jj)
622                        ijje = mje_crs(jj)
623                        DO ji = nldi_crs, nlei_crs
624                           ijis = mis_crs(ji)
625                           ijie = mie_crs(ji)
626                           p_fld_crs(ji,jj,jk) = MAXVAL( p_fld(ijis:ijie,ijjs:ijje,jk) * zmask(ijis:ijie,ijjs:ijje,jk) - &
627                                                       & ( ( 1._wp - zmask(ijis:ijie,ijjs:ijje,jk))* r_inf )                )
628                        ENDDO
629                     ENDDO
630                  ENDDO
631 
632               CASE( 'V' )
633                  CALL ctl_stop('MAX operator and V case not available')
634           
635               CASE( 'U' )
636                  CALL ctl_stop('MAX operator and U case not available')
637
638            END SELECT
639
640            CALL wrk_dealloc( jpi, jpj, jpk, zmask )
641
642         CASE ( 'MIN' )      !   Search the min of unmasked grid cells
643
644            CALL wrk_alloc( jpi, jpj, jpk, zmask )
645            DO jk = 1, jpk
646               zmask(:,:,jk) = p_mask(:,:,jk)
647            ENDDO
648
649            SELECT CASE ( cd_type )
650
651               CASE( 'T', 'W' )
652
653                  DO jk = 1, jpk
654                     DO jj  = nldj_crs,nlej_crs
655                        ijjs = mjs_crs(jj)
656                        ijje = mje_crs(jj)
657                        DO ji = nldi_crs, nlei_crs
658                           ijis = mis_crs(ji)
659                           ijie = mie_crs(ji)
660
661                           p_fld_crs(ji,jj,jk) = MINVAL( p_fld(ijis:ijie,ijjs:ijje,jk) * zmask(ijis:ijie,ijjs:ijje,jk) + &
662                                                       & ( 1._wp - zmask(ijis:ijie,ijjs:ijje,jk)* r_inf )                )
663                        ENDDO
664                     ENDDO
665                  ENDDO
666
667           
668               CASE( 'V' )
669                  CALL ctl_stop('MIN operator and V case not available')
670           
671               CASE( 'U' )
672                  CALL ctl_stop('MIN operator and U case not available')
673         
674            END SELECT
675            !
676            CALL wrk_dealloc( jpi, jpj, jpk, zmask )
677            !
678         END SELECT
679         !
680         CALL crs_lbc_lnk( p_fld_crs, cd_type, psgn )
681         !
682    END SUBROUTINE crs_dom_ope_3d
683
684    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 )
685      !!----------------------------------------------------------------
686      !!               *** SUBROUTINE crsfun_UV ***
687      !! ** Purpose :  Average, area-weighted, of U or V on the east and north faces
688      !!
689      !! ** Method  :  The U and V velocities (3D) are determined as the area-weighted averages
690      !!               on the east and north faces, respectively,
691      !!               of the parent grid subset comprising the coarse grid box.
692      !!               In the case of the V and F grid, the last jrow minus 1 is spurious.
693      !! ** Inputs  : p_e1_e2     = parent grid e1 or e2 (t,u,v,f)
694      !!              cd_type     = grid type (T,U,V,F) for scale factors; for velocities (U or V)
695      !!              psgn        = sign change over north fold (See lbclnk.F90)
696      !!              p_pmask     = parent grid mask (T,U,V,F) for scale factors;
697      !!                                       for velocities (U or V)
698      !!              p_fse3      = parent grid vertical level thickness (fse3u or fse3v)
699      !!              p_pfield    = U or V on the parent grid
700      !!              p_surf_crs  = (Optional) Coarse grid weight for averaging
701      !! ** Outputs : p_cfield3d = 3D field on coarse grid
702      !!
703      !! History.  29 May.  completed draft.
704      !!            4 Jun.  Revision for WGT
705      !!            5 Jun.  Streamline for area-weighted average only ; separate scale factor and weights.
706      !!----------------------------------------------------------------
707      !!
708      !!  Arguments
709      REAL(wp), DIMENSION(jpi,jpj),             INTENT(in)           :: p_fld   ! T, U, V or W on parent grid
710      CHARACTER(len=3),                         INTENT(in)           :: cd_op    ! Operation SUM, MAX or MIN
711      CHARACTER(len=1),                         INTENT(in)           :: cd_type    ! grid type U,V
712      REAL(wp), DIMENSION(jpi,jpj,jpk),         INTENT(in)           :: p_mask    ! Parent grid T,U,V mask
713      REAL(wp), DIMENSION(jpi,jpj),             INTENT(in), OPTIONAL :: p_e12    ! Parent grid T,U,V scale factors (e1 or e2)
714      REAL(wp), DIMENSION(jpi,jpj,jpk),         INTENT(in), OPTIONAL :: p_e3     ! Parent grid vertical level thickness (fse3u, fse3v)
715      REAL(wp), DIMENSION(jpi_crs,jpj_crs)    , INTENT(in), OPTIONAL :: p_surf_crs ! Coarse grid area-weighting denominator   
716      REAL(wp), DIMENSION(jpi_crs,jpj_crs,jpk), INTENT(in), OPTIONAL :: p_mask_crs    ! Coarse grid T,U,V mask
717      REAL(wp),                                 INTENT(in)           :: psgn   
718
719      REAL(wp), DIMENSION(jpi_crs,jpj_crs)    , INTENT(out)          :: p_fld_crs ! Coarse grid box 3D quantity
720
721      !! Local variables
722      INTEGER  :: ji, jj, jk                 ! dummy loop indices
723      INTEGER ::  ijis, ijie, ijjs, ijje
724      REAL(wp) :: zflcrs, zsfcrs   
725      REAL(wp), DIMENSION(:,:), POINTER :: zsurfmsk   
726
727      !!---------------------------------------------------------------- 
728 
729      p_fld_crs(:,:) = 0.0
730
731      SELECT CASE ( cd_op )
732     
733        CASE ( 'VOL' )
734
735            CALL wrk_alloc( jpi, jpj, zsurfmsk )
736            zsurfmsk(:,:) =  p_e12(:,:) * p_e3(:,:,1) * p_mask(:,:,1)
737
738            DO jj  = nldj_crs,nlej_crs
739               ijjs = mjs_crs(jj)
740               ijje = mje_crs(jj)
741               DO ji = nldi_crs, nlei_crs
742                  ijis = mis_crs(ji)
743                  ijie = mie_crs(ji)
744
745                  zflcrs = SUM( p_fld(ijis:ijie,ijjs:ijje) * zsurfmsk(ijis:ijie,ijjs:ijje) )
746                  zsfcrs = SUM(                              zsurfmsk(ijis:ijie,ijjs:ijje) )
747
748                  p_fld_crs(ji,jj) = zflcrs
749                  IF( zsfcrs /= 0.0 )  p_fld_crs(ji,jj) = zflcrs / zsfcrs
750               ENDDO
751            ENDDO
752            CALL wrk_dealloc( jpi, jpj, zsurfmsk )
753            !
754
755         CASE ( 'SUM' )
756         
757            CALL wrk_alloc( jpi, jpj, zsurfmsk )
758            IF( PRESENT( p_e3 ) ) THEN
759               zsurfmsk(:,:) =  p_e12(:,:) * p_e3(:,:,1) * p_mask(:,:,1)
760            ELSE
761               zsurfmsk(:,:) =  p_e12(:,:) * p_mask(:,:,1)
762            ENDIF
763
764            SELECT CASE ( cd_type )
765
766               CASE( 'T', 'W' )
767
768                  DO jj  = nldj_crs,nlej_crs
769                     ijjs = mjs_crs(jj)
770                     ijje = mje_crs(jj)
771                     DO ji = nldi_crs, nlei_crs
772                        ijis = mis_crs(ji)
773                        ijie = mie_crs(ji)
774                        p_fld_crs(ji,jj) = SUM( p_fld(ijis:ijie,ijjs:ijje) * zsurfmsk(ijis:ijie,ijjs:ijje) )
775                     ENDDO
776                  ENDDO
777           
778               CASE( 'V' )
779
780                  DO jj  = nldj_crs,nlej_crs
781                     ijjs = mjs_crs(jj)
782                     ijje = mje_crs(jj)
783                     DO ji = nldi_crs, nlei_crs
784                        ijis = mis_crs(ji)
785                        ijie = mie_crs(ji)
786                        p_fld_crs(ji,jj) = SUM( p_fld(ijis:ijie,ijje) * zsurfmsk(ijis:ijie,ijje) )
787                     ENDDO
788                  ENDDO
789
790               CASE( 'U' )
791
792                  DO jj  = nldj_crs,nlej_crs
793                     ijjs = mjs_crs(jj)
794                     ijje = mje_crs(jj)
795                     DO ji = nldi_crs, nlei_crs
796                        ijis = mis_crs(ji)
797                        ijie = mie_crs(ji)
798                        p_fld_crs(ji,jj) = SUM( p_fld(ijie,ijjs:ijje) * zsurfmsk(ijie,ijjs:ijje) )
799                     ENDDO
800                  ENDDO
801
802              END SELECT
803
804              IF( PRESENT( p_surf_crs ) ) THEN
805                 WHERE ( p_surf_crs /= 0.0 ) p_fld_crs(:,:) = p_fld_crs(:,:) / p_surf_crs(:,:)
806              ENDIF
807
808              CALL wrk_dealloc( jpi, jpj, zsurfmsk )
809
810         CASE ( 'MAX' )
811
812            SELECT CASE ( cd_type )
813           
814               CASE( 'T', 'W' )
815 
816                  DO jj  = nldj_crs,nlej_crs
817                     ijjs = mjs_crs(jj)
818                     ijje = mje_crs(jj)
819                     DO ji = nldi_crs, nlei_crs
820                        ijis = mis_crs(ji)
821                        ijie = mie_crs(ji)
822                        p_fld_crs(ji,jj) = MAXVAL( p_fld(ijis:ijie,ijjs:ijje) * p_mask(ijis:ijie,ijjs:ijje,1) - &
823                                                 & ( 1._wp - p_mask(ijis:ijie,ijjs:ijje,1) )                    )
824                     ENDDO
825                  ENDDO
826           
827               CASE( 'V' )
828                  CALL ctl_stop('MAX operator and V case not available')
829           
830               CASE( 'U' )
831                  CALL ctl_stop('MAX operator and U case not available')
832
833              END SELECT
834
835         CASE ( 'MIN' )      !   Search the min of unmasked grid cells
836
837           SELECT CASE ( cd_type )
838
839              CASE( 'T', 'W' )
840
841                  DO jj  = nldj_crs,nlej_crs
842                     ijjs = mjs_crs(jj)
843                     ijje = mje_crs(jj)
844                     DO ji = nldi_crs, nlei_crs
845                        ijis = mis_crs(ji)
846                        ijie = mie_crs(ji)
847                        p_fld_crs(ji,jj) = MINVAL( p_fld(ijis:ijie,ijjs:ijje) * p_mask(ijis:ijie,ijjs:ijje,1) + &
848                                                 & ( 1._wp - p_mask(ijis:ijie,ijjs:ijje,1) )                    )
849                     ENDDO
850                  ENDDO
851           
852               CASE( 'V' )
853                  CALL ctl_stop('MIN operator and V case not available')
854           
855               CASE( 'U' )
856                  CALL ctl_stop('MIN operator and U case not available')
857
858              END SELECT
859             !
860         END SELECT
861         !
862         CALL crs_lbc_lnk( p_fld_crs, cd_type, psgn )
863         !
864   END SUBROUTINE crs_dom_ope_2d
865
866   SUBROUTINE crs_dom_e3( p_e1, p_e2, p_e3, p_sfc_2d_crs,  p_sfc_3d_crs, cd_type, p_mask, p_e3_crs, p_e3_max_crs)
867      !!---------------------------------------------------------------- 
868      !!
869      !!
870      !!
871      !!
872      !!----------------------------------------------------------------
873      !!  Arguments
874      CHARACTER(len=1),                         INTENT(in)          :: cd_type           ! grid type T, W ( U, V, F)
875      REAL(wp), DIMENSION(jpi,jpj,jpk),         INTENT(in)          :: p_mask            ! Parent grid T mask
876      REAL(wp), DIMENSION(jpi,jpj)    ,         INTENT(in)          :: p_e1, p_e2        ! 2D tracer T or W on parent grid
877      REAL(wp), DIMENSION(jpi,jpj,jpk),         INTENT(in)          :: p_e3              ! 3D tracer T or W on parent grid
878      REAL(wp), DIMENSION(jpi_crs,jpj_crs)    , INTENT(in),OPTIONAL :: p_sfc_2d_crs      ! Coarse grid box east or north face quantity
879      REAL(wp), DIMENSION(jpi_crs,jpj_crs,jpk), INTENT(in),OPTIONAL :: p_sfc_3d_crs      ! Coarse grid box east or north face quantity
880      REAL(wp), DIMENSION(jpi_crs,jpj_crs,jpk), INTENT(inout)       :: p_e3_crs          ! Coarse grid box east or north face quantity
881      REAL(wp), DIMENSION(jpi_crs,jpj_crs,jpk), INTENT(inout)       :: p_e3_max_crs      ! Coarse grid box east or north face quantity
882
883      !! Local variables
884      INTEGER ::  ji, jj, jk                   ! dummy loop indices
885      INTEGER ::  ijis, ijie, ijjs, ijje 
886      REAL(wp) :: ze3crs 
887
888      !!---------------------------------------------------------------- 
889      p_e3_crs    (:,:,:) = 0._wp
890      p_e3_max_crs(:,:,:) = 0._wp
891   
892
893      SELECT CASE ( cd_type )
894
895         CASE ('T')
896
897            DO jk = 1, jpk
898               DO ji = nldi_crs, nlei_crs
899
900                  ijis = mis_crs(ji)
901                  ijie = mie_crs(ji)
902
903                  DO jj = nldj_crs, nlej_crs
904
905                     ijjs = mjs_crs(jj)
906                     ijje = mje_crs(jj)
907
908                     p_e3_max_crs(ji,jj,jk) = MAXVAL( p_e3(ijis:ijie,ijjs:ijje,jk) * p_mask(ijis:ijie,ijjs:ijje,jk) )
909
910                     ze3crs = SUM( p_e1(ijis:ijie,ijjs:ijje) * p_e2(ijis:ijie,ijjs:ijje) * p_e3(ijis:ijie,ijjs:ijje,jk) * p_mask(ijis:ijie,ijjs:ijje,jk) )
911                     IF( p_sfc_3d_crs(ji,jj,jk) .NE. 0._wp )p_e3_crs(ji,jj,jk) = ze3crs / p_sfc_3d_crs(ji,jj,jk)
912
913                  ENDDO
914               ENDDO
915            ENDDO
916
917         CASE ('U')
918
919            DO jk = 1, jpk
920               DO ji = nldi_crs, nlei_crs
921
922                  ijis = mis_crs(ji)
923                  ijie = mie_crs(ji)
924
925                  DO jj = nldj_crs, nlej_crs
926
927                     ijjs = mjs_crs(jj)
928                     ijje = mje_crs(jj)
929
930                     p_e3_max_crs(ji,jj,jk) = MAXVAL( p_e3(ijie,ijjs:ijje,jk) * p_mask(ijie,ijjs:ijje,jk) )
931
932                     ze3crs = SUM( p_e2(ijie,ijjs:ijje) * p_e3(ijie,ijjs:ijje,jk) * p_mask(ijie,ijjs:ijje,jk) )
933                     IF( p_sfc_2d_crs(ji,jj) .NE. 0._wp )p_e3_crs(ji,jj,jk) = ze3crs / p_sfc_2d_crs(ji,jj)
934                  ENDDO
935               ENDDO
936            ENDDO
937
938         CASE ('V')
939
940            DO jk = 1, jpk
941               DO ji = nldi_crs, nlei_crs
942
943                  ijis = mis_crs(ji)
944                  ijie = mie_crs(ji)
945
946                  DO jj = nldj_crs, nlej_crs
947
948                     ijjs = mjs_crs(jj)
949                     ijje = mje_crs(jj)
950
951                     p_e3_max_crs(ji,jj,jk) = MAXVAL( p_e3(ijis:ijie,ijje,jk) * p_mask(ijis:ijie,ijje,jk) )
952
953                     ze3crs = SUM( p_e1(ijis:ijie,ijje) * p_e3(ijis:ijie,ijje,jk) * p_mask(ijis:ijie,ijje,jk) )
954                     IF( p_sfc_2d_crs(ji,jj) .NE. 0._wp )p_e3_crs(ji,jj,jk) = ze3crs / p_sfc_2d_crs(ji,jj)
955
956                  ENDDO
957               ENDDO
958            ENDDO
959
960         CASE ('W')
961
962            DO jk = 1, jpk
963               DO ji = nldi_crs, nlei_crs
964
965                  ijis = mis_crs(ji)
966                  ijie = mie_crs(ji)
967
968                  DO jj = nldj_crs, nlej_crs
969
970                     ijjs = mjs_crs(jj)
971                     ijje = mje_crs(jj)
972
973                     p_e3_max_crs(ji,jj,jk) = MAXVAL( p_e3(ijis:ijie,ijjs:ijje,jk) * p_mask(ijis:ijie,ijjs:ijje,jk) )
974
975                     ze3crs = SUM( p_e1(ijis:ijie,ijjs:ijje) * p_e2(ijis:ijie,ijjs:ijje) * p_e3(ijis:ijie,ijjs:ijje,jk) * p_mask(ijis:ijie,ijjs:ijje,jk) )
976                     IF( p_sfc_3d_crs(ji,jj,jk) .NE. 0._wp )p_e3_crs(ji,jj,jk) = ze3crs / p_sfc_3d_crs(ji,jj,jk)
977
978                  ENDDO
979               ENDDO
980            ENDDO
981
982      END SELECT
983
984      CALL crs_lbc_lnk( p_e3_max_crs, cd_type, 1.0, pval=1.0 )
985      CALL crs_lbc_lnk( p_e3_crs    , cd_type, 1.0, pval=1.0 )
986
987   END SUBROUTINE crs_dom_e3
988
989   SUBROUTINE crs_dom_sfc(p_mask, cd_type, p_surf_crs, p_surf_crs_msk,  p_e1, p_e2, p_e3 )
990      !!=========================================================================================
991      !!
992      !!
993      !!=========================================================================================
994      !!  Arguments
995      CHARACTER(len=1),                         INTENT(in)           :: cd_type      ! grid type T, W ( U, V, F)
996      REAL(wp), DIMENSION(jpi,jpj,jpk)        , INTENT(in)           :: p_mask       ! Parent grid T mask
997      REAL(wp), DIMENSION(jpi,jpj)            , INTENT(in), OPTIONAL :: p_e1, p_e2         ! 3D tracer T or W on parent grid
998      REAL(wp), DIMENSION(jpi,jpj,jpk)        , INTENT(in), OPTIONAL :: p_e3         ! 3D tracer T or W on parent grid
999      REAL(wp), DIMENSION(jpi_crs,jpj_crs,jpk), INTENT(out)          :: p_surf_crs ! Coarse grid box east or north face quantity
1000      REAL(wp), DIMENSION(jpi_crs,jpj_crs,jpk), INTENT(out)          :: p_surf_crs_msk ! Coarse grid box east or north face quantity
1001
1002      !! Local variables
1003      INTEGER  :: ji, jj, jk                   ! dummy loop indices
1004      INTEGER  :: ijis,ijie,ijjs,ijje
1005      REAL(wp), DIMENSION(:,:,:), POINTER :: zsurf, zsurfmsk   
1006      !!---------------------------------------------------------------- 
1007      ! Initialize
1008      p_surf_crs(:,:,:)=0._wp
1009      p_surf_crs_msk(:,:,:)=0._wp
1010
1011      CALL wrk_alloc( jpi, jpj, jpk, zsurf, zsurfmsk )
1012      !
1013      SELECT CASE ( cd_type )
1014     
1015         CASE ('W')   
1016            DO jk = 1, jpk
1017               zsurf(:,:,jk) = p_e1(:,:) * p_e2(:,:) 
1018            ENDDO
1019
1020         CASE ('V')     
1021            DO jk = 1, jpk
1022               zsurf(:,:,jk) = p_e1(:,:) * p_e3(:,:,jk) 
1023            ENDDO
1024 
1025         CASE ('U')     
1026            DO jk = 1, jpk
1027               zsurf(:,:,jk) = p_e2(:,:) * p_e3(:,:,jk) 
1028            ENDDO
1029
1030         CASE DEFAULT
1031            DO jk = 1, jpk
1032               zsurf(:,:,jk) = p_e1(:,:) * p_e2(:,:) 
1033            ENDDO
1034      END SELECT
1035
1036      DO jk = 1, jpk
1037         zsurfmsk(:,:,jk) = zsurf(:,:,jk) * p_mask(:,:,jk)
1038      ENDDO
1039
1040      SELECT CASE ( cd_type )
1041
1042         CASE ('W')
1043
1044            DO jk = 1, jpk
1045               DO jj = nldj_crs,nlej_crs
1046                  ijjs=mjs_crs(jj)
1047                  ijje=mje_crs(jj)
1048                  DO ji = nldi_crs,nlei_crs
1049                     ijis=mis_crs(ji)
1050                     ijie=mie_crs(ji)
1051                     p_surf_crs    (ji,jj,jk) =  SUM(zsurf   (ijis:ijie,ijjs:ijje,jk) )
1052                     p_surf_crs_msk(ji,jj,jk) =  SUM(zsurfmsk(ijis:ijie,ijjs:ijje,jk) )
1053                  ENDDO     
1054               ENDDO
1055            ENDDO   
1056
1057         CASE ('U')
1058
1059            DO jk = 1, jpk
1060               DO jj = nldj_crs,nlej_crs
1061                  ijjs=mjs_crs(jj)
1062                  ijje=mje_crs(jj)
1063                  DO ji = nldi_crs,nlei_crs
1064                     ijis=mis_crs(ji)
1065                     ijie=mie_crs(ji)
1066                     p_surf_crs    (ji,jj,jk) =  SUM(zsurf   (ijie,ijjs:ijje,jk) )
1067                     p_surf_crs_msk(ji,jj,jk) =  SUM(zsurfmsk(ijie,ijjs:ijje,jk) )
1068                  ENDDO
1069               ENDDO
1070            ENDDO
1071
1072         CASE ('V')
1073
1074            DO jk = 1, jpk
1075               DO jj = nldj_crs,nlej_crs
1076                  ijjs=mjs_crs(jj)
1077                  ijje=mje_crs(jj)
1078                  DO ji = nldi_crs,nlei_crs
1079                     ijis=mis_crs(ji)
1080                     ijie=mie_crs(ji)
1081                     p_surf_crs    (ji,jj,jk) =  SUM(zsurf   (ijis:ijie,ijje,jk) )
1082                     p_surf_crs_msk(ji,jj,jk) =  SUM(zsurfmsk(ijis:ijie,ijje,jk) )
1083                  ENDDO
1084               ENDDO
1085            ENDDO
1086
1087      END SELECT
1088
1089      CALL crs_lbc_lnk( p_surf_crs    , cd_type, 1.0 )
1090      CALL crs_lbc_lnk( p_surf_crs_msk, cd_type, 1.0 )
1091
1092      CALL wrk_dealloc( jpi, jpj, jpk, zsurf, zsurfmsk )
1093
1094   END SUBROUTINE crs_dom_sfc
1095   
1096   SUBROUTINE crs_dom_def
1097      !!----------------------------------------------------------------
1098      !!               *** SUBROUTINE crs_dom_def ***
1099      !! ** Purpose :  Three applications.
1100      !!               1) Define global domain indice of the croasening grid
1101      !!               2) Define local domain indice of the croasening grid
1102      !!               3) Define the processor domain indice for a croasening grid
1103      !!----------------------------------------------------------------
1104      INTEGER :: ji,jj,jk,ijjgloT,ijis,ijie,ijjs,ijje,jn      ! dummy indices
1105      INTEGER :: ierr                                ! allocation error status
1106      INTEGER :: iproci,iprocj,iproc,iprocno,iprocso,iimppt_crs
1107      INTEGER :: ii_start,ii_end,ij_start,ij_end
1108      !!----------------------------------------------------------------
1109 
1110 
1111      !==============================================================================================
1112      ! Define global and local domain sizes
1113      !==============================================================================================
1114      jpiglo_crs   = INT( (jpiglo - 2) / nn_factx ) + 2
1115      jpjglo_crs   = INT( (jpjglo - MOD(jpjglo, nn_facty)) / nn_facty ) + 2
1116      jpiglo_crsm1 = jpiglo_crs - 1
1117      jpjglo_crsm1 = jpjglo_crs - 1 
1118
1119      jpi_crs = ( jpiglo_crs   - 2 * jpreci + (jpni-1) ) / jpni + 2 * jpreci
1120      jpj_crs = ( jpjglo_crsm1 - 2 * jprecj + (jpnj-1) ) / jpnj + 2 * jprecj
1121       
1122      jpi_crsm1   = jpi_crs - 1
1123      jpj_crsm1   = jpj_crs - 1
1124
1125      npolj_crs   = npolj
1126     
1127      ierr = crs_dom_alloc()          ! allocate most coarse grid arrays
1128
1129      !==============================================================================================
1130      ! Define processor domain indices
1131      !==============================================================================================
1132      IF( .NOT. lk_mpp ) THEN
1133
1134         nimpp_crs  = 1
1135         njmpp_crs  = 1
1136         nlci_crs   = jpi_crs
1137         nlcj_crs   = jpj_crs
1138         nldi_crs   = 1
1139         nldj_crs   = 1
1140         nlei_crs   = jpi_crs
1141         nlej_crs   = jpj_crs
1142
1143      ELSE
1144
1145         nimpp_crs  = 1
1146         njmpp_crs  = 1
1147         nlci_crs   = jpi_crs
1148         nlcj_crs   = jpj_crs
1149         nldi_crs   = 1
1150         nldj_crs   = 1
1151         nlei_crs   = jpi_crs
1152         nlej_crs   = jpj_crs
1153
1154         !==============================================================================================
1155         ! mpp_ini2
1156         !==============================================================================================
1157
1158         !order of local domain in i and j directions
1159         DO ji = 1 , jpni
1160            DO jj = 1 ,jpnj
1161               IF( nfipproc(ji,jj)  == narea-1 )THEN
1162                  iproci=ji
1163                  iprocj=jj
1164               ENDIF
1165            ENDDO
1166         ENDDO
1167
1168         WRITE(narea+8000-1,*)"nfipproc(ji,jj),narea :",nfipproc(iproci,iprocj),narea
1169         WRITE(narea+8000-1,*)"proc i,j ",iproci,iprocj
1170         WRITE(narea+8000-1,*)"jpni  jpnj jpnij ",jpni,jpnj,jpnij
1171         WRITE(narea+8000-1,*)"nperio jperio ",nperio,jperio
1172         WRITE(narea+8000-1,*)"nowe noea",nowe,noea
1173         WRITE(narea+8000-1,*)"noso nono",noso,nono
1174         WRITE(narea+8000-1,*)"nbondi nbondj ",nbondi,nbondj
1175         WRITE(narea+8000-1,*)"jpiglo jpjglo ",jpiglo,jpjglo
1176         WRITE(narea+8000-1,*)"jpi jpj ",jpi,jpj
1177         WRITE(narea+8000-1,*)"nbondi nbondj",nbondi,nbondj
1178         WRITE(narea+8000-1,*)"nimpp njmpp ",nimpp,njmpp
1179         WRITE(narea+8000-1,*)"loc jpi nldi,nlei,nlci ",jpi, nldi        ,nlei         ,nlci
1180         WRITE(narea+8000-1,*)"glo jpi nldi,nlei      ",jpi, nldi+nimpp-1,nlei+nimpp-1
1181         WRITE(narea+8000-1,*)"loc jpj nldj,nlej,nlcj ",jpj, nldj        ,nlej         ,nlcj
1182         WRITE(narea+8000-1,*)"glo jpj nldj,nlej      ",jpj, nldj+njmpp-1,nlej+njmpp-1
1183         WRITE(narea+8000-1,*)"jpiglo_crs jpjglo_crs ",jpiglo_crs,jpjglo_crs
1184         WRITE(narea+8000-1,*)"jpi_crs jpj_crs ",jpi_crs,jpj_crs
1185         WRITE(narea+8000-1,*)"glamt gphit ",glamt(1,1),gphit(jpi,jpj),glamt(jpi,jpj),gphit(jpi,jpj)
1186
1187         !==========================================================================
1188         ! coarsened domain: dimensions along I
1189         !==========================================================================
1190
1191         !------------------------------------------------------------------------------------
1192         !I-1 fill mis2_crs and mie2_crs: arrays to switch from physic grid to coarsened grid
1193         !------------------------------------------------------------------------------------
1194
1195         ! !--------!--------!--------!
1196         ! !        !        !        !
1197         ! !        !        !        !
1198         ! !        !        !        !
1199         ! !--------!--------!--------!
1200         ! !        !        !        !
1201         ! !        ! ji,jj  !        !
1202         ! !        !        !        !
1203         ! !--------!--------!--------!
1204         ! !        !        !        !
1205         ! !        !        !        !
1206         ! !        !        !        !
1207         ! !--------!--------!--------!
1208         !  mis2_crs(ji)      mie2_crs(ji)
1209       
1210
1211         SELECT CASE ( jperio )
1212
1213         CASE ( 0, 1 )
1214
1215            DO ji=1,jpiglo_crs
1216               ijis=nn_factx*(ji-1)+1
1217               ijie=nn_factx*(ji-1)+3
1218               mis2_crs(ji)=ijis
1219               mie2_crs(ji)=ijie
1220            ENDDO
1221
1222         CASE ( 3, 4 )    !   3, 4 : T-Pivot at North Fold: make correspondinf the pivot points of the 2 grids
1223
1224            DO ji=1,jpiglo_crs
1225               ijis=nn_factx*(ji-1)-2
1226               ijie=nn_factx*(ji-1)
1227               mis2_crs(ji)=ijis
1228               mie2_crs(ji)=ijie
1229            ENDDO
1230
1231         CASE DEFAULT
1232            WRITE(numout,*) 'crs_init. Only jperio = 0, 1, 3, 4 supported; narea: ',narea
1233         END SELECT
1234
1235         !-------------------------------------------------------------------------------
1236         ! I-2 find the first CRS cell which is inside the physic grid inner domain
1237         !-------------------------------------------------------------------------------
1238         ! ijis           : global indice of the first CRS cell which inside the physic grid inner domain
1239         ! mis2_crs(ijis) : global indice of the bottom-left physic cell corresponding to ijis cell
1240         ! ii_start       : local  ndice of the bottom-left physic cell corresponding to ijis cell
1241
1242         ji=1
1243         DO WHILE( mis2_crs(ji) - nimpp + 1 .LT. 1 ) 
1244            ji=ji+1
1245            IF( ji==jpiglo_crs )EXIT
1246         END DO
1247
1248         ijis=ji
1249         ii_start = mis2_crs(ijis)-nimpp+1
1250
1251         !----------------------------------------------------------------------------------------------
1252         ! I-3 compute nldi_crs and compute mis2_crs and mie2_crs for the first cell of the local domain
1253         !---------------------------------------------------------------------------------------------
1254         nldi_crs = 2
1255         IF( nowe == -1 .AND. ( (jperio==3 .OR. jperio==4 ) .OR. ( (jperio==0 .OR. jperio==1 ) .AND. iproci .NE. 1 )) )THEN
1256
1257            mie2_crs(ijis-1) = mis2_crs(ijis)-1
1258             
1259            SELECT CASE(ii_start)
1260               CASE(1)
1261                  nldi_crs=2
1262                  mie2_crs(ijis-1) = -1
1263                  mis2_crs(ijis-1) = -1
1264               CASE(2)
1265                  nldi_crs=2
1266                  mis2_crs(ijis-1) = mie2_crs(ijis-1)
1267               CASE(3)
1268                  nldi_crs=2
1269                  mis2_crs(ijis-1) = mie2_crs(ijis-1) -1
1270               CASE DEFAULT
1271                  WRITE(narea+8000-1,*)"WRONG VALUE FOR iistart ",ii_start
1272            END SELECT
1273
1274         ENDIF
1275
1276         !----------------------------------------------------------------------------------------------
1277         ! I-4 compute nimpp_crs
1278         !---------------------------------------------------------------------------------------------
1279         nimpp_crs = ijis-1
1280         IF( nimpp==1 )nimpp_crs=1
1281
1282         !-------------------------------------------------------------------------------
1283         ! I-5 find the last CRS cell which is inside the physic grid inner domain
1284         !-------------------------------------------------------------------------------
1285         ! ijie           : global indice of the last CRS cell which inside the physic grid inner domain
1286
1287         ji=jpiglo_crs
1288         DO WHILE( mie2_crs(ji) - nimpp + 1 .GT. jpi )
1289            ji=ji-1
1290            IF( ji==1 )EXIT
1291         END DO
1292         ijie=ji
1293
1294         !-------------------------------------------------------------------------------
1295         ! I-6 compute nlei_crs and nlci_crs
1296         !-------------------------------------------------------------------------------
1297         nlei_crs=ijie-nimpp_crs+1
1298         nlci_crs=nlei_crs+jpreci
1299         IF( iproci == jpni )nlei_crs=nlci_crs
1300
1301         !-------------------------------------------------------------------------------
1302         ! I-7 local to global and global to local indices for CRS grid
1303         !-------------------------------------------------------------------------------
1304         DO ji = 1, jpi_crs
1305            mig_crs(ji) = ji + nimpp_crs - 1
1306         ENDDO
1307         DO ji = 1, jpiglo_crs
1308            mi0_crs(ji) = MAX( 1, MIN( ji - nimpp_crs + 1 , jpi_crs + 1 ) )
1309            mi1_crs(ji) = MAX( 0, MIN( ji - nimpp_crs + 1 , jpi_crs     ) )
1310         ENDDO
1311
1312         !---------------------------------------------------------------------------------------
1313         ! I-8 CRS to physic grid: local indices mis_crs and mie_crs and local coarsening factor
1314         !---------------------------------------------------------------------------------------
1315         DO ji = 1, nlei_crs
1316            mis_crs(ji) = mis2_crs(mig_crs(ji)) - nimpp + 1
1317            mie_crs(ji) = mie2_crs(mig_crs(ji)) - nimpp + 1
1318            IF( iproci == jpni  .AND. ji == nlei_crs )THEN
1319               mie_crs(ji) = nlei
1320               mie2_crs(mig_crs(ji)) = mig(nlei)
1321            ENDIF
1322            nfactx(ji)  = mie_crs(ji)-mis_crs(ji)+1
1323         ENDDO
1324
1325         !==========================================================================
1326         ! coarsened domain: dimensions along J
1327         !==========================================================================
1328
1329         !-----------------------------------------------------------------------------------
1330         !J-1 fill mjs2_crs and mje2_crs: arrays to switch from physic grid to coarsened grid
1331         !-----------------------------------------------------------------------------------
1332
1333         ! !--------!--------!--------!
1334         ! !        !        !        !
1335         ! !        !        !        !
1336         ! !        !        !        ! mje2_crs(jj)
1337         ! !--------!--------!--------!
1338         ! !        !        !        !
1339         ! !        ! ji,jj  !        !
1340         ! !        !        !        !
1341         ! !--------!--------!--------!
1342         ! !        !        !        !
1343         ! !        !        !        ! mjs2_crs(jj)
1344         ! !        !        !        !
1345         ! !--------!--------!--------!
1346
1347         SELECT CASE ( jperio )
1348
1349         CASE ( 0, 1 )    !
1350
1351            DO jj=1,jpjglo_crs
1352               ijjs=nn_facty*(jj-1)+1
1353               ijje=nn_facty*(jj-1)+3
1354               mjs2_crs(jj)=ijjs
1355               mje2_crs(jj)=ijje
1356            ENDDO
1357
1358         CASE ( 3, 4 )    !   3, 4 : T-Pivot at North Fold
1359
1360            DO jj=1,jpjglo_crs
1361               ijjs=nn_facty*(jj)-5
1362               ijje=nn_facty*(jj)-3
1363               mjs2_crs(jj)=ijjs
1364               mje2_crs(jj)=ijje
1365            ENDDO
1366
1367         CASE DEFAULT
1368            WRITE(numout,*) 'crs_init. Only jperio = 0, 1, 3, 4 supported; narea: ',narea
1369         END SELECT
1370
1371         !-------------------------------------------------------------------------------
1372         ! J-2 find the first CRS cell which is inside the physic grid inner domain
1373         !-------------------------------------------------------------------------------
1374         ! ijjs           : global indice of the first CRS cell which inside the physic grid inner domain
1375         ! mis2_crs(ijjs) : global indice of the bottom-left physic cell corresponding to ijis cell
1376         ! ij_start       : local  ndice of the bottom-left physic cell corresponding to ijis cell
1377
1378         jj=1
1379         DO WHILE( mjs2_crs(jj) - njmpp + 1 .LT. 1 )
1380            jj=jj+1
1381            IF( jj==jpjglo_crs )EXIT
1382         END DO
1383
1384         ijjs=jj
1385         ij_start = mjs2_crs(ijjs)-njmpp+1
1386
1387         !----------------------------------------------------------------------------------------------
1388         ! J-3 compute nldj_crs and compute mjs2_crs and mje2_crs for the first cell of the local domain
1389         !---------------------------------------------------------------------------------------------
1390         nldj_crs = 2
1391
1392         IF( jperio==3 .OR. jperio==4 )THEN
1393
1394            IF( noso == -1 )THEN
1395
1396               mje2_crs(ijjs-1) = mjs2_crs(ijjs)-1
1397
1398               SELECT CASE(ij_start)
1399                  CASE(1)
1400                     nldj_crs=2
1401                     mje2_crs(ijjs-1) = -1
1402                     mjs2_crs(ijjs-1) = -1
1403                  CASE(2)
1404                     nldj_crs=2
1405                     mjs2_crs(ijjs-1) = mje2_crs(ijjs-1)
1406                  CASE(3)
1407                     nldj_crs=2
1408                     mjs2_crs(ijjs-1) = mje2_crs(ijjs-1) -1
1409                  CASE DEFAULT
1410                     WRITE(narea+8000-1,*)"WRONG VALUE FOR iistart ",ii_start
1411               END SELECT
1412
1413            ENDIF
1414         ENDIF
1415
1416         !----------------------------------------------------------------------------------------------
1417         ! J-4 compute nimpp_crs
1418         !---------------------------------------------------------------------------------------------
1419         njmpp_crs = ijjs-1
1420         IF( njmpp==1 )njmpp_crs=1
1421
1422         !-------------------------------------------------------------------------------
1423         ! J-5 find the last CRS cell which is inside the physic grid inner domain
1424         !-------------------------------------------------------------------------------
1425         ! ijje           : global indice of the last CRS cell which inside the physic grid inner domain
1426
1427         jj=jpjglo_crs
1428         DO WHILE( mje2_crs(jj) - njmpp + 1 .GT. nlcj )
1429            jj=jj-1
1430            IF( jj==1 )EXIT
1431         END DO
1432         ijje=jj
1433
1434         !-------------------------------------------------------------------------------
1435         ! J-6 compute nlej_crs and nlcj_crs
1436         !-------------------------------------------------------------------------------
1437         nlej_crs=ijje-njmpp_crs+1
1438         nlcj_crs=nlej_crs+jprecj
1439
1440         IF( iprocj == jpnj )THEN
1441            IF( jperio==3 .OR. jperio==4 )THEN
1442               nlej_crs=jpj_crs
1443               nlcj_crs=nlej_crs
1444            ELSE
1445               nlej_crs= nlej_crs+1
1446               nlcj_crs= nlcj_crs+1
1447            ENDIF
1448         ENDIF
1449
1450         !-------------------------------------------------------------------------------
1451         ! J-7 local to global and global to local indices for CRS grid
1452         !-------------------------------------------------------------------------------
1453         DO jj = 1, jpj_crs
1454            mjg_crs(jj) = jj + njmpp_crs - 1
1455         ENDDO
1456         DO jj = 1, jpjglo_crs
1457            mj0_crs(jj) = MAX( 1, MIN( jj - njmpp_crs + 1 , jpj_crs + 1 ) )
1458            mj1_crs(jj) = MAX( 0, MIN( jj - njmpp_crs + 1 , jpj_crs     ) )
1459         ENDDO
1460
1461         !---------------------------------------------------------------------------------------
1462         ! J-8 CRS to physic grid: local indices mis_crs and mie_crs and local coarsening factor
1463         !---------------------------------------------------------------------------------------
1464         DO jj = 1, nlej_crs
1465            mjs_crs(jj) = mjs2_crs(mjg_crs(jj)) - njmpp + 1
1466            mje_crs(jj) = mje2_crs(mjg_crs(jj)) - njmpp + 1
1467            IF( iprocj == jpnj  .AND. jj == nlej_crs )THEN
1468               mjs_crs(jj) = nlej
1469               mjs2_crs(mjg_crs(jj)) = mjg(nlej)
1470               mje_crs(jj) = nlej
1471               mje2_crs(mjg_crs(jj)) = mjg(nlej)
1472            ENDIF
1473            nfacty(jj)  = mje_crs(jj)-mjs_crs(jj)+1
1474         ENDDO
1475
1476         !==========================================================================
1477         ! send local start and end indices to all procs
1478         !==========================================================================
1479
1480         nldit_crs(:)=0 ; nleit_crs(:)=0 ; nlcit_crs(:)=0 ; nimppt_crs(:)=0
1481         nldjt_crs(:)=0 ; nlejt_crs(:)=0 ; nlcjt_crs(:)=0 ; njmppt_crs(:)=0
1482
1483         CALL mppgatheri((/nlci_crs/),0,nlcit_crs) ; CALL mppgatheri((/nlcj_crs/),0,nlcjt_crs) 
1484         CALL mppgatheri((/nldi_crs/),0,nldit_crs) ; CALL mppgatheri((/nldj_crs/),0,nldjt_crs) 
1485         CALL mppgatheri((/nlei_crs/),0,nleit_crs) ; CALL mppgatheri((/nlej_crs/),0,nlejt_crs) 
1486         CALL mppgatheri((/nimpp_crs/),0,nimppt_crs) ; CALL mppgatheri((/njmpp_crs/),0,njmppt_crs) 
1487
1488         DO jj = 1 ,jpnj
1489            DO ji = 1 , jpni
1490               jn=nfipproc(ji,jj)+1
1491               IF( jn .GE. 1 )THEN
1492                  nfiimpp_crs(ji,jj)=nimppt_crs(jn)
1493               ELSE
1494                  nfiimpp_crs(ji,jj) = ANINT( REAL( (nfiimpp(ji,jj) + 1 ) / nn_factx, wp ) ) + 1
1495               ENDIF
1496            ENDDO
1497         ENDDO
1498 
1499         !nogather=T
1500         nfsloop_crs = 1
1501         nfeloop_crs = nlci_crs
1502         DO jn = 2,jpni-1
1503            IF( nfipproc(jn,jpnj) .eq. (narea - 1) )THEN
1504               IF (nfipproc(jn - 1 ,jpnj) .eq. -1 )THEN
1505                  nfsloop_crs = nldi_crs
1506               ENDIF
1507               IF( nfipproc(jn + 1,jpnj) .eq. -1 )THEN
1508                  nfeloop_crs = nlei_crs
1509               ENDIF
1510            ENDIF
1511         END DO
1512
1513         !WRITE(narea+8000-1,*)"loc crs jpi nldi,nlei,nlci ",jpi_crs, nldi_crs            ,nlei_crs             ,nlci_crs
1514         !WRITE(narea+8000-1,*)"glo crs jpi nldi,nlei      ",jpi_crs, nldi_crs+nimpp_crs-1,nlei_crs+nimpp_crs-1
1515         !WRITE(narea+8000-1,*)"loc crs jpj nldj,nlej,nlcj ",jpj_crs, nldj_crs            ,nlej_crs             ,nlcj_crs
1516         !WRITE(narea+8000-1,*)"glo crs jpj nldj,nlej      ",jpj_crs, nldj_crs+njmpp_crs-1,nlej_crs+njmpp_crs-1
1517
1518         IF( jpizoom /= 1 .OR. jpjzoom /= 1)    STOP  !cbr mettre un ctlstp et ailleurs ( crsini )
1519
1520         !==========================================================================
1521         ! Save the parent grid information
1522         !==========================================================================
1523         jpi_full    = jpi
1524         jpj_full    = jpj
1525         jpim1_full  = jpim1
1526         jpjm1_full  = jpjm1
1527         npolj_full  = npolj
1528         jpiglo_full = jpiglo
1529         jpjglo_full = jpjglo
1530
1531         nlcj_full   = nlcj
1532         nlci_full   = nlci
1533         nldi_full   = nldi
1534         nldj_full   = nldj
1535         nlei_full   = nlei
1536         nlej_full   = nlej
1537         nimpp_full  = nimpp     
1538         njmpp_full  = njmpp
1539     
1540         nlcit_full(:)  = nlcit(:)
1541         nldit_full(:)  = nldit(:)
1542         nleit_full(:)  = nleit(:)
1543         nimppt_full(:) = nimppt(:)
1544         nlcjt_full(:)  = nlcjt(:)
1545         nldjt_full(:)  = nldjt(:)
1546         nlejt_full(:)  = nlejt(:)
1547         njmppt_full(:) = njmppt(:)
1548     
1549         nfsloop_full = nfsloop
1550         nfeloop_full = nfeloop
1551
1552         nfiimpp_full(:,:) = nfiimpp(:,:) 
1553
1554
1555         !==========================================================================
1556         ! control
1557         !==========================================================================
1558         CALL dom_grid_crs  !swich from mother grid to coarsened grid
1559
1560         IF(lwp) THEN
1561            WRITE(numout,*)
1562            WRITE(numout,*) 'crs_init : coarse grid dimensions'
1563            WRITE(numout,*) '~~~~~~~   coarse domain global j-dimension           jpjglo = ', jpjglo
1564            WRITE(numout,*) '~~~~~~~   coarse domain global i-dimension           jpiglo = ', jpiglo
1565            WRITE(numout,*) '~~~~~~~   coarse domain local  i-dimension              jpi = ', jpi
1566            WRITE(numout,*) '~~~~~~~   coarse domain local  j-dimension              jpj = ', jpj
1567            WRITE(numout,*)
1568            WRITE(numout,*) ' nproc  = '     , nproc
1569            WRITE(numout,*) ' nlci   = '     , nlci
1570            WRITE(numout,*) ' nlcj   = '     , nlcj
1571            WRITE(numout,*) ' nldi   = '     , nldi
1572            WRITE(numout,*) ' nldj   = '     , nldj
1573            WRITE(numout,*) ' nlei   = '     , nlei
1574            WRITE(numout,*) ' nlej   = '     , nlej
1575            WRITE(numout,*) ' nlei_full='    , nlei_full
1576            WRITE(numout,*) ' nldi_full='    , nldi_full
1577            WRITE(numout,*) ' nimpp  = '     , nimpp
1578            WRITE(numout,*) ' njmpp  = '     , njmpp
1579            WRITE(numout,*) ' njmpp_full  = ', njmpp_full
1580            WRITE(numout,*)
1581         ENDIF
1582     
1583         CALL dom_grid_glo ! switch from coarsened grid to mother grid
1584     
1585         nrestx = MOD( nn_factx, 2 )   ! check if even- or odd- numbered reduction factor
1586         nresty = MOD( nn_facty, 2 )
1587
1588         IF( nresty == 0 )THEN
1589            IF( npolj == 3 ) npolj_crs = 5
1590            IF( npolj == 5 ) npolj_crs = 3
1591         ENDIF     
1592     
1593         rfactxy = nn_factx * nn_facty
1594     
1595      ENDIF ! lk_mpp
1596      !
1597      nistr = mis_crs(2)  ;   niend = mis_crs(nlci_crs - 1)
1598      njstr = mjs_crs(3)  ;   njend = mjs_crs(nlcj_crs - 1)
1599      !
1600      !
1601   END SUBROUTINE crs_dom_def
1602   
1603   SUBROUTINE crs_dom_bat
1604      !!----------------------------------------------------------------
1605      !!               *** SUBROUTINE crs_dom_bat ***
1606      !! ** Purpose :  coarsenig bathy
1607      !!----------------------------------------------------------------
1608      !!
1609      !!  local variables
1610      INTEGER  :: ji,jj,jk      ! dummy indices
1611      REAL(wp), DIMENSION(:,:)  , POINTER :: zmbk
1612      !!----------------------------------------------------------------
1613   
1614      CALL wrk_alloc( jpi_crs, jpj_crs, zmbk )
1615   
1616      mbathy_crs(:,:) = jpkm1
1617      mbkt_crs(:,:) = 1
1618      mbku_crs(:,:) = 1
1619      mbkv_crs(:,:) = 1
1620
1621
1622      DO jj = 1, jpj_crs
1623         DO ji = 1, jpi_crs
1624            jk = 0
1625            DO WHILE( tmask_crs(ji,jj,jk+1) > 0.)
1626               jk = jk + 1
1627            ENDDO
1628            mbathy_crs(ji,jj) = float( jk )
1629         ENDDO
1630      ENDDO
1631     
1632      CALL wrk_alloc( jpi_crs, jpj_crs, zmbk )
1633
1634      zmbk(:,:) = 0.0
1635      zmbk(:,:) = REAL( mbathy_crs(:,:), wp ) ;   CALL crs_lbc_lnk(zmbk,'T',1.0)   ;   mbathy_crs(:,:) = INT( zmbk(:,:) )
1636
1637
1638      !
1639      IF(lwp) WRITE(numout,*)
1640      IF(lwp) WRITE(numout,*) '    crsini : mbkt is ocean bottom k-index of T-, U-, V- and W-levels '
1641      IF(lwp) WRITE(numout,*) '    ~~~~~~~~~~~~~'
1642      !
1643      mbkt_crs(:,:) = MAX( mbathy_crs(:,:) , 1 )    ! bottom k-index of T-level (=1 over land)
1644      !                                     ! bottom k-index of W-level = mbkt+1
1645
1646      DO jj = 1, jpj_crsm1                      ! bottom k-index of u- (v-) level
1647         DO ji = 1, jpi_crsm1
1648            mbku_crs(ji,jj) = MIN(  mbkt_crs(ji+1,jj  ) , mbkt_crs(ji,jj)  )
1649            mbkv_crs(ji,jj) = MIN(  mbkt_crs(ji  ,jj+1) , mbkt_crs(ji,jj)  )
1650         END DO
1651      END DO
1652
1653      ! convert into REAL to use lbc_lnk ; impose a min value of 1 as a zero can be set in lbclnk
1654      zmbk(:,:) = 1.e0;   
1655      zmbk(:,:) = REAL( mbku_crs(:,:), wp )   ;   CALL crs_lbc_lnk(zmbk,'U',1.0) ; mbku_crs  (:,:) = MAX( INT( zmbk(:,:) ), 1 ) 
1656      zmbk(:,:) = REAL( mbkv_crs(:,:), wp )   ;   CALL crs_lbc_lnk(zmbk,'V',1.0) ; mbkv_crs  (:,:) = MAX( INT( zmbk(:,:) ), 1 ) 
1657      !
1658      CALL wrk_dealloc( jpi_crs, jpj_crs, zmbk )
1659      !
1660   END SUBROUTINE crs_dom_bat
1661
1662   SUBROUTINE PIKSRT(N,ARR)
1663     INTEGER                  ,INTENT(IN) :: N
1664     REAL(kind=8),DIMENSION(N),INTENT(INOUT) :: ARR
1665
1666     INTEGER      :: i,j
1667     REAL(kind=8) :: a
1668     !!----------------------------------------------------------------
1669
1670     DO j=2, N
1671       a=ARR(j)
1672       DO i=j-1,1,-1
1673          IF(ARR(i)<=a) goto 10
1674          ARR(i+1)=ARR(i)
1675       ENDDO
1676       i=0
167710     ARR(i+1)=a
1678     ENDDO
1679     RETURN
1680
1681   END SUBROUTINE PIKSRT
1682
1683
1684END MODULE crsdom
Note: See TracBrowser for help on using the repository browser.