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

Context Navigation

source: branches/2015/dev_r5836_NOC3_vvl_by_default/NEMOGCM/NEMO/OPA_SRC/CRS/crsdom.F90 @ 5845

Last change on this file since 5845 was 5845, checked in by gm, 8 years ago
#1613: vvl by default: suppression of domzgr_substitute.h90
Property svn:keywords set to `Id`
File size: 111.5 KB

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

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

Download in other formats: