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

Since March 2022 along with NEMO 4.2 release, the code development moved to a self-hosted GitLab.
This present forge is now archived and remained online for history.

crsdom.F90 in branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/CRS – NEMO

Context Navigation

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

Last change on this file since 6772 was 6772, checked in by cbricaud, 8 years ago
clean in coarsening branch
Property svn:keywords set to `Id`
File size: 63.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
38	USE crslbclnk
39	USE lib_mpp
40	USE ieee_arithmetic
41
42	IMPLICIT NONE
43
44	PRIVATE
45
46	PUBLIC crs_dom_ope
47	PUBLIC crs_dom_e3, crs_dom_sfc, crs_dom_msk, crs_dom_hgr, crs_dom_coordinates
48	PUBLIC crs_dom_facvol, crs_dom_def, crs_dom_bat
49
50	INTERFACE crs_dom_ope
51	MODULE PROCEDURE crs_dom_ope_3d, crs_dom_ope_2d
52	END INTERFACE
53
54	REAL(wp),PUBLIC :: r_inf = 1e+7 !cbr 1e+36
55
56	!! Substitutions
57	# include "domzgr_substitute.h90"
58
59	CONTAINS
60
61
62	SUBROUTINE crs_dom_msk
63	!!===================================================================
64	!
65	!
66	!
67	!!===================================================================
68	INTEGER :: ji, jj, jk ! dummy loop indices
69	INTEGER :: ijis,ijie,ijjs,ijje
70	REAL(wp) :: zmask
71	!!-------------------------------------------------------------------
72
73	! Initialize
74	tmask_crs(:,:,:) = 0.0
75	vmask_crs(:,:,:) = 0.0
76	umask_crs(:,:,:) = 0.0
77	fmask_crs(:,:,:) = 0.0
78	!
79	DO jk = 1, jpkm1
80	DO ji = nldi_crs, nlei_crs
81
82	ijis = mis_crs(ji)
83	ijie = mie_crs(ji)
84
85	DO jj = nldj_crs, nlej_crs
86
87	ijjs = mjs_crs(jj)
88	ijje = mje_crs(jj)
89
90	zmask = 0.0
91	zmask = SUM( tmask(ijis:ijie,ijjs:ijje,jk) )
92	IF ( zmask > 0.0 ) tmask_crs(ji,jj,jk) = 1.0
93
94	zmask = 0.0
95	zmask = SUM( vmask(ijis:ijie,ijje ,jk) )
96	IF ( zmask > 0.0 ) vmask_crs(ji,jj,jk) = 1.0
97
98	zmask = 0.0
99	zmask = SUM( umask(ijie ,ijjs:ijje,jk) )
100	IF ( zmask > 0.0 ) umask_crs(ji,jj,jk) = 1.0
101
102	fmask_crs(ji,jj,jk) = fmask(ijie,ijje,jk)
103
104
105	ENDDO
106	ENDDO
107	ENDDO
108
109	CALL crs_lbc_lnk( tmask_crs, 'T', 1.0 )
110	CALL crs_lbc_lnk( vmask_crs, 'V', 1.0 )
111	CALL crs_lbc_lnk( umask_crs, 'U', 1.0 )
112	CALL crs_lbc_lnk( fmask_crs, 'F', 1.0 )
113	!
114	END SUBROUTINE crs_dom_msk
115
116	SUBROUTINE crs_dom_coordinates( p_gphi, p_glam, cd_type, p_gphi_crs, p_glam_crs )
117	!!----------------------------------------------------------------
118	!! * SUBROUTINE crs_coordinates *
119	!! ** Purpose : Determine the coordinates for the coarse grid
120	!!
121	!! ** Method : From the parent grid subset, search for the central
122	!! point. For an odd-numbered reduction factor,
123	!! the coordinate will be that of the central T-cell.
124	!! For an even-numbered reduction factor, of a non-square
125	!! coarse grid box, the coordinate will be that of
126	!! the east or north face or more likely. For a square
127	!! coarse grid box, the coordinate will be that of
128	!! the central f-corner.
129	!!
130	!! ** Input : p_gphi = parent grid gphi[t\|u\|v\|f]
131	!! p_glam = parent grid glam[t\|u\|v\|f]
132	!! cd_type = grid type (T,U,V,F)
133	!! ** Output : p_gphi_crs = coarse grid gphi[t\|u\|v\|f]
134	!! p_glam_crs = coarse grid glam[t\|u\|v\|f]
135	!!
136	!! History. 1 Jun.
137	!!----------------------------------------------------------------
138	!! Arguments
139	REAL(wp), DIMENSION(jpi,jpj) , INTENT(in) :: p_gphi ! Parent grid latitude
140	REAL(wp), DIMENSION(jpi,jpj) , INTENT(in) :: p_glam ! Parent grid longitude
141	CHARACTER(len=1), INTENT(in) :: cd_type ! grid type (T,U,V,F)
142	REAL(wp), DIMENSION(jpi_crs,jpj_crs), INTENT(out) :: p_gphi_crs ! Coarse grid latitude
143	REAL(wp), DIMENSION(jpi_crs,jpj_crs), INTENT(out) :: p_glam_crs ! Coarse grid longitude
144
145	!! Local variables
146	INTEGER :: ji, jj, jk ! dummy loop indices
147	INTEGER :: iji, ijj
148	INTEGER :: ir,jr
149	!!----------------------------------------------------------------
150	p_gphi_crs(:,:)=0._wp
151	p_glam_crs(:,:)=0._wp
152
153
154	SELECT CASE ( cd_type )
155	CASE ( 'T' )
156	DO jj = nldj_crs, nlej_crs
157	ijj = mjs_crs(jj) + 1
158	DO ji = nldi_crs, nlei_crs
159	iji = mis_crs(ji) + 1
160	p_gphi_crs(ji,jj) = p_gphi(iji,ijj)
161	p_glam_crs(ji,jj) = p_glam(iji,ijj)
162	ENDDO
163	ENDDO
164	CASE ( 'U' )
165	DO jj = nldj_crs, nlej_crs
166	ijj = mjs_crs(jj) + 1
167	DO ji = nldi_crs, nlei_crs
168	iji = mie_crs(ji)
169	p_gphi_crs(ji,jj) = p_gphi(iji,ijj)
170	p_glam_crs(ji,jj) = p_glam(iji,ijj)
171
172	ENDDO
173	ENDDO
174	CASE ( 'V' )
175	DO jj = nldj_crs, nlej_crs
176	ijj = mje_crs(jj)
177	DO ji = nldi_crs, nlei_crs
178	iji = mis_crs(ji) + 1
179	p_gphi_crs(ji,jj) = p_gphi(iji,ijj)
180	p_glam_crs(ji,jj) = p_glam(iji,ijj)
181	ENDDO
182	ENDDO
183	CASE ( 'F' )
184	DO jj = nldj_crs, nlej_crs
185	ijj = mje_crs(jj)
186	DO ji = nldi_crs, nlei_crs
187	iji = mie_crs(ji)
188	p_gphi_crs(ji,jj) = p_gphi(iji,ijj)
189	p_glam_crs(ji,jj) = p_glam(iji,ijj)
190	ENDDO
191	ENDDO
192	END SELECT
193
194	! Retroactively add back the boundary halo cells.
195	CALL crs_lbc_lnk( p_gphi_crs, cd_type, 1.0 )
196	CALL crs_lbc_lnk( p_glam_crs, cd_type, 1.0 )
197
198	!cbr??? ! Fill up jrow=1 which is zeroed out or not handled by lbc_lnk and lbc_nfd
199	! SELECT CASE ( cd_type )
200	! CASE ( 'T', 'V' )
201	! DO ji = 2, nlei_crs
202	! ijis = mis_crs(ji) + mxbinctr
203	! p_gphi_crs(ji,1) = p_gphi(ijis,1)
204	! p_glam_crs(ji,1) = p_glam(ijis,1)
205	! ENDDO
206	! CASE ( 'U', 'F' )
207	! DO ji = 2, nlei_crs
208	! ijis = mis_crs(ji)
209	! p_gphi_crs(ji,1) = p_gphi(ijis,1)
210	! p_glam_crs(ji,1) = p_glam(ijis,1)
211	! ENDDO
212	! END SELECT
213	!
214	END SUBROUTINE crs_dom_coordinates
215
216	SUBROUTINE crs_dom_hgr( p_e1, p_e2, cd_type, p_e1_crs, p_e2_crs )
217	!!----------------------------------------------------------------
218	!! * SUBROUTINE crs_dom_hgr *
219	!!
220	!! ** Purpose : Get coarse grid horizontal scale factors and unmasked fraction
221	!!
222	!! ** Method : For grid types T,U,V,Fthe 2D scale factors of
223	!! the coarse grid are the sum of the east or north faces of the
224	!! parent grid subset comprising the coarse grid box.
225	!! - e1,e2 Scale factors
226	!! Valid arguments:
227	!! ** Inputs : p_e1, p_e2 = parent grid e1 or e2 (t,u,v,f)
228	!! cd_type = grid type (T,U,V,F) for scale factors; for velocities (U or V)
229	!! ** Outputs : p_e1_crs, p_e2_crs = parent grid e1 or e2 (t,u,v,f)
230	!!
231	!! History. 4 Jun. Write for WGT and scale factors only
232	!!----------------------------------------------------------------
233	!!
234	!! Arguments
235	REAL(wp), DIMENSION(jpi,jpj) , INTENT(in) :: p_e1 ! Parent grid U,V scale factors (e1)
236	REAL(wp), DIMENSION(jpi,jpj) , INTENT(in) :: p_e2 ! Parent grid U,V scale factors (e2)
237	CHARACTER(len=1) , INTENT(in) :: cd_type ! grid type U,V
238
239	REAL(wp), DIMENSION(jpi_crs,jpj_crs), INTENT(out) :: p_e1_crs ! Coarse grid box 2D quantity
240	REAL(wp), DIMENSION(jpi_crs,jpj_crs), INTENT(out) :: p_e2_crs ! Coarse grid box 2D quantity
241
242	!! Local variables
243	INTEGER :: ji, jj, jk ! dummy loop indices
244	INTEGER :: ijis,ijie,ijjs,ijje
245	INTEGER :: ji1, jj1
246
247	!!----------------------------------------------------------------
248	! Initialize
249
250	DO ji = nldi_crs, nlei_crs
251
252	ijis = mis_crs(ji)
253	ijie = mie_crs(ji)
254
255	DO jj = nldj_crs, nlej_crs
256
257	ijjs = mjs_crs(jj)
258	ijje = mje_crs(jj)
259
260	! Only for a factro 3 coarsening
261	SELECT CASE ( cd_type )
262	CASE ( 'T' )
263	!p_e1_crs(ji,jj) = SUM( p_e1(ijis:ijie ,ijjs+1 ) )
264	!p_e2_crs(ji,jj) = SUM( p_e2(ijis+1 ,ijjs:ijje ) )
265	p_e1_crs(ji,jj) = REAL(nn_factx,wp)*p_e1(ijis+1,ijjs+1)
266	p_e2_crs(ji,jj) = REAL(nn_facty,wp)*p_e2(ijis+1,ijjs+1)
267	CASE ( 'U' )
268	!p_e1_crs(ji,jj) = SUM( p_e1(ijis+1:ijie+1 ,ijjs+1 ) )
269	!p_e2_crs(ji,jj) = SUM( p_e2(ijie ,ijjs:ijje ) )
270	p_e1_crs(ji,jj) = REAL(nn_factx,wp)*p_e1(ijis+1,ijjs+1 )
271	p_e2_crs(ji,jj) = REAL(nn_facty,wp)*p_e2(ijie ,ijjs+1 )
272
273	CASE ( 'V' )
274	!p_e1_crs(ji,jj) = SUM( p_e1(ijis:ijie ,ijje ) )
275	!p_e2_crs(ji,jj) = SUM( p_e2(ijis+1 ,ijjs+1:ijje+1) )
276	p_e1_crs(ji,jj) = REAL(nn_factx,wp)*p_e1(ijis+1,ijje )
277	p_e2_crs(ji,jj) = REAL(nn_facty,wp)*p_e2(ijis+1,ijjs+1 )
278	CASE ( 'F' )
279	!p_e1_crs(ji,jj) = SUM( p_e1(ijis+1:ijie+1 ,ijje ) )
280	!p_e2_crs(ji,jj) = SUM( p_e2(ijie ,ijjs+1:ijje+1) )
281	p_e1_crs(ji,jj) = REAL(nn_factx,wp)*p_e1(ijis+1,ijje )
282	p_e2_crs(ji,jj) = REAL(nn_facty,wp)*p_e2(ijie ,ijjs+1 )
283	END SELECT
284	ENDDO
285	ENDDO
286
287
288	CALL crs_lbc_lnk( p_e1_crs, cd_type, 1.0 ) !cbr , pval=1.0 )
289	CALL crs_lbc_lnk( p_e2_crs, cd_type, 1.0 ) !cbr , pval=1.0 )
290
291	END SUBROUTINE crs_dom_hgr
292
293
294	SUBROUTINE crs_dom_facvol( p_mask, cd_type, p_e1, p_e2, p_e3, p_fld1_crs, p_fld2_crs )
295	!!----------------------------------------------------------------
296	!! * SUBROUTINE crsfun_wgt *
297	!! ** Purpose : Three applications.
298	!! 1) SUM. Get coarse grid horizontal scale factors and unmasked fraction
299	!! 2) VOL. Get coarse grid box volumes
300	!! 3) WGT. Weighting multiplier for volume-weighted and/or
301	!! area-weighted averages.
302	!! Weights (i.e. the denominator) calculated here
303	!! to avoid IF-tests and division.
304	!! ** Method : 1) SUM. For grid types T,U,V,F (and W) the 2D scale factors of
305	!! the coarse grid are the sum of the east or north faces of the
306	!! parent grid subset comprising the coarse grid box.
307	!! The fractions of masked:total surface (3D) on the east,
308	!! north and top faces is, optionally, also output.
309	!! - Top face area sum
310	!! Valid arguments: cd_type, cd_op='W', p_pmask, p_e1, p_e2
311	!! - Top face ocean surface fraction
312	!! Valid arguments: cd_type, cd_op='W', p_pmask, p_e1, p_e2
313	!! - e1,e2 Scale factors
314	!! Valid arguments:
315	!! 2) VOL. For grid types W and T, the coarse grid box
316	!! volumes are output. Also optionally, the fraction of
317	!! masked:total volume of the parent grid subset is output (i.e. facvol).
318	!! 3) WGT. Based on the grid type, the denominator is pre-determined here to
319	!! perform area- or volume- weighted averages,
320	!! to avoid IF-tests and divisions.
321	!! ** Inputs : p_e1, p_e2 = parent grid e1 or e2 (t,u,v,f)
322	!! p_pmask = parent grid mask (T,U,V,F)
323	!! cd_type = grid type (T,U,V,F) for scale factors; for velocities (U or V)
324	!! cd_op = applied operation (SUM, VOL, WGT)
325	!! p_fse3 = (Optional) parent grid vertical level thickness (fse3u or fse3v)
326	!! ** Outputs : p_cfield2d_1 = (Optional) 2D field on coarse grid
327	!! p_cfield2d_2 = (Optional) 2D field on coarse grid
328	!! p_cfield3d_1 = (Optional) 3D field on coarse grid
329	!! p_cfield3d_2 = (Optional) 3D field on coarse grid
330	!!
331	!! History. 4 Jun. Write for WGT and scale factors only
332	!!----------------------------------------------------------------
333	!!
334	!! Arguments
335	CHARACTER(len=1), INTENT(in) :: cd_type ! grid type U,V
336	REAL(wp), DIMENSION(jpi,jpj,jpk) , INTENT(in) :: p_mask ! Parent grid U,V mask
337	REAL(wp), DIMENSION(jpi,jpj) , INTENT(in) :: p_e1 ! Parent grid U,V scale factors (e1)
338	REAL(wp), DIMENSION(jpi,jpj) , INTENT(in) :: p_e2 ! Parent grid U,V scale factors (e2)
339	REAL(wp), DIMENSION(jpi,jpj,jpk) , INTENT(in) :: p_e3 ! Parent grid vertical level thickness (fse3u, fse3v)
340
341	REAL(wp), DIMENSION(jpi_crs,jpj_crs,jpk), INTENT(out) :: p_fld1_crs ! Coarse grid box 3D quantity
342	REAL(wp), DIMENSION(jpi_crs,jpj_crs,jpk), INTENT(out) :: p_fld2_crs ! Coarse grid box 3D quantity
343
344	!! Local variables
345	REAL(wp) :: zdAm
346	INTEGER :: ji, jj, jk
347	INTEGER :: ijis,ijie,ijjs,ijje
348
349	REAL(wp), DIMENSION(:,:,:), POINTER :: zvol, zmask
350	!!----------------------------------------------------------------
351
352	CALL wrk_alloc( jpi, jpj, jpk, zvol, zmask )
353
354	p_fld1_crs(:,:,:) = 0.0
355	p_fld2_crs(:,:,:) = 0.0
356
357	DO jk = 1, jpk
358	zvol (:,:,jk) = p_e1(:,:) * p_e2(:,:) * p_e3(:,:,jk)
359	zmask(:,:,jk) = p_mask(:,:,jk)
360	ENDDO
361
362	DO jk = 1, jpk
363	DO ji = nldi_crs, nlei_crs
364
365	ijis = mis_crs(ji)
366	ijie = mie_crs(ji)
367
368	DO jj = nldj_crs, nlej_crs
369
370	ijjs = mjs_crs(jj)
371	ijje = mje_crs(jj)
372
373	p_fld1_crs(ji,jj,jk) = SUM( zvol(ijis:ijie,ijjs:ijje,jk) )
374	zdAm = SUM( zvol(ijis:ijie,ijjs:ijje,jk) * zmask(ijis:ijie,ijjs:ijje,jk) )
375	p_fld2_crs(ji,jj,jk) = zdAm / p_fld1_crs(ji,jj,jk)
376	ENDDO
377	ENDDO
378	ENDDO
379	! ! Retroactively add back the boundary halo cells.
380	CALL crs_lbc_lnk( p_fld1_crs, cd_type, 1.0 )
381	CALL crs_lbc_lnk( p_fld2_crs, cd_type, 1.0 )
382	!
383	CALL wrk_dealloc( jpi, jpj, jpk, zvol, zmask )
384	!
385	END SUBROUTINE crs_dom_facvol
386
387
388	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 )
389	!!----------------------------------------------------------------
390	!! * SUBROUTINE crsfun_UV *
391	!! ** Purpose : Average, area-weighted, of U or V on the east and north faces
392	!!
393	!! ** Method : The U and V velocities (3D) are determined as the area-weighted averages
394	!! on the east and north faces, respectively,
395	!! of the parent grid subset comprising the coarse grid box.
396	!! In the case of the V and F grid, the last jrow minus 1 is spurious.
397	!! ** Inputs : p_e1_e2 = parent grid e1 or e2 (t,u,v,f)
398	!! cd_type = grid type (T,U,V,F) for scale factors; for velocities (U or V)
399	!! psgn = sign change over north fold (See lbclnk.F90)
400	!! p_pmask = parent grid mask (T,U,V,F) for scale factors;
401	!! for velocities (U or V)
402	!! p_fse3 = parent grid vertical level thickness (fse3u or fse3v)
403	!! p_pfield = U or V on the parent grid
404	!! p_surf_crs = (Optional) Coarse grid weight for averaging
405	!! ** Outputs : p_cfield3d = 3D field on coarse grid
406	!!
407	!! History. 29 May. completed draft.
408	!! 4 Jun. Revision for WGT
409	!! 5 Jun. Streamline for area-weighted average only ; separate scale factor and weights.
410	!!----------------------------------------------------------------
411	!!
412	!! Arguments
413	REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in) :: p_fld ! T, U, V or W on parent grid
414	CHARACTER(len=*), INTENT(in) :: cd_op ! Operation SUM, MAX or MIN
415	CHARACTER(len=1), INTENT(in) :: cd_type ! grid type U,V
416	REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in) :: p_mask ! Parent grid T,U,V mask
417	REAL(wp), DIMENSION(jpi,jpj), INTENT(in), OPTIONAL :: p_e12 ! Parent grid T,U,V scale factors (e1 or e2)
418	REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in), OPTIONAL :: p_e3 ! Parent grid vertical level thickness (fse3u, fse3v)
419	REAL(wp), DIMENSION(jpi_crs,jpj_crs,jpk), INTENT(in), OPTIONAL :: p_surf_crs ! Coarse grid area-weighting denominator
420	REAL(wp), DIMENSION(jpi_crs,jpj_crs,jpk), INTENT(in), OPTIONAL :: p_mask_crs ! Coarse grid T,U,V maska
421	REAL(wp), INTENT(in) :: psgn ! sign
422
423	REAL(wp), DIMENSION(jpi_crs,jpj_crs,jpk), INTENT(out) :: p_fld_crs ! Coarse grid box 3D quantity
424
425	!! Local variables
426	INTEGER :: ji, jj, jk
427	INTEGER :: ijis, ijie, ijjs, ijje
428	REAL(wp) :: zflcrs, zsfcrs
429	REAL(wp), DIMENSION(:,:,:), POINTER :: zsurf, zsurfmsk, zmask,ztabtmp
430	INTEGER :: ir,jr
431	REAL(wp), DIMENSION(nn_factx,nn_facty):: ztmp
432	REAL(wp), DIMENSION(nn_factx*nn_facty):: ztmp1
433	REAL(wp), DIMENSION(:), ALLOCATABLE :: ztmp2
434	INTEGER , DIMENSION(1) :: zdim1
435	REAL(wp) :: zmin,zmax
436	!!----------------------------------------------------------------
437
438	p_fld_crs(:,:,:) = 0.0
439
440	SELECT CASE ( cd_op )
441
442	CASE ( 'VOL' )
443
444	CALL wrk_alloc( jpi, jpj, jpk, zsurf, zsurfmsk )
445
446	SELECT CASE ( cd_type )
447
448	CASE( 'T', 'W' )
449	DO jk = 1, jpk
450	zsurf (:,:,jk) = p_e12(:,:) * p_e3(:,:,jk) * p_mask(:,:,jk)
451	zsurfmsk(:,:,jk) = zsurf(:,:,jk)
452	ENDDO
453	!
454	DO jk = 1, jpk
455	DO jj = nldj_crs,nlej_crs
456	ijjs = mjs_crs(jj)
457	ijje = mje_crs(jj)
458	DO ji = nldi_crs, nlei_crs
459
460	ijis = mis_crs(ji)
461	ijie = mie_crs(ji)
462
463	zflcrs = SUM( p_fld(ijis:ijie,ijjs:ijje,jk) * zsurfmsk(ijis:ijie,ijjs:ijje,jk) )
464	zsfcrs = SUM( zsurfmsk(ijis:ijie,ijjs:ijje,jk) )
465
466	p_fld_crs(ji,jj,jk) = zflcrs
467	IF( zsfcrs /= 0.0 ) p_fld_crs(ji,jj,jk) = zflcrs / zsfcrs
468	ENDDO
469	ENDDO
470	ENDDO
471	!
472	CASE DEFAULT
473	STOP
474	END SELECT
475
476	CALL wrk_dealloc( jpi, jpj, jpk, zsurf, zsurfmsk )
477
478	CASE ( 'LOGVOL' )
479
480	CALL wrk_alloc( jpi, jpj, jpk, zsurf, zsurfmsk, ztabtmp )
481
482	ztabtmp(:,:,:)=0._wp
483	WHERE(p_fld* p_mask .NE. 0._wp ) ztabtmp = LOG10(p_fld * p_mask)*p_mask
484	ztabtmp = ztabtmp * p_mask
485
486	SELECT CASE ( cd_type )
487
488	CASE( 'T', 'W' )
489
490	DO jk = 1, jpk
491	zsurf (:,:,jk) = p_e12(:,:) * p_e3(:,:,jk) * p_mask(:,:,jk)
492	zsurfmsk(:,:,jk) = zsurf(:,:,jk)
493	ENDDO
494	!
495	DO jk = 1, jpk
496	DO jj = nldj_crs,nlej_crs
497	ijjs = mjs_crs(jj)
498	ijje = mje_crs(jj)
499	DO ji = nldi_crs, nlei_crs
500	ijis = mis_crs(ji)
501	ijie = mie_crs(ji)
502	zflcrs = SUM( p_fld(ijis:ijie,ijjs:ijje,jk) * zsurfmsk(ijis:ijie,ijjs:ijje,jk) )
503	zsfcrs = SUM( zsurfmsk(ijis:ijie,ijjs:ijje,jk) )
504	p_fld_crs(ji,jj,jk) = zflcrs
505	IF( zsfcrs /= 0.0 ) p_fld_crs(ji,jj,jk) = zflcrs / zsfcrs
506	p_fld_crs(ji,jj,jk) = 10 ** ( p_fld_crs(ji,jj,jk) * p_mask_crs(ji,jj,jk) ) * p_mask_crs(ji,jj,jk)
507	ENDDO
508	ENDDO
509	ENDDO
510	CASE DEFAULT
511	STOP
512	END SELECT
513
514	CALL wrk_dealloc( jpi, jpj, jpk, zsurf, zsurfmsk ,ztabtmp )
515
516	CASE ( 'MED' )
517
518	CALL wrk_alloc( jpi, jpj, jpk, zsurf, zsurfmsk )
519
520	SELECT CASE ( cd_type )
521
522	CASE( 'T', 'W' )
523	DO jk = 1, jpk
524	zsurf (:,:,jk) = p_e12(:,:) * p_e3(:,:,jk) * p_mask(:,:,jk)
525	zsurfmsk(:,:,jk) = zsurf(:,:,jk)
526	ENDDO
527	!
528	DO jk = 1, jpk
529	DO jj = nldj_crs,nlej_crs
530	ijjs = mjs_crs(jj)
531	ijje = mje_crs(jj)
532	DO ji = nldi_crs, nlei_crs
533	ijis = mis_crs(ji)
534	ijie = mie_crs(ji)
535
536	ztmp(:,:)= p_fld(ijis:ijie,ijjs:ijje,jk)
537	zdim1(1) = nn_factx*nn_facty
538	ztmp1(:) = RESHAPE( ztmp(:,:) , zdim1 )
539	CALL PIKSRT(nn_factx*nn_facty,ztmp1)
540
541	ir=0
542	jr=1
543	DO WHILE( jr .LE. nn_factx*nn_facty )
544	IF( ztmp1(jr) == 0. ) THEN
545	ir=jr
546	jr=jr+1
547	ELSE
548	EXIT
549	ENDIF
550	ENDDO
551	IF( ir .LE. nn_factx*nn_facty-1 )THEN
552	ALLOCATE( ztmp2(nn_factx*nn_facty-ir) )
553	ztmp2(1:nn_factxnn_facty-ir) = ztmp1(1+ir:nn_factxnn_facty)
554	jr=INT( 0.5 * REAL(nn_factx*nn_facty-ir,wp) )+1
555	p_fld_crs(ji,jj,jk) = ztmp2(jr)
556	DEALLOCATE( ztmp2 )
557	ELSE
558	p_fld_crs(ji,jj,jk) = 0._wp
559	ENDIF
560
561	ENDDO
562	ENDDO
563	ENDDO
564	CASE DEFAULT
565	STOP
566	END SELECT
567
568	CALL wrk_dealloc( jpi, jpj, jpk, zsurf, zsurfmsk )
569
570	CASE ( 'SUM' )
571
572	CALL wrk_alloc( jpi, jpj, jpk, zsurfmsk )
573
574	IF( PRESENT( p_e3 ) ) THEN
575	DO jk = 1, jpk
576	zsurfmsk(:,:,jk) = p_e12(:,:) * p_e3(:,:,jk) * p_mask(:,:,jk)
577	ENDDO
578	ELSE
579	DO jk = 1, jpk
580	zsurfmsk(:,:,jk) = p_e12(:,:) * p_mask(:,:,jk)
581	ENDDO
582	ENDIF
583
584	SELECT CASE ( cd_type )
585
586	CASE( 'T', 'W' )
587
588	DO jk = 1, jpk
589	DO jj = nldj_crs,nlej_crs
590	ijjs = mjs_crs(jj)
591	ijje = mje_crs(jj)
592	DO ji = nldi_crs, nlei_crs
593	ijis = mis_crs(ji)
594	ijie = mie_crs(ji)
595
596	p_fld_crs(ji,jj,jk) = SUM( p_fld(ijis:ijie,ijjs:ijje,jk) * zsurfmsk(ijis:ijie,ijjs:ijje,jk) )
597	ENDDO
598	ENDDO
599	ENDDO
600
601	CASE( 'V' )
602
603
604	DO jk = 1, jpk
605	DO jj = nldj_crs,nlej_crs
606	ijjs = mjs_crs(jj)
607	ijje = mje_crs(jj)
608	DO ji = nldi_crs, nlei_crs
609	ijis = mis_crs(ji)
610	ijie = mie_crs(ji)
611
612	p_fld_crs(ji,jj,jk) = SUM( p_fld(ijis:ijie,ijje,jk) * zsurfmsk(ijis:ijie,ijje,jk) )
613	ENDDO
614	ENDDO
615	ENDDO
616
617	CASE( 'U' )
618
619	DO jk = 1, jpk
620	DO jj = nldj_crs,nlej_crs
621	ijjs = mjs_crs(jj)
622	ijje = mje_crs(jj)
623	DO ji = nldi_crs, nlei_crs
624	ijis = mis_crs(ji)
625	ijie = mie_crs(ji)
626
627	p_fld_crs(ji,jj,jk) = SUM( p_fld(ijie,ijjs:ijje,jk) * zsurfmsk(ijie,ijjs:ijje,jk) )
628	ENDDO
629	ENDDO
630	ENDDO
631
632	END SELECT
633
634	IF( PRESENT( p_surf_crs ) ) THEN
635	WHERE ( p_surf_crs /= 0.0 ) p_fld_crs(:,:,:) = p_fld_crs(:,:,:) / p_surf_crs(:,:,:)
636	ENDIF
637
638	CALL wrk_dealloc( jpi, jpj, jpk, zsurfmsk )
639
640	CASE ( 'MAX' ) ! search the max of unmasked grid cells
641
642	CALL wrk_alloc( jpi, jpj, jpk, zmask )
643
644	DO jk = 1, jpk
645	zmask(:,:,jk) = p_mask(:,:,jk)
646	ENDDO
647
648	SELECT CASE ( cd_type )
649
650	CASE( 'T', 'W' )
651
652	DO jk = 1, jpk
653	DO jj = nldj_crs,nlej_crs
654	ijjs = mjs_crs(jj)
655	ijje = mje_crs(jj)
656	DO ji = nldi_crs, nlei_crs
657	ijis = mis_crs(ji)
658	ijie = mie_crs(ji)
659	p_fld_crs(ji,jj,jk) = MAXVAL( p_fld(ijis:ijie,ijjs:ijje,jk) * zmask(ijis:ijie,ijjs:ijje,jk) - &
660	& ( ( 1._wp - zmask(ijis:ijie,ijjs:ijje,jk))* r_inf ) )
661	ENDDO
662	ENDDO
663	ENDDO
664
665	CASE( 'V' )
666	CALL ctl_stop('MAX operator and V case not available')
667
668	CASE( 'U' )
669	CALL ctl_stop('MAX operator and U case not available')
670
671	END SELECT
672
673	CALL wrk_dealloc( jpi, jpj, jpk, zmask )
674
675	CASE ( 'MIN' ) ! Search the min of unmasked grid cells
676
677	CALL wrk_alloc( jpi, jpj, jpk, zmask )
678	DO jk = 1, jpk
679	zmask(:,:,jk) = p_mask(:,:,jk)
680	ENDDO
681
682	SELECT CASE ( cd_type )
683
684	CASE( 'T', 'W' )
685
686	DO jk = 1, jpk
687	DO jj = nldj_crs,nlej_crs
688	ijjs = mjs_crs(jj)
689	ijje = mje_crs(jj)
690	DO ji = nldi_crs, nlei_crs
691	ijis = mis_crs(ji)
692	ijie = mie_crs(ji)
693
694	p_fld_crs(ji,jj,jk) = MINVAL( p_fld(ijis:ijie,ijjs:ijje,jk) * zmask(ijis:ijie,ijjs:ijje,jk) + &
695	& ( 1._wp - zmask(ijis:ijie,ijjs:ijje,jk)* r_inf ) )
696	ENDDO
697	ENDDO
698	ENDDO
699
700
701	CASE( 'V' )
702	CALL ctl_stop('MIN operator and V case not available')
703
704	CASE( 'U' )
705	CALL ctl_stop('MIN operator and U case not available')
706
707	END SELECT
708	!
709	CALL wrk_dealloc( jpi, jpj, jpk, zmask )
710	!
711	END SELECT
712	!
713	CALL crs_lbc_lnk( p_fld_crs, cd_type, psgn )
714	!
715	END SUBROUTINE crs_dom_ope_3d
716
717	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 )
718	!!----------------------------------------------------------------
719	!! * SUBROUTINE crsfun_UV *
720	!! ** Purpose : Average, area-weighted, of U or V on the east and north faces
721	!!
722	!! ** Method : The U and V velocities (3D) are determined as the area-weighted averages
723	!! on the east and north faces, respectively,
724	!! of the parent grid subset comprising the coarse grid box.
725	!! In the case of the V and F grid, the last jrow minus 1 is spurious.
726	!! ** Inputs : p_e1_e2 = parent grid e1 or e2 (t,u,v,f)
727	!! cd_type = grid type (T,U,V,F) for scale factors; for velocities (U or V)
728	!! psgn = sign change over north fold (See lbclnk.F90)
729	!! p_pmask = parent grid mask (T,U,V,F) for scale factors;
730	!! for velocities (U or V)
731	!! p_fse3 = parent grid vertical level thickness (fse3u or fse3v)
732	!! p_pfield = U or V on the parent grid
733	!! p_surf_crs = (Optional) Coarse grid weight for averaging
734	!! ** Outputs : p_cfield3d = 3D field on coarse grid
735	!!
736	!! History. 29 May. completed draft.
737	!! 4 Jun. Revision for WGT
738	!! 5 Jun. Streamline for area-weighted average only ; separate scale factor and weights.
739	!!----------------------------------------------------------------
740	!!
741	!! Arguments
742	REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: p_fld ! T, U, V or W on parent grid
743	CHARACTER(len=3), INTENT(in) :: cd_op ! Operation SUM, MAX or MIN
744	CHARACTER(len=1), INTENT(in) :: cd_type ! grid type U,V
745	REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in) :: p_mask ! Parent grid T,U,V mask
746	REAL(wp), DIMENSION(jpi,jpj), INTENT(in), OPTIONAL :: p_e12 ! Parent grid T,U,V scale factors (e1 or e2)
747	REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in), OPTIONAL :: p_e3 ! Parent grid vertical level thickness (fse3u, fse3v)
748	REAL(wp), DIMENSION(jpi_crs,jpj_crs) , INTENT(in), OPTIONAL :: p_surf_crs ! Coarse grid area-weighting denominator
749	REAL(wp), DIMENSION(jpi_crs,jpj_crs,jpk), INTENT(in), OPTIONAL :: p_mask_crs ! Coarse grid T,U,V mask
750	REAL(wp), INTENT(in) :: psgn
751
752	REAL(wp), DIMENSION(jpi_crs,jpj_crs) , INTENT(out) :: p_fld_crs ! Coarse grid box 3D quantity
753
754	!! Local variables
755	INTEGER :: ji, jj, jk ! dummy loop indices
756	INTEGER :: ijis, ijie, ijjs, ijje
757	REAL(wp) :: zflcrs, zsfcrs
758	REAL(wp), DIMENSION(:,:), POINTER :: zsurfmsk
759
760	!!----------------------------------------------------------------
761
762	p_fld_crs(:,:) = 0.0
763
764	SELECT CASE ( cd_op )
765
766	CASE ( 'VOL' )
767
768	CALL wrk_alloc( jpi, jpj, zsurfmsk )
769	zsurfmsk(:,:) = p_e12(:,:) * p_e3(:,:,1) * p_mask(:,:,1)
770
771	DO jj = nldj_crs,nlej_crs
772	ijjs = mjs_crs(jj)
773	ijje = mje_crs(jj)
774	DO ji = nldi_crs, nlei_crs
775	ijis = mis_crs(ji)
776	ijie = mie_crs(ji)
777
778	zflcrs = SUM( p_fld(ijis:ijie,ijjs:ijje) * zsurfmsk(ijis:ijie,ijjs:ijje) )
779	zsfcrs = SUM( zsurfmsk(ijis:ijie,ijjs:ijje) )
780
781	p_fld_crs(ji,jj) = zflcrs
782	IF( zsfcrs /= 0.0 ) p_fld_crs(ji,jj) = zflcrs / zsfcrs
783	ENDDO
784	ENDDO
785	CALL wrk_dealloc( jpi, jpj, zsurfmsk )
786	!
787
788	CASE ( 'SUM' )
789
790	CALL wrk_alloc( jpi, jpj, zsurfmsk )
791	IF( PRESENT( p_e3 ) ) THEN
792	zsurfmsk(:,:) = p_e12(:,:) * p_e3(:,:,1) * p_mask(:,:,1)
793	ELSE
794	zsurfmsk(:,:) = p_e12(:,:) * p_mask(:,:,1)
795	ENDIF
796
797	SELECT CASE ( cd_type )
798
799	CASE( 'T', 'W' )
800
801	DO jj = nldj_crs,nlej_crs
802	ijjs = mjs_crs(jj)
803	ijje = mje_crs(jj)
804	DO ji = nldi_crs, nlei_crs
805	ijis = mis_crs(ji)
806	ijie = mie_crs(ji)
807	p_fld_crs(ji,jj) = SUM( p_fld(ijis:ijie,ijjs:ijje) * zsurfmsk(ijis:ijie,ijjs:ijje) )
808	ENDDO
809	ENDDO
810
811	CASE( 'V' )
812
813	DO jj = nldj_crs,nlej_crs
814	ijjs = mjs_crs(jj)
815	ijje = mje_crs(jj)
816	DO ji = nldi_crs, nlei_crs
817	ijis = mis_crs(ji)
818	ijie = mie_crs(ji)
819	p_fld_crs(ji,jj) = SUM( p_fld(ijis:ijie,ijje) * zsurfmsk(ijis:ijie,ijje) )
820	ENDDO
821	ENDDO
822
823	CASE( 'U' )
824
825	DO jj = nldj_crs,nlej_crs
826	ijjs = mjs_crs(jj)
827	ijje = mje_crs(jj)
828	DO ji = nldi_crs, nlei_crs
829	ijis = mis_crs(ji)
830	ijie = mie_crs(ji)
831	p_fld_crs(ji,jj) = SUM( p_fld(ijie,ijjs:ijje) * zsurfmsk(ijie,ijjs:ijje) )
832	ENDDO
833	ENDDO
834
835	END SELECT
836
837	IF( PRESENT( p_surf_crs ) ) THEN
838	WHERE ( p_surf_crs /= 0.0 ) p_fld_crs(:,:) = p_fld_crs(:,:) / p_surf_crs(:,:)
839	ENDIF
840
841	CALL wrk_dealloc( jpi, jpj, zsurfmsk )
842
843	CASE ( 'MAX' )
844
845	SELECT CASE ( cd_type )
846
847	CASE( 'T', 'W' )
848
849	DO jj = nldj_crs,nlej_crs
850	ijjs = mjs_crs(jj)
851	ijje = mje_crs(jj)
852	DO ji = nldi_crs, nlei_crs
853	ijis = mis_crs(ji)
854	ijie = mie_crs(ji)
855	p_fld_crs(ji,jj) = MAXVAL( p_fld(ijis:ijie,ijjs:ijje) * p_mask(ijis:ijie,ijjs:ijje,1) - &
856	& ( 1._wp - p_mask(ijis:ijie,ijjs:ijje,1) ) )
857	ENDDO
858	ENDDO
859
860	CASE( 'V' )
861	CALL ctl_stop('MAX operator and V case not available')
862
863	CASE( 'U' )
864	CALL ctl_stop('MAX operator and U case not available')
865
866	END SELECT
867
868	CASE ( 'MIN' ) ! Search the min of unmasked grid cells
869
870	SELECT CASE ( cd_type )
871
872	CASE( 'T', 'W' )
873
874	DO jj = nldj_crs,nlej_crs
875	ijjs = mjs_crs(jj)
876	ijje = mje_crs(jj)
877	DO ji = nldi_crs, nlei_crs
878	ijis = mis_crs(ji)
879	ijie = mie_crs(ji)
880	p_fld_crs(ji,jj) = MINVAL( p_fld(ijis:ijie,ijjs:ijje) * p_mask(ijis:ijie,ijjs:ijje,1) + &
881	& ( 1._wp - p_mask(ijis:ijie,ijjs:ijje,1) ) )
882	ENDDO
883	ENDDO
884
885	CASE( 'V' )
886	CALL ctl_stop('MIN operator and V case not available')
887
888	CASE( 'U' )
889	CALL ctl_stop('MIN operator and U case not available')
890
891	END SELECT
892	!
893	END SELECT
894	!
895	CALL crs_lbc_lnk( p_fld_crs, cd_type, psgn )
896	!
897	END SUBROUTINE crs_dom_ope_2d
898
899	SUBROUTINE crs_dom_e3( p_e1, p_e2, p_e3, p_sfc_2d_crs, p_sfc_3d_crs, cd_type, p_mask, p_e3_crs, p_e3_max_crs)
900	!!----------------------------------------------------------------
901	!!
902	!!
903	!!
904	!!
905	!!----------------------------------------------------------------
906	!! Arguments
907	CHARACTER(len=1), INTENT(in) :: cd_type ! grid type T, W ( U, V, F)
908	REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in) :: p_mask ! Parent grid T mask
909	REAL(wp), DIMENSION(jpi,jpj) , INTENT(in) :: p_e1, p_e2 ! 2D tracer T or W on parent grid
910	REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in) :: p_e3 ! 3D tracer T or W on parent grid
911	REAL(wp), DIMENSION(jpi_crs,jpj_crs) , INTENT(in),OPTIONAL :: p_sfc_2d_crs ! Coarse grid box east or north face quantity
912	REAL(wp), DIMENSION(jpi_crs,jpj_crs,jpk), INTENT(in),OPTIONAL :: p_sfc_3d_crs ! Coarse grid box east or north face quantity
913	REAL(wp), DIMENSION(jpi_crs,jpj_crs,jpk), INTENT(inout) :: p_e3_crs ! Coarse grid box east or north face quantity
914	REAL(wp), DIMENSION(jpi_crs,jpj_crs,jpk), INTENT(inout) :: p_e3_max_crs ! Coarse grid box east or north face quantity
915
916	!! Local variables
917	INTEGER :: ji, jj, jk ! dummy loop indices
918	INTEGER :: ijis, ijie, ijjs, ijje
919	REAL(wp) :: ze3crs
920
921	!!----------------------------------------------------------------
922	p_e3_crs (:,:,:) = 0._wp
923	p_e3_max_crs(:,:,:) = 0._wp
924
925
926	SELECT CASE ( cd_type )
927
928	CASE ('T')
929
930	DO jk = 1, jpk
931	DO ji = nldi_crs, nlei_crs
932
933	ijis = mis_crs(ji)
934	ijie = mie_crs(ji)
935
936	DO jj = nldj_crs, nlej_crs
937
938	ijjs = mjs_crs(jj)
939	ijje = mje_crs(jj)
940
941	p_e3_max_crs(ji,jj,jk) = MAXVAL( p_e3(ijis:ijie,ijjs:ijje,jk) * p_mask(ijis:ijie,ijjs:ijje,jk) )
942
943	ze3crs = SUM( p_e1(ijis:ijie,ijjs:ijje) * p_e2(ijis:ijie,ijjs:ijje) * p_e3(ijis:ijie,ijjs:ijje,jk) * p_mask(ijis:ijie,ijjs:ijje,jk) )
944	IF( p_sfc_3d_crs(ji,jj,jk) .NE. 0._wp )p_e3_crs(ji,jj,jk) = ze3crs / p_sfc_3d_crs(ji,jj,jk)
945
946	ENDDO
947	ENDDO
948	ENDDO
949
950	CASE ('U')
951
952	DO jk = 1, jpk
953	DO ji = nldi_crs, nlei_crs
954
955	ijis = mis_crs(ji)
956	ijie = mie_crs(ji)
957
958	DO jj = nldj_crs, nlej_crs
959
960	ijjs = mjs_crs(jj)
961	ijje = mje_crs(jj)
962
963	p_e3_max_crs(ji,jj,jk) = MAXVAL( p_e3(ijie,ijjs:ijje,jk) * p_mask(ijie,ijjs:ijje,jk) )
964
965	ze3crs = SUM( p_e2(ijie,ijjs:ijje) * p_e3(ijie,ijjs:ijje,jk) * p_mask(ijie,ijjs:ijje,jk) )
966	IF( p_sfc_2d_crs(ji,jj) .NE. 0._wp )p_e3_crs(ji,jj,jk) = ze3crs / p_sfc_2d_crs(ji,jj)
967	ENDDO
968	ENDDO
969	ENDDO
970
971	CASE ('V')
972
973	DO jk = 1, jpk
974	DO ji = nldi_crs, nlei_crs
975
976	ijis = mis_crs(ji)
977	ijie = mie_crs(ji)
978
979	DO jj = nldj_crs, nlej_crs
980
981	ijjs = mjs_crs(jj)
982	ijje = mje_crs(jj)
983
984	p_e3_max_crs(ji,jj,jk) = MAXVAL( p_e3(ijis:ijie,ijje,jk) * p_mask(ijis:ijie,ijje,jk) )
985
986	ze3crs = SUM( p_e1(ijis:ijie,ijje) * p_e3(ijis:ijie,ijje,jk) * p_mask(ijis:ijie,ijje,jk) )
987	IF( p_sfc_2d_crs(ji,jj) .NE. 0._wp )p_e3_crs(ji,jj,jk) = ze3crs / p_sfc_2d_crs(ji,jj)
988
989	ENDDO
990	ENDDO
991	ENDDO
992
993	CASE ('W')
994
995	DO jk = 1, jpk
996	DO ji = nldi_crs, nlei_crs
997
998	ijis = mis_crs(ji)
999	ijie = mie_crs(ji)
1000
1001	DO jj = nldj_crs, nlej_crs
1002
1003	ijjs = mjs_crs(jj)
1004	ijje = mje_crs(jj)
1005
1006	p_e3_max_crs(ji,jj,jk) = MAXVAL( p_e3(ijis:ijie,ijjs:ijje,jk) * p_mask(ijis:ijie,ijjs:ijje,jk) )
1007
1008	ze3crs = SUM( p_e1(ijis:ijie,ijjs:ijje) * p_e2(ijis:ijie,ijjs:ijje) * p_e3(ijis:ijie,ijjs:ijje,jk) * p_mask(ijis:ijie,ijjs:ijje,jk) )
1009	IF( p_sfc_3d_crs(ji,jj,jk) .NE. 0._wp )p_e3_crs(ji,jj,jk) = ze3crs / p_sfc_3d_crs(ji,jj,jk)
1010
1011	ENDDO
1012	ENDDO
1013	ENDDO
1014
1015	END SELECT
1016
1017	CALL crs_lbc_lnk( p_e3_max_crs, cd_type, 1.0, pval=1.0 )
1018	CALL crs_lbc_lnk( p_e3_crs , cd_type, 1.0, pval=1.0 )
1019
1020	END SUBROUTINE crs_dom_e3
1021
1022	SUBROUTINE crs_dom_sfc(p_mask, cd_type, p_surf_crs, p_surf_crs_msk, p_e1, p_e2, p_e3 )
1023	!!=========================================================================================
1024	!!
1025	!!
1026	!!=========================================================================================
1027	!! Arguments
1028	CHARACTER(len=1), INTENT(in) :: cd_type ! grid type T, W ( U, V, F)
1029	REAL(wp), DIMENSION(jpi,jpj,jpk) , INTENT(in) :: p_mask ! Parent grid T mask
1030	REAL(wp), DIMENSION(jpi,jpj) , INTENT(in), OPTIONAL :: p_e1, p_e2 ! 3D tracer T or W on parent grid
1031	REAL(wp), DIMENSION(jpi,jpj,jpk) , INTENT(in), OPTIONAL :: p_e3 ! 3D tracer T or W on parent grid
1032	REAL(wp), DIMENSION(jpi_crs,jpj_crs,jpk), INTENT(out) :: p_surf_crs ! Coarse grid box east or north face quantity
1033	REAL(wp), DIMENSION(jpi_crs,jpj_crs,jpk), INTENT(out) :: p_surf_crs_msk ! Coarse grid box east or north face quantity
1034
1035	!! Local variables
1036	INTEGER :: ji, jj, jk ! dummy loop indices
1037	INTEGER :: ijis,ijie,ijjs,ijje
1038	REAL(wp), DIMENSION(:,:,:), POINTER :: zsurf, zsurfmsk
1039	!!----------------------------------------------------------------
1040	! Initialize
1041	p_surf_crs(:,:,:)=0._wp
1042	p_surf_crs_msk(:,:,:)=0._wp
1043
1044	CALL wrk_alloc( jpi, jpj, jpk, zsurf, zsurfmsk )
1045	!
1046	SELECT CASE ( cd_type )
1047
1048	CASE ('W')
1049	DO jk = 1, jpk
1050	zsurf(:,:,jk) = p_e1(:,:) * p_e2(:,:)
1051	ENDDO
1052
1053	CASE ('V')
1054	DO jk = 1, jpk
1055	zsurf(:,:,jk) = p_e1(:,:) * p_e3(:,:,jk)
1056	ENDDO
1057
1058	CASE ('U')
1059	DO jk = 1, jpk
1060	zsurf(:,:,jk) = p_e2(:,:) * p_e3(:,:,jk)
1061	ENDDO
1062
1063	CASE DEFAULT
1064	DO jk = 1, jpk
1065	zsurf(:,:,jk) = p_e1(:,:) * p_e2(:,:)
1066	ENDDO
1067	END SELECT
1068
1069	DO jk = 1, jpk
1070	zsurfmsk(:,:,jk) = zsurf(:,:,jk) * p_mask(:,:,jk)
1071	ENDDO
1072
1073	SELECT CASE ( cd_type )
1074
1075	CASE ('W')
1076
1077	DO jk = 1, jpk
1078	DO jj = nldj_crs,nlej_crs
1079	ijjs=mjs_crs(jj)
1080	ijje=mje_crs(jj)
1081	DO ji = nldi_crs,nlei_crs
1082	ijis=mis_crs(ji)
1083	ijie=mie_crs(ji)
1084	p_surf_crs (ji,jj,jk) = SUM(zsurf (ijis:ijie,ijjs:ijje,jk) )
1085	p_surf_crs_msk(ji,jj,jk) = SUM(zsurfmsk(ijis:ijie,ijjs:ijje,jk) )
1086	ENDDO
1087	ENDDO
1088	ENDDO
1089
1090	CASE ('U')
1091
1092	DO jk = 1, jpk
1093	DO jj = nldj_crs,nlej_crs
1094	ijjs=mjs_crs(jj)
1095	ijje=mje_crs(jj)
1096	DO ji = nldi_crs,nlei_crs
1097	ijis=mis_crs(ji)
1098	ijie=mie_crs(ji)
1099	p_surf_crs (ji,jj,jk) = SUM(zsurf (ijie,ijjs:ijje,jk) )
1100	p_surf_crs_msk(ji,jj,jk) = SUM(zsurfmsk(ijie,ijjs:ijje,jk) )
1101	ENDDO
1102	ENDDO
1103	ENDDO
1104
1105	CASE ('V')
1106
1107	DO jk = 1, jpk
1108	DO jj = nldj_crs,nlej_crs
1109	ijjs=mjs_crs(jj)
1110	ijje=mje_crs(jj)
1111	DO ji = nldi_crs,nlei_crs
1112	ijis=mis_crs(ji)
1113	ijie=mie_crs(ji)
1114	p_surf_crs (ji,jj,jk) = SUM(zsurf (ijis:ijie,ijje,jk) )
1115	p_surf_crs_msk(ji,jj,jk) = SUM(zsurfmsk(ijis:ijie,ijje,jk) )
1116	ENDDO
1117	ENDDO
1118	ENDDO
1119
1120	END SELECT
1121
1122	CALL crs_lbc_lnk( p_surf_crs , cd_type, 1.0 ) !cbr , pval=1.0 )
1123	CALL crs_lbc_lnk( p_surf_crs_msk, cd_type, 1.0 ) !cbr , pval=1.0 )
1124
1125	CALL wrk_dealloc( jpi, jpj, jpk, zsurf, zsurfmsk )
1126
1127	END SUBROUTINE crs_dom_sfc
1128
1129	SUBROUTINE crs_dom_def
1130	!!----------------------------------------------------------------
1131	!! * SUBROUTINE crs_dom_def *
1132	!! ** Purpose : Three applications.
1133	!! 1) Define global domain indice of the croasening grid
1134	!! 2) Define local domain indice of the croasening grid
1135	!! 3) Define the processor domain indice for a croasening grid
1136	!!----------------------------------------------------------------
1137	!!
1138	!! local variables
1139
1140	INTEGER :: ji,jj,jk,ijjgloT,ijis,ijie,ijjs,ijje,jn ! dummy indices
1141	INTEGER :: ierr ! allocation error status
1142	INTEGER :: iproci,iprocj,iproc,iprocno,iprocso,iimppt_crs
1143	INTEGER :: ii_start,ii_end,ij_start,ij_end
1144
1145
1146	! 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
1147	jpiglo_crs = INT( (jpiglo - 2) / nn_factx ) + 2
1148	! jpjglo_crs = INT( (jpjglo - 2) / nn_facty ) + 2 ! the -2 removes j=1, j=jpj
1149	! jpjglo_crs = INT( (jpjglo - 2) / nn_facty ) + 3
1150	jpjglo_crs = INT( (jpjglo - MOD(jpjglo, nn_facty)) / nn_facty ) + 2
1151	jpiglo_crsm1 = jpiglo_crs - 1
1152	jpjglo_crsm1 = jpjglo_crs - 1
1153
1154	jpi_crs = ( jpiglo_crs - 2 * jpreci + (jpni-1) ) / jpni + 2 * jpreci
1155	jpj_crs = ( jpjglo_crsm1 - 2 * jprecj + (jpnj-1) ) / jpnj + 2 * jprecj
1156	!cbr? IF( njmpp==1 )THEN
1157	! jpj_crs=jpj_crs+1
1158	! ENDIF
1159
1160
1161	jpi_crsm1 = jpi_crs - 1
1162	jpj_crsm1 = jpj_crs - 1
1163	nperio_crs = jperio
1164	npolj_crs = npolj
1165
1166	ierr = crs_dom_alloc() ! allocate most coarse grid arrays
1167
1168	! 2.a Define processor domain
1169	IF( .NOT. lk_mpp ) THEN
1170	nimpp_crs = 1
1171	njmpp_crs = 1
1172	nlci_crs = jpi_crs
1173	nlcj_crs = jpj_crs
1174	nldi_crs = 1
1175	nldj_crs = 1
1176	nlei_crs = jpi_crs
1177	nlej_crs = jpj_crs
1178	ELSE
1179	! Initialisation of most local variables -
1180	nimpp_crs = 1
1181	njmpp_crs = 1
1182	nlci_crs = jpi_crs
1183	nlcj_crs = jpj_crs
1184	nldi_crs = 1
1185	nldj_crs = 1
1186	nlei_crs = jpi_crs
1187	nlej_crs = jpj_crs
1188
1189	!==============================================================================================
1190	! mpp_ini2
1191	!==============================================================================================
1192	DO ji = 1 , jpni
1193	DO jj = 1 ,jpnj
1194	IF( nfipproc(ji,jj) == narea-1 )THEN
1195	iproci=ji
1196	iprocj=jj
1197	ENDIF
1198	ENDDO
1199	ENDDO
1200
1201	!WRITE(narea+8000-1,*)"nfipproc(ji,jj),narea :",nfipproc(iproci,iprocj),narea
1202	!WRITE(narea+8000-1,*)"proc i,j ",iproci,iprocj
1203	!WRITE(narea+8000-1,*)"nowe noea",nowe,noea
1204	!WRITE(narea+8000-1,*)"noso nono",noso,nono
1205	!WRITE(narea+8000-1,*)"nbondi nbondj ",nbondi,nbondj
1206	!WRITE(narea+8000-1,*)"jpiglo jpjglo ",jpiglo,jpjglo
1207	!WRITE(narea+8000-1,*)"jpi jpj ",jpi,jpj
1208	!WRITE(narea+8000-1,*)"nbondi nbondj",nbondi,nbondj
1209	!WRITE(narea+8000-1,*)"nimpp njmpp ",nimpp,njmpp
1210	!WRITE(narea+8000-1,*)"loc jpi nldi,nlei,nlci ",jpi, nldi ,nlei ,nlci
1211	!WRITE(narea+8000-1,*)"glo jpi nldi,nlei ",jpi, nldi+nimpp-1,nlei+nimpp-1
1212	!WRITE(narea+8000-1,*)"loc jpj nldj,nlej,nlcj ",jpj, nldj ,nlej ,nlcj
1213	!WRITE(narea+8000-1,*)"glo jpj nldj,nlej ",jpj, nldj+njmpp-1,nlej+njmpp-1
1214	!WRITE(narea+8000-1,*)"jpiglo_crs jpjglo_crs ",jpiglo_crs,jpjglo_crs
1215	!WRITE(narea+8000-1,*)"jpi_crs jpj_crs ",jpi_crs,jpj_crs
1216	!WRITE(narea+8000-1,*)"jpni jpnj jpnij ",jpni,jpnj,jpnij
1217	!WRITE(narea+8000-1,*)"glamt gphit ",glamt(1,1),gphit(jpi,jpj),glamt(jpi,jpj),gphit(jpi,jpj)
1218	!==========================================================================
1219	! dim along I
1220	!==========================================================================
1221	SELECT CASE ( nperio )
1222	CASE ( 0, 1, 3, 4 ) ! 3, 4 : T-Pivot at North Fold
1223
1224	DO ji=1,jpiglo_crs
1225	ijis=nn_factx*(ji-1)-2
1226	ijie=nn_factx*(ji-1)
1227	mis2_crs(ji)=ijis
1228	mie2_crs(ji)=ijie
1229	ENDDO
1230
1231	ji=1
1232	DO WHILE( mis2_crs(ji) - nimpp + 1 .LT. 1 )
1233	ji=ji+1
1234	IF( ji==jpiglo_crs )EXIT
1235	END DO
1236	ijis=ji
1237
1238	!mjs2_crs(ijis)=indice global ds la grille no crs de la premiere maille du premier pavé contenu ds le domaine intérieur
1239	!ijis =indice global ds la grille crs de la premire maille qui est ds le domaine intérieur
1240	!ii_start =indice local de mjs2_crs(jj)
1241	ii_start = mis2_crs(ijis)-nimpp+1
1242	nimpp_crs = ijis-1
1243
1244	nldi_crs = 2
1245	IF( nowe == -1 )THEN
1246
1247	mie2_crs(ijis-1) = mis2_crs(ijis)-1
1248
1249	SELECT CASE(ii_start)
1250	CASE(1)
1251	nldi_crs=2
1252	mie2_crs(ijis-1) = -1
1253	mis2_crs(ijis-1) = -1
1254	CASE(2)
1255	!CBR? nldi_crs=1
1256	nldi_crs=2
1257	mis2_crs(ijis-1) = mie2_crs(ijis-1)
1258	CASE(3)
1259	!CBR? nldi_crs=1
1260	nldi_crs=2
1261	mis2_crs(ijis-1) = mie2_crs(ijis-1) -1
1262	CASE DEFAULT
1263	WRITE(narea+8000-1,*)"WRONG VALUE FOR iistart ",ii_start
1264	END SELECT
1265
1266	ENDIF
1267
1268	IF( nimpp==1 )nimpp_crs=1
1269
1270	!----------------------------------------
1271	ji=jpiglo_crs
1272	DO WHILE( mie2_crs(ji) - nimpp + 1 .GT. jpi )
1273	ji=ji-1
1274	IF( ji==1 )EXIT
1275	END DO
1276	ijie=ji
1277	nlei_crs=ijie-nimpp_crs+1
1278	nlci_crs=nlei_crs+jpreci
1279
1280	!----------------------------------------
1281	DO ji = 1, jpi_crs
1282	mig_crs(ji) = ji + nimpp_crs - 1
1283	ENDDO
1284	DO ji = 1, jpiglo_crs
1285	mi0_crs(ji) = MAX( 1, MIN( ji - nimpp_crs + 1 , jpi_crs + 1 ) )
1286	mi1_crs(ji) = MAX( 0, MIN( ji - nimpp_crs + 1 , jpi_crs ) )
1287	ENDDO
1288
1289	!----------------------------------------
1290	DO ji = 1, nlei_crs
1291	mis_crs(ji) = mis2_crs(mig_crs(ji)) - nimpp + 1
1292	mie_crs(ji) = mie2_crs(mig_crs(ji)) - nimpp + 1
1293	nfactx(ji) = mie_crs(ji)-mie_crs(ji)+1
1294	ENDDO
1295
1296	IF( iproci == jpni )THEN
1297	nlei_crs=nlci_crs
1298	mis_crs(nlei_crs)=mis_crs(nlei_crs-1)
1299	mie_crs(nlei_crs)=mie_crs(nlei_crs-1)
1300	ENDIF
1301
1302	!----------------------------------------
1303
1304	CASE DEFAULT
1305	WRITE(numout,*) 'crs_init. Only jperio = 0, 1, 3, 4 supported'
1306	END SELECT
1307
1308	!==========================================================================
1309	! dim along J
1310	!==========================================================================
1311	SELECT CASE ( nperio )
1312	CASE ( 0, 1, 3, 4 ) ! 3, 4 : T-Pivot at North Fold
1313
1314	DO jj=1,jpjglo_crs
1315	ijjs=nn_facty*(jj)-5
1316	ijje=nn_facty*(jj)-3
1317	mjs2_crs(jj)=ijjs
1318	mje2_crs(jj)=ijje
1319	ENDDO
1320
1321	jj=1
1322	DO WHILE( mjs2_crs(jj) - njmpp + 1 .LT. 1 )
1323	jj=jj+1
1324	IF( jj==jpjglo_crs )EXIT
1325	END DO
1326	ijjs=jj
1327
1328	!mjs2_crs(jj)=indice global ds la grille no crs de la premiere maille du premier pavé contenu ds le domaine intérieur
1329	!ijjs =indice global ds la grille crs de la premire maille qui est ds le domaine intérieur
1330	!ij_start =indice local de mjs2_crs(jj)
1331	ij_start = mjs2_crs(ijjs)-njmpp+1
1332	njmpp_crs = ijjs-1
1333
1334	nldj_crs = 2
1335	IF( noso == -1 )THEN
1336
1337	mje2_crs(ijjs-1) = mjs2_crs(ijjs)-1
1338
1339	SELECT CASE(ij_start)
1340	CASE(1)
1341	nldj_crs=2
1342	mje2_crs(ijjs-1) = -1
1343	mjs2_crs(ijjs-1) = -1
1344	CASE(2)
1345	!CBR? nldj_crs=1
1346	nldj_crs=2
1347	mjs2_crs(ijjs-1) = mje2_crs(ijjs-1)
1348	CASE(3)
1349	!CBR? nldj_crs=1
1350	nldj_crs=2
1351	mjs2_crs(ijjs-1) = mje2_crs(ijjs-1) -1
1352	CASE DEFAULT
1353	WRITE(narea+8000-1,*)"WRONG VALUE FOR iistart ",ii_start
1354	END SELECT
1355
1356	ENDIF
1357	IF( njmpp==1 )njmpp_crs=1
1358
1359
1360	!----------------------------------------
1361	jj=jpjglo_crs
1362	DO WHILE( mje2_crs(jj) - njmpp + 1 .GT. nlcj )
1363	jj=jj-1
1364	IF( jj==1 )EXIT
1365	END DO
1366	ijje=jj
1367
1368	nlej_crs=ijje-njmpp_crs+1
1369
1370	!----------------------------------------
1371	nlcj_crs=nlej_crs+jprecj
1372	IF( iprocj == jpnj )THEN
1373	nlej_crs=jpj_crs ! cbr -1 ????????????????????
1374	nlcj_crs=nlej_crs
1375	ENDIF
1376
1377	!----------------------------------------
1378	DO jj = 1, jpj_crs
1379	mjg_crs(jj) = jj + njmpp_crs - 1
1380	ENDDO
1381	DO jj = 1, jpjglo_crs
1382	mj0_crs(jj) = MAX( 1, MIN( jj - njmpp_crs + 1 , jpj_crs + 1 ) )
1383	mj1_crs(jj) = MAX( 0, MIN( jj - njmpp_crs + 1 , jpj_crs ) )
1384	ENDDO
1385
1386	!----------------------------------------
1387	DO jj = 1, nlej_crs
1388	mjs_crs(jj) = mjs2_crs(mjg_crs(jj)) - njmpp + 1
1389	mje_crs(jj) = mje2_crs(mjg_crs(jj)) - njmpp + 1
1390	nfacty(jj) = mje_crs(jj)-mje_crs(jj)+1
1391	ENDDO
1392
1393	IF( iprocj == jpnj )THEN
1394	mjs_crs(nlej_crs)=mjs_crs(nlej_crs-1)
1395	mje_crs(nlej_crs)=mje_crs(nlej_crs-1)
1396	ENDIF
1397
1398	!----------------------------------------
1399
1400	CASE DEFAULT
1401	WRITE(numout,*) 'crs_init. Only jperio = 0, 1, 3, 4 supported'
1402	END SELECT
1403
1404	!==========================================================================
1405	IF( nlci_crs .GT. jpi_crs .OR. nlei_crs .GT. jpi_crs )WRITE(narea+8000-1,*)"BUGDIM ",nlei_crs,nlci_crs,jpi_crs; CALL FLUSH(narea+8000-1)
1406	IF( nlcj_crs .GT. jpj_crs .OR. nlej_crs .GT. jpj_crs )WRITE(narea+8000-1,*)"BUGDIM ",nlej_crs,nlcj_crs,jpj_crs; CALL FLUSH(narea+8000-1)
1407	!==========================================================================
1408
1409	nldit_crs(:)=0 ; nleit_crs(:)=0 ; nlcit_crs(:)=0 ; nimppt_crs(:)=0
1410	nldjt_crs(:)=0 ; nlejt_crs(:)=0 ; nlcjt_crs(:)=0 ; njmppt_crs(:)=0
1411
1412	CALL mppgatheri((/nlci_crs/),0,nlcit_crs) ; CALL mppgatheri((/nlcj_crs/),0,nlcjt_crs)
1413	CALL mppgatheri((/nldi_crs/),0,nldit_crs) ; CALL mppgatheri((/nldj_crs/),0,nldjt_crs)
1414	CALL mppgatheri((/nlei_crs/),0,nleit_crs) ; CALL mppgatheri((/nlej_crs/),0,nlejt_crs)
1415	CALL mppgatheri((/nimpp_crs/),0,nimppt_crs) ; CALL mppgatheri((/njmpp_crs/),0,njmppt_crs)
1416
1417	DO jj = 1 ,jpnj
1418	DO ji = 1 , jpni
1419	jn=nfipproc(ji,jj)+1
1420	IF( jn .GE. 1 )THEN
1421	nfiimpp_crs(ji,jj)=nimppt_crs(jn)
1422	ELSE
1423	nfiimpp_crs(ji,jj) = ANINT( REAL( (nfiimpp(ji,jj) + 1 ) / nn_factx, wp ) ) + 1
1424	ENDIF
1425	ENDDO
1426	ENDDO
1427
1428	!nogather=T
1429	nfsloop_crs = 1
1430	nfeloop_crs = nlci_crs
1431	DO jn = 2,jpni-1
1432	IF(nfipproc(jn,jpnj) .eq. (narea - 1)) THEN
1433	IF (nfipproc(jn - 1 ,jpnj) .eq. -1) THEN
1434	nfsloop_crs = nldi_crs
1435	ENDIF
1436	IF (nfipproc(jn + 1,jpnj) .eq. -1) THEN
1437	nfeloop_crs = nlei_crs
1438	ENDIF
1439	ENDIF
1440	END DO
1441
1442	!WRITE(narea+8000-1,*)"loc crs jpi nldi,nlei,nlci ",jpi_crs, nldi_crs ,nlei_crs ,nlci_crs
1443	!WRITE(narea+8000-1,*)"glo crs jpi nldi,nlei ",jpi_crs, nldi_crs+nimpp_crs-1,nlei_crs+nimpp_crs-1
1444	!WRITE(narea+8000-1,*)"loc crs jpj nldj,nlej,nlcj ",jpj_crs, nldj_crs ,nlej_crs ,nlcj_crs
1445	!WRITE(narea+8000-1,*)"glo crs jpj nldj,nlej ",jpj_crs, nldj_crs+njmpp_crs-1,nlej_crs+njmpp_crs-1
1446	!==============================================================================================
1447	IF( jpizoom /= 1 .OR. jpjzoom /= 1) STOP
1448
1449	! Save the parent grid information
1450	jpi_full = jpi
1451	jpj_full = jpj
1452	jpim1_full = jpim1
1453	jpjm1_full = jpjm1
1454	nperio_full = nperio
1455
1456	npolj_full = npolj
1457	jpiglo_full = jpiglo
1458	jpjglo_full = jpjglo
1459
1460	nlcj_full = nlcj
1461	nlci_full = nlci
1462	nldi_full = nldi
1463	nldj_full = nldj
1464	nlei_full = nlei
1465	nlej_full = nlej
1466	nimpp_full = nimpp
1467	njmpp_full = njmpp
1468
1469	nlcit_full(:) = nlcit(:)
1470	nldit_full(:) = nldit(:)
1471	nleit_full(:) = nleit(:)
1472	nimppt_full(:) = nimppt(:)
1473	nlcjt_full(:) = nlcjt(:)
1474	nldjt_full(:) = nldjt(:)
1475	nlejt_full(:) = nlejt(:)
1476	njmppt_full(:) = njmppt(:)
1477
1478	nfsloop_full = nfsloop
1479	nfeloop_full = nfeloop
1480
1481	nfiimpp_full(:,:) = nfiimpp(:,:)
1482
1483
1484	CALL dom_grid_crs !swich de grille
1485
1486
1487	IF(lwp) THEN
1488	WRITE(numout,*)
1489	WRITE(numout,*) 'crs_init : coarse grid dimensions'
1490	WRITE(numout,*) '~~~~~~~ coarse domain global j-dimension jpjglo = ', jpjglo
1491	WRITE(numout,*) '~~~~~~~ coarse domain global i-dimension jpiglo = ', jpiglo
1492	WRITE(numout,*) '~~~~~~~ coarse domain local i-dimension jpi = ', jpi
1493	WRITE(numout,*) '~~~~~~~ coarse domain local j-dimension jpj = ', jpj
1494	WRITE(numout,*)
1495	WRITE(numout,*) ' nproc = ' , nproc
1496	WRITE(numout,*) ' nlci = ' , nlci
1497	WRITE(numout,*) ' nlcj = ' , nlcj
1498	WRITE(numout,*) ' nldi = ' , nldi
1499	WRITE(numout,*) ' nldj = ' , nldj
1500	WRITE(numout,*) ' nlei = ' , nlei
1501	WRITE(numout,*) ' nlej = ' , nlej
1502	WRITE(numout,*) ' nlei_full=' , nlei_full
1503	WRITE(numout,*) ' nldi_full=' , nldi_full
1504	WRITE(numout,*) ' nimpp = ' , nimpp
1505	WRITE(numout,*) ' njmpp = ' , njmpp
1506	WRITE(numout,*) ' njmpp_full = ', njmpp_full
1507	WRITE(numout,*)
1508	ENDIF
1509
1510	CALL dom_grid_glo
1511
1512	mxbinctr = INT( nn_factx * 0.5 )
1513	mybinctr = INT( nn_facty * 0.5 )
1514
1515	nrestx = MOD( nn_factx, 2 ) ! check if even- or odd- numbered reduction factor
1516	nresty = MOD( nn_facty, 2 )
1517
1518	IF ( nrestx == 0 ) THEN
1519	mxbinctr = mxbinctr - 1
1520	ENDIF
1521
1522	IF ( nresty == 0 ) THEN
1523	mybinctr = mybinctr - 1
1524	IF ( jperio == 3 .OR. jperio == 4 ) nperio_crs = jperio + 2
1525	IF ( jperio == 5 .OR. jperio == 6 ) nperio_crs = jperio - 2
1526
1527	IF ( npolj == 3 ) npolj_crs = 5
1528	IF ( npolj == 5 ) npolj_crs = 3
1529	ENDIF
1530
1531	rfactxy = nn_factx * nn_facty
1532
1533	ENDIF
1534	!
1535	nistr = mis_crs(2) ; niend = mis_crs(nlci_crs - 1)
1536	njstr = mjs_crs(3) ; njend = mjs_crs(nlcj_crs - 1)
1537	!
1538	!
1539	END SUBROUTINE crs_dom_def
1540
1541	SUBROUTINE crs_dom_bat
1542	!!----------------------------------------------------------------
1543	!! * SUBROUTINE crs_dom_bat *
1544	!! ** Purpose : coarsenig bathy
1545	!!----------------------------------------------------------------
1546	!!
1547	!! local variables
1548	INTEGER :: ji,jj,jk ! dummy indices
1549	REAL(wp), DIMENSION(:,:) , POINTER :: zmbk
1550	!!----------------------------------------------------------------
1551
1552	CALL wrk_alloc( jpi_crs, jpj_crs, zmbk )
1553
1554	mbathy_crs(:,:) = jpkm1
1555	mbkt_crs(:,:) = 1
1556	mbku_crs(:,:) = 1
1557	mbkv_crs(:,:) = 1
1558
1559
1560	DO jj = 1, jpj_crs
1561	DO ji = 1, jpi_crs
1562	jk = 0
1563	DO WHILE( tmask_crs(ji,jj,jk+1) > 0.)
1564	jk = jk + 1
1565	ENDDO
1566	mbathy_crs(ji,jj) = float( jk )
1567	ENDDO
1568	ENDDO
1569
1570	CALL wrk_alloc( jpi_crs, jpj_crs, zmbk )
1571
1572	zmbk(:,:) = 0.0
1573	zmbk(:,:) = REAL( mbathy_crs(:,:), wp ) ; CALL crs_lbc_lnk(zmbk,'T',1.0) ; mbathy_crs(:,:) = INT( zmbk(:,:) )
1574
1575
1576	!
1577	IF(lwp) WRITE(numout,*)
1578	IF(lwp) WRITE(numout,*) ' crsini : mbkt is ocean bottom k-index of T-, U-, V- and W-levels '
1579	IF(lwp) WRITE(numout,*) ' ~~~~~~~~~~~~~'
1580	!
1581	mbkt_crs(:,:) = MAX( mbathy_crs(:,:) , 1 ) ! bottom k-index of T-level (=1 over land)
1582	! ! bottom k-index of W-level = mbkt+1
1583
1584	DO jj = 1, jpj_crsm1 ! bottom k-index of u- (v-) level
1585	DO ji = 1, jpi_crsm1
1586	mbku_crs(ji,jj) = MIN( mbkt_crs(ji+1,jj ) , mbkt_crs(ji,jj) )
1587	mbkv_crs(ji,jj) = MIN( mbkt_crs(ji ,jj+1) , mbkt_crs(ji,jj) )
1588	END DO
1589	END DO
1590
1591	! convert into REAL to use lbc_lnk ; impose a min value of 1 as a zero can be set in lbclnk
1592	zmbk(:,:) = 1.e0;
1593	zmbk(:,:) = REAL( mbku_crs(:,:), wp ) ; CALL crs_lbc_lnk(zmbk,'U',1.0) ; mbku_crs (:,:) = MAX( INT( zmbk(:,:) ), 1 )
1594	zmbk(:,:) = REAL( mbkv_crs(:,:), wp ) ; CALL crs_lbc_lnk(zmbk,'V',1.0) ; mbkv_crs (:,:) = MAX( INT( zmbk(:,:) ), 1 )
1595	!
1596	CALL wrk_dealloc( jpi_crs, jpj_crs, zmbk )
1597	!
1598	END SUBROUTINE crs_dom_bat
1599
1600	SUBROUTINE PIKSRT(N,ARR)
1601	INTEGER ,INTENT(IN) :: N
1602	REAL(kind=8),DIMENSION(N),INTENT(INOUT) :: ARR
1603
1604	INTEGER :: i,j
1605	REAL(kind=8) :: a
1606	!!----------------------------------------------------------------
1607
1608	DO j=2, N
1609	a=ARR(j)
1610	DO i=j-1,1,-1
1611	IF(ARR(i)<=a) goto 10
1612	ARR(i+1)=ARR(i)
1613	ENDDO
1614	i=0
1615	10 ARR(i+1)=a
1616	ENDDO
1617	RETURN
1618
1619	END SUBROUTINE PIKSRT
1620
1621
1622	END MODULE crsdom

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

Download in other formats: