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 NEMO/branches/2020/dev_r12558_HPC-08_epico_Extra_Halo/src/OCE/CRS – NEMO

Context Navigation

source: NEMO/branches/2020/dev_r12558_HPC-08_epico_Extra_Halo/src/OCE/CRS/crsdom.F90 @ 12807

Last change on this file since 12807 was 12807, checked in by smasson, 5 years ago
Extra_Halo: input file only over inner domain + new variables names, see #2366
Property svn:keywords set to `Id`
File size: 111.0 KB

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

Note: See TracBrowser for help on using the repository browser.

Download in other formats: