Context Navigation

← Previous Revision
Latest Revision
Next Revision →
Blame
Revision Log

crsdom.F90 @ 7910

Last change on this file since 7910 was 7910, checked in by timgraham, 7 years ago
All wrk_alloc removed
Property svn:keywords set to `Id`
File size: 110.2 KB

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

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

New URL for NEMO forge! http://forge.nemo-ocean.eu

Context Navigation

source: branches/2017/dev_r7881_no_wrk_alloc/NEMOGCM/NEMO/OPA_SRC/CRS/crsdom.F90 @ 7910

Download in other formats: