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

Last change on this file since 7210 was 7210, checked in by cbricaud, 7 years ago
commit modification in CRS branch
Property svn:keywords set to `Id`
File size: 65.8 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,*)"jpni jpnj ",jpni,jpnj
1204	WRITE(narea+8000-1,*)"nowe noea",nowe,noea
1205	WRITE(narea+8000-1,*)"noso nono",noso,nono
1206	WRITE(narea+8000-1,*)"nbondi nbondj ",nbondi,nbondj
1207	WRITE(narea+8000-1,*)"jpiglo jpjglo ",jpiglo,jpjglo
1208	WRITE(narea+8000-1,*)"jpi jpj ",jpi,jpj
1209	WRITE(narea+8000-1,*)"nbondi nbondj",nbondi,nbondj
1210	WRITE(narea+8000-1,*)"nimpp njmpp ",nimpp,njmpp
1211	WRITE(narea+8000-1,*)"loc jpi nldi,nlei,nlci ",jpi, nldi ,nlei ,nlci
1212	WRITE(narea+8000-1,*)"glo jpi nldi,nlei ",jpi, nldi+nimpp-1,nlei+nimpp-1
1213	WRITE(narea+8000-1,*)"loc jpj nldj,nlej,nlcj ",jpj, nldj ,nlej ,nlcj
1214	WRITE(narea+8000-1,*)"glo jpj nldj,nlej ",jpj, nldj+njmpp-1,nlej+njmpp-1
1215	WRITE(narea+8000-1,*)"jpiglo_crs jpjglo_crs ",jpiglo_crs,jpjglo_crs
1216	WRITE(narea+8000-1,*)"jpi_crs jpj_crs ",jpi_crs,jpj_crs
1217	WRITE(narea+8000-1,*)"jpni jpnj jpnij ",jpni,jpnj,jpnij
1218	WRITE(narea+8000-1,*)"glamt gphit ",glamt(1,1),gphit(jpi,jpj),glamt(jpi,jpj),gphit(jpi,jpj)
1219	!==========================================================================
1220	! dim along I
1221	!==========================================================================
1222	SELECT CASE ( nperio )
1223	CASE ( 0, 1, 3, 4 ) ! 3, 4 : T-Pivot at North Fold
1224
1225	DO ji=1,jpiglo_crs
1226	ijis=nn_factx*(ji-1)-2
1227	ijie=nn_factx*(ji-1)
1228	mis2_crs(ji)=ijis
1229	mie2_crs(ji)=ijie
1230	WRITE(narea+8000-1,*)"ji",ji,mis2_crs(ji),mie2_crs(ji),mis2_crs(ji)-nimpp+1,mie2_crs(ji)-nimpp+1
1231	ENDDO
1232
1233	ji=1
1234	DO WHILE( mis2_crs(ji) - nimpp + 1 .LT. 1 )
1235	ji=ji+1
1236	IF( ji==jpiglo_crs )EXIT
1237	END DO
1238	ijis=ji
1239
1240	!mjs2_crs(ijis)=indice global ds la grille no crs de la premiere maille du premier pavé contenu ds le domaine intérieur
1241	!ijis =indice global ds la grille crs de la premire maille qui est ds le domaine intérieur
1242	!ii_start =indice local de mjs2_crs(jj)
1243	ii_start = mis2_crs(ijis)-nimpp+1
1244	nimpp_crs = ijis-1
1245	WRITE(narea+8000-1,*)"ii_start = ",ii_start , mis2_crs(ijis), nimpp
1246
1247	nldi_crs = 2
1248	IF( nowe == -1 )THEN
1249
1250	mie2_crs(ijis-1) = mis2_crs(ijis)-1
1251
1252	SELECT CASE(ii_start)
1253	CASE(1)
1254	nldi_crs=2
1255	mie2_crs(ijis-1) = -1
1256	mis2_crs(ijis-1) = -1
1257	CASE(2)
1258	!CBR? nldi_crs=1
1259	nldi_crs=2
1260	mis2_crs(ijis-1) = mie2_crs(ijis-1)
1261	CASE(3)
1262	!CBR? nldi_crs=1
1263	nldi_crs=2
1264	mis2_crs(ijis-1) = mie2_crs(ijis-1) -1
1265	CASE DEFAULT
1266	WRITE(narea+8000-1,*)"WRONG VALUE FOR iistart ",ii_start
1267	END SELECT
1268
1269	ENDIF
1270
1271	IF( nimpp==1 )nimpp_crs=1
1272
1273	IF( iproci == 1 )THEN
1274	nldi_crs=1
1275	nimpp_crs=1
1276	ENDIF
1277
1278	!----------------------------------------
1279	ji=jpiglo_crs
1280	DO WHILE( mie2_crs(ji) - nimpp + 1 .GT. nlci )
1281	ji=ji-1
1282	IF( ji==1 )EXIT
1283	END DO
1284	WRITE(narea+8000-1,*)"=> mie2_crs ",ji,mie2_crs(ji), mie2_crs(ji) - nimpp + 1
1285	ijie=ji
1286	nlei_crs=ijie-nimpp_crs+1
1287	nlci_crs=nlei_crs+jpreci
1288
1289	!----------------------------------------
1290	DO ji = 1, jpi_crs
1291	mig_crs(ji) = ji + nimpp_crs - 1
1292	ENDDO
1293	DO ji = 1, jpiglo_crs
1294	mi0_crs(ji) = MAX( 1, MIN( ji - nimpp_crs + 1 , jpi_crs + 1 ) )
1295	mi1_crs(ji) = MAX( 0, MIN( ji - nimpp_crs + 1 , jpi_crs ) )
1296	ENDDO
1297
1298	!----------------------------------------
1299	DO ji = 1, nlei_crs
1300	mis_crs(ji) = mis2_crs(mig_crs(ji)) - nimpp + 1
1301	mie_crs(ji) = mie2_crs(mig_crs(ji)) - nimpp + 1
1302	nfactx(ji) = mie_crs(ji)-mis_crs(ji)+1
1303	ENDDO
1304
1305	IF( iproci == jpni )THEN
1306	nlei_crs=nlci_crs
1307	ji=nlei_crs
1308	mis_crs(ji) = mis2_crs(mig_crs(ji)) - nimpp + 1
1309	mie_crs(ji) = nlei
1310	mie2_crs(mig_crs(ji)) = nlei + nimpp -1
1311	nfactx(ji) = mie_crs(ji)-mis_crs(ji)+1
1312	ENDIF
1313
1314	DO ji = 1, nlei_crs
1315	WRITE(narea+8000-1,'(A4,7(1X,I4))')"loc ",ji,mig_crs(ji),mis2_crs(mig_crs(ji)),mie2_crs(mig_crs(ji)),mis_crs(ji),mie_crs(ji),nfactx(ji)
1316	ENDDO
1317
1318	!----------------------------------------
1319
1320	CASE DEFAULT
1321	WRITE(numout,*) 'crs_init. Only jperio = 0, 1, 3, 4 supported'
1322	END SELECT
1323
1324	!==========================================================================
1325	! dim along J
1326	!==========================================================================
1327	SELECT CASE ( nperio )
1328	CASE ( 0, 1, 3, 4 ) ! 3, 4 : T-Pivot at North Fold
1329
1330	DO jj=1,jpjglo_crs
1331	ijjs=nn_facty*(jj)-5
1332	ijje=nn_facty*(jj)-3
1333	mjs2_crs(jj)=ijjs
1334	mje2_crs(jj)=ijje
1335	ENDDO
1336
1337	jj=1
1338	DO WHILE( mjs2_crs(jj) - njmpp + 1 .LT. 1 )
1339	jj=jj+1
1340	IF( jj==jpjglo_crs )EXIT
1341	END DO
1342	ijjs=jj
1343
1344	!mjs2_crs(jj)=indice global ds la grille no crs de la premiere maille du premier pavé contenu ds le domaine intérieur
1345	!ijjs =indice global ds la grille crs de la premire maille qui est ds le domaine intérieur
1346	!ij_start =indice local de mjs2_crs(jj)
1347	ij_start = mjs2_crs(ijjs)-njmpp+1
1348	njmpp_crs = ijjs-1
1349
1350	nldj_crs = 2
1351	IF( noso == -1 )THEN
1352
1353	mje2_crs(ijjs-1) = mjs2_crs(ijjs)-1
1354
1355	SELECT CASE(ij_start)
1356	CASE(1)
1357	nldj_crs=2
1358	mje2_crs(ijjs-1) = -1
1359	mjs2_crs(ijjs-1) = -1
1360	CASE(2)
1361	!CBR? nldj_crs=1
1362	nldj_crs=2
1363	mjs2_crs(ijjs-1) = mje2_crs(ijjs-1)
1364	CASE(3)
1365	!CBR? nldj_crs=1
1366	nldj_crs=2
1367	mjs2_crs(ijjs-1) = mje2_crs(ijjs-1) -1
1368	CASE DEFAULT
1369	WRITE(narea+8000-1,*)"WRONG VALUE FOR iistart ",ii_start
1370	END SELECT
1371
1372	ENDIF
1373	IF( njmpp==1 )njmpp_crs=1
1374
1375
1376	!----------------------------------------
1377	jj=jpjglo_crs
1378	DO WHILE( mje2_crs(jj) - njmpp + 1 .GT. nlcj )
1379	jj=jj-1
1380	IF( jj==1 )EXIT
1381	END DO
1382	ijje=jj
1383
1384	nlej_crs=ijje-njmpp_crs+1
1385
1386	!----------------------------------------
1387	nlcj_crs=nlej_crs+jprecj
1388	IF( iprocj == jpnj )THEN
1389	nlej_crs=jpj_crs ! cbr -1 ????????????????????
1390	nlcj_crs=nlej_crs
1391	ENDIF
1392
1393	!----------------------------------------
1394	DO jj = 1, jpj_crs
1395	mjg_crs(jj) = jj + njmpp_crs - 1
1396	ENDDO
1397	DO jj = 1, jpjglo_crs
1398	mj0_crs(jj) = MAX( 1, MIN( jj - njmpp_crs + 1 , jpj_crs + 1 ) )
1399	mj1_crs(jj) = MAX( 0, MIN( jj - njmpp_crs + 1 , jpj_crs ) )
1400	ENDDO
1401
1402	!----------------------------------------
1403	DO jj = 1, nlej_crs
1404	mjs_crs(jj) = mjs2_crs(mjg_crs(jj)) - njmpp + 1
1405	mje_crs(jj) = mje2_crs(mjg_crs(jj)) - njmpp + 1
1406	nfacty(jj) = mje_crs(jj)-mjs_crs(jj)+1
1407	ENDDO
1408	IF( nono==-1 )THEn
1409	nlej_crs = nlcj_crs
1410	mjs_crs(nlej_crs) = mjs2_crs(mjg_crs(nlej_crs)) - njmpp + 1
1411	mje_crs(nlej_crs) = nlcj
1412	nfacty(jj) = mje_crs(jj)-mjs_crs(jj)+1
1413	ENDIF
1414
1415	IF( iprocj == jpnj )THEN
1416	mjs_crs(nlej_crs) = mjs_crs(nlej_crs-1)
1417	mje_crs(nlej_crs) = mje_crs(nlej_crs-1)
1418	nfacty(nlej_crs) = mje_crs(nlej_crs)-mjs_crs(nlej_crs)+1
1419	ENDIF
1420
1421	DO jj = 1, nlej_crs
1422	WRITE(narea+8000-1,'(A4,7(1X,I4))')"loc ",jj,mjg_crs(jj),mjs2_crs(mjg_crs(jj)),mje2_crs(mjg_crs(jj)),mjs_crs(jj),mje_crs(jj),nfacty(jj)
1423	ENDDO
1424	!----------------------------------------
1425
1426	CASE DEFAULT
1427	WRITE(numout,*) 'crs_init. Only jperio = 0, 1, 3, 4 supported'
1428	END SELECT
1429
1430	!==========================================================================
1431	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)
1432	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)
1433	!==========================================================================
1434
1435	nldit_crs(:)=0 ; nleit_crs(:)=0 ; nlcit_crs(:)=0 ; nimppt_crs(:)=0
1436	nldjt_crs(:)=0 ; nlejt_crs(:)=0 ; nlcjt_crs(:)=0 ; njmppt_crs(:)=0
1437
1438	CALL mppgatheri((/nlci_crs/),0,nlcit_crs) ; CALL mppgatheri((/nlcj_crs/),0,nlcjt_crs)
1439	CALL mppgatheri((/nldi_crs/),0,nldit_crs) ; CALL mppgatheri((/nldj_crs/),0,nldjt_crs)
1440	CALL mppgatheri((/nlei_crs/),0,nleit_crs) ; CALL mppgatheri((/nlej_crs/),0,nlejt_crs)
1441	CALL mppgatheri((/nimpp_crs/),0,nimppt_crs) ; CALL mppgatheri((/njmpp_crs/),0,njmppt_crs)
1442
1443	DO jj = 1 ,jpnj
1444	DO ji = 1 , jpni
1445	jn=nfipproc(ji,jj)+1
1446	IF( jn .GE. 1 )THEN
1447	nfiimpp_crs(ji,jj)=nimppt_crs(jn)
1448	ELSE
1449	nfiimpp_crs(ji,jj) = ANINT( REAL( (nfiimpp(ji,jj) + 1 ) / nn_factx, wp ) ) + 1
1450	ENDIF
1451	ENDDO
1452	ENDDO
1453
1454	!nogather=T
1455	nfsloop_crs = 1
1456	nfeloop_crs = nlci_crs
1457	DO jn = 2,jpni-1
1458	IF(nfipproc(jn,jpnj) .eq. (narea - 1)) THEN
1459	IF (nfipproc(jn - 1 ,jpnj) .eq. -1) THEN
1460	nfsloop_crs = nldi_crs
1461	ENDIF
1462	IF (nfipproc(jn + 1,jpnj) .eq. -1) THEN
1463	nfeloop_crs = nlei_crs
1464	ENDIF
1465	ENDIF
1466	END DO
1467
1468	WRITE(narea+8000-1,*)"loc crs jpi nldi,nlei,nlci ",jpi_crs, nldi_crs ,nlei_crs ,nlci_crs
1469	WRITE(narea+8000-1,*)"glo crs jpi nldi,nlei ",jpi_crs, nldi_crs+nimpp_crs-1,nlei_crs+nimpp_crs-1
1470	WRITE(narea+8000-1,*)"loc crs jpj nldj,nlej,nlcj ",jpj_crs, nldj_crs ,nlej_crs ,nlcj_crs
1471	WRITE(narea+8000-1,*)"glo crs jpj nldj,nlej ",jpj_crs, nldj_crs+njmpp_crs-1,nlej_crs+njmpp_crs-1
1472	WRITE(narea+8000-1,*)"jpi_crs jpj_crs ",jpi_crs,jpj_crs
1473	WRITE(narea+8000-1,*)"nimpp_crs njmpp_crs ",nimpp_crs,njmpp_crs
1474
1475	WRITE(narea+8000-1,*)"min max tmask ",MINVAL(tmask),MAXVAL(tmask)
1476
1477	IF( jpi_crs .LE. 0 ) WRITE(narea+8000-1,*)"BUG jpi_crs"
1478	IF( jpj_crs .LE. 0 ) WRITE(narea+8000-1,*)"BUG jpj_crs"
1479	IF( nldi_crs .LE. 0 ) WRITE(narea+8000-1,*)"BUG nldi_crs"
1480	IF( nldj_crs .LE. 0 ) WRITE(narea+8000-1,*)"BUG nldj_crs"
1481	IF( nlei_crs .GT. jpi_crs ) WRITE(narea+8000-1,*)"BUG nlei_crs"
1482	IF( nlej_crs .GT. jpj_crs ) WRITE(narea+8000-1,*)"BUG nlej_crs"
1483	IF( nimpp_crs .LE. 0 .OR. nimpp_crs .GT. jpiglo_crs) WRITE(narea+8000-1,*)"BUG nimpp_crs",nimpp_crs
1484	IF( njmpp_crs .LE. 0 .OR. njmpp_crs .GT. jpjglo_crs) WRITE(narea+8000-1,*)"BUG njmpp_crs",njmpp_crs
1485	CALL FLUSh(narea+8000-1)
1486
1487	DO ji=1,nlei_crs
1488	IF( ji+nimpp_crs-1 .GT. jpiglo_crs )WRITE(narea+8000-1,*)"BUG ji+nimpp_crs-1 .GT. jpiglo_crs ",ji,ji+nimpp_crs-1
1489	ENDDO
1490	DO jj=1,nlej_crs
1491	IF( jj+njmpp_crs-1 .GT. jpjglo_crs )WRITE(narea+8000-1,*)"BUG jj+njmpp_crs-1 .GT. jpjglo_crs ",jj,jj+njmpp_crs-1
1492	ENDDO
1493	!==============================================================================================
1494	IF( jpizoom /= 1 .OR. jpjzoom /= 1) STOP
1495
1496	! Save the parent grid information
1497	jpi_full = jpi
1498	jpj_full = jpj
1499	jpim1_full = jpim1
1500	jpjm1_full = jpjm1
1501	nperio_full = nperio
1502
1503	npolj_full = npolj
1504	jpiglo_full = jpiglo
1505	jpjglo_full = jpjglo
1506
1507	nlcj_full = nlcj
1508	nlci_full = nlci
1509	nldi_full = nldi
1510	nldj_full = nldj
1511	nlei_full = nlei
1512	nlej_full = nlej
1513	nimpp_full = nimpp
1514	njmpp_full = njmpp
1515
1516	nlcit_full(:) = nlcit(:)
1517	nldit_full(:) = nldit(:)
1518	nleit_full(:) = nleit(:)
1519	nimppt_full(:) = nimppt(:)
1520	nlcjt_full(:) = nlcjt(:)
1521	nldjt_full(:) = nldjt(:)
1522	nlejt_full(:) = nlejt(:)
1523	njmppt_full(:) = njmppt(:)
1524
1525	nfsloop_full = nfsloop
1526	nfeloop_full = nfeloop
1527
1528	nfiimpp_full(:,:) = nfiimpp(:,:)
1529
1530
1531	CALL dom_grid_crs !swich de grille
1532
1533
1534	IF(lwp) THEN
1535	WRITE(numout,*)
1536	WRITE(numout,*) 'crs_init : coarse grid dimensions'
1537	WRITE(numout,*) '~~~~~~~ coarse domain global j-dimension jpjglo = ', jpjglo
1538	WRITE(numout,*) '~~~~~~~ coarse domain global i-dimension jpiglo = ', jpiglo
1539	WRITE(numout,*) '~~~~~~~ coarse domain local i-dimension jpi = ', jpi
1540	WRITE(numout,*) '~~~~~~~ coarse domain local j-dimension jpj = ', jpj
1541	WRITE(numout,*)
1542	WRITE(numout,*) ' nproc = ' , nproc
1543	WRITE(numout,*) ' nlci = ' , nlci
1544	WRITE(numout,*) ' nlcj = ' , nlcj
1545	WRITE(numout,*) ' nldi = ' , nldi
1546	WRITE(numout,*) ' nldj = ' , nldj
1547	WRITE(numout,*) ' nlei = ' , nlei
1548	WRITE(numout,*) ' nlej = ' , nlej
1549	WRITE(numout,*) ' nlei_full=' , nlei_full
1550	WRITE(numout,*) ' nldi_full=' , nldi_full
1551	WRITE(numout,*) ' nimpp = ' , nimpp
1552	WRITE(numout,*) ' njmpp = ' , njmpp
1553	WRITE(numout,*) ' njmpp_full = ', njmpp_full
1554	WRITE(numout,*)
1555	ENDIF
1556
1557	CALL dom_grid_glo
1558
1559	mxbinctr = INT( nn_factx * 0.5 )
1560	mybinctr = INT( nn_facty * 0.5 )
1561
1562	nrestx = MOD( nn_factx, 2 ) ! check if even- or odd- numbered reduction factor
1563	nresty = MOD( nn_facty, 2 )
1564
1565	IF ( nrestx == 0 ) THEN
1566	mxbinctr = mxbinctr - 1
1567	ENDIF
1568
1569	IF ( nresty == 0 ) THEN
1570	mybinctr = mybinctr - 1
1571	IF ( jperio == 3 .OR. jperio == 4 ) nperio_crs = jperio + 2
1572	IF ( jperio == 5 .OR. jperio == 6 ) nperio_crs = jperio - 2
1573
1574	IF ( npolj == 3 ) npolj_crs = 5
1575	IF ( npolj == 5 ) npolj_crs = 3
1576	ENDIF
1577
1578	rfactxy = nn_factx * nn_facty
1579
1580	ENDIF
1581	!
1582	nistr = mis_crs(2) ; niend = mis_crs(nlci_crs - 1)
1583	njstr = mjs_crs(3) ; njend = mjs_crs(nlcj_crs - 1)
1584	!
1585	!
1586	END SUBROUTINE crs_dom_def
1587
1588	SUBROUTINE crs_dom_bat
1589	!!----------------------------------------------------------------
1590	!! * SUBROUTINE crs_dom_bat *
1591	!! ** Purpose : coarsenig bathy
1592	!!----------------------------------------------------------------
1593	!!
1594	!! local variables
1595	INTEGER :: ji,jj,jk ! dummy indices
1596	REAL(wp), DIMENSION(:,:) , POINTER :: zmbk
1597	!!----------------------------------------------------------------
1598
1599	CALL wrk_alloc( jpi_crs, jpj_crs, zmbk )
1600
1601	mbathy_crs(:,:) = jpkm1
1602	mbkt_crs(:,:) = 1
1603	mbku_crs(:,:) = 1
1604	mbkv_crs(:,:) = 1
1605
1606
1607	DO jj = 1, jpj_crs
1608	DO ji = 1, jpi_crs
1609	jk = 0
1610	DO WHILE( tmask_crs(ji,jj,jk+1) > 0.)
1611	jk = jk + 1
1612	ENDDO
1613	mbathy_crs(ji,jj) = float( jk )
1614	ENDDO
1615	ENDDO
1616
1617	CALL wrk_alloc( jpi_crs, jpj_crs, zmbk )
1618
1619	zmbk(:,:) = 0.0
1620	zmbk(:,:) = REAL( mbathy_crs(:,:), wp ) ; CALL crs_lbc_lnk(zmbk,'T',1.0) ; mbathy_crs(:,:) = INT( zmbk(:,:) )
1621
1622
1623	!
1624	IF(lwp) WRITE(numout,*)
1625	IF(lwp) WRITE(numout,*) ' crsini : mbkt is ocean bottom k-index of T-, U-, V- and W-levels '
1626	IF(lwp) WRITE(numout,*) ' ~~~~~~~~~~~~~'
1627	!
1628	mbkt_crs(:,:) = MAX( mbathy_crs(:,:) , 1 ) ! bottom k-index of T-level (=1 over land)
1629	! ! bottom k-index of W-level = mbkt+1
1630
1631	DO jj = 1, jpj_crsm1 ! bottom k-index of u- (v-) level
1632	DO ji = 1, jpi_crsm1
1633	mbku_crs(ji,jj) = MIN( mbkt_crs(ji+1,jj ) , mbkt_crs(ji,jj) )
1634	mbkv_crs(ji,jj) = MIN( mbkt_crs(ji ,jj+1) , mbkt_crs(ji,jj) )
1635	END DO
1636	END DO
1637
1638	! convert into REAL to use lbc_lnk ; impose a min value of 1 as a zero can be set in lbclnk
1639	zmbk(:,:) = 1.e0;
1640	zmbk(:,:) = REAL( mbku_crs(:,:), wp ) ; CALL crs_lbc_lnk(zmbk,'U',1.0) ; mbku_crs (:,:) = MAX( INT( zmbk(:,:) ), 1 )
1641	zmbk(:,:) = REAL( mbkv_crs(:,:), wp ) ; CALL crs_lbc_lnk(zmbk,'V',1.0) ; mbkv_crs (:,:) = MAX( INT( zmbk(:,:) ), 1 )
1642	!
1643	CALL wrk_dealloc( jpi_crs, jpj_crs, zmbk )
1644	!
1645	END SUBROUTINE crs_dom_bat
1646
1647	SUBROUTINE PIKSRT(N,ARR)
1648	INTEGER ,INTENT(IN) :: N
1649	REAL(kind=8),DIMENSION(N),INTENT(INOUT) :: ARR
1650
1651	INTEGER :: i,j
1652	REAL(kind=8) :: a
1653	!!----------------------------------------------------------------
1654
1655	DO j=2, N
1656	a=ARR(j)
1657	DO i=j-1,1,-1
1658	IF(ARR(i)<=a) goto 10
1659	ARR(i+1)=ARR(i)
1660	ENDDO
1661	i=0
1662	10 ARR(i+1)=a
1663	ENDDO
1664	RETURN
1665
1666	END SUBROUTINE PIKSRT
1667
1668
1669	END MODULE crsdom

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

Download in other formats: