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

Context Navigation

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

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

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

Download in other formats: