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 NEMO/branches/2018/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/CRS – NEMO

Context Navigation

source: NEMO/branches/2018/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/CRS/crsdom.F90 @ 10210

Last change on this file since 10210 was 10210, checked in by cbricaud, 6 years ago
modifications for limited area configuration
Property svn:keywords set to `Id`
File size: 77.2 KB

Line
1	MODULE crsdom
2	!!===================================================================
3	!! * crs.F90 *
4	!! Purpose: Interface for calculating quantities from a
5	!! higher-resolution grid for the coarse grid.
6	!!
7	!! Method:
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, crs_dom_top
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	IF( ijis .le. 0 )WRITE(narea+1000-1,*)"BUG ijis ";CALL FLUSH(narea+1000-1)
76	IF( ijie .gt. jpi )WRITE(narea+1000-1,*)"BUG ijie ";CALL FLUSH(narea+1000-1)
77	IF( ijjs .le. 0 )WRITE(narea+1000-1,*)"BUG ijjs ";CALL FLUSH(narea+1000-1)
78	IF( ijje .gt. jpj )WRITE(narea+1000-1,*)"BUG ijje ";CALL FLUSH(narea+1000-1)
79
80	!IF( jj==nlej_crs .OR. ji==nlei_crs )THEN
81	!WRITE(narea+1000-1,*)"MASK A",ji,jj
82	!WRITE(narea+1000-1,*)"MASK A",ji+nimpp_crs-1,jj+njmpp_crs-1
83	!WRITE(narea+1000-1,*)"MASK B",ijis,ijie,ijjs,ijje
84	!WRITE(narea+1000-1,*)"MASK B",ijis+nimpp-1,ijie+nimpp-1,ijjs+njmpp-1,ijje+njmpp-1
85	!WRITE(narea+1000-1,*)"MASK C",SUM( tmask(ijis:ijie,ijjs:ijje,jk) )
86	!ENDIF
87
88	zmask = 0.0
89	zmask = SUM( tmask(ijis:ijie,ijjs:ijje,jk) )
90	IF ( zmask > 0.0 ) tmask_crs(ji,jj,jk) = 1.0
91
92	zmask = 0.0
93	zmask = SUM( vmask(ijis:ijie,ijje ,jk) )
94	IF ( zmask > 0.0 ) vmask_crs(ji,jj,jk) = 1.0
95
96	zmask = 0.0
97	zmask = SUM( umask(ijie ,ijjs:ijje,jk) )
98	IF ( zmask > 0.0 ) umask_crs(ji,jj,jk) = 1.0
99
100	fmask_crs(ji,jj,jk) = fmask(ijie,ijje,jk)
101
102	ENDDO
103	ENDDO
104	ENDDO
105
106	CALL crs_lbc_lnk( tmask_crs, 'T', 1.0 )
107	CALL crs_lbc_lnk( vmask_crs, 'V', 1.0 )
108	CALL crs_lbc_lnk( umask_crs, 'U', 1.0 )
109	CALL crs_lbc_lnk( fmask_crs, 'F', 1.0 )
110
111	!
112	END SUBROUTINE crs_dom_msk
113
114	SUBROUTINE crs_dom_coordinates( p_gphi, p_glam, cd_type, p_gphi_crs, p_glam_crs )
115	!!----------------------------------------------------------------
116	!! * SUBROUTINE crs_coordinates *
117	!! ** Purpose : Determine the coordinates for the coarse grid
118	!!
119	!! ** Method : From the parent grid subset, search for the central
120	!! point. For an odd-numbered reduction factor,
121	!! the coordinate will be that of the central T-cell.
122	!! For an even-numbered reduction factor, of a non-square
123	!! coarse grid box, the coordinate will be that of
124	!! the east or north face or more likely. For a square
125	!! coarse grid box, the coordinate will be that of
126	!! the central f-corner.
127	!!
128	!! ** Input : p_gphi = parent grid gphi[t\|u\|v\|f]
129	!! p_glam = parent grid glam[t\|u\|v\|f]
130	!! cd_type = grid type (T,U,V,F)
131	!! ** Output : p_gphi_crs = coarse grid gphi[t\|u\|v\|f]
132	!! p_glam_crs = coarse grid glam[t\|u\|v\|f]
133	!!
134	!! History. 1 Jun.
135	!!----------------------------------------------------------------
136	!! Arguments
137	REAL(wp), DIMENSION(jpi,jpj) , INTENT(in) :: p_gphi ! Parent grid latitude
138	REAL(wp), DIMENSION(jpi,jpj) , INTENT(in) :: p_glam ! Parent grid longitude
139	CHARACTER(len=1), INTENT(in) :: cd_type ! grid type (T,U,V,F)
140	REAL(wp), DIMENSION(jpi_crs,jpj_crs), INTENT(out) :: p_gphi_crs ! Coarse grid latitude
141	REAL(wp), DIMENSION(jpi_crs,jpj_crs), INTENT(out) :: p_glam_crs ! Coarse grid longitude
142
143	!! Local variables
144	INTEGER :: ji, jj, jk ! dummy loop indices
145	INTEGER :: iji, ijj
146	INTEGER :: ir,jr
147	!!----------------------------------------------------------------
148	p_gphi_crs(:,:)=0._wp
149	p_glam_crs(:,:)=0._wp
150
151
152	SELECT CASE ( cd_type )
153	CASE ( 'T' )
154	DO jj = nldj_crs, nlej_crs
155	ijj = mjs_crs(jj) + + INT(0.5*nfacty(jj))
156	DO ji = nldi_crs, nlei_crs
157	iji = mis_crs(ji) + INT(0.5*nfactx(ji))
158	p_gphi_crs(ji,jj) = p_gphi(iji,ijj)
159	p_glam_crs(ji,jj) = p_glam(iji,ijj)
160	ENDDO
161	ENDDO
162	CASE ( 'U' )
163	DO jj = nldj_crs, nlej_crs
164	ijj = mjs_crs(jj) + INT(0.5*nfacty(jj))
165	DO ji = nldi_crs, nlei_crs
166	iji = mie_crs(ji)
167	p_gphi_crs(ji,jj) = p_gphi(iji,ijj)
168	p_glam_crs(ji,jj) = p_glam(iji,ijj)
169
170	ENDDO
171	ENDDO
172	CASE ( 'V' )
173	DO jj = nldj_crs, nlej_crs
174	ijj = mje_crs(jj)
175	DO ji = nldi_crs, nlei_crs
176	iji = mis_crs(ji) + INT(0.5*nfactx(ji))
177	p_gphi_crs(ji,jj) = p_gphi(iji,ijj)
178	p_glam_crs(ji,jj) = p_glam(iji,ijj)
179	ENDDO
180	ENDDO
181	CASE ( 'F' )
182	DO jj = nldj_crs, nlej_crs
183	ijj = mje_crs(jj)
184	DO ji = nldi_crs, nlei_crs
185	iji = mie_crs(ji)
186	p_gphi_crs(ji,jj) = p_gphi(iji,ijj)
187	p_glam_crs(ji,jj) = p_glam(iji,ijj)
188	ENDDO
189	ENDDO
190	END SELECT
191	WRITE(narea+1000-1,*)"end glam_crs gphi_crs ",p_glam_crs(1,2),p_gphi_crs(1,2)
192
193	! Retroactively add back the boundary halo cells.
194	!???? CALL crs_lbc_lnk( p_gphi_crs, cd_type, 1.0 )
195	!???? CALL crs_lbc_lnk( p_glam_crs, cd_type, 1.0 )
196	WRITE(narea+1000-1,*)"end1 glam_crs gphi_crs ",p_glam_crs(1,2),p_gphi_crs(1,2)
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 :: i1, j1
230
231	!!----------------------------------------------------------------
232	p_e1_crs(:,:)=0._wp
233	p_e2_crs(:,:)=0._wp
234
235	! Initialize
236
237	DO ji = nldi_crs, nlei_crs
238
239	ijis = mis_crs(ji)
240	ijie = mie_crs(ji)
241
242	DO jj = nldj_crs, nlej_crs
243
244	ijjs = mjs_crs(jj)
245	ijje = mje_crs(jj)
246
247	i1=INT(0.5*nfactx(ji))
248	j1=INT(0.5*nfacty(jj))
249
250	! Only for a factro 3 coarsening
251	SELECT CASE ( cd_type )
252	CASE ( 'T' )
253	p_e1_crs(ji,jj) = REAL(nn_factx,wp)*p_e1(ijis+i1,ijjs+j1)
254	p_e2_crs(ji,jj) = REAL(nn_facty,wp)*p_e2(ijis+i1,ijjs+j1)
255	CASE ( 'U' )
256	p_e1_crs(ji,jj) = REAL(nn_factx,wp)*p_e1(ijis+i1,ijjs+j1)
257	p_e2_crs(ji,jj) = REAL(nn_facty,wp)*p_e2(ijie ,ijjs+j1)
258
259	CASE ( 'V' )
260	p_e1_crs(ji,jj) = REAL(nn_factx,wp)*p_e1(ijis+i1,ijje )
261	p_e2_crs(ji,jj) = REAL(nn_facty,wp)*p_e2(ijis+i1,ijjs+j1)
262	CASE ( 'F' )
263	p_e1_crs(ji,jj) = REAL(nn_factx,wp)*p_e1(ijis+i1,ijje )
264	p_e2_crs(ji,jj) = REAL(nn_facty,wp)*p_e2(ijie ,ijjs+j1)
265	END SELECT
266	ENDDO
267	ENDDO
268
269
270	CALL crs_lbc_lnk( p_e1_crs, cd_type, 1.0 )
271	CALL crs_lbc_lnk( p_e2_crs, cd_type, 1.0 )
272
273	END SUBROUTINE crs_dom_hgr
274
275
276	SUBROUTINE crs_dom_facvol( p_mask, cd_type, p_e1, p_e2, p_e3, p_fld1_crs, p_fld2_crs )
277	!!----------------------------------------------------------------
278	!! * SUBROUTINE crsfun_wgt *
279	!! ** Purpose : Three applications.
280	!! 1) SUM. Get coarse grid horizontal scale factors and unmasked fraction
281	!! 2) VOL. Get coarse grid box volumes
282	!! 3) WGT. Weighting multiplier for volume-weighted and/or
283	!! area-weighted averages.
284	!! Weights (i.e. the denominator) calculated here
285	!! to avoid IF-tests and division.
286	!! ** Method : 1) SUM. For grid types T,U,V,F (and W) the 2D scale factors of
287	!! the coarse grid are the sum of the east or north faces of the
288	!! parent grid subset comprising the coarse grid box.
289	!! The fractions of masked:total surface (3D) on the east,
290	!! north and top faces is, optionally, also output.
291	!! - Top face area sum
292	!! Valid arguments: cd_type, cd_op='W', p_pmask, p_e1, p_e2
293	!! - Top face ocean surface fraction
294	!! Valid arguments: cd_type, cd_op='W', p_pmask, p_e1, p_e2
295	!! - e1,e2 Scale factors
296	!! Valid arguments:
297	!! 2) VOL. For grid types W and T, the coarse grid box
298	!! volumes are output. Also optionally, the fraction of
299	!! masked:total volume of the parent grid subset is output (i.e. facvol).
300	!! 3) WGT. Based on the grid type, the denominator is pre-determined here to
301	!! perform area- or volume- weighted averages,
302	!! to avoid IF-tests and divisions.
303	!! ** Inputs : p_e1, p_e2 = parent grid e1 or e2 (t,u,v,f)
304	!! p_pmask = parent grid mask (T,U,V,F)
305	!! cd_type = grid type (T,U,V,F) for scale factors; for velocities (U or V)
306	!! cd_op = applied operation (SUM, VOL, WGT)
307	!! p_fse3 = (Optional) parent grid vertical level thickness (fse3u or fse3v)
308	!! ** Outputs : p_cfield2d_1 = (Optional) 2D field on coarse grid
309	!! p_cfield2d_2 = (Optional) 2D field on coarse grid
310	!! p_cfield3d_1 = (Optional) 3D field on coarse grid
311	!! p_cfield3d_2 = (Optional) 3D field on coarse grid
312	!!
313	!! History. 4 Jun. Write for WGT and scale factors only
314	!!----------------------------------------------------------------
315	!!
316	!! Arguments
317	CHARACTER(len=1), INTENT(in) :: cd_type ! grid type U,V
318	REAL(wp), DIMENSION(jpi,jpj,jpk) , INTENT(in) :: p_mask ! Parent grid U,V mask
319	REAL(wp), DIMENSION(jpi,jpj) , INTENT(in) :: p_e1 ! Parent grid U,V scale factors (e1)
320	REAL(wp), DIMENSION(jpi,jpj) , INTENT(in) :: p_e2 ! Parent grid U,V scale factors (e2)
321	REAL(wp), DIMENSION(jpi,jpj,jpk) , INTENT(in) :: p_e3 ! Parent grid vertical level thickness (fse3u, fse3v)
322
323	REAL(wp), DIMENSION(jpi_crs,jpj_crs,jpk), INTENT(out) :: p_fld1_crs ! Coarse grid box 3D quantity
324	REAL(wp), DIMENSION(jpi_crs,jpj_crs,jpk), INTENT(out) :: p_fld2_crs ! Coarse grid box 3D quantity
325
326	!! Local variables
327	REAL(wp) :: zdAm
328	INTEGER :: ji, jj, jk
329	INTEGER :: ijis,ijie,ijjs,ijje
330
331	REAL(wp), DIMENSION(:,:,:), POINTER :: zvol, zmask
332	!!----------------------------------------------------------------
333
334	CALL wrk_alloc( jpi, jpj, jpk, zvol, zmask )
335
336	p_fld1_crs(:,:,:) = 0.0
337	p_fld2_crs(:,:,:) = 0.0
338
339	DO jk = 1, jpk
340	zvol (:,:,jk) = p_e1(:,:) * p_e2(:,:) * p_e3(:,:,jk)
341	zmask(:,:,jk) = p_mask(:,:,jk)
342	ENDDO
343
344	DO jk = 1, jpk
345	DO ji = nldi_crs, nlei_crs
346
347	ijis = mis_crs(ji)
348	ijie = mie_crs(ji)
349
350	DO jj = nldj_crs, nlej_crs
351
352	ijjs = mjs_crs(jj)
353	ijje = mje_crs(jj)
354
355	p_fld1_crs(ji,jj,jk) = SUM( zvol(ijis:ijie,ijjs:ijje,jk) )
356	zdAm = SUM( zvol(ijis:ijie,ijjs:ijje,jk) * zmask(ijis:ijie,ijjs:ijje,jk) )
357	p_fld2_crs(ji,jj,jk) = zdAm / p_fld1_crs(ji,jj,jk)
358	ENDDO
359	ENDDO
360	ENDDO
361	! ! Retroactively add back the boundary halo cells.
362	CALL crs_lbc_lnk( p_fld1_crs, cd_type, 1.0 )
363	CALL crs_lbc_lnk( p_fld2_crs, cd_type, 1.0 )
364	!
365	CALL wrk_dealloc( jpi, jpj, jpk, zvol, zmask )
366	!
367	END SUBROUTINE crs_dom_facvol
368
369
370	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 )
371	!!----------------------------------------------------------------
372	!! * SUBROUTINE crsfun_UV *
373	!! ** Purpose : Average, area-weighted, of U or V on the east and north faces
374	!!
375	!! ** Method : The U and V velocities (3D) are determined as the area-weighted averages
376	!! on the east and north faces, respectively,
377	!! of the parent grid subset comprising the coarse grid box.
378	!! In the case of the V and F grid, the last jrow minus 1 is spurious.
379	!! ** Inputs : p_e1_e2 = parent grid e1 or e2 (t,u,v,f)
380	!! cd_type = grid type (T,U,V,F) for scale factors; for velocities (U or V)
381	!! psgn = sign change over north fold (See lbclnk.F90)
382	!! p_pmask = parent grid mask (T,U,V,F) for scale factors;
383	!! for velocities (U or V)
384	!! p_fse3 = parent grid vertical level thickness (fse3u or fse3v)
385	!! p_pfield = U or V on the parent grid
386	!! p_surf_crs = (Optional) Coarse grid weight for averaging
387	!! ** Outputs : p_cfield3d = 3D field on coarse grid
388	!!
389	!! History. 29 May. completed draft.
390	!! 4 Jun. Revision for WGT
391	!! 5 Jun. Streamline for area-weighted average only ; separate scale factor and weights.
392	!!----------------------------------------------------------------
393	!!
394	!! Arguments
395	REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in) :: p_fld ! T, U, V or W on parent grid
396	CHARACTER(len=*), INTENT(in) :: cd_op ! Operation SUM, MAX or MIN
397	CHARACTER(len=1), INTENT(in) :: cd_type ! grid type U,V
398	REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in) :: p_mask ! Parent grid T,U,V mask
399	REAL(wp), DIMENSION(jpi,jpj), INTENT(in), OPTIONAL :: p_e12 ! Parent grid T,U,V scale factors (e1 or e2)
400	REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in), OPTIONAL :: p_e3 ! Parent grid vertical level thickness (fse3u, fse3v)
401	REAL(wp), DIMENSION(jpi_crs,jpj_crs,jpk), INTENT(in), OPTIONAL :: p_surf_crs ! Coarse grid area-weighting denominator
402	REAL(wp), DIMENSION(jpi_crs,jpj_crs,jpk), INTENT(in), OPTIONAL :: p_mask_crs ! Coarse grid T,U,V maska
403	REAL(wp), INTENT(in) :: psgn ! sign
404
405	REAL(wp), DIMENSION(jpi_crs,jpj_crs,jpk), INTENT(out) :: p_fld_crs ! Coarse grid box 3D quantity
406
407	!! Local variables
408	INTEGER :: ji, jj, jk
409	INTEGER :: ijis, ijie, ijjs, ijje
410	INTEGER :: ini, inj
411	REAL(wp) :: zflcrs, zsfcrs
412	REAL(wp), DIMENSION(:,:,:), POINTER :: zsurf, zsurfmsk, zmask,ztabtmp
413	INTEGER :: ir,jr
414	REAL(wp), DIMENSION(nn_factx,nn_facty):: ztmp
415	REAL(wp), DIMENSION(nn_factx*nn_facty):: ztmp1
416	REAL(wp), DIMENSION(:), ALLOCATABLE :: ztmp2
417	INTEGER , DIMENSION(1) :: zdim1
418	REAL(wp) :: zmin,zmax
419	!!----------------------------------------------------------------
420
421	p_fld_crs(:,:,:) = 0.0
422
423	SELECT CASE ( cd_op )
424
425	CASE ( 'VOL' )
426
427	CALL wrk_alloc( jpi, jpj, jpk, zsurf, zsurfmsk )
428
429	SELECT CASE ( cd_type )
430
431	CASE( 'T', 'W','U','V' )
432	DO jk = 1, jpk
433	zsurf (:,:,jk) = p_e12(:,:) * p_e3(:,:,jk) * p_mask(:,:,jk)
434	zsurfmsk(:,:,jk) = zsurf(:,:,jk)
435	ENDDO
436	!
437	DO jk = 1, jpk
438	DO jj = nldj_crs,nlej_crs
439	ijjs = mjs_crs(jj)
440	ijje = mje_crs(jj)
441	DO ji = nldi_crs, nlei_crs
442
443	ijis = mis_crs(ji)
444	ijie = mie_crs(ji)
445
446	zflcrs = SUM( p_fld(ijis:ijie,ijjs:ijje,jk) * zsurfmsk(ijis:ijie,ijjs:ijje,jk) )
447	zsfcrs = SUM( zsurfmsk(ijis:ijie,ijjs:ijje,jk) )
448
449	p_fld_crs(ji,jj,jk) = zflcrs
450	IF( zsfcrs /= 0.0 ) p_fld_crs(ji,jj,jk) = zflcrs / zsfcrs
451	ENDDO
452	ENDDO
453	ENDDO
454	!
455	CASE DEFAULT
456	STOP
457	END SELECT
458
459	CALL wrk_dealloc( jpi, jpj, jpk, zsurf, zsurfmsk )
460
461	CASE ( 'LOGVOL' )
462
463	CALL wrk_alloc( jpi, jpj, jpk, zsurf, zsurfmsk, ztabtmp )
464
465	ztabtmp(:,:,:)=0._wp
466	WHERE(p_fld* p_mask .NE. 0._wp ) ztabtmp = LOG10(p_fld * p_mask)*p_mask
467	ztabtmp = ztabtmp * p_mask
468
469	SELECT CASE ( cd_type )
470
471	CASE( 'T', 'W' )
472
473	DO jk = 1, jpk
474	zsurf (:,:,jk) = p_e12(:,:) * p_e3(:,:,jk) * p_mask(:,:,jk)
475	zsurfmsk(:,:,jk) = zsurf(:,:,jk)
476	ENDDO
477	!
478	DO jk = 1, jpk
479	DO jj = nldj_crs,nlej_crs
480	ijjs = mjs_crs(jj)
481	ijje = mje_crs(jj)
482	DO ji = nldi_crs, nlei_crs
483	ijis = mis_crs(ji)
484	ijie = mie_crs(ji)
485	zflcrs = SUM( ztabtmp(ijis:ijie,ijjs:ijje,jk) * zsurfmsk(ijis:ijie,ijjs:ijje,jk) )
486	zsfcrs = SUM( zsurfmsk(ijis:ijie,ijjs:ijje,jk) )
487	p_fld_crs(ji,jj,jk) = zflcrs
488	IF( zsfcrs /= 0.0 ) p_fld_crs(ji,jj,jk) = zflcrs / zsfcrs
489	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)
490	ENDDO
491	ENDDO
492	ENDDO
493	CASE DEFAULT
494	STOP
495	END SELECT
496
497	CALL wrk_dealloc( jpi, jpj, jpk, zsurf, zsurfmsk ,ztabtmp )
498
499	CASE ( 'MED' )
500
501	CALL wrk_alloc( jpi, jpj, jpk, zsurf, zsurfmsk )
502
503	SELECT CASE ( cd_type )
504
505	CASE( 'T', 'W' )
506	DO jk = 1, jpk
507	zsurf (:,:,jk) = p_e12(:,:) * p_e3(:,:,jk) * p_mask(:,:,jk)
508	zsurfmsk(:,:,jk) = zsurf(:,:,jk)
509	ENDDO
510	!
511	DO jk = 1, jpk
512
513	DO jj = nldj_crs,nlej_crs
514
515	ijjs = mjs_crs(jj)
516	ijje = mje_crs(jj)
517	inj = ijje-ijjs+1
518
519	DO ji = nldi_crs, nlei_crs
520	ijis = mis_crs(ji)
521	ijie = mie_crs(ji)
522	ini = ijie-ijis+1
523
524	ztmp(1:ini,1:inj)= p_fld(ijis:ijie,ijjs:ijje,jk)
525	zdim1(1) = nn_factx*nn_facty
526	ztmp1(:) = RESHAPE( ztmp(:,:) , zdim1 )
527	CALL PIKSRT(nn_factx*nn_facty,ztmp1)
528
529	ir=0
530	jr=1
531	DO WHILE( jr .LE. nn_factx*nn_facty )
532	IF( ztmp1(jr) == 0. ) THEN
533	ir=jr
534	jr=jr+1
535	ELSE
536	EXIT
537	ENDIF
538	ENDDO
539	IF( ir .LE. nn_factx*nn_facty-1 )THEN
540	ALLOCATE( ztmp2(nn_factx*nn_facty-ir) )
541	ztmp2(1:nn_factxnn_facty-ir) = ztmp1(1+ir:nn_factxnn_facty)
542	jr=INT( 0.5 * REAL(nn_factx*nn_facty-ir,wp) )+1
543	p_fld_crs(ji,jj,jk) = ztmp2(jr)
544	DEALLOCATE( ztmp2 )
545	ELSE
546	p_fld_crs(ji,jj,jk) = 0._wp
547	ENDIF
548
549	ENDDO
550	ENDDO
551	ENDDO
552	CASE DEFAULT
553	STOP
554	END SELECT
555
556	CALL wrk_dealloc( jpi, jpj, jpk, zsurf, zsurfmsk )
557
558	CASE ( 'SUM' )
559
560	CALL wrk_alloc( jpi, jpj, jpk, zsurfmsk )
561
562	IF( PRESENT( p_e3 ) ) THEN
563	DO jk = 1, jpk
564	zsurfmsk(:,:,jk) = p_e12(:,:) * p_e3(:,:,jk) * p_mask(:,:,jk)
565	ENDDO
566	ELSE
567	DO jk = 1, jpk
568	zsurfmsk(:,:,jk) = p_e12(:,:) * p_mask(:,:,jk)
569	ENDDO
570	ENDIF
571
572	SELECT CASE ( cd_type )
573
574	CASE( 'T', 'W' )
575
576	DO jk = 1, jpk
577	DO jj = nldj_crs,nlej_crs
578	ijjs = mjs_crs(jj)
579	ijje = mje_crs(jj)
580	DO ji = nldi_crs, nlei_crs
581	ijis = mis_crs(ji)
582	ijie = mie_crs(ji)
583
584	p_fld_crs(ji,jj,jk) = SUM( p_fld(ijis:ijie,ijjs:ijje,jk) * zsurfmsk(ijis:ijie,ijjs:ijje,jk) )
585	ENDDO
586	ENDDO
587	ENDDO
588
589	CASE( 'V' )
590
591
592	DO jk = 1, jpk
593	DO jj = nldj_crs,nlej_crs
594	ijjs = mjs_crs(jj)
595	ijje = mje_crs(jj)
596	DO ji = nldi_crs, nlei_crs
597	ijis = mis_crs(ji)
598	ijie = mie_crs(ji)
599
600	p_fld_crs(ji,jj,jk) = SUM( p_fld(ijis:ijie,ijje,jk) * zsurfmsk(ijis:ijie,ijje,jk) )
601	ENDDO
602	ENDDO
603	ENDDO
604
605	CASE( 'U' )
606
607	DO jk = 1, jpk
608	DO jj = nldj_crs,nlej_crs
609	ijjs = mjs_crs(jj)
610	ijje = mje_crs(jj)
611	DO ji = nldi_crs, nlei_crs
612	ijis = mis_crs(ji)
613	ijie = mie_crs(ji)
614
615	p_fld_crs(ji,jj,jk) = SUM( p_fld(ijie,ijjs:ijje,jk) * zsurfmsk(ijie,ijjs:ijje,jk) )
616	ENDDO
617	ENDDO
618	ENDDO
619
620	END SELECT
621
622	IF( PRESENT( p_surf_crs ) ) THEN
623	WHERE ( p_surf_crs /= 0.0 ) p_fld_crs(:,:,:) = p_fld_crs(:,:,:) / p_surf_crs(:,:,:)
624	ENDIF
625
626	CALL wrk_dealloc( jpi, jpj, jpk, zsurfmsk )
627
628	CASE ( 'MAX' ) ! search the max of unmasked grid cells
629
630	CALL wrk_alloc( jpi, jpj, jpk, zmask )
631
632	DO jk = 1, jpk
633	zmask(:,:,jk) = p_mask(:,:,jk)
634	ENDDO
635
636	SELECT CASE ( cd_type )
637
638	CASE( 'T', 'W' )
639
640	DO jk = 1, jpk
641	DO jj = nldj_crs,nlej_crs
642	ijjs = mjs_crs(jj)
643	ijje = mje_crs(jj)
644	DO ji = nldi_crs, nlei_crs
645	ijis = mis_crs(ji)
646	ijie = mie_crs(ji)
647	p_fld_crs(ji,jj,jk) = MAXVAL( p_fld(ijis:ijie,ijjs:ijje,jk) * zmask(ijis:ijie,ijjs:ijje,jk) - &
648	& ( ( 1._wp - zmask(ijis:ijie,ijjs:ijje,jk))* r_inf ) )
649	ENDDO
650	ENDDO
651	ENDDO
652
653	CASE( 'V' )
654	CALL ctl_stop('MAX operator and V case not available')
655
656	CASE( 'U' )
657	CALL ctl_stop('MAX operator and U case not available')
658
659	END SELECT
660
661	CALL wrk_dealloc( jpi, jpj, jpk, zmask )
662
663	CASE ( 'MIN' ) ! Search the min of unmasked grid cells
664
665	CALL wrk_alloc( jpi, jpj, jpk, zmask )
666	DO jk = 1, jpk
667	zmask(:,:,jk) = p_mask(:,:,jk)
668	ENDDO
669
670	SELECT CASE ( cd_type )
671
672	CASE( 'T', 'W' )
673
674	DO jk = 1, jpk
675	DO jj = nldj_crs,nlej_crs
676	ijjs = mjs_crs(jj)
677	ijje = mje_crs(jj)
678	DO ji = nldi_crs, nlei_crs
679	ijis = mis_crs(ji)
680	ijie = mie_crs(ji)
681
682	p_fld_crs(ji,jj,jk) = MINVAL( p_fld(ijis:ijie,ijjs:ijje,jk) * zmask(ijis:ijie,ijjs:ijje,jk) + &
683	& ( 1._wp - zmask(ijis:ijie,ijjs:ijje,jk)* r_inf ) )
684	ENDDO
685	ENDDO
686	ENDDO
687
688
689	CASE( 'V' )
690	CALL ctl_stop('MIN operator and V case not available')
691
692	CASE( 'U' )
693	CALL ctl_stop('MIN operator and U case not available')
694
695	END SELECT
696	!
697	CALL wrk_dealloc( jpi, jpj, jpk, zmask )
698	!
699	END SELECT
700	!
701	CALL crs_lbc_lnk( p_fld_crs, cd_type, psgn )
702	!
703	END SUBROUTINE crs_dom_ope_3d
704
705	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 )
706	!!----------------------------------------------------------------
707	!! * SUBROUTINE crsfun_UV *
708	!! ** Purpose : Average, area-weighted, of U or V on the east and north faces
709	!!
710	!! ** Method : The U and V velocities (3D) are determined as the area-weighted averages
711	!! on the east and north faces, respectively,
712	!! of the parent grid subset comprising the coarse grid box.
713	!! In the case of the V and F grid, the last jrow minus 1 is spurious.
714	!! ** Inputs : p_e1_e2 = parent grid e1 or e2 (t,u,v,f)
715	!! cd_type = grid type (T,U,V,F) for scale factors; for velocities (U or V)
716	!! psgn = sign change over north fold (See lbclnk.F90)
717	!! p_pmask = parent grid mask (T,U,V,F) for scale factors;
718	!! for velocities (U or V)
719	!! p_fse3 = parent grid vertical level thickness (fse3u or fse3v)
720	!! p_pfield = U or V on the parent grid
721	!! p_surf_crs = (Optional) Coarse grid weight for averaging
722	!! ** Outputs : p_cfield3d = 3D field on coarse grid
723	!!
724	!! History. 29 May. completed draft.
725	!! 4 Jun. Revision for WGT
726	!! 5 Jun. Streamline for area-weighted average only ; separate scale factor and weights.
727	!!----------------------------------------------------------------
728	!!
729	!! Arguments
730	REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: p_fld ! T, U, V or W on parent grid
731	CHARACTER(len=*), INTENT(in) :: cd_op ! Operation SUM, MAX or MIN
732	CHARACTER(len=1), INTENT(in) :: cd_type ! grid type U,V
733	REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in) :: p_mask ! Parent grid T,U,V mask
734	REAL(wp), DIMENSION(jpi,jpj), INTENT(in), OPTIONAL :: p_e12 ! Parent grid T,U,V scale factors (e1 or e2)
735	REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in), OPTIONAL :: p_e3 ! Parent grid vertical level thickness (fse3u, fse3v)
736	REAL(wp), DIMENSION(jpi_crs,jpj_crs) , INTENT(in), OPTIONAL :: p_surf_crs ! Coarse grid area-weighting denominator
737	REAL(wp), DIMENSION(jpi_crs,jpj_crs,jpk), INTENT(in), OPTIONAL :: p_mask_crs ! Coarse grid T,U,V mask
738	REAL(wp), INTENT(in) :: psgn
739
740	REAL(wp), DIMENSION(jpi_crs,jpj_crs) , INTENT(out) :: p_fld_crs ! Coarse grid box 3D quantity
741
742	!! Local variables
743	INTEGER :: ji, jj, jk ! dummy loop indices
744	INTEGER :: ijis, ijie, ijjs, ijje
745	REAL(wp) :: zflcrs, zsfcrs
746	REAL(wp), DIMENSION(:,:), POINTER :: zsurfmsk
747
748	!!----------------------------------------------------------------
749
750	p_fld_crs(:,:) = 0.0
751
752	SELECT CASE ( TRIM(cd_op) )
753
754	CASE ( 'VOL' )
755
756	CALL wrk_alloc( jpi, jpj, zsurfmsk )
757	zsurfmsk(:,:) = p_e12(:,:) * p_e3(:,:,1) * p_mask(:,:,1)
758
759	DO jj = nldj_crs,nlej_crs
760	ijjs = mjs_crs(jj)
761	ijje = mje_crs(jj)
762	DO ji = nldi_crs, nlei_crs
763	ijis = mis_crs(ji)
764	ijie = mie_crs(ji)
765
766	zflcrs = SUM( p_fld(ijis:ijie,ijjs:ijje) * zsurfmsk(ijis:ijie,ijjs:ijje) )
767	zsfcrs = SUM( zsurfmsk(ijis:ijie,ijjs:ijje) )
768
769	p_fld_crs(ji,jj) = zflcrs
770	IF( zsfcrs /= 0.0 ) p_fld_crs(ji,jj) = zflcrs / zsfcrs
771	ENDDO
772	ENDDO
773	CALL wrk_dealloc( jpi, jpj, zsurfmsk )
774	!
775
776	CASE ( 'SUM' )
777
778	CALL wrk_alloc( jpi, jpj, zsurfmsk )
779	IF( PRESENT( p_e3 ) ) THEN
780	zsurfmsk(:,:) = p_e12(:,:) * p_e3(:,:,1) * p_mask(:,:,1)
781	ELSE
782	zsurfmsk(:,:) = p_e12(:,:) * p_mask(:,:,1)
783	ENDIF
784
785	SELECT CASE ( cd_type )
786
787	CASE( 'T', 'W' )
788
789	DO jj = nldj_crs,nlej_crs
790	ijjs = mjs_crs(jj)
791	ijje = mje_crs(jj)
792	DO ji = nldi_crs, nlei_crs
793	ijis = mis_crs(ji)
794	ijie = mie_crs(ji)
795	p_fld_crs(ji,jj) = SUM( p_fld(ijis:ijie,ijjs:ijje) * zsurfmsk(ijis:ijie,ijjs:ijje) )
796	ENDDO
797	ENDDO
798
799	CASE( 'V' )
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,ijje) * zsurfmsk(ijis:ijie,ijje) )
808	ENDDO
809	ENDDO
810
811	CASE( 'U' )
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(ijie,ijjs:ijje) * zsurfmsk(ijie,ijjs:ijje) )
820	ENDDO
821	ENDDO
822
823	END SELECT
824
825	IF( PRESENT( p_surf_crs ) ) THEN
826	WHERE ( p_surf_crs /= 0.0 ) p_fld_crs(:,:) = p_fld_crs(:,:) / p_surf_crs(:,:)
827	ENDIF
828
829	CALL wrk_dealloc( jpi, jpj, zsurfmsk )
830
831	CASE ( 'MAX' )
832
833	SELECT CASE ( cd_type )
834
835	CASE( 'T', 'W' )
836
837	DO jj = nldj_crs,nlej_crs
838	ijjs = mjs_crs(jj)
839	ijje = mje_crs(jj)
840	DO ji = nldi_crs, nlei_crs
841	ijis = mis_crs(ji)
842	ijie = mie_crs(ji)
843	p_fld_crs(ji,jj) = MAXVAL( p_fld(ijis:ijie,ijjs:ijje) * p_mask(ijis:ijie,ijjs:ijje,1) - &
844	& ( 1._wp - p_mask(ijis:ijie,ijjs:ijje,1) ) )
845	ENDDO
846	ENDDO
847
848	CASE( 'V' )
849	CALL ctl_stop('MAX operator and V case not available')
850
851	CASE( 'U' )
852	CALL ctl_stop('MAX operator and U case not available')
853
854	END SELECT
855
856	CASE ( 'MIN' ) ! Search the min of unmasked grid cells
857
858	SELECT CASE ( cd_type )
859
860	CASE( 'T', 'W' )
861
862	DO jj = nldj_crs,nlej_crs
863	ijjs = mjs_crs(jj)
864	ijje = mje_crs(jj)
865	DO ji = nldi_crs, nlei_crs
866	ijis = mis_crs(ji)
867	ijie = mie_crs(ji)
868	p_fld_crs(ji,jj) = MINVAL( p_fld(ijis:ijie,ijjs:ijje) * p_mask(ijis:ijie,ijjs:ijje,1) + &
869	& ( 1._wp - p_mask(ijis:ijie,ijjs:ijje,1) ) )
870	ENDDO
871	ENDDO
872
873	CASE( 'V' )
874	CALL ctl_stop('MIN operator and V case not available')
875
876	CASE( 'U' )
877	CALL ctl_stop('MIN operator and U case not available')
878
879	END SELECT
880	!
881	END SELECT
882	!
883	CALL crs_lbc_lnk( p_fld_crs, cd_type, psgn )
884	!
885	END SUBROUTINE crs_dom_ope_2d
886
887	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)
888	!!----------------------------------------------------------------
889	!!
890	!!
891	!!
892	!!
893	!!----------------------------------------------------------------
894	!! Arguments
895	CHARACTER(len=1), INTENT(in) :: cd_type ! grid type T, W ( U, V, F)
896	REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in) :: p_mask ! Parent grid T mask
897	REAL(wp), DIMENSION(jpi,jpj) , INTENT(in) :: p_e1, p_e2 ! 2D tracer T or W on parent grid
898	REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in) :: p_e3 ! 3D tracer T or W on parent grid
899	REAL(wp), DIMENSION(jpi_crs,jpj_crs) , INTENT(in),OPTIONAL :: p_sfc_2d_crs ! Coarse grid box east or north face quantity
900	REAL(wp), DIMENSION(jpi_crs,jpj_crs,jpk), INTENT(in),OPTIONAL :: p_sfc_3d_crs ! Coarse grid box east or north face quantity
901	REAL(wp), DIMENSION(jpi_crs,jpj_crs,jpk), INTENT(inout) :: p_e3_crs ! Coarse grid box east or north face quantity
902	REAL(wp), DIMENSION(jpi_crs,jpj_crs,jpk), INTENT(inout) :: p_e3_max_crs ! Coarse grid box east or north face quantity
903
904	!! Local variables
905	INTEGER :: ji, jj, jk ! dummy loop indices
906	INTEGER :: ijis, ijie, ijjs, ijje
907	REAL(wp) :: ze3crs
908
909	!!----------------------------------------------------------------
910	p_e3_crs (:,:,:) = 0._wp
911	p_e3_max_crs(:,:,:) = 0._wp
912
913
914	SELECT CASE ( cd_type )
915
916	CASE ('T')
917
918	DO jk = 1, jpk
919	DO ji = nldi_crs, nlei_crs
920
921	ijis = mis_crs(ji)
922	ijie = mie_crs(ji)
923
924	DO jj = nldj_crs, nlej_crs
925
926	ijjs = mjs_crs(jj)
927	ijje = mje_crs(jj)
928
929	p_e3_max_crs(ji,jj,jk) = MAXVAL( p_e3(ijis:ijie,ijjs:ijje,jk) * p_mask(ijis:ijie,ijjs:ijje,jk) )
930
931	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) )
932	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)
933
934	ENDDO
935	ENDDO
936	ENDDO
937
938	CASE ('U')
939
940	DO jk = 1, jpk
941	DO ji = nldi_crs, nlei_crs
942
943	ijis = mis_crs(ji)
944	ijie = mie_crs(ji)
945
946	DO jj = nldj_crs, nlej_crs
947
948	ijjs = mjs_crs(jj)
949	ijje = mje_crs(jj)
950
951	p_e3_max_crs(ji,jj,jk) = MAXVAL( p_e3(ijie,ijjs:ijje,jk) * p_mask(ijie,ijjs:ijje,jk) )
952
953	ze3crs = SUM( p_e2(ijie,ijjs:ijje) * p_e3(ijie,ijjs:ijje,jk) * p_mask(ijie,ijjs:ijje,jk) )
954	IF( p_sfc_2d_crs(ji,jj) .NE. 0._wp )p_e3_crs(ji,jj,jk) = ze3crs / p_sfc_2d_crs(ji,jj)
955	ENDDO
956	ENDDO
957	ENDDO
958
959	CASE ('V')
960
961	DO jk = 1, jpk
962	DO ji = nldi_crs, nlei_crs
963
964	ijis = mis_crs(ji)
965	ijie = mie_crs(ji)
966
967	DO jj = nldj_crs, nlej_crs
968
969	ijjs = mjs_crs(jj)
970	ijje = mje_crs(jj)
971
972	p_e3_max_crs(ji,jj,jk) = MAXVAL( p_e3(ijis:ijie,ijje,jk) * p_mask(ijis:ijie,ijje,jk) )
973
974	ze3crs = SUM( p_e1(ijis:ijie,ijje) * p_e3(ijis:ijie,ijje,jk) * p_mask(ijis:ijie,ijje,jk) )
975	IF( p_sfc_2d_crs(ji,jj) .NE. 0._wp )p_e3_crs(ji,jj,jk) = ze3crs / p_sfc_2d_crs(ji,jj)
976
977	ENDDO
978	ENDDO
979	ENDDO
980
981	CASE ('W')
982
983	DO jk = 1, jpk
984	DO ji = nldi_crs, nlei_crs
985
986	ijis = mis_crs(ji)
987	ijie = mie_crs(ji)
988
989	DO jj = nldj_crs, nlej_crs
990
991	ijjs = mjs_crs(jj)
992	ijje = mje_crs(jj)
993
994	p_e3_max_crs(ji,jj,jk) = MAXVAL( p_e3(ijis:ijie,ijjs:ijje,jk) * p_mask(ijis:ijie,ijjs:ijje,jk) )
995
996	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) )
997	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)
998
999	ENDDO
1000	ENDDO
1001	ENDDO
1002
1003	END SELECT
1004
1005	CALL crs_lbc_lnk( p_e3_max_crs, cd_type, 1.0 )
1006	CALL crs_lbc_lnk( p_e3_crs , cd_type, 1.0 )
1007
1008	END SUBROUTINE crs_dom_e3
1009
1010	SUBROUTINE crs_dom_sfc(p_mask, cd_type, p_surf_crs, p_surf_crs_msk, p_e1, p_e2, p_e3 )
1011	!!=========================================================================================
1012	!!
1013	!!
1014	!!=========================================================================================
1015	!! Arguments
1016	CHARACTER(len=1), INTENT(in) :: cd_type ! grid type T, W ( U, V, F)
1017	REAL(wp), DIMENSION(jpi,jpj,jpk) , INTENT(in) :: p_mask ! Parent grid T mask
1018	REAL(wp), DIMENSION(jpi,jpj) , INTENT(in), OPTIONAL :: p_e1, p_e2 ! 3D tracer T or W on parent grid
1019	REAL(wp), DIMENSION(jpi,jpj,jpk) , INTENT(in), OPTIONAL :: p_e3 ! 3D tracer T or W on parent grid
1020	REAL(wp), DIMENSION(jpi_crs,jpj_crs,jpk), INTENT(out) :: p_surf_crs ! Coarse grid box east or north face quantity
1021	REAL(wp), DIMENSION(jpi_crs,jpj_crs,jpk), INTENT(out) :: p_surf_crs_msk ! Coarse grid box east or north face quantity
1022
1023	!! Local variables
1024	INTEGER :: ji, jj, jk ! dummy loop indices
1025	INTEGER :: ijis,ijie,ijjs,ijje
1026	REAL(wp), DIMENSION(:,:,:), POINTER :: zsurf, zsurfmsk
1027	!!----------------------------------------------------------------
1028	! Initialize
1029	p_surf_crs(:,:,:)=0._wp
1030	p_surf_crs_msk(:,:,:)=0._wp
1031
1032	CALL wrk_alloc( jpi, jpj, jpk, zsurf, zsurfmsk )
1033	!
1034	SELECT CASE ( cd_type )
1035
1036	CASE ('W')
1037	DO jk = 1, jpk
1038	zsurf(:,:,jk) = p_e1(:,:) * p_e2(:,:)
1039	ENDDO
1040
1041	CASE ('V')
1042	DO jk = 1, jpk
1043	zsurf(:,:,jk) = p_e1(:,:) * p_e3(:,:,jk)
1044	ENDDO
1045
1046	CASE ('U')
1047	DO jk = 1, jpk
1048	zsurf(:,:,jk) = p_e2(:,:) * p_e3(:,:,jk)
1049	ENDDO
1050
1051	CASE DEFAULT
1052	DO jk = 1, jpk
1053	zsurf(:,:,jk) = p_e1(:,:) * p_e2(:,:)
1054	ENDDO
1055	END SELECT
1056
1057	DO jk = 1, jpk
1058	zsurfmsk(:,:,jk) = zsurf(:,:,jk) * p_mask(:,:,jk)
1059	ENDDO
1060
1061	SELECT CASE ( cd_type )
1062
1063	CASE ('W')
1064
1065	DO jk = 1, jpk
1066	DO jj = nldj_crs,nlej_crs
1067	ijjs=mjs_crs(jj)
1068	ijje=mje_crs(jj)
1069	DO ji = nldi_crs,nlei_crs
1070	ijis=mis_crs(ji)
1071	ijie=mie_crs(ji)
1072	p_surf_crs (ji,jj,jk) = SUM(zsurf (ijis:ijie,ijjs:ijje,jk) )
1073	p_surf_crs_msk(ji,jj,jk) = SUM(zsurfmsk(ijis:ijie,ijjs:ijje,jk) )
1074	ENDDO
1075	ENDDO
1076	ENDDO
1077
1078	CASE ('U')
1079
1080	DO jk = 1, jpk
1081	DO jj = nldj_crs,nlej_crs
1082	ijjs=mjs_crs(jj)
1083	ijje=mje_crs(jj)
1084	DO ji = nldi_crs,nlei_crs
1085	ijis=mis_crs(ji)
1086	ijie=mie_crs(ji)
1087	p_surf_crs (ji,jj,jk) = SUM(zsurf (ijie,ijjs:ijje,jk) )
1088	p_surf_crs_msk(ji,jj,jk) = SUM(zsurfmsk(ijie,ijjs:ijje,jk) )
1089	ENDDO
1090	ENDDO
1091	ENDDO
1092
1093	CASE ('V')
1094
1095	DO jk = 1, jpk
1096	DO jj = nldj_crs,nlej_crs
1097	ijjs=mjs_crs(jj)
1098	ijje=mje_crs(jj)
1099	DO ji = nldi_crs,nlei_crs
1100	ijis=mis_crs(ji)
1101	ijie=mie_crs(ji)
1102	p_surf_crs (ji,jj,jk) = SUM(zsurf (ijis:ijie,ijje,jk) )
1103	p_surf_crs_msk(ji,jj,jk) = SUM(zsurfmsk(ijis:ijie,ijje,jk) )
1104	ENDDO
1105	ENDDO
1106	ENDDO
1107
1108	END SELECT
1109
1110	CALL crs_lbc_lnk( p_surf_crs , cd_type , 1. )
1111	CALL crs_lbc_lnk( p_surf_crs_msk, cd_type , 1. )
1112
1113	CALL wrk_dealloc( jpi, jpj, jpk, zsurf, zsurfmsk )
1114
1115	END SUBROUTINE crs_dom_sfc
1116
1117	SUBROUTINE crs_dom_def
1118	!!----------------------------------------------------------------
1119	!! * SUBROUTINE crs_dom_def *
1120	!! ** Purpose : Three applications.
1121	!! 1) Define global domain indice of the croasening grid
1122	!! 2) Define local domain indice of the croasening grid
1123	!! 3) Define the processor domain indice for a croasening grid
1124	!!----------------------------------------------------------------
1125	INTEGER :: ji,jj,jk,ijjgloT,ijis,ijie,ijjs,ijje,jn ! dummy indices
1126	INTEGER :: ierr ! allocation error status
1127	INTEGER :: iproci,iprocj,iproc,iprocno,iprocso,iimppt_crs
1128	INTEGER :: ii_start,ii_end,ij_start,ij_end
1129	!!----------------------------------------------------------------
1130
1131
1132	!==============================================================================================
1133	! Define global and local domain sizes
1134	!==============================================================================================
1135	SELECT CASE ( jperio )
1136
1137	CASE ( 0, 1 ) ! limited area
1138
1139	!--!--!--!--!--!--!--!--!--!
1140	! ! ! !
1141	! ! ! !
1142	! ! ! !
1143	!--!--!--!--!--!--!--!--!--!
1144	!IBI36 1 2 3 4 5
1145	!IBI12 ! 1 ! 2 ! 3 !
1146
1147
1148	jpiglo_crs = INT( (jpiglo - 4) / nn_factx ) + 4
1149	jpjglo_crs = INT( (jpjglo - 4) / nn_facty ) + 4
1150
1151	CASE ( 3, 4 ) ! global
1152	jpiglo_crs = INT( (jpiglo - 2) / nn_factx ) + 2
1153	jpjglo_crs = INT( (jpjglo - MOD(jpjglo, nn_facty)) / nn_facty ) + 2
1154
1155	END SELECT
1156
1157	jpiglo_crsm1 = jpiglo_crs - 1
1158	jpjglo_crsm1 = jpjglo_crs - 1
1159
1160	jpi_crs = ( jpiglo_crs - 2 * jpreci + (jpni-1) ) / jpni + 2 * jpreci
1161	jpj_crs = ( jpjglo_crsm1 - 2 * jprecj + (jpnj-1) ) / jpnj + 2 * jprecj
1162
1163	jpi_crsm1 = jpi_crs - 1
1164	jpj_crsm1 = jpj_crs - 1
1165
1166	npolj_crs = npolj
1167
1168	ierr = crs_dom_alloc() ! allocate most coarse grid arrays
1169
1170	!==============================================================================================
1171	! Define processor domain indices
1172	!==============================================================================================
1173	IF( .NOT. lk_mpp ) THEN
1174
1175	nimpp_crs = 1
1176	njmpp_crs = 1
1177	nlci_crs = jpi_crs
1178	nlcj_crs = jpj_crs
1179	nldi_crs = 1
1180	nldj_crs = 1
1181	nlei_crs = jpi_crs
1182	nlej_crs = jpj_crs
1183
1184	ELSE
1185
1186	nimpp_crs = 1
1187	njmpp_crs = 1
1188	nlci_crs = jpi_crs
1189	nlcj_crs = jpj_crs
1190	nldi_crs = 1
1191	nldj_crs = 1
1192	nlei_crs = jpi_crs
1193	nlej_crs = jpj_crs
1194
1195	!==============================================================================================
1196	! mpp_ini2
1197	!==============================================================================================
1198
1199	!order of local domain in i and j directions
1200	DO ji = 1 , jpni
1201	DO jj = 1 ,jpnj
1202	IF( nfipproc(ji,jj) == narea-1 )THEN
1203	iproci=ji
1204	iprocj=jj
1205	ENDIF
1206	ENDDO
1207	ENDDO
1208
1209	!==========================================================================
1210	! check
1211	!==========================================================================
1212	!WRITE(narea+1000-1,*)"nfipproc(ji,jj),narea :",nfipproc(iproci,iprocj),narea
1213	!WRITE(narea+1000-1,*)"proc i,j ",iproci,iprocj
1214	!WRITE(narea+1000-1,*)"jpni jpnj jpnij ",jpni,jpnj,jpnij
1215	!WRITE(narea+1000-1,*)"nperio jperio ",nperio,jperio
1216	!WRITE(narea+1000-1,*)"nowe noea",nowe,noea
1217	!WRITE(narea+1000-1,*)"noso nono",noso,nono
1218	!WRITE(narea+1000-1,*)"nbondi nbondj ",nbondi,nbondj
1219	!WRITE(narea+1000-1,*)"jpiglo jpjglo ",jpiglo,jpjglo
1220	!WRITE(narea+1000-1,*)"jpi jpj ",jpi,jpj
1221	!WRITE(narea+1000-1,*)"nbondi nbondj",nbondi,nbondj
1222	!WRITE(narea+1000-1,*)"nimpp njmpp ",nimpp,njmpp
1223	!WRITE(narea+1000-1,*)"loc jpi nldi,nlei,nlci ",jpi, nldi ,nlei ,nlci
1224	!WRITE(narea+1000-1,*)"glo jpi nldi,nlei ",jpi, nldi+nimpp-1,nlei+nimpp-1
1225	!WRITE(narea+1000-1,*)"loc jpj nldj,nlej,nlcj ",jpj, nldj ,nlej ,nlcj
1226	!WRITE(narea+1000-1,*)"glo jpj nldj,nlej ",jpj, nldj+njmpp-1,nlej+njmpp-1
1227	!WRITE(narea+1000-1,*)"jpiglo_crs jpjglo_crs ",jpiglo_crs,jpjglo_crs
1228	!WRITE(narea+1000-1,*)"jpi_crs jpj_crs ",jpi_crs,jpj_crs
1229	!WRITE(narea+1000-1,*)"glamt gphit ",glamt(1,1),gphit(jpi,jpj),glamt(jpi,jpj),gphit(jpi,jpj)
1230	!WRITE(narea+1000-1,*)"min max tmask ",MINVAL(tmask),MAXVAL(tmask)
1231	!CALL FLUSH(narea+1000-1)
1232	!==========================================================================
1233	! coarsened domain: dimensions along I
1234	!==========================================================================
1235
1236	!------------------------------------------------------------------------------------
1237	!I-1 fill mis2_crs and mie2_crs: arrays to switch from physic grid to coarsened grid
1238	!------------------------------------------------------------------------------------
1239
1240	! !--------!--------!--------!
1241	! ! ! ! !
1242	! ! ! ! !
1243	! ! ! ! !
1244	! !--------!--------!--------!
1245	! ! ! ! !
1246	! ! ! ji,jj ! !
1247	! ! ! ! !
1248	! !--------!--------!--------!
1249	! ! ! ! !
1250	! ! ! ! !
1251	! ! ! ! !
1252	! !--------!--------!--------!
1253	! mis2_crs(ji) mie2_crs(ji)
1254
1255
1256	SELECT CASE ( jperio )
1257
1258	CASE ( 0, 1 )
1259
1260	DO ji=1,jpiglo_crs
1261	ijis=nn_factx*ji-6
1262	ijie=nn_factx*ji-4
1263	mis2_crs(ji)=ijis
1264	mie2_crs(ji)=ijie
1265	!WRITE(narea+1000-1,*)"glo crs",ji,ijis,ijie,ijis-nimpp+1,ijie-nimpp+1
1266	ENDDO
1267
1268	CASE ( 3, 4 ) ! 3, 4 : T-Pivot at North Fold: make correspondinf the pivot points of the 2 grids
1269
1270	DO ji=1,jpiglo_crs
1271	ijis=nn_factx*(ji-1)-2
1272	ijie=nn_factx*(ji-1)
1273	mis2_crs(ji)=ijis
1274	mie2_crs(ji)=ijie
1275	!WRITE(narea+1000-1,*)"glo crs",ji,ijis,ijie,ijis-nimpp+1,ijie-nimpp+1
1276	ENDDO
1277
1278	CASE DEFAULT
1279	WRITE(numout,*) 'crs_init. Only jperio = 0, 1, 3, 4 supported; narea: ',narea
1280	END SELECT
1281
1282	!-------------------------------------------------------------------------------
1283	! I-2 find the first CRS cell which is inside the physic grid inner domain
1284	!-------------------------------------------------------------------------------
1285	! ijis : global indice of the first CRS cell which inside the physic grid inner domain
1286	! mis2_crs(ijis) : global indice of the bottom-left physic cell corresponding to ijis cell
1287	! ii_start : local ndice of the bottom-left physic cell corresponding to ijis cell
1288
1289	ji=1
1290	DO WHILE( mis2_crs(ji) - nimpp + 1 .LT. 1 )
1291	ji=ji+1
1292	IF( ji==jpiglo_crs )EXIT
1293	END DO
1294
1295	ijis=ji
1296	ii_start = mis2_crs(ijis)-nimpp+1
1297	!WRITE(narea+1000-1,*)"start ",ijis,mis2_crs(ijis),ii_start ; CALL FLUSH(narea+1000-1)
1298
1299	!----------------------------------------------------------------------------------------------
1300	! I-3 compute nldi_crs
1301	! special case when the domain on the left is land:
1302	! compute mis2_crs and mie2_crs for the first cell of the local domain
1303	!---------------------------------------------------------------------------------------------
1304	nldi_crs = 2
1305	IF( nowe == -1 .AND. ( jperio==3 .OR. jperio==4 .OR. jperio==0 .OR. jperio==1 ) )THEN
1306
1307	mie2_crs(ijis-1) = mis2_crs(ijis)-1
1308
1309	SELECT CASE(ii_start)
1310	CASE(1)
1311	nldi_crs=2
1312	mie2_crs(ijis-1) = 1
1313	mis2_crs(ijis-1) = 1
1314	CASE(2)
1315	nldi_crs=2
1316	mis2_crs(ijis-1) = mie2_crs(ijis-1)
1317	CASE(3)
1318	nldi_crs=2
1319	mis2_crs(ijis-1) = mie2_crs(ijis-1) -1
1320	END SELECT
1321
1322	ENDIF
1323
1324	!----------------------------------------------------------------------------------------------
1325	! I-4 compute nimpp_crs
1326	!---------------------------------------------------------------------------------------------
1327	nimpp_crs = ijis-1
1328	IF( nimpp==1 )nimpp_crs=1
1329
1330	!WRITE(narea+1000-1,*)" nimpp_crs ",nimpp_crs
1331
1332	!-------------------------------------------------------------------------------
1333	! I-5 find the last CRS cell which is inside the physic grid inner domain
1334	!-------------------------------------------------------------------------------
1335	! ijie : global indice of the last CRS cell which inside the physic grid inner domain
1336
1337	ji=jpiglo_crs
1338	DO WHILE( mie2_crs(ji) - nimpp + 1 .GT. nlci )
1339	ji=ji-1
1340	IF( ji==1 )EXIT
1341	END DO
1342	ijie=ji
1343	!WRITE(narea+1000-1,*)"end ",ijie ; CALL FLUSH(narea+1000-1)
1344
1345	!-------------------------------------------------------------------------------
1346	! I-6 compute nlei_crs and nlci_crs
1347	!-------------------------------------------------------------------------------
1348	nlei_crs = ijie-nimpp_crs+1
1349	nlci_crs = nlei_crs+1
1350
1351	!-------------------------------------------------------------------------------
1352	! I-7 local to global and global to local indices for CRS grid
1353	!-------------------------------------------------------------------------------
1354	DO ji = 1, jpi_crs
1355	mig_crs(ji) = ji + nimpp_crs - 1
1356	!WRITE(narea+1000-1,*)"crs loctoglo",ji,mig_crs(ji) ; CALL FLUSH(narea+1000-1)
1357	ENDDO
1358	DO ji = 1, jpiglo_crs
1359	mi0_crs(ji) = MAX( 1, MIN( ji - nimpp_crs + 1 , jpi_crs + 1 ) )
1360	mi1_crs(ji) = MAX( 0, MIN( ji - nimpp_crs + 1 , jpi_crs ) )
1361	ENDDO
1362
1363	!---------------------------------------------------------------------------------------
1364	! I-8 CRS to physic grid: local indices mis_crs and mie_crs and local coarsening factor
1365	!---------------------------------------------------------------------------------------
1366	DO ji = 1, nlei_crs
1367	mis_crs(ji) = mis2_crs(mig_crs(ji)) - nimpp + 1
1368	mie_crs(ji) = mie2_crs(mig_crs(ji)) - nimpp + 1
1369	nfactx(ji) = mie_crs(ji)-mis_crs(ji)+1
1370	ENDDO
1371
1372	!-----------------------------------------------------------------------------
1373	!adapt western indices for E-W BC ( jperio 3/4 ) or ghost cells ( jperio 0/1)
1374	!-----------------------------------------------------------------------------
1375	IF( iproci == 1 ) THEN
1376
1377	SELECT CASE ( jperio )
1378
1379	CASE ( 3, 4 )
1380
1381	nldi_crs=1
1382	mis_crs(1) = 1
1383	mie_crs(1) = 1
1384	mis2_crs(1) = 1
1385	mie2_crs(1) = 1
1386
1387	CASE ( 0, 1 )
1388	nldi_crs=1
1389	!the first cell is a ghsot cell; so set indices to 1 just to have an positive indice
1390	mis_crs(1) = 1
1391	mie_crs(1) = 1
1392	mis2_crs(1) = 1
1393	mie2_crs(1) = 1
1394	nfactx(1) = 1
1395
1396	!the second coarsened cell correspond to the first (ghost) and second cell of HR grid
1397	mis_crs(2) = 1
1398	mie_crs(2) = 2
1399	mis2_crs(2) = 1
1400	mie2_crs(2) = 2
1401	nfactx(2) = 2
1402
1403	CASE DEFAULT
1404	WRITE(numout,*) 'crs_init. Only jperio = 0, 1, 3, 4 supported; narea: ',narea
1405	END SELECT
1406
1407	ENDIF
1408
1409	!----------------------------------------------------------------------------
1410	!adapt eastern indices for E-W BC ( jperio 3/4 ) or ghost cells ( jperio 0/1)
1411	!----------------------------------------------------------------------------
1412	SELECT CASE ( jperio )
1413
1414	CASE ( 3, 4 )
1415
1416	IF( iproci == jpni ) THEN
1417	nlei_crs = jpiglo_crs-nimpp_crs+1
1418	nlci_crs = nlei_crs
1419	mis_crs(nlei_crs) = 1
1420	mie_crs(nlei_crs) = 1
1421	mis2_crs(nlei_crs) = 1
1422	mie2_crs(nlei_crs) = 1
1423	nfactx(nlei_crs) = 0
1424	ENDIF
1425
1426	CASE ( 0, 1 )
1427	IF( iproci == jpni ) THEN
1428
1429	! \| \| \| \|
1430	! __\|_____!_____!_____\|_____!_____!_____\|_____!_____!_____\|
1431	!HR grid loc nlei
1432	!HR grid glo jpiglo
1433	!HRCRS grid loc nlei_crs-1 nlei
1434	!HRCRS grid glo jpiglo-1 jpiglo
1435
1436
1437	!last cell ( = ghost cell)
1438	nlei_crs = jpiglo_crs-nimpp_crs+1
1439	nlci_crs = nlei_crs
1440
1441	mis2_crs(nlei_crs) = jpiglo
1442	mie2_crs(nlei_crs) = jpiglo
1443	mis_crs (nlei_crs) = jpiglo - nimpp + 1
1444	mie_crs (nlei_crs) = jpiglo - nimpp + 1
1445	nfactx (nlei_crs) = 1
1446
1447	mis2_crs(nlei_crs-1) = jpiglo - 1
1448	mie2_crs(nlei_crs-1) = jpiglo
1449	mis_crs (nlei_crs-1) = jpiglo - 1 - nimpp + 1
1450	mie_crs (nlei_crs-1) = jpiglo - nimpp + 1
1451	nfactx (nlei_crs-1) = 2
1452
1453	ENDIF
1454	CASE DEFAULT
1455	WRITE(numout,*) 'crs_init. Only jperio = 0, 1, 3, 4 supported; narea: ',narea
1456	END SELECT
1457
1458
1459	!WRITE(narea+1000-1,*)"loc crs jpi nldi,nlei,nlci ",jpi_crs, nldi_crs ,nlei_crs ,nlci_crs
1460	!CALL FLUSH(narea+1000-1)
1461	!WRITE(narea+1000-1,*)"glo crs jpi nldi,nlei ",jpi_crs, nldi_crs+nimpp_crs-1,nlei_crs+nimpp_crs-1
1462	!CALL FLUSH(narea+1000-1)
1463	!DO ji = 1, jpi_crs
1464	! WRITE(narea+1000-1,'(A15,7(1X,I4.4))')"crs test i",ji,ji+nimpp_crs-1,mis_crs(ji),mie_crs(ji), &
1465	! & mis_crs(ji)+nimpp-1,mie_crs(ji)+nimpp-1,nfactx(ji)
1466	!ENDDO
1467
1468	!==========================================================================
1469	! coarsened domain: dimensions along J
1470	!==========================================================================
1471
1472	!-----------------------------------------------------------------------------------
1473	!J-1 fill mjs2_crs and mje2_crs: arrays to switch from physic grid to coarsened grid
1474	!-----------------------------------------------------------------------------------
1475
1476	! !--------!--------!--------!
1477	! ! ! ! !
1478	! ! ! ! !
1479	! ! ! ! ! mje2_crs(jj)
1480	! !--------!--------!--------!
1481	! ! ! ! !
1482	! ! ! ji,jj ! !
1483	! ! ! ! !
1484	! !--------!--------!--------!
1485	! ! ! ! !
1486	! ! ! ! ! mjs2_crs(jj)
1487	! ! ! ! !
1488	! !--------!--------!--------!
1489
1490	SELECT CASE ( jperio )
1491
1492	CASE ( 0, 1 ) !
1493
1494	DO jj=1,jpjglo_crs
1495	ijjs=nn_facty*jj-6
1496	ijje=nn_facty*jj-4
1497	mjs2_crs(jj)=ijjs
1498	mje2_crs(jj)=ijje
1499	!WRITE(narea+1000-1,*)"glo crs",jj,ijjs,ijje,ijjs-njmpp+1,ijje-njmpp+1
1500	ENDDO
1501
1502	CASE ( 3, 4 ) ! 3, 4 : T-Pivot at North Fold
1503
1504	DO jj=1,jpjglo_crs
1505	ijjs=nn_facty*(jj) - 5 + MOD(jpjglo, nn_facty)
1506	ijje=nn_facty*(jj) - 3 + MOD(jpjglo, nn_facty)
1507	mjs2_crs(jj)=ijjs
1508	mje2_crs(jj)=ijje
1509	!WRITE(narea+1000-1,*)"glo crs",jj,ijjs,ijje,ijjs-njmpp+1,ijje-njmpp+1
1510	ENDDO
1511
1512	CASE DEFAULT
1513	WRITE(numout,*) 'crs_init. Only jperio = 0, 1, 3, 4 supported; narea: ',narea
1514	END SELECT
1515
1516	!-------------------------------------------------------------------------------
1517	! J-2 find the first CRS cell which is inside the physic grid inner domain
1518	!-------------------------------------------------------------------------------
1519	! ijjs : global indice of the first CRS cell which inside the physic grid inner domain
1520	! mis2_crs(ijjs) : global indice of the bottom-left physic cell corresponding to ijis cell
1521	! ij_start : local ndice of the bottom-left physic cell corresponding to ijis cell
1522
1523	jj=1
1524	DO WHILE( mjs2_crs(jj) - njmpp + 1 .LT. 1 )
1525	jj=jj+1
1526	IF( jj==jpjglo_crs )EXIT
1527	END DO
1528
1529	ijjs=jj
1530	ij_start = mjs2_crs(ijjs)-njmpp+1
1531
1532	!----------------------------------------------------------------------------------------------
1533	! J-3 compute nldj_crs
1534	! global: special case when the domain on the north is land:
1535	! compute mjs2_crs and mje2_crs for the first cell of the local domain
1536	! local : special case for southern domain
1537	!---------------------------------------------------------------------------------------------
1538	nldj_crs = 2
1539
1540	IF( jperio==3 .OR. jperio==4 )THEN
1541
1542	IF( noso == -1 )THEN
1543
1544	mje2_crs(ijjs-1) = mjs2_crs(ijjs)-1
1545
1546	SELECT CASE(ij_start)
1547	CASE(1)
1548	nldj_crs=2
1549	mje2_crs(ijjs-1) = -1
1550	mjs2_crs(ijjs-1) = -1
1551	CASE(2)
1552	nldj_crs=2
1553	mjs2_crs(ijjs-1) = mje2_crs(ijjs-1)
1554	CASE(3)
1555	nldj_crs=2
1556	mjs2_crs(ijjs-1) = mje2_crs(ijjs-1) -1
1557	CASE DEFAULT
1558	WRITE(narea+8000-1,*)"WRONG VALUE FOR iistart ",ii_start
1559	END SELECT
1560
1561	ENDIF
1562	ENDIF
1563	IF( jperio==0 .OR. jperio==1 )THEN
1564	IF( njmpp==1 )nldj_crs=1
1565	END IF
1566
1567	!----------------------------------------------------------------------------------------------
1568	! J-4 compute nimpp_crs
1569	!---------------------------------------------------------------------------------------------
1570	njmpp_crs = ijjs-1
1571	IF( njmpp==1 )njmpp_crs=1
1572	!WRITE(narea+1000-1,*)" njmpp_crs ",njmpp_crs
1573
1574	!-------------------------------------------------------------------------------
1575	! J-5 find the last CRS cell which is inside the physic grid inner domain
1576	!-------------------------------------------------------------------------------
1577	! ijje : global indice of the last CRS cell which inside the physic grid inner domain
1578
1579	jj=jpjglo_crs
1580	DO WHILE( mje2_crs(jj) - njmpp + 1 .GT. nlcj )
1581	jj=jj-1
1582	IF( jj==1 )EXIT
1583	END DO
1584	ijje=jj
1585
1586	!-------------------------------------------------------------------------------
1587	! J-6 compute nlej_crs and nlcj_crs
1588	!-------------------------------------------------------------------------------
1589	nlej_crs=ijje-njmpp_crs+1
1590	nlcj_crs=nlej_crs+jprecj
1591
1592	!north-fold BC for global
1593	IF( iprocj == jpnj )THEN
1594	IF( jperio==3 .OR. jperio==4 )THEN
1595	nlej_crs=nlej_crs+1
1596	nlcj_crs=nlej_crs
1597	ENDIF
1598	ENDIF
1599
1600	!-------------------------------------------------------------------------------
1601	! J-7 local to global and global to local indices for CRS grid
1602	!-------------------------------------------------------------------------------
1603	DO jj = 1, jpj_crs
1604	mjg_crs(jj) = jj + njmpp_crs - 1
1605	ENDDO
1606	DO jj = 1, jpjglo_crs
1607	mj0_crs(jj) = MAX( 1, MIN( jj - njmpp_crs + 1 , jpj_crs + 1 ) )
1608	mj1_crs(jj) = MAX( 0, MIN( jj - njmpp_crs + 1 , jpj_crs ) )
1609	ENDDO
1610
1611	!---------------------------------------------------------------------------------------
1612	! J-8 CRS to physic grid: local indices mis_crs and mie_crs and local coarsening factor
1613	!---------------------------------------------------------------------------------------
1614	DO jj = 1, nlej_crs
1615	mjs_crs(jj) = mjs2_crs(mjg_crs(jj)) - njmpp + 1
1616	mje_crs(jj) = mje2_crs(mjg_crs(jj)) - njmpp + 1
1617	nfacty(jj) = mje_crs(jj)-mjs_crs(jj)+1
1618	!WRITE(narea+1000-1,*)"test J",jj,mjg_crs(jj),mjs_crs(jj),mje_crs(jj),mjs_crs(jj)+njmpp-1,mje_crs(jj)+njmpp-1,nfacty(jj)
1619	ENDDO
1620
1621	!-----------------------------------------------------------------------------
1622	!adpat indices for southern side of the domain (ghost cells for jperio 0/1 )
1623	!-----------------------------------------------------------------------------
1624	IF( iprocj == 1 ) THEN
1625
1626	SELECT CASE ( jperio )
1627
1628	CASE ( 3, 4 )
1629	! do nothing
1630	CASE ( 0, 1 )
1631	nldj_crs = 1
1632	!the first cell is a ghsot cell; so set indices to 1 just to have an positive indice
1633	mjs_crs(1) = 1
1634	mje_crs(1) = 1
1635	mjs2_crs(1) = 1
1636	mje2_crs(1) = 1
1637	nfacty(1) = 1
1638
1639	!the second coarsened cell correspond to the first (ghost) and second cell of HR grid
1640	mjs_crs(2) = 1
1641	mje_crs(2) = 2
1642	mjs2_crs(2) = 1
1643	mje2_crs(2) = 2
1644	nfacty(2) = 2
1645
1646	CASE DEFAULT
1647	WRITE(numout,*) 'crs_init. Only jperio = 0, 1, 3, 4 supported; narea: ',narea
1648	END SELECT
1649
1650	ENDIF
1651
1652	!-----------------------------------------------
1653	!adapt northen indices for ghost cells ( jperio 0/1)
1654	!-----------------------------------------------
1655	SELECT CASE ( jperio )
1656
1657	CASE ( 3, 4 )
1658	IF( iprocj == jpnj .AND. jj == nlej_crs )THEN
1659	mjs_crs(jj) = nlej
1660	mjs2_crs(mjg_crs(jj)) = mjg(nlej)
1661	mje_crs(jj) = nlej
1662	mje2_crs(mjg_crs(jj)) = mjg(nlej)
1663	ENDIF
1664
1665	CASE ( 0, 1 )
1666	IF( iprocj == jpnj ) THEN
1667	!north side of the domain
1668
1669	!last cell ( = ghost cell)
1670	nlej_crs = jpjglo_crs-njmpp_crs+1
1671	nlcj_crs = nlej_crs
1672
1673	mjs2_crs(nlej_crs) = jpjglo
1674	mje2_crs(nlej_crs) = jpjglo
1675	mjs_crs (nlej_crs) = jpjglo - njmpp + 1
1676	mje_crs (nlej_crs) = jpjglo - njmpp + 1
1677	nfacty (nlej_crs) = 1
1678
1679	mjs2_crs(nlej_crs-1) = jpjglo - 1
1680	mje2_crs(nlej_crs-1) = jpjglo
1681	mjs_crs (nlej_crs-1) = jpjglo - 1 - njmpp + 1
1682	mje_crs (nlej_crs-1) = jpjglo - njmpp + 1
1683	nfacty (nlej_crs-1) = 2
1684
1685	ENDIF
1686	CASE DEFAULT
1687	WRITE(numout,*) 'crs_init. Only jperio = 0, 1, 3, 4 supported; narea: ',narea
1688	END SELECT
1689
1690	!WRITE(narea+1000-1,*)"loc crs jpj nldj,nlej,nlcj ",jpj_crs, nldj_crs ,nlej_crs,nlcj_crs ; CALL FLUSH(narea+1000-1)
1691	!WRITE(narea+1000-1,*)"glo crs jpj nldj,nlej ",jpj_crs, nldj_crs+njmpp_crs-1,nlej_crs+njmpp_crs-1 ;CALL FLUSH(narea+1000-1)
1692	!DO jj = 1, jpj_crs
1693	! WRITE(narea+1000-1,'(A15,7(1X,I4.4))')"crs test j",jj,jj+njmpp_crs-1,mjs_crs(jj),mje_crs(jj), &
1694	! & mjs_crs(jj)+njmpp-1,mje_crs(jj)+njmpp-1,nfacty(jj)
1695	!ENDDO
1696
1697	!==========================================================================
1698	! send local start and end indices to all procs
1699	!==========================================================================
1700
1701	nldit_crs(:)=0 ; nleit_crs(:)=0 ; nlcit_crs(:)=0 ; nimppt_crs(:)=0
1702	nldjt_crs(:)=0 ; nlejt_crs(:)=0 ; nlcjt_crs(:)=0 ; njmppt_crs(:)=0
1703
1704	CALL mppgatheri((/nlci_crs/),0,nlcit_crs) ; CALL mppgatheri((/nlcj_crs/),0,nlcjt_crs)
1705	CALL mppgatheri((/nldi_crs/),0,nldit_crs) ; CALL mppgatheri((/nldj_crs/),0,nldjt_crs)
1706	CALL mppgatheri((/nlei_crs/),0,nleit_crs) ; CALL mppgatheri((/nlej_crs/),0,nlejt_crs)
1707	CALL mppgatheri((/nimpp_crs/),0,nimppt_crs) ; CALL mppgatheri((/njmpp_crs/),0,njmppt_crs)
1708
1709	DO jj = 1 ,jpnj
1710	DO ji = 1 , jpni
1711	jn=nfipproc(ji,jj)+1
1712	IF( jn .GE. 1 )THEN
1713	nfiimpp_crs(ji,jj)=nimppt_crs(jn)
1714	ELSE
1715	nfiimpp_crs(ji,jj) = ANINT( REAL( (nfiimpp(ji,jj) + 1 ) / nn_factx, wp ) ) + 1
1716	ENDIF
1717	ENDDO
1718	ENDDO
1719
1720	!nogather=T
1721	nfsloop_crs = 1
1722	nfeloop_crs = nlci_crs
1723	DO jn = 2,jpni-1
1724	IF( nfipproc(jn,jpnj) .eq. (narea - 1) )THEN
1725	IF (nfipproc(jn - 1 ,jpnj) .eq. -1 )THEN
1726	nfsloop_crs = nldi_crs
1727	ENDIF
1728	IF( nfipproc(jn + 1,jpnj) .eq. -1 )THEN
1729	nfeloop_crs = nlei_crs
1730	ENDIF
1731	ENDIF
1732	END DO
1733
1734	!==========================================================================
1735	! check
1736	!==========================================================================
1737	!WRITE(narea+1000-1,*)"mpp_crs ",nimpp_crs,njmpp_crs
1738	!WRITE(narea+1000-1,*)"loc crs jpi nldi,nlei,nlci ",jpi_crs, nldi_crs ,nlei_crs ,nlci_crs
1739	!WRITE(narea+1000-1,*)"glo crs jpi nldi,nlei ",jpi_crs, nldi_crs+nimpp_crs-1,nlei_crs+nimpp_crs-1
1740	!WRITE(narea+1000-1,*)"loc crs jpj nldj,nlej,nlcj ",jpj_crs, nldj_crs ,nlej_crs ,nlcj_crs
1741	!WRITE(narea+1000-1,*)"glo crs jpj nldj,nlej ",jpj_crs, nldj_crs+njmpp_crs-1,nlej_crs+njmpp_crs-1
1742
1743	!==========================================================================
1744	! Save the parent grid information
1745	!==========================================================================
1746	IF( jpizoom /= 1 .OR. jpjzoom /= 1) STOP !cbr mettre un ctlstp et ailleurs ( crsini )
1747	jpi_full = jpi
1748	jpj_full = jpj
1749	jpim1_full = jpim1
1750	jpjm1_full = jpjm1
1751	npolj_full = npolj
1752	jpiglo_full = jpiglo
1753	jpjglo_full = jpjglo
1754
1755	nlcj_full = nlcj
1756	nlci_full = nlci
1757	nldi_full = nldi
1758	nldj_full = nldj
1759	nlei_full = nlei
1760	nlej_full = nlej
1761	nimpp_full = nimpp
1762	njmpp_full = njmpp
1763
1764	nlcit_full(:) = nlcit(:)
1765	nldit_full(:) = nldit(:)
1766	nleit_full(:) = nleit(:)
1767	nimppt_full(:) = nimppt(:)
1768	nlcjt_full(:) = nlcjt(:)
1769	nldjt_full(:) = nldjt(:)
1770	nlejt_full(:) = nlejt(:)
1771	njmppt_full(:) = njmppt(:)
1772
1773	nfsloop_full = nfsloop
1774	nfeloop_full = nfeloop
1775
1776	nfiimpp_full(:,:) = nfiimpp(:,:)
1777
1778
1779	!==========================================================================
1780	! control
1781	!==========================================================================
1782	CALL dom_grid_crs !swich from mother grid to coarsened grid
1783
1784	IF(lwp) THEN
1785	WRITE(numout,*)
1786	WRITE(numout,*) 'crs_init : coarse grid dimensions'
1787	WRITE(numout,*) '~~~~~~~ coarse domain global j-dimension jpjglo = ', jpjglo
1788	WRITE(numout,*) '~~~~~~~ coarse domain global i-dimension jpiglo = ', jpiglo
1789	WRITE(numout,*) '~~~~~~~ coarse domain local i-dimension jpi = ', jpi
1790	WRITE(numout,*) '~~~~~~~ coarse domain local j-dimension jpj = ', jpj
1791	WRITE(numout,*)
1792	WRITE(numout,*) ' nproc = ' , nproc
1793	WRITE(numout,*) ' nlci = ' , nlci
1794	WRITE(numout,*) ' nlcj = ' , nlcj
1795	WRITE(numout,*) ' nldi = ' , nldi
1796	WRITE(numout,*) ' nldj = ' , nldj
1797	WRITE(numout,*) ' nlei = ' , nlei
1798	WRITE(numout,*) ' nlej = ' , nlej
1799	WRITE(numout,*) ' nlei_full=' , nlei_full
1800	WRITE(numout,*) ' nldi_full=' , nldi_full
1801	WRITE(numout,*) ' nimpp = ' , nimpp
1802	WRITE(numout,*) ' njmpp = ' , njmpp
1803	WRITE(numout,*) ' njmpp_full = ', njmpp_full
1804	WRITE(numout,*)
1805	ENDIF
1806
1807	CALL dom_grid_glo ! switch from coarsened grid to mother grid
1808
1809	nrestx = MOD( nn_factx, 2 ) ! check if even- or odd- numbered reduction factor
1810	nresty = MOD( nn_facty, 2 )
1811
1812	IF( nresty == 0 )THEN
1813	IF( npolj == 3 ) npolj_crs = 5
1814	IF( npolj == 5 ) npolj_crs = 3
1815	ENDIF
1816
1817	rfactxy = nn_factx * nn_facty
1818
1819	ENDIF ! lk_mpp
1820	!
1821	nistr = mis_crs(2) ; niend = mis_crs(nlci_crs - 1)
1822	njstr = mjs_crs(3) ; njend = mjs_crs(nlcj_crs - 1)
1823	!
1824	!
1825	END SUBROUTINE crs_dom_def
1826
1827	SUBROUTINE crs_dom_bat
1828	!!----------------------------------------------------------------
1829	!! * SUBROUTINE crs_dom_bat *
1830	!! ** Purpose : coarsenig bathy
1831	!!----------------------------------------------------------------
1832	!!
1833	!! local variables
1834	INTEGER :: ji,jj,jk ! dummy indices
1835	REAL(wp), DIMENSION(:,:) , POINTER :: zmbk
1836	!!----------------------------------------------------------------
1837
1838	CALL wrk_alloc( jpi_crs, jpj_crs, zmbk )
1839
1840	mbathy_crs(:,:) = jpkm1
1841	mbkt_crs(:,:) = 1
1842	mbku_crs(:,:) = 1
1843	mbkv_crs(:,:) = 1
1844
1845
1846	DO jj = 1, jpj_crs
1847	DO ji = 1, jpi_crs
1848	jk = 0
1849	DO WHILE( tmask_crs(ji,jj,jk+1) > 0.)
1850	jk = jk + 1
1851	ENDDO
1852	mbathy_crs(ji,jj) = float( jk )
1853	ENDDO
1854	ENDDO
1855
1856	CALL wrk_alloc( jpi_crs, jpj_crs, zmbk )
1857
1858	zmbk(:,:) = 0.0
1859	zmbk(:,:) = REAL( mbathy_crs(:,:), wp ) ; CALL crs_lbc_lnk(zmbk,'T',1.0) ; mbathy_crs(:,:) = INT( zmbk(:,:) )
1860
1861
1862	!
1863	IF(lwp) WRITE(numout,*)
1864	IF(lwp) WRITE(numout,*) ' crsini : mbkt is ocean bottom k-index of T-, U-, V- and W-levels '
1865	IF(lwp) WRITE(numout,*) ' ~~~~~~~~~~~~~'
1866	!
1867	mbkt_crs(:,:) = MAX( mbathy_crs(:,:) , 1 ) ! bottom k-index of T-level (=1 over land)
1868	! ! bottom k-index of W-level = mbkt+1
1869
1870	DO jj = 1, jpj_crsm1 ! bottom k-index of u- (v-) level
1871	DO ji = 1, jpi_crsm1
1872	mbku_crs(ji,jj) = MIN( mbkt_crs(ji+1,jj ) , mbkt_crs(ji,jj) )
1873	mbkv_crs(ji,jj) = MIN( mbkt_crs(ji ,jj+1) , mbkt_crs(ji,jj) )
1874	END DO
1875	END DO
1876
1877	! convert into REAL to use lbc_lnk ; impose a min value of 1 as a zero can be set in lbclnk
1878	zmbk(:,:) = 1.e0;
1879	zmbk(:,:) = REAL( mbku_crs(:,:), wp ) ; CALL crs_lbc_lnk(zmbk,'U',1.0) ; mbku_crs (:,:) = MAX( INT( zmbk(:,:) ), 1 )
1880	zmbk(:,:) = REAL( mbkv_crs(:,:), wp ) ; CALL crs_lbc_lnk(zmbk,'V',1.0) ; mbkv_crs (:,:) = MAX( INT( zmbk(:,:) ), 1 )
1881	!
1882	CALL wrk_dealloc( jpi_crs, jpj_crs, zmbk )
1883	!
1884	END SUBROUTINE crs_dom_bat
1885
1886	SUBROUTINE crs_dom_top
1887	!!----------------------------------------------------------------
1888	!! * SUBROUTINE crs_dom_top *
1889	!!
1890	!! ** Purpose : coarsening mikt
1891	!!
1892	!!----------------------------------------------------------------
1893	INTEGER :: ji, jj, jk
1894	INTEGER :: ijis, ijie, ijjs, ijje
1895
1896	!!----------------------------------------------------------------
1897
1898	mikt_crs(:,:)=1
1899
1900	DO jj = nldj_crs,nlej_crs
1901
1902	ijjs = mjs_crs(jj)
1903	ijje = mje_crs(jj)
1904
1905	DO ji = nldi_crs, nlei_crs
1906
1907	ijis = mis_crs(ji)
1908	ijie = mie_crs(ji)
1909
1910	mikt_crs(ji,jj) = MINVAL( mikt(ijis:ijie,ijjs:ijje) )
1911	ENDDO
1912	ENDDO
1913
1914	mikt_crs = MAX( mikt_crs , 1 )
1915
1916	END SUBROUTINE crs_dom_top
1917
1918	SUBROUTINE PIKSRT(N,ARR)
1919	INTEGER ,INTENT(IN) :: N
1920	REAL(kind=8),DIMENSION(N),INTENT(INOUT) :: ARR
1921
1922	INTEGER :: i,j
1923	REAL(kind=8) :: a
1924	!!----------------------------------------------------------------
1925
1926	DO j=2, N
1927	a=ARR(j)
1928	DO i=j-1,1,-1
1929	IF(ARR(i)<=a) goto 10
1930	ARR(i+1)=ARR(i)
1931	ENDDO
1932	i=0
1933	10 ARR(i+1)=a
1934	ENDDO
1935	RETURN
1936
1937	END SUBROUTINE PIKSRT
1938
1939
1940	END MODULE crsdom

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

Download in other formats: