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

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

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

Download in other formats: