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 @ 7204

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

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

Download in other formats: