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.

domain.f90 in branches/2013/dev_rev4119_MERCATOR4_CONFMAN/NEMOGCM/TOOLS/SIREN/src – NEMO

Context Navigation

source: branches/2013/dev_rev4119_MERCATOR4_CONFMAN/NEMOGCM/TOOLS/SIREN/src/domain.f90 @ 4213

Last change on this file since 4213 was 4213, checked in by cbricaud, 10 years ago
first draft of the CONFIGURATION MANAGER demonstrator
File size: 52.7 KB

Line
1	!----------------------------------------------------------------------
2	! NEMO system team, System and Interface for oceanic RElocable Nesting
3	!----------------------------------------------------------------------
4	!
5	! MODULE: dom
6	!
7	! DESCRIPTION:
8	!> @brief
9	!> This module manage domain computation.
10	!
11	!> @details
12	!>
13	!>
14	!>
15	!>
16	!>
17	!> @author
18	!> J.Paul
19	! REVISION HISTORY:
20	!> @date Nov, 2013 - Initial Version
21	!> @todo
22	!> - check use of id_pivot
23	!>
24	!> @note Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt)
25	!----------------------------------------------------------------------
26	MODULE dom
27	USE kind ! F90 kind parameter
28	USE global ! global parameter
29	USE fct ! basic useful function
30	USE logger ! log file manager
31	USE dim ! dimension manager
32	USE var ! variable manager
33	USE file ! file manager
34	IMPLICIT NONE
35	PRIVATE
36	! NOTE_avoid_public_variables_if_possible
37
38	! type and variable
39	PUBLIC :: TDOM !< domain structure
40
41	! function and subroutine
42	PUBLIc :: dom_clean !< clean domain structure
43	PUBLIC :: dom_init !< initialise domain structure
44	PUBLIC :: dom_print !< print information about domain
45	PUBLIC :: dom_get_ew_overlap !< get east west overlap
46	PUBLIC :: dom_add_extra !< add useful extra point to coarse grid for interpolation
47	PUBLIC :: dom_clean_extra !< reset domain without extra point
48	PUBLIC :: dom_del_extra !< remove extra point from fine grid after interpolation
49
50	PRIVATE :: dom__define !< define extract domain indices
51	!< define extract domain indices for input domain with
52	PRIVATE :: dom__define_cyclic_north_fold !< - cyclic east-west boundary and north fold boundary condition.
53	PRIVATE :: dom__define_north_fold !< - north fold boundary condition.
54	PRIVATE :: dom__define_symmetric !< - symmetric boundary condition across the equator.
55	PRIVATE :: dom__define_cyclic !< - cyclic east-west boundary.
56	PRIVATE :: dom__define_closed !< - cyclic east-west boundary.
57	PRIVATE :: dom__check_EW_index !< check East-West indices
58	!< compute size of an extract domain
59	PRIVATE :: dom__size_no_pole !< - without north fold condition
60	PRIVATE :: dom__size_no_pole_overlap !< - without north fold condition, and which overlap east-west boundary
61	PRIVATE :: dom__size_no_pole_no_overlap !< - without north fold condition, and which do not overlap east-west boundary
62	PRIVATE :: dom__size_pole !< - with north fold condition
63	PRIVATE :: dom__size_pole_overlap !< - with north fold condition, and which overlap east-west boundary
64	PRIVATE :: dom__size_pole_no_overlap !< - with north fold condition, and which do not overlap east-west boundary
65
66	!> @struct
67	TYPE TDOM
68	TYPE(TDIM), DIMENSION(ip_maxdim) :: t_dim0 !< global domain dimension
69	TYPE(TDIM), DIMENSION(ip_maxdim) :: t_dim !< sub domain dimension
70	INTEGER(i4) :: i_perio0 !< NEMO periodicity index
71	INTEGER(i4) :: i_ew0 !< East-West overlap
72	INTEGER(i4) :: i_perio !< NEMO periodicity index
73	INTEGER(i4) :: i_pivot !< NEMO pivot point index F(0),T(1)
74	INTEGER(i4) :: i_imin = 1 !< i-direction sub-domain lower left point indice
75	INTEGER(i4) :: i_imax = 1 !< i-direction sub-domain upper right point indice
76	INTEGER(i4) :: i_jmin = 1 !< j-direction sub-domain lower left point indice
77	INTEGER(i4) :: i_jmax = 1 !< j-direction sub-domain upper right point indice
78	INTEGER(i4) :: i_kmin = 1 !< k-direction sub-domain lower level indice
79	INTEGER(i4) :: i_kmax = 1 !< k-direction sub-domain upper level indice
80	INTEGER(i4) :: i_lmin = 1 !< l-direction sub-domain lower time indice
81	INTEGER(i4) :: i_lmax = 1 !< l-direction sub-domain upper time indice
82
83	INTEGER(i4) :: i_ighost = 0 !< i-direction ghost cell factor
84	INTEGER(i4) :: i_jghost = 0 !< j-direction ghost cell factor
85
86	INTEGER(i4), DIMENSION(2) :: i_iextra = 0 !< i-direction extra point
87	INTEGER(i4), DIMENSION(2) :: i_jextra = 0 !< j-direction extra point
88
89	END TYPE TDOM
90
91	INTEGER(i4), PARAMETER :: im_minext = 2 !< default minumum number of extraband
92
93	INTERFACE dom_init
94	MODULE PROCEDURE dom_init_file
95	! MODULE PROCEDURE dom_init_mpp
96	END INTERFACE dom_init
97
98	CONTAINS
99	!-------------------------------------------------------------------
100	!> @brief This subroutine print some information about domain strucutre.
101	!
102	!> @author J.Paul
103	!> - Nov, 2013- Initial Version
104	!
105	!> @param[inout] td_dom : dom structure
106	!-------------------------------------------------------------------
107	!> @code
108	SUBROUTINE dom_print(td_dom)
109	IMPLICIT NONE
110	! Argument
111	TYPE(TDOM), INTENT(IN) :: td_dom
112
113	! local argument
114	CHARACTER(LEN=lc) :: cl_pivot
115	!----------------------------------------------------------------
116	SELECT CASE(td_dom%i_pivot)
117	CASE(0)
118	cl_pivot='F-point'
119	CASE(1)
120	cl_pivot='T-point'
121	CASE DEFAULT
122	cl_pivot='unknown'
123	END SELECT
124
125	WRITE(*,'((a,4(i0,1x)),(/a,i2,a,a),(/a,4(i0,1x)),(/a,i2/),10(/a,i0))') &
126	& " global domain size ",td_dom%t_dim0(:)%i_len, &
127	& " domain periodicity ",td_dom%i_perio0,", pivot: ",TRIM(cl_pivot), &
128	& " sub-domain size : ",td_dom%t_dim(:)%i_len, &
129	& " sub domain periodicity ",td_dom%i_perio, &
130	& " i-direction sub-domain lower left point indice ",td_dom%i_imin, &
131	& " i-direction sub-domain upper right point indice ",td_dom%i_imax, &
132	& " j-direction sub-domain lower left point indice ",td_dom%i_jmin, &
133	& " j-direction sub-domain upper right point indice ",td_dom%i_jmax, &
134	! & " k-direction sub-domain lower level indice ",td_dom%i_kmin, &
135	! & " k-direction sub-domain upper level indice ",td_dom%i_kmax, &
136	! & " l-direction sub-domain lower time indice ",td_dom%i_lmin, &
137	! & " l-direction sub-domain upper time indice ",td_dom%i_lmax, &
138	& " i-direction ghost cell factor ",td_dom%i_ighost, &
139	& " j-direction ghost cell factor ",td_dom%i_jghost
140
141	END SUBROUTINE dom_print
142	!> @endcode
143	!-------------------------------------------------------------------
144	!> @brief
145	!> This function intialise domain structure, given open file structure,
146	!> and grid periodicity.
147	!
148	!> @author J.Paul
149	!> - June, 2013- Initial Version
150	!
151	!> @param[in] td_file : file structure
152	!> @param[in] id_perio : grid periodicity
153	!> @param[in] id_imin : i-direction sub-domain lower left point indice
154	!> @param[in] id_imax : i-direction sub-domain upper right point indice
155	!> @param[in] id_jmin : j-direction sub-domain lower left point indice
156	!> @param[in] id_jmax : j-direction sub-domain upper right point indice
157	!> @param[in] id_kmin : k-direction sub-domain lower level indice
158	!> @param[in] id_kmax : k-direction sub-domain upper level indice
159	!> @param[in] id_lmin : l-direction sub-domain lower time indice
160	!> @param[in] id_lmax : l-direction sub-domain upper time indice
161	!> @return domain structure
162	!>
163	!> @todo
164	!> - initialiser domain
165	!> - add info new perio.. dans sortie
166	!-------------------------------------------------------------------
167	!> @code
168	TYPE(TDOM) FUNCTION dom_init_file( td_file, &
169	& id_imin, id_imax, id_jmin, id_jmax )
170	! & id_kmin, id_kmax, id_lmin, id_lmax )
171	IMPLICIT NONE
172	! Argument
173	TYPE(TFILE), INTENT(IN) :: td_file
174	INTEGER(i4), INTENT(IN), OPTIONAL :: id_imin
175	INTEGER(i4), INTENT(IN), OPTIONAL :: id_imax
176	INTEGER(i4), INTENT(IN), OPTIONAL :: id_jmin
177	INTEGER(i4), INTENT(IN), OPTIONAL :: id_jmax
178	! INTEGER(i4), INTENT(IN), OPTIONAL :: id_kmin
179	! INTEGER(i4), INTENT(IN), OPTIONAL :: id_kmax
180	! INTEGER(i4), INTENT(IN), OPTIONAL :: id_lmin
181	! INTEGER(i4), INTENT(IN), OPTIONAL :: id_lmax
182
183	!local variable
184	!----------------------------------------------------------------
185
186	! clean domain structure
187	CALL dom_clean(dom_init_file)
188
189	IF( td_file%i_id == 0 )THEN
190
191	CALL logger_error( &
192	& " DOM INIT: no id associated to file "//TRIM(td_file%c_name))
193
194	ELSE
195	! global domain define by file
196
197	! use global dimension define by file
198	dom_init_file%t_dim0(:) = td_file%t_dim(:)
199
200	IF( td_file%i_perio < 0 .OR. td_file%i_perio > 6 )THEN
201	CALL logger_error("DOM INIT: invalid grid periodicity. "//&
202	& "you should use dom_get_perio to compute it")
203	ELSE
204	dom_init_file%i_perio0=td_file%i_perio
205	ENDIF
206
207	! global domain pivot point
208	SELECT CASE(dom_init_file%i_perio0)
209	CASE(3,4)
210	dom_init_file%i_pivot = 0
211	CASE(5,6)
212	dom_init_file%i_pivot = 1
213	CASE DEFAULT
214	dom_init_file%i_pivot = 0
215	END SELECT
216
217	! look for EW overlap
218	dom_init_file%i_ew0=td_file%i_ew
219
220	! initialise domain as global
221	dom_init_file%i_imin = 1
222	dom_init_file%i_imax = dom_init_file%t_dim0(1)%i_len
223
224	dom_init_file%i_jmin = 1
225	dom_init_file%i_jmax = dom_init_file%t_dim0(2)%i_len
226
227	! dom_init_file%i_kmin = 1
228	! dom_init_file%i_kmax = dom_init_file%t_dim(3)%i_len
229	!
230	! dom_init_file%i_lmin = 1
231	! dom_init_file%i_lmax = dom_init_file%t_dim(4)%i_len
232
233	! extract domain dimension
234	dom_init_file%t_dim(:) = td_file%t_dim(:)
235
236	! define extract domain indices
237	CALL dom__define( dom_init_file, &
238	& id_imin, id_imax, id_jmin, id_jmax )
239	! & id_kmin, id_kmax, id_lmin, id_lmax )
240
241	ENDIF
242
243	END FUNCTION dom_init_file
244	!> @endcode
245	! !-------------------------------------------------------------------
246	! !> @brief
247	! !> This function intialise domain structure, given mpp structure,
248	! !> and variable name. domain indices could be specify.
249	! !
250	! !> @details
251	! !>
252	! !
253	! !> @author J.Paul
254	! !> - Nov, 2013- Initial Version
255	! !
256	! !> @param[in] td_mpp : mpp structure
257	! !> @param[in] cd_varname : variable name
258	! !> @return domain structure
259	! !>
260	! !> @todo
261	! !> - initialiser domain
262	! !-------------------------------------------------------------------
263	! !> @code
264	! TYPE(TDOM) FUNCTION dom_init_mpp( td_mpp, cd_varname )
265	! IMPLICIT NONE
266	! ! Argument
267	! TYPE(TMPP), INTENT(IN) :: td_mpp
268	! CHARACTER(LEN=*), INTENT(IN) :: cd_varname
269	! !----------------------------------------------------------------
270
271	! ! clean domain structure
272	! CALL dom_clean(dom_init_mpp)
273
274	! IF( ASSOCIATED(td_mpp%t_proc) )THEN
275
276	! CALL logger_error( " INIT: mpp strcuture "//TRIM(td_mpp%c_name)//&
277	! & " not define" )
278
279	! ELSE
280	! ! global domain define by mpp
281
282	! ! use global dimension define by mpp
283	! dom_init_mpp%t_dim(:) = td_mpp%t_dim(:)
284
285	! ! get global domain periodicity ??
286	! dom_init_mpp%i_perio = dom_get_perio(td_mpp, cd_varname)
287
288	! ! global domain pivot point
289	! SELECT CASE(dom_init%i_perio)
290	! CASE(3,4)
291	! dom_init%i_pivot = 0
292	! CASE(5,6)
293	! dom_init%i_pivot = 1
294	! CASE DEFAULT
295	! dom_init%i_pivot = 0
296	! END SELECT
297
298	! ! initialise domain as global
299	! dom_init_mpp%i_imin = 1
300	! dom_init_mpp%i_imax = dom_init_mpp%t_dim(1)%i_len
301
302	! dom_init_mpp%i_jmin = 1
303	! dom_init_mpp%i_jmax = dom_init_mpp%t_dim(2)%i_len
304
305	! dom_init_mpp%i_kmin = 1
306	! dom_init_mpp%i_kmax = dom_init_mpp%t_dim(3)%i_len
307
308	! dom_init_mpp%i_lmin = 1
309	! dom_init_mpp%i_lmax = dom_init_mpp%t_dim(4)%i_len
310
311	! ENDIF
312
313	! END FUNCTION dom_init_mpp
314	! !> @endcode
315	!-------------------------------------------------------------------
316	!> @brief
317	!> This subroutine define extract domain indices, and compute the size
318	!> of the domain.
319	!>
320	!> @author J.Paul
321	!> - Nov, 2013- Subroutine written
322	!
323	!> @param[inout] td_dom : domain structure
324	!> @param[in] id_imin : i-direction sub-domain lower left point indice
325	!> @param[in] id_imax : i-direction sub-domain upper right point indice
326	!> @param[in] id_jmin : j-direction sub-domain lower left point indice
327	!> @param[in] id_jmax : j-direction sub-domain upper right point indice
328	!> @param[in] id_kmin : k-direction sub-domain lower level indice
329	!> @param[in] id_kmax : k-direction sub-domain upper level indice
330	!> @param[in] id_lmin : l-direction sub-domain lower time indice
331	!> @param[in] id_lmax : l-direction sub-domain upper time indice
332	!-------------------------------------------------------------------
333	!> @code
334	SUBROUTINE dom__define(td_dom, &
335	& id_imin, id_imax, id_jmin, id_jmax )
336	! & id_kmin, id_kmax, id_lmin, id_lmax )
337	IMPLICIT NONE
338	! Argument
339	TYPE(TDOM), INTENT(INOUT) :: td_dom
340	INTEGER(i4), INTENT(IN), OPTIONAL :: id_imin
341	INTEGER(i4), INTENT(IN), OPTIONAL :: id_imax
342	INTEGER(i4), INTENT(IN), OPTIONAL :: id_jmin
343	INTEGER(i4), INTENT(IN), OPTIONAL :: id_jmax
344	! INTEGER(i4), INTENT(IN), OPTIONAL :: id_kmin
345	! INTEGER(i4), INTENT(IN), OPTIONAL :: id_kmax
346	! INTEGER(i4), INTENT(IN), OPTIONAL :: id_lmin
347	! INTEGER(i4), INTENT(IN), OPTIONAL :: id_lmax
348	!----------------------------------------------------------------
349
350	IF( PRESENT(id_imin) ) td_dom%i_imin = id_imin
351	IF( PRESENT(id_imax) ) td_dom%i_imax = id_imax
352
353	IF( PRESENT(id_jmin) ) td_dom%i_jmin = id_jmin
354	IF( PRESENT(id_jmax) ) td_dom%i_jmax = id_jmax
355
356	! IF( PRESENT(id_kmin) ) td_dom%i_kmin = id_kmin
357	! IF( PRESENT(id_kmax) ) td_dom%i_kmax = id_kmax
358	!
359	! IF( PRESENT(id_lmin) ) td_dom%i_lmin = id_lmin
360	! IF( PRESENT(id_lmax) ) td_dom%i_lmax = id_lmax
361
362	! check indices
363	IF(( td_dom%i_imin < 0 .OR. td_dom%i_imin > td_dom%t_dim0(1)%i_len ).OR. &
364	& ( td_dom%i_imax < 0 .OR. td_dom%i_imax > td_dom%t_dim0(1)%i_len ).OR. &
365	& ( td_dom%i_jmin < 0 .OR. td_dom%i_jmin > td_dom%t_dim0(2)%i_len ).OR. &
366	& ( td_dom%i_jmax < 0 .OR. td_dom%i_jmax > td_dom%t_dim0(2)%i_len ))THEN
367	! & ( td_dom%i_kmin < 0 .OR. td_dom%i_kmin > td_dom%t_dim0(3)%i_len ).OR. &
368	! & ( td_dom%i_kmax < 0 .OR. td_dom%i_kmax > td_dom%t_dim0(3)%i_len ).OR. &
369	! & ( td_dom%i_lmin < 0 .OR. td_dom%i_lmin > td_dom%t_dim0(4)%i_len ).OR. &
370	! & ( td_dom%i_lmax < 0 .OR. td_dom%i_lmax > td_dom%t_dim0(4)%i_len ))THEN
371	CALL logger_error( "DOM INIT DEFINE: invalid grid definition."// &
372	& " check min and max indices")
373	CALL logger_debug("0 < imin ("//TRIM(fct_str(id_imin))//") < "//&
374	& TRIM(fct_str(td_dom%t_dim0(1)%i_len)))
375	CALL logger_debug("0 < imax ("//TRIM(fct_str(id_imax))//") < "//&
376	& TRIM(fct_str(td_dom%t_dim0(1)%i_len)))
377	CALL logger_debug("0 < jmin ("//TRIM(fct_str(id_jmin))//") < "//&
378	& TRIM(fct_str(td_dom%t_dim0(2)%i_len)))
379	CALL logger_debug("0 < jmax ("//TRIM(fct_str(id_jmax))//") < "//&
380	& TRIM(fct_str(td_dom%t_dim0(2)%i_len)))
381	! CALL logger_debug("0 < kmin ("//TRIM(fct_str(id_kmin))//") < "//&
382	! & TRIM(fct_str(td_dom%t_dim0(3)%i_len)))
383	! CALL logger_debug("0 < kmax ("//TRIM(fct_str(id_kmax))//") < "//&
384	! & TRIM(fct_str(td_dom%t_dim0(3)%i_len)))
385	! CALL logger_debug("0 < lmin ("//TRIM(fct_str(id_lmin))//") < "//&
386	! & TRIM(fct_str(td_dom%t_dim0(4)%i_len)))
387	! CALL logger_debug("0 < lmax ("//TRIM(fct_str(id_lmax))//") < "//&
388	! & TRIM(fct_str(td_dom%t_dim0(4)%i_len)))
389	ELSE
390
391	! td_dom%t_dim(3)%i_len=td_dom%i_kmax-td_dom%i_kmin+1
392	! td_dom%t_dim(4)%i_len=td_dom%i_lmax-td_dom%i_lmin+1
393
394	SELECT CASE(td_dom%i_perio0)
395	CASE(0) ! closed boundary
396	CALL logger_trace("DEFINE: closed boundary")
397	CALL dom__define_closed( td_dom )
398	CASE(1) ! cyclic east-west boundary
399	CALL logger_trace("DEFINE: cyclic east-west boundary")
400	CALL dom__define_cyclic( td_dom )
401	CASE(2) ! symmetric boundary condition across the equator
402	CALL logger_trace("DEFINE: symmetric boundary condition "//&
403	& " across the equator")
404	CALL dom__define_symmetric( td_dom )
405	CASE(3) ! North fold boundary (with a F-point pivot)
406	CALL logger_trace("DEFINE: North fold boundary "//&
407	& "(with a F-point pivot)")
408	CALL dom__define_north_fold( td_dom )
409	CASE(5) ! North fold boundary (with a T-point pivot)
410	CALL logger_trace("DEFINE: North fold boundary "//&
411	& "(with a T-point pivot)")
412	CALL dom__define_north_fold( td_dom )
413	CASE(4) ! North fold boundary (with a F-point pivot)
414	! and cyclic east-west boundary
415	CALL logger_trace("DEFINE: North fold boundary "//&
416	& "(with a F-point pivot) and cyclic "//&
417	& "east-west boundary")
418	CALL dom__define_cyclic_north_fold( td_dom )
419	CASE(6) ! North fold boundary (with a T-point pivot)
420	! and cyclic east-west boundary
421	CALL logger_trace("DEFINE: North fold boundary "//&
422	& "(with a T-point pivot) and cyclic "//&
423	& "east-west boundary")
424	CALL dom__define_cyclic_north_fold( td_dom )
425	CASE DEFAULT
426	CALL logger_error("DEFINE: invalid grid periodicity index")
427	END SELECT
428
429	ENDIF
430
431	END SUBROUTINE dom__define
432	!> @endcode
433	!-------------------------------------------------------------------
434	!> @brief
435	!> This subroutine define domain indices from global domain with
436	!> cyclic east-west boundary and north fold boundary condition.
437	!>
438	!> @author J.Paul
439	!> - Nov, 2013- Subroutine written
440	!
441	!> @param[inout] td_dom : domain strcuture
442	!-------------------------------------------------------------------
443	!> @code
444	SUBROUTINE dom__define_cyclic_north_fold( td_dom )
445	IMPLICIT NONE
446	! Argument
447	TYPE(TDOM), INTENT(INOUT) :: td_dom
448	!----------------------------------------------------------------
449
450	CALL dom__check_EW_index( td_dom )
451
452	IF( td_dom%i_imin == td_dom%i_imax .AND. &
453	& td_dom%i_jmin == td_dom%i_jmax )THEN
454
455	CALL logger_trace("DEFINE CYCLIC NORTH FOLD: "//&
456	& "domain to extract is global" )
457	! coarse domain is global domain
458
459	CALL dom__size_global( td_dom )
460
461	ELSEIF( td_dom%i_imin == td_dom%i_imax .AND. &
462	& td_dom%i_jmin >= td_dom%i_jmax )THEN
463
464	CALL logger_trace("DEFINE CYCLIC NORTH FOLD: "//&
465	& "domain to extract is semi-global" )
466
467	CALL dom__size_semi_global( td_dom )
468
469	ELSEIF( td_dom%i_imin == td_dom%i_imax .AND. &
470	& td_dom%i_jmin < td_dom%i_jmax )THEN
471
472	CALL logger_trace("DEFINE CYCLIC NORTH FOLD: "//&
473	& "domain to extract is band of latidue" )
474
475	CALL dom__size_no_pole( td_dom )
476
477	ELSEIF( td_dom%i_imin /= td_dom%i_imax .AND. &
478	& td_dom%i_jmin == td_dom%i_jmax )THEN
479
480	CALL logger_trace("DEFINE CYCLIC NORTH FOLD: "//&
481	& "domain to extract has north boundary" )
482
483	CALL dom__size_pole( td_dom )
484
485	ELSEIF( td_dom%i_imin /= td_dom%i_imax .AND. &
486	& td_dom%i_jmin /= td_dom%i_jmax )THEN
487
488	IF( td_dom%i_jmax < td_dom%t_dim0(2)%i_len-1 .AND. &
489	& td_dom%i_jmax > td_dom%i_jmin )THEN
490
491	CALL logger_trace("DEFINE CYCLIC NORTH FOLD: "//&
492	& "domain to extract has no north boundary" )
493	! no North Pole
494
495	CALL dom__size_no_pole( td_dom )
496
497	ELSE
498
499	CALL logger_trace("DEFINE CYCLIC NORTH FOLD: "//&
500	& "domain to extract has north boundary" )
501
502	CALL dom__size_pole( td_dom )
503
504	ENDIF
505
506	ELSE
507
508	CALL logger_error("DEFINE CYCLIC NORTH FOLD: "//&
509	& "should have been an impossible case" )
510
511	ENDIF
512
513	END SUBROUTINE dom__define_cyclic_north_fold
514	!> @endcode
515	!-------------------------------------------------------------------
516	!> @brief
517	!> This subroutine define extract domain indices from global domain
518	!> with north fold boundary condition.
519	!>
520	!> @author J.Paul
521	!> - Nov, 2013- Subroutine written
522	!
523	!> @param[inout] td_dom : domain strcuture
524	!-------------------------------------------------------------------
525	!> @code
526	SUBROUTINE dom__define_north_fold( td_dom )
527	IMPLICIT NONE
528	! Argument
529	TYPE(TDOM), INTENT(INOUT) :: td_dom
530	!----------------------------------------------------------------
531
532	IF( td_dom%i_jmax < td_dom%t_dim0(2)%i_len-1 .AND. &
533	& td_dom%i_jmax > td_dom%i_jmin )THEN
534
535	CALL logger_trace("DEFINE NORTH FOLD: "//&
536	& "domain to extract has no north boundary" )
537	! no North Pole
538
539	CALL dom__size_no_pole_no_overlap( td_dom )
540
541	ELSE
542
543	CALL logger_trace("DEFINE NORTH FOLD: "//&
544	& "domain to extract has north boundary" )
545
546	CALL dom__size_pole_no_overlap( td_dom )
547
548	ENDIF
549
550	END SUBROUTINE dom__define_north_fold
551	!> @endcode
552	!-------------------------------------------------------------------
553	!> @brief
554	!> This subroutine define extract domain indices from global domain
555	!> with symmetric boundary condition across the equator.
556	!>
557	!> @author J.Paul
558	!> - Nov, 2013- Subroutine written
559	!
560	!> @param[inout] td_dom : domain strcuture
561	!-------------------------------------------------------------------
562	!> @code
563	SUBROUTINE dom__define_symmetric( td_dom )
564	IMPLICIT NONE
565	! Argument
566	TYPE(TDOM), INTENT(INOUT) :: td_dom
567	!----------------------------------------------------------------
568
569	CALL dom__size_no_pole_no_overlap( td_dom )
570
571	END SUBROUTINE dom__define_symmetric
572	!> @endcode
573	!-------------------------------------------------------------------
574	!> @brief
575	!> This subroutine define extract domain indices from global domain
576	!> with cyclic east-west boundary.
577	!>
578	!> @author J.Paul
579	!> - Nov, 2013- Subroutine written
580	!
581	!> @param[inout] td_dom : domain strcuture
582	!-------------------------------------------------------------------
583	!> @code
584	SUBROUTINE dom__define_cyclic( td_dom )
585	IMPLICIT NONE
586	! Argument
587	TYPE(TDOM), INTENT(INOUT) :: td_dom
588	!----------------------------------------------------------------
589	CALL dom__check_EW_index( td_dom )
590
591	IF( td_dom%i_imin >= td_dom%i_imax )THEN
592	CALL logger_trace("DEFINE CYCLIC: "//&
593	& "domain to extract overlap east-west boundary")
594
595	CALL dom__size_no_pole_overlap( td_dom )
596
597	ELSE
598	! id_imin < id_imax
599	CALL logger_trace("DEFINE CYCLIC: "//&
600	& "domain to extract do not overlap east-west boundary")
601
602	CALL dom__size_no_pole_no_overlap( td_dom )
603
604	ENDIF
605
606	END SUBROUTINE dom__define_cyclic
607	!> @endcode
608	!-------------------------------------------------------------------
609	!> @brief
610	!> This subroutine define extract domain indices from global domain
611	!> with closed boundaries.
612	!>
613	!> @author J.Paul
614	!> - Nov, 2013- Subroutine written
615	!
616	!> @param[inout] td_dom : domain strcuture
617	!-------------------------------------------------------------------
618	!> @code
619	SUBROUTINE dom__define_closed( td_dom )
620	IMPLICIT NONE
621	! Argument
622	TYPE(TDOM), INTENT(INOUT) :: td_dom
623	!----------------------------------------------------------------
624
625	CALL dom__size_no_pole_no_overlap( td_dom )
626
627	END SUBROUTINE dom__define_closed
628	!> @endcode
629	!-------------------------------------------------------------------
630	!> @brief
631	!> This subroutine check East-West indices, use inside a cyclic domain,
632	!> and redefine it in some particular cases.
633	!>
634	!> @author J.Paul
635	!> - Nov, 2013- Subroutine written
636	!
637	!> @param[inout] td_dom : domain strcuture
638	!-------------------------------------------------------------------
639	!> @code
640	SUBROUTINE dom__check_EW_index( td_dom )
641	IMPLICIT NONE
642	! Argument
643	TYPE(TDOM), INTENT(INOUT) :: td_dom
644	!----------------------------------------------------------------
645
646	IF( td_dom%i_imin /= td_dom%i_imax )THEN
647
648	IF((ABS(td_dom%i_imax-td_dom%i_imin) >= td_dom%t_dim0(1)%i_len-1).OR.&
649	(ABS(td_dom%i_imax-td_dom%i_imin) <= td_dom%i_ew0 ) )THEN
650
651	td_dom%i_imin = td_dom%i_imax
652
653	ENDIF
654
655	ENDIF
656
657	END SUBROUTINE dom__check_EW_index
658	!> @endcode
659	!-------------------------------------------------------------------
660	!> @brief
661	!> This subroutine compute size of global domain
662	!>
663	!> @author J.Paul
664	!> - Nov, 2013- Subroutine written
665	!
666	!> @param[inout] td_dom : domain strcuture
667	!-------------------------------------------------------------------
668	!> @code
669	SUBROUTINE dom__size_global( td_dom )
670	IMPLICIT NONE
671	! Argument
672	TYPE(TDOM), INTENT(INOUT) :: td_dom
673	!----------------------------------------------------------------
674
675	td_dom%i_imin = 1
676	td_dom%i_imax = td_dom%t_dim0(1)%i_len
677
678	td_dom%i_jmin = 1
679	td_dom%i_jmax = td_dom%t_dim0(2)%i_len
680
681	! domain size
682	td_dom%t_dim(1)%i_len = td_dom%t_dim0(1)%i_len
683	td_dom%t_dim(2)%i_len = td_dom%t_dim0(2)%i_len
684
685	! no ghost cell to add
686	td_dom%i_ighost=0
687	td_dom%i_jghost=0
688
689	! peiordicity
690	IF( td_dom%i_pivot == 0 )THEN ! 0-F
691	td_dom%i_perio=4
692	td_dom%i_pivot=0
693	ELSE ! 1-T
694	td_dom%i_perio=6
695	td_dom%i_pivot=1
696	ENDIF
697
698	END SUBROUTINE dom__size_global
699	!> @endcode
700	!-------------------------------------------------------------------
701	!> @brief
702	!> This subroutine compute size of a semi global domain
703	!>
704	!> @author J.Paul
705	!> - Nov, 2013- Subroutine written
706	!
707	!> @param[inout] td_dom : domain strcuture
708	!> @note never tested
709	!-------------------------------------------------------------------
710	!> @code
711	SUBROUTINE dom__size_semi_global( td_dom )
712	IMPLICIT NONE
713	! Argument
714	TYPE(TDOM), INTENT(INOUT) :: td_dom
715
716	! local variable
717	INTEGER(i4) :: il_imid ! cananadian bipole index (middle of global domain)
718	!----------------------------------------------------------------
719
720	il_imid = td_dom%t_dim0(1)%i_len/2 + td_dom%i_pivot
721
722	td_dom%i_imin = 2
723	td_dom%i_imax = il_imid !td_dom%t_dim0(1)%i_len
724
725	IF( td_dom%i_jmax >= td_dom%t_dim0(2)%i_len-1 )THEN
726	td_dom%i_jmax=MIN( td_dom%i_jmin, &
727	& td_dom%t_dim0(2)%i_len-td_dom%i_jmax )
728	ELSE
729	td_dom%i_jmin=td_dom%i_jmax
730	ENDIF
731
732	! domain size
733	td_dom%t_dim(1)%i_len = (td_dom%i_imax ) - &
734	& (td_dom%i_imin ) + 1
735
736	td_dom%t_dim(2)%i_len = ( td_dom%t_dim0(2)%i_len - &
737	& ( td_dom%i_jmin ) + 1 ) + &
738	& ( td_dom%t_dim0(2)%i_len - &
739	& ( td_dom%i_jmax ) + 1 ) - 2 ! remove north fold condition ?
740
741	! ghost cell to add
742	td_dom%i_ighost=1
743	td_dom%i_jghost=1
744
745	! periodicity
746	IF( td_dom%i_pivot == 0 )THEN !0-F
747	td_dom%i_perio=3
748	td_dom%i_pivot=0
749	ELSE !1-T
750	td_dom%i_perio=5
751	td_dom%i_pivot=1
752	ENDIF
753
754	END SUBROUTINE dom__size_semi_global
755	!> @endcode
756	!-------------------------------------------------------------------
757	!> @brief
758	!> This subroutine compute size of an extract domain without north fold
759	!> condition
760	!>
761	!> @author J.Paul
762	!> - Nov, 2013- Subroutine written
763	!
764	!> @param[inout] td_dom : domain strcuture
765	!-------------------------------------------------------------------
766	!> @code
767	SUBROUTINE dom__size_no_pole( td_dom )
768	IMPLICIT NONE
769	! Argument
770	TYPE(TDOM), INTENT(INOUT) :: td_dom
771	!----------------------------------------------------------------
772
773	IF( td_dom%i_jmin >= td_dom%i_jmax )THEN
774	CALL logger_fatal("DOM INIT: invalid domain. "//&
775	& "can not get north pole from this coarse grid. "//&
776	& "check namelist and coarse grid periodicity." )
777	ENDIF
778
779	IF( td_dom%i_imin >= td_dom%i_imax )THEN
780	CALL logger_trace("DEFINE NO POLE: "// &
781	& "domain to extract overlap east-west boundary")
782
783	CALL dom__size_no_pole_overlap( td_dom )
784
785	ELSE
786	! id_imin < id_imax
787	CALL logger_trace("DEFINE NO POLE: "// &
788	& "domain to extract do not overlap east-west boundary")
789
790	CALL dom__size_no_pole_no_overlap( td_dom )
791
792	ENDIF
793
794	END SUBROUTINE dom__size_no_pole
795	!> @endcode
796	!-------------------------------------------------------------------
797	!> @brief
798	!> This subroutine compute size of an extract domain with north fold
799	!> condition
800	!>
801	!> @author J.Paul
802	!> - April, 2013- Subroutine written
803	!
804	!> @param[inout] td_dom : domain strcuture
805	!-------------------------------------------------------------------
806	!> @code
807	SUBROUTINE dom__size_pole( td_dom )
808	IMPLICIT NONE
809	! Argument
810	TYPE(TDOM), INTENT(INOUT) :: td_dom
811	!----------------------------------------------------------------
812
813	IF( td_dom%i_imin > td_dom%i_imax )THEN
814	CALL logger_trace("DEFINE POLE: "//&
815	& "domain to extract overlap east-west boundary")
816	CALL dom__size_pole_overlap( td_dom )
817	ELSEIF( td_dom%i_imin < td_dom%i_imax )THEN
818	CALL logger_trace("DEFINE POLE: "//&
819	& "domain to extract do not overlap east-west boundary")
820	CALL dom__size_pole_no_overlap( td_dom )
821	ENDIF
822
823	END SUBROUTINE dom__size_pole
824	!> @endcode
825	!-------------------------------------------------------------------
826	!> @brief
827	!> This subroutine compute size of an extract domain without north fold
828	!> condition, and which overlap east-west boundary
829	!>
830	!> @author J.Paul
831	!> - Nov, 2013- Subroutine written
832	!
833	!> @param[inout] td_dom : domain strcuture
834	!-------------------------------------------------------------------
835	!> @code
836	SUBROUTINE dom__size_no_pole_overlap( td_dom )
837	IMPLICIT NONE
838	! Argument
839	TYPE(TDOM), INTENT(INOUT) :: td_dom
840	!----------------------------------------------------------------
841
842	IF( td_dom%i_jmin >= td_dom%i_jmax )THEN
843	CALL logger_fatal("DOM INIT: invalid domain. "//&
844	& "can not get north pole from this coarse grid. "//&
845	& "check namelist and coarse grid periodicity." )
846	ENDIF
847
848	IF( td_dom%i_imin == td_dom%i_imax )THEN
849	! domain to extract with east west cyclic boundary
850	CALL logger_trace("DEFINE NO POLE OVERLAP: "//&
851	& "domain to extract has cyclic east-west boundary")
852
853	td_dom%i_imin = 1
854	td_dom%i_imax = td_dom%t_dim0(1)%i_len
855
856	td_dom%t_dim(1)%i_len = td_dom%t_dim0(1)%i_len
857
858	! no ghost cell
859	td_dom%i_ighost=0
860
861	! periodicity
862	td_dom%i_perio=1
863
864	ELSE
865
866	! id_imin > id_imax
867	! extract domain overlap east-west boundary
868
869	td_dom%t_dim(1)%i_len = td_dom%t_dim0(1)%i_len - &
870	& (td_dom%i_imin ) + 1 + &
871	& (td_dom%i_imax ) - 2 ! remove cyclic boundary
872
873	! add ghost cell
874	td_dom%i_ighost=1
875
876	! periodicity
877	td_dom%i_perio=0
878
879	ENDIF
880
881	td_dom%t_dim(2)%i_len = (td_dom%i_jmax ) - &
882	& (td_dom%i_jmin ) + 1
883
884	! add ghost cell
885	td_dom%i_jghost=1
886
887	END SUBROUTINE dom__size_no_pole_overlap
888	!> @endcode
889	!-------------------------------------------------------------------
890	!> @brief
891	!> This subroutine compute size of an extract domain without north fold
892	!> condition, and which do not overlap east-west boundary
893	!>
894	!> @author J.Paul
895	!> - Nov, 2013- Subroutine written
896	!
897	!> @param[inout] td_dom : domain strcuture
898	!-------------------------------------------------------------------
899	!> @code
900	SUBROUTINE dom__size_no_pole_no_overlap( td_dom )
901	IMPLICIT NONE
902	! Argument
903	TYPE(TDOM), INTENT(INOUT) :: td_dom
904	!----------------------------------------------------------------
905
906	IF( td_dom%i_jmin >= td_dom%i_jmax )THEN
907	CALL logger_fatal("DOM INIT: invalid domain. "//&
908	& "can not get north pole from this coarse grid. "//&
909	& "check namelist and coarse grid periodicity." )
910	ENDIF
911
912	IF( td_dom%i_imin >= td_dom%i_imax )THEN
913	CALL logger_fatal("DOM INIT: invalid domain. "//&
914	& "can not overlap East-West boundary with this coarse grid. "//&
915	& "check namelist and coarse grid periodicity." )
916	ENDIF
917
918	td_dom%t_dim(1)%i_len = ( td_dom%i_imax ) - &
919	& ( td_dom%i_imin ) + 1
920
921	td_dom%t_dim(2)%i_len = ( td_dom%i_jmax ) - &
922	& ( td_dom%i_jmin ) + 1
923
924	! add ghost cell
925	td_dom%i_ighost=1
926	td_dom%i_jghost=1
927
928	! periodicity
929	td_dom%i_perio=0
930
931	END SUBROUTINE dom__size_no_pole_no_overlap
932	!> @endcode
933	!-------------------------------------------------------------------
934	!> @brief
935	!> This subroutine compute size of an extract domain with north fold
936	!> condition, and which overlap east-west boundary
937	!>
938	!> @author J.Paul
939	!> - Nov, 2013- Subroutine written
940	!
941	!> @param[inout] td_dom : domain strcuture
942	!> @note never tested
943	!-------------------------------------------------------------------
944	!> @code
945	SUBROUTINE dom__size_pole_overlap( td_dom )
946	IMPLICIT NONE
947	! Argument
948	TYPE(TDOM), INTENT(INOUT) :: td_dom
949
950	! local variable
951	INTEGER(i4) :: il_idom1 ! extract domain size, east part
952	INTEGER(i4) :: il_idom2 ! extract domain size, west part
953	INTEGER(i4) :: il_imid ! cananadian bipole index (middle of global domain)
954	!----------------------------------------------------------------
955
956	CALL logger_trace("DEFINE POLE OVERLAP: "//&
957	& "asian bipole inside domain to extract")
958
959	il_imid = td_dom%t_dim0(1)%i_len/2 + td_dom%i_pivot
960
961	il_idom1 = td_dom%t_dim0(1)%i_len - td_dom%i_imin + 1
962	il_idom2 = td_dom%i_imax
963
964	IF( il_idom1 > il_imid .OR. il_idom2 > il_imid )THEN
965
966	CALL logger_trace("DEFINE POLE OVERLAP: "//&
967	& "canadian bipole inside domain to extract")
968	td_dom%i_imin = td_dom%i_imax
969
970	IF( td_dom%i_jmin == td_dom%i_jmax )THEN
971	CALL dom__size_global( td_dom )
972	ELSE
973	CALL dom__size_semi_global( td_dom )
974	ENDIF
975
976	! periodicity
977	td_dom%i_perio=0
978
979	ELSEIF( il_idom1 > il_idom2 )THEN
980
981	! east part bigger than west part
982	CALL logger_trace("DEFINE POLE OVERLAP: east part bigger than west part ")
983	! to respect symmetry around asian bipole
984	td_dom%i_imax = il_idom1
985
986	! north pole
987	IF( td_dom%i_jmax >= td_dom%t_dim0(2)%i_len-1 )THEN
988	td_dom%i_jmax=MIN( td_dom%i_jmin, &
989	& td_dom%t_dim0(2)%i_len-td_dom%i_jmax )
990	ELSE
991	td_dom%i_jmax=MIN( td_dom%i_jmin, td_dom%i_jmax )
992	ENDIF
993	td_dom%i_jmin=td_dom%i_jmax
994
995	! compute size
996	td_dom%t_dim(1)%i_len = il_idom1 !! no ghost cell ??
997	td_dom%t_dim(2)%i_len = ( td_dom%t_dim0(2)%i_len - &
998	& ( td_dom%i_jmin ) + 1 ) + &
999	& ( td_dom%t_dim0(2)%i_len - &
1000	& ( td_dom%i_jmax ) + 1 ) - 2 ! remove north fold condition ?
1001
1002	! add ghost cell
1003	td_dom%i_ighost=1
1004	td_dom%i_jghost=1
1005
1006	! periodicity
1007	td_dom%i_perio=0
1008
1009	ELSE ! il_idom2 >= il_idom1
1010
1011	! west part bigger than east part
1012	CALL logger_trace("DEFINE POLE OVERLAP: west part bigger than east part ")
1013
1014	! to respect symmetry around asian bipole
1015	td_dom%i_imin = td_dom%t_dim0(1)%i_len - il_idom2 + 1
1016
1017	! north pole
1018	IF( td_dom%i_jmax >= td_dom%t_dim0(2)%i_len-1 )THEN
1019	td_dom%i_jmax=MIN( td_dom%i_jmin, &
1020	& td_dom%t_dim0(2)%i_len-td_dom%i_jmax )
1021	ELSE
1022	td_dom%i_jmax=MIN( td_dom%i_jmin, td_dom%i_jmax )
1023	ENDIF
1024	td_dom%i_jmin=td_dom%i_jmax
1025
1026	! compute size
1027	td_dom%t_dim(1)%i_len = il_idom2
1028	td_dom%t_dim(2)%i_len = ( td_dom%t_dim0(2)%i_len - &
1029	& ( td_dom%i_jmin ) + 1 ) + &
1030	& ( td_dom%t_dim0(2)%i_len - &
1031	& ( td_dom%i_jmax ) + 1 ) - 2
1032
1033	! add ghost cell
1034	td_dom%i_ighost=1
1035	td_dom%i_jghost=1
1036
1037	! periodicity
1038	td_dom%i_perio=0
1039
1040	ENDIF
1041
1042	END SUBROUTINE dom__size_pole_overlap
1043	!> @endcode
1044	!-------------------------------------------------------------------
1045	!> @brief
1046	!> This subroutine compute size of an extract domain with north fold
1047	!> condition, and which do not overlap east-west boundary
1048	!>
1049	!> @author J.Paul
1050	!> - Nov, 2013- Subroutine written
1051	!
1052	!> @param[inout] td_dom : domain strcuture
1053	!> @note never tested
1054	!-------------------------------------------------------------------
1055	!> @code
1056	SUBROUTINE dom__size_pole_no_overlap( td_dom )
1057	IMPLICIT NONE
1058	! Argument
1059	TYPE(TDOM), INTENT(INOUT) :: td_dom
1060
1061	! local variable
1062	INTEGER(i4) :: il_idom1 ! extract domain size, east part
1063	INTEGER(i4) :: il_idom2 ! extract domain size, west part
1064	INTEGER(i4) :: il_mid ! canadian biple index ?
1065	!----------------------------------------------------------------
1066
1067	IF( td_dom%i_imin >= td_dom%i_imax )THEN
1068	CALL logger_fatal("DOM INIT: invalid domain. "//&
1069	& "can not overlap East-West boundary with this coarse grid. "//&
1070	& "check namelist and coarse grid periodicity." )
1071	ENDIF
1072
1073	CALL logger_trace("DEFINE POLE NO OVERLAP: "//&
1074	& "no asian bipole inside domain to extract")
1075
1076	! north pole
1077	IF( td_dom%i_jmax >= td_dom%t_dim0(2)%i_len-1 )THEN
1078	td_dom%i_jmax=MIN( td_dom%i_jmin, &
1079	& td_dom%t_dim0(2)%i_len-td_dom%i_jmax )
1080	ELSE
1081	td_dom%i_jmax=MIN( td_dom%i_jmin, td_dom%i_jmax )
1082	ENDIF
1083	td_dom%i_jmin=td_dom%i_jmax
1084
1085	!
1086	il_mid = td_dom%t_dim0(1)%i_len/2 + td_dom%i_pivot
1087
1088	IF( (td_dom%i_imin < il_mid .AND. td_dom%i_imax < il_mid) .OR. &
1089	& (td_dom%i_imin > il_mid .AND. td_dom%i_imax > il_mid) )THEN
1090	CALL logger_trace("DEFINE POLE NO OVERLAP: "//&
1091	& "no canadian bipole inside domain to extract")
1092
1093	td_dom%t_dim(1)%i_len = ( td_dom%i_imax ) - &
1094	& ( td_dom%i_imin ) + 1
1095
1096	td_dom%t_dim(2)%i_len = ( td_dom%t_dim0(2)%i_len - &
1097	& ( td_dom%i_jmin ) + 1 ) + &
1098	& ( td_dom%t_dim0(2)%i_len - &
1099	& ( td_dom%i_jmax ) + 1 ) - 2 ! remove north fold condition ?
1100
1101	! add ghost cell
1102	td_dom%i_ighost=1
1103	td_dom%i_jghost=1
1104
1105	! periodicity
1106	td_dom%i_perio=0
1107
1108	ELSE ! id_imin < il_mid .AND. id_imax > il_mid
1109	CALL logger_trace("DEFINE POLE NO OVERLAP: "//&
1110	& "canadian bipole inside domain to extract")
1111
1112	il_idom1 = td_dom%i_imax - (il_mid - 1)
1113	il_idom2 = il_mid - td_dom%i_imin
1114	IF( il_idom1 > il_idom2 )THEN
1115	! east part bigger than west part
1116	CALL logger_trace("DEFINE POLE NO OVERLAP: east part bigger than west part ")
1117	! to respect symmetry around canadian bipole
1118	td_dom%i_imin = il_mid - il_idom1
1119
1120	td_dom%t_dim(1)%i_len = il_idom1 + 1
1121	td_dom%t_dim(2)%i_len = ( td_dom%t_dim0(2)%i_len - &
1122	& ( td_dom%i_jmin ) + 1 ) + &
1123	& ( td_dom%t_dim0(2)%i_len - &
1124	& ( td_dom%i_jmax ) + 1 ) &
1125	& - 2 - 2 * td_dom%i_pivot ! remove north fold condition ?
1126
1127	! add ghost cell
1128	td_dom%i_ighost=1
1129	td_dom%i_jghost=1
1130
1131	! periodicity
1132	td_dom%i_perio=0
1133
1134	ELSE ! il_idom2 >= il_idom1
1135	! west part bigger than east part
1136	CALL logger_trace("DEFINE POLE NO OVERLAP: west part bigger than east part ")
1137	! to respect symmetry around canadian bipole
1138
1139	td_dom%i_imax = il_mid + il_idom2
1140
1141	td_dom%t_dim(1)%i_len = il_idom2 + 1
1142	td_dom%t_dim(2)%i_len = ( td_dom%t_dim0(2)%i_len - &
1143	& ( td_dom%i_jmin ) + 1 ) + &
1144	& ( td_dom%t_dim0(2)%i_len - &
1145	& ( td_dom%i_jmax ) + 1 ) &
1146	& - 2 - 2 * td_dom%i_pivot ! remove north fold condition ?
1147
1148	! add ghost cell
1149	td_dom%i_ighost=1
1150	td_dom%i_jghost=1
1151
1152	! periodicity
1153	td_dom%i_perio=0
1154
1155	ENDIF
1156	ENDIF
1157
1158	END SUBROUTINE dom__size_pole_no_overlap
1159	!> @endcode
1160	!-------------------------------------------------------------------
1161	!> @brief This function get east west overlap.
1162	!
1163	!> @details
1164	!> If no east -west wrap return -1,
1165	!> else return the size of the ovarlap band
1166	!
1167	!> @author J.Paul
1168	!> - 2013- Initial Version
1169	!
1170	!> @param[in]
1171	!-------------------------------------------------------------------
1172	!> @code
1173	FUNCTION dom_get_ew_overlap(td_lon)
1174	IMPLICIT NONE
1175	! Argument
1176	TYPE(TVAR), INTENT(IN) :: td_lon
1177
1178	! function
1179	INTEGER(i4) :: dom_get_ew_overlap
1180
1181	! local variable
1182	REAL(dp), DIMENSION(:,:,:,:), ALLOCATABLE :: dl_value
1183	REAL(dp), DIMENSION(:) , ALLOCATABLE :: dl_lone
1184	REAL(dp), DIMENSION(:) , ALLOCATABLE :: dl_lonw
1185
1186	REAL(dp) :: dl_delta
1187	REAL(dp) :: dl_lonmax
1188	REAL(dp) :: dl_lonmin
1189
1190	INTEGER(i4) :: il_east
1191	INTEGER(i4) :: il_west
1192	INTEGER(i4) :: il_jmin
1193	INTEGER(i4) :: il_jmax
1194
1195	INTEGER(i4), PARAMETER :: ip_max_overlap = 5
1196
1197	! loop indices
1198	INTEGER(i4) :: ji
1199	!----------------------------------------------------------------
1200	! init
1201	dom_get_ew_overlap=-1
1202
1203	il_west=1
1204	il_east=td_lon%t_dim(1)%i_len
1205
1206	ALLOCATE( dl_value(td_lon%t_dim(1)%i_len, &
1207	& td_lon%t_dim(2)%i_len, &
1208	& td_lon%t_dim(3)%i_len, &
1209	& td_lon%t_dim(4)%i_len) )
1210
1211	dl_value(:,:,:,:)=td_lon%d_value(:,:,:,:)
1212	WHERE( dl_value(:,:,:,:) > 180._dp .AND. &
1213	& dl_value(:,:,:,:) /= td_lon%d_fill )
1214	dl_value(:,:,:,:)=360.-dl_value(:,:,:,:)
1215	END WHERE
1216
1217	! we do not use jmax as dimension length due to north fold boundary
1218	il_jmin=1+ig_ghost
1219	il_jmax=(td_lon%t_dim(2)%i_len-ig_ghost)/2
1220
1221	ALLOCATE( dl_lone(il_jmax-il_jmin+1) )
1222	ALLOCATE( dl_lonw(il_jmax-il_jmin+1) )
1223
1224	dl_lone(:)=dl_value(il_east,il_jmin:il_jmax,1,1)
1225	dl_lonw(:)=dl_value(il_west,il_jmin:il_jmax,1,1)
1226
1227	IF( .NOT.( ALL(dl_lone(:)==td_lon%d_fill) .AND. &
1228	& ALL(dl_lonw(:)==td_lon%d_fill) ) )THEN
1229
1230	dl_lonmax=MAXVAL(dl_value(:,il_jmin:il_jmax,:,:))
1231	dl_lonmin=MINVAL(dl_value(:,il_jmin:il_jmax,:,:))
1232
1233	dl_delta=(dl_lonmax-dl_lonmin)/td_lon%t_dim(1)%i_len
1234
1235	IF( ALL(ABS(dl_lone(:)) - ABS(dl_lonw(:)) == dl_delta) )THEN
1236
1237	dom_get_ew_overlap=0
1238
1239	ELSE IF( ALL( ABS(dl_lone(:)) - ABS(dl_lonw(:)) < &
1240	& ip_max_overlap*dl_delta ) )THEN
1241	DO ji=0,ip_max_overlap
1242
1243	IF( il_east-ji == il_west )THEN
1244	! case of small domain
1245	EXIT
1246	ELSE
1247	dl_lone(:)=dl_value(il_east-ji,il_jmin:il_jmax,1,1)
1248
1249	IF( ALL( dl_lonw(:) == dl_lone(:) ) )THEN
1250	dom_get_ew_overlap=ji+1
1251	EXIT
1252	ENDIF
1253	ENDIF
1254
1255	ENDDO
1256	ENDIF
1257
1258	ENDIF
1259
1260	DEALLOCATE( dl_value )
1261
1262	END FUNCTION dom_get_ew_overlap
1263	!> @endcode
1264	!-------------------------------------------------------------------
1265	!> @brief
1266	!> This subroutine add extra point to domain
1267	!
1268	!> @author J.Paul
1269	!> @date Nov, 2013
1270	!
1271	!> @param[inout] td_dom : domain strcuture
1272	!> @param [in] id_iext : i-direction size of extra bands (default=im_minext)
1273	!> @param [in] id_jext : j-direction size of extra bands (default=im_minext)
1274	!-------------------------------------------------------------------
1275	!> @code
1276	SUBROUTINE dom_add_extra( td_dom, id_iext, id_jext )
1277	IMPLICIT NONE
1278	! Argument
1279	TYPE(TDOM) , INTENT(INOUT) :: td_dom
1280	INTEGER(i4), INTENT(IN ), OPTIONAL :: id_iext
1281	INTEGER(i4), INTENT(IN ), OPTIONAL :: id_jext
1282
1283	! local variable
1284	INTEGER(i4) :: il_iext
1285	INTEGER(i4) :: il_jext
1286
1287	! loop indices
1288	!----------------------------------------------------------------
1289	! init
1290	!WARNING: two extrabands are required for cubic interpolation
1291	il_iext=im_minext
1292	IF( PRESENT(id_iext) ) il_iext=id_iext
1293
1294	il_jext=im_minext
1295	IF( PRESENT(id_jext) ) il_jext=id_jext
1296
1297	td_dom%i_iextra(:)=0
1298	td_dom%i_jextra(:)=0
1299
1300	IF( td_dom%i_imin == 1 .AND. &
1301	& td_dom%i_imax == td_dom%t_dim0(1)%i_len .AND. &
1302	& td_dom%i_jmin == 1 .AND. &
1303	& td_dom%i_jmax == td_dom%t_dim0(2)%i_len )THEN
1304	! global
1305	! nothing to be done
1306	ELSE
1307	IF( td_dom%i_imin == 1 .AND. &
1308	& td_dom%i_imax == td_dom%t_dim0(1)%i_len )THEN
1309	! EW cyclic
1310	! nothing to be done
1311	ELSE
1312	IF( td_dom%i_imin /= 1 )THEN
1313	td_dom%i_iextra(1)=il_iext
1314
1315	ELSE
1316	IF( td_dom%i_ew0 > 0 )THEN
1317	td_dom%i_iextra(1)=il_iext
1318
1319	ENDIF
1320	ENDIF
1321
1322	IF( td_dom%i_imax /= td_dom%t_dim(1)%i_len )THEN
1323	td_dom%i_iextra(2)=1
1324
1325	ELSE
1326	IF( td_dom%i_ew0 > 0 )THEN
1327	td_dom%i_iextra(2)=il_jext
1328
1329	ENDIF
1330	ENDIF
1331
1332	ENDIF
1333
1334	IF( td_dom%i_jmin == td_dom%i_jmax )THEN
1335	td_dom%i_jextra(1)=il_iext
1336	td_dom%i_jextra(2)=il_jext
1337
1338	ELSE
1339	IF( td_dom%i_jmin /= 1)THEN
1340	td_dom%i_jextra(1)=il_iext
1341
1342	ENDIF
1343	IF( td_dom%i_jmax /= td_dom%t_dim(2)%i_len )THEN
1344	td_dom%i_jextra(2)=il_jext
1345
1346	ENDIF
1347
1348	ENDIF
1349
1350	ENDIF
1351
1352	! change domain
1353	td_dom%i_imin = td_dom%i_imin - td_dom%i_iextra(1)
1354	td_dom%i_jmin = td_dom%i_jmin - td_dom%i_jextra(1)
1355
1356	td_dom%i_imax = td_dom%i_imax + td_dom%i_iextra(2)
1357	td_dom%i_jmax = td_dom%i_jmax + td_dom%i_jextra(2)
1358
1359	td_dom%t_dim(1)%i_len = td_dom%t_dim(1)%i_len + &
1360	& td_dom%i_iextra(1) + &
1361	& td_dom%i_iextra(2)
1362	td_dom%t_dim(2)%i_len = td_dom%t_dim(2)%i_len + &
1363	& td_dom%i_jextra(1) + &
1364	& td_dom%i_jextra(2)
1365
1366
1367	END SUBROUTINE dom_add_extra
1368	!> @endcode
1369	!-------------------------------------------------------------------
1370	!> @brief
1371	!> This subroutine clean domain structure. it remove extra point added.
1372	!
1373	!> @author J.Paul
1374	!> @date Nov, 2013
1375	!
1376	!> @param[inout] td_dom : domain strcuture
1377	!-------------------------------------------------------------------
1378	!> @code
1379	SUBROUTINE dom_clean_extra( td_dom )
1380	IMPLICIT NONE
1381	! Argument
1382	TYPE(TDOM) , INTENT(INOUT) :: td_dom
1383
1384	! local variable
1385	! loop indices
1386	!----------------------------------------------------------------
1387
1388	! change domain
1389	td_dom%i_imin = td_dom%i_imin + td_dom%i_iextra(1)
1390	td_dom%i_jmin = td_dom%i_jmin + td_dom%i_jextra(1)
1391
1392	td_dom%i_imax = td_dom%i_imax - td_dom%i_iextra(2)
1393	td_dom%i_jmax = td_dom%i_jmax - td_dom%i_jextra(2)
1394
1395	td_dom%t_dim(1)%i_len = td_dom%t_dim(1)%i_len - &
1396	& td_dom%i_iextra(1) - &
1397	& td_dom%i_iextra(2)
1398	td_dom%t_dim(2)%i_len = td_dom%t_dim(2)%i_len - &
1399	& td_dom%i_jextra(1) - &
1400	& td_dom%i_jextra(2)
1401
1402	td_dom%i_iextra(:)=0
1403	td_dom%i_jextra(:)=0
1404
1405	END SUBROUTINE dom_clean_extra
1406	!> @endcode
1407	!-------------------------------------------------------------------
1408	!> @brief
1409	!> This subroutine
1410	!
1411	!> @author J.Paul
1412	!> @date Nov, 2013
1413	!
1414	!> @param[inout] td_var : variable strcuture
1415	!> @param[inout] td_dom : domain strcuture
1416	!> @param[inout] id_rhoi : i-direction refinement factor
1417	!> @param[inout] id_rhoj : j-direction refinement factor
1418	!-------------------------------------------------------------------
1419	!> @code
1420	SUBROUTINE dom_del_extra( td_var, td_dom, id_rho )
1421	IMPLICIT NONE
1422	! Argument
1423	TYPE(TVAR) , INTENT(INOUT) :: td_var
1424	TYPE(TDOM) , INTENT(IN ) :: td_dom
1425	INTEGER(i4), DIMENSION(:), INTENT(IN ) :: id_rho
1426
1427	! local variable
1428	INTEGER(i4) :: il_iextra
1429	INTEGER(i4) :: il_jextra
1430
1431	INTEGER(i4) :: il_imin
1432	INTEGER(i4) :: il_imax
1433	INTEGER(i4) :: il_jmin
1434	INTEGER(i4) :: il_jmax
1435
1436	REAL(dp), DIMENSION(:,:,:,:), ALLOCATABLE :: dl_value
1437
1438	! loop indices
1439	!----------------------------------------------------------------
1440
1441	IF( .NOT. ASSOCIATED(td_var%d_value) )THEN
1442	CALL logger_error("DOM DEL EXTRA: no value associated to "//&
1443	& "variable "//TRIM(td_var%c_name) )
1444	ELSE
1445	! get vairbale right domain
1446	IF( ALL(td_var%t_dim(1:2)%l_use) )THEN
1447	il_iextra=SUM(td_dom%i_iextra(:))*id_rho(jp_I)
1448	il_jextra=SUM(td_dom%i_jextra(:))*id_rho(jp_J)
1449
1450	ALLOCATE(dl_value(td_var%t_dim(1)%i_len, &
1451	& td_var%t_dim(2)%i_len, &
1452	& td_var%t_dim(3)%i_len, &
1453	& td_var%t_dim(4)%i_len) )
1454	dl_value(:,:,:,:)=td_var%d_value(:,:,:,:)
1455
1456	il_imin=1 + td_dom%i_iextra(1)*id_rho(jp_I)
1457	il_imax=td_var%t_dim(1)%i_len - td_dom%i_iextra(2)*id_rho(jp_I)
1458
1459	il_jmin=1 + td_dom%i_jextra(1)*id_rho(jp_J)
1460	il_jmax=td_var%t_dim(2)%i_len - td_dom%i_jextra(2)*id_rho(jp_J)
1461
1462	td_var%t_dim(1)%i_len=td_var%t_dim(1)%i_len-il_iextra
1463	td_var%t_dim(2)%i_len=td_var%t_dim(2)%i_len-il_jextra
1464
1465	DEALLOCATE(td_var%d_value)
1466	ALLOCATE(td_var%d_value(td_var%t_dim(1)%i_len, &
1467	& td_var%t_dim(2)%i_len, &
1468	& td_var%t_dim(3)%i_len, &
1469	& td_var%t_dim(4)%i_len) )
1470
1471	td_var%d_value(:,:,:,:)=dl_value(il_imin:il_imax, &
1472	& il_jmin:il_jmax, &
1473	& :, :)
1474	DEALLOCATE(dl_value)
1475	ENDIF
1476
1477	ENDIF
1478
1479	END SUBROUTINE dom_del_extra
1480	!> @endcode
1481	!-------------------------------------------------------------------
1482	!> @brief
1483	!> This subroutine clean mpp strcuture.
1484	!
1485	!> @author J.Paul
1486	!> @date Nov, 2013
1487	!
1488	!> @param[inout] td_dom : domain strcuture
1489	!-------------------------------------------------------------------
1490	!> @code
1491	SUBROUTINE dom_clean( td_dom )
1492	IMPLICIT NONE
1493	! Argument
1494	TYPE(TDOM), INTENT(INOUT) :: td_dom
1495
1496	! local variable
1497	TYPE(TDOM) :: tl_dom ! empty file structure
1498
1499	! loop indices
1500	INTEGER(i4) :: ji
1501	!----------------------------------------------------------------
1502
1503	CALL logger_info( " CLEAN: reset domain " )
1504
1505	! del dimension
1506	DO ji=ip_maxdim,1,-1
1507	CALL dim_clean( td_dom%t_dim0(ji) )
1508	ENDDO
1509
1510	! replace by empty structure
1511	td_dom=tl_dom
1512
1513	END SUBROUTINE dom_clean
1514	END MODULE dom

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

Download in other formats: