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

Context Navigation

source: branches/2013/dev_r3940_CNRS4_IOCRS/NEMOGCM/NEMO/OPA_SRC/CRS/crsdom.F90 @ 4064

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

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

Download in other formats: