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.

boundary.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/boundary.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: 58.7 KB

Line
1	!----------------------------------------------------------------------
2	! NEMO system team, System and Interface for oceanic RElocable Nesting
3	!----------------------------------------------------------------------
4	!
5	! MODULE: boundary
6	!
7	! DESCRIPTION:
8	!> @brief
9	!> This module manage boundary.
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	!> - add description generique de l'objet boundary
23	!>
24	!> @note Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt)
25	!----------------------------------------------------------------------
26	MODULE boundary
27	USE netcdf ! nf90 library
28	USE global ! global parameter
29	USE phycst ! physical constant
30	USE kind ! F90 kind parameter
31	USE logger ! log file manager
32	USE fct ! basic useful function
33	! USE date ! date manager
34	! USE att ! attribute manager
35	! USE dim ! dimension manager
36	USE var ! variable manager
37	! USE file ! file manager
38	! USE iom ! I/O manager
39	! USE dom ! domain manager
40	! USE grid ! grid manager
41	! USE extrap ! extrapolation manager
42	! USE interp ! interpolation manager
43	! USE filter ! filter manager
44	! USE mpp ! MPP manager
45	! USE iom_mpp ! MPP I/O manager
46
47	IMPLICIT NONE
48	PRIVATE
49	! NOTE_avoid_public_variables_if_possible
50
51	! type and variable
52	PUBLIC :: ip_ncard !< number of cardinal point
53	PUBLIC :: ip_card !< table of cardinal point
54	PUBLIC :: TBDY !< boundary structure
55	PUBLIC :: TSEG !< segment structure
56
57	! function and subroutine
58	PUBLIC :: boundary_init !< initialise boundary structure
59	PUBLIC :: boundary_print !< print information about boundary
60	PUBLIC :: boundary_clean !< clean boundary structure
61	PUBLIC :: boundary_get_indices !< get indices of each semgent for each boundary.
62	PUBLIC :: boundary_check !< check boundary indices and corner.
63	PUBLIC :: boundary_check_corner !< check boundary corner
64	PUBLIC :: boundary_set_filename !< set boundary filename
65	PUBLIC :: boundary_clean_interp !< clean interpolated boundary
66	PUBLIC :: boundary_swap !< swap array for north and east boundary
67
68	PRIVATE :: boundary__init_wrapper !< initialise a boundary structure
69	PRIVATE :: boundary__init !< initialise basically a boundary structure
70	! PRIVATE :: boundary__copy !< copy boundary structure in another
71	PRIVATE :: boundary__copy_unit !< copy boundary structure in another
72	PRIVATE :: boundary__copy_tab !< copy boundary structure in another
73	PRIVATE :: boundary__add_seg !< add one segment structure to a boundary
74	PRIVATE :: boundary__del_seg !< remove all segments of a boundary
75	PRIVATE :: boundary__get_info !< get boundary information from boundary description string character.
76	PRIVATE :: boundary__get_seg_number !< compute the number of sea segment for one boundary
77	PRIVATE :: boundary__get_seg_indices !< get segment indices for one boundary
78	PRIVATE :: boundary__print_unit !< print information about one boundary
79	PRIVATE :: boundary__print_tab !< print information about a table of boundary
80
81	PRIVATE :: seg__init !< initialise segment structure
82	PRIVATE :: seg__clean !< clean segment structure
83	PRIVATE :: seg__copy !< copy segment structure in another
84
85	!> @struct
86	TYPE TSEG
87	INTEGER(i4) :: i_index = 0 !< segment index
88	INTEGER(i4) :: i_width = 0 !< segment width
89	INTEGER(i4) :: i_first = 0 !< segment first indice
90	INTEGER(i4) :: i_last = 0 !< segment last indices
91	END TYPE TSEG
92
93	!> @struct
94	TYPE TBDY
95	CHARACTER(LEN=lc) :: c_card = ''
96	LOGICAL :: l_use = .FALSE.
97	INTEGER(i4) :: i_nseg = 0
98	TYPE(TSEG), DIMENSION(:), POINTER :: t_seg => NULL()
99	END TYPE TBDY
100
101	INTEGER(i4), PARAMETER :: ip_ncard=4
102	CHARACTER(LEN=lc), DIMENSION(ip_ncard), PARAMETER :: ip_card = &
103	& (/ 'north', &
104	& 'south', &
105	& 'east ', &
106	& 'west ' /)
107
108	INTEGER(i4), PARAMETER :: jp_north=1
109	INTEGER(i4), PARAMETER :: jp_south=2
110	INTEGER(i4), PARAMETER :: jp_east =3
111	INTEGER(i4), PARAMETER :: jp_west =4
112
113	INTEGER(i4), PARAMETER :: im_width=10
114
115	INTERFACE boundary_init
116	MODULE PROCEDURE boundary__init_wrapper
117	END INTERFACE boundary_init
118
119	INTERFACE boundary_print
120	MODULE PROCEDURE boundary__print_unit
121	MODULE PROCEDURE boundary__print_tab
122	END INTERFACE boundary_print
123
124	INTERFACE ASSIGNMENT(=)
125	MODULE PROCEDURE boundary__copy_unit
126	MODULE PROCEDURE boundary__copy_tab
127	MODULE PROCEDURE seg__copy ! copy segment structure
128	END INTERFACE
129
130	CONTAINS
131	!-------------------------------------------------------------------
132	!> @brief
133	!> This subroutine copy boundary structure in another boundary
134	!> structure
135	!> @details
136	!>
137	!> @warning to avoid infinite loop, do not use any function inside
138	!> this subroutine
139	!>
140	!> @author J.Paul
141	!> - Nov, 2013- Initial Version
142	!
143	!> @param[out] td_bdy1 : boundary structure
144	!> @param[in] td_bdy2 : boundary structure
145	!-------------------------------------------------------------------
146	!> @code
147	SUBROUTINE boundary__copy_tab( td_bdy1, td_bdy2 )
148	IMPLICIT NONE
149	! Argument
150	TYPE(TBDY), DIMENSION(:), INTENT(OUT) :: td_bdy1
151	TYPE(TBDY), DIMENSION(:), INTENT(IN) :: td_bdy2
152
153	! local variable
154	! loop indices
155	INTEGER(i4) :: jk
156	!----------------------------------------------------------------
157
158	IF( SIZE(td_bdy1(:)) /= SIZE(td_bdy2(:)) )THEN
159	CALL logger_error("BOUNDARY COPY: dimension of table of boundary differ")
160	ELSE
161	DO jk=1,SIZE(td_bdy1(:))
162	td_bdy1(jk)=td_bdy2(jk)
163	ENDDO
164	ENDIF
165	END SUBROUTINE boundary__copy_tab
166	!> @endcode
167	!-------------------------------------------------------------------
168	!> @brief
169	!> This subroutine copy boundary structure in another boundary
170	!> structure
171	!> @details
172	!>
173	!> @warning to avoid infinite loop, do not use any function inside
174	!> this subroutine
175	!>
176	!> @author J.Paul
177	!> - Nov, 2013- Initial Version
178	!
179	!> @param[out] td_bdy1 : boundary structure
180	!> @param[in] td_bdy2 : boundary structure
181	!-------------------------------------------------------------------
182	!> @code
183	SUBROUTINE boundary__copy_unit( td_bdy1, td_bdy2 )
184	IMPLICIT NONE
185	! Argument
186	TYPE(TBDY), INTENT(OUT) :: td_bdy1
187	TYPE(TBDY), INTENT(IN) :: td_bdy2
188
189	! local variable
190	! loop indices
191	INTEGER(i4) :: ji
192	!----------------------------------------------------------------
193
194	! copy variable name, id, ..
195	td_bdy1%c_card = TRIM(td_bdy2%c_card)
196	td_bdy1%i_nseg = td_bdy2%i_nseg
197	td_bdy1%l_use = td_bdy2%l_use
198
199	! copy segment
200	IF( ASSOCIATED(td_bdy1%t_seg) ) DEALLOCATE(td_bdy1%t_seg)
201	IF( ASSOCIATED(td_bdy2%t_seg) .AND. td_bdy1%i_nseg > 0 )THEN
202	ALLOCATE( td_bdy1%t_seg(td_bdy1%i_nseg) )
203	DO ji=1,td_bdy1%i_nseg
204	td_bdy1%t_seg(ji)=td_bdy2%t_seg(ji)
205	ENDDO
206	ENDIF
207
208	END SUBROUTINE boundary__copy_unit
209	!> @endcode
210	!-------------------------------------------------------------------
211	!> @brief This subroutine clean boundary structure
212	!
213	!> @author J.Paul
214	!> - Nov, 2013- Initial Version
215	!
216	!> @param[inout] td_bdy : boundary strucutre
217	!-------------------------------------------------------------------
218	!> @code
219	SUBROUTINE boundary_clean( td_bdy )
220	IMPLICIT NONE
221	! Argument
222	TYPE(TBDY), INTENT(INOUT) :: td_bdy
223
224	! local variable
225	TYPE(TBDY) :: tl_bdy ! empty boundary strucutre
226
227	! loop indices
228	INTEGER(i4) :: ji
229	!----------------------------------------------------------------
230
231	CALL logger_info( &
232	& " CLEAN: reset boundary "//TRIM(td_bdy%c_card) )
233
234	! del segment
235	IF( ASSOCIATED(td_bdy%t_seg) )THEN
236	! clean each attribute
237	DO ji=td_bdy%i_nseg,1,-1
238	CALL seg__clean(td_bdy%t_seg(ji) )
239	ENDDO
240	DEALLOCATE( td_bdy%t_seg )
241	ENDIF
242
243	! replace by empty structure
244	td_bdy=tl_bdy
245
246	END SUBROUTINE boundary_clean
247	!> @endcode
248	!-------------------------------------------------------------------
249	!> @brief This function put cardinal name inside file name
250	!
251	!> @details
252	!
253	!> @author J.Paul
254	!> - Nov, 2013- Initial Version
255	!
256	!> @param[in] cd_file : file name
257	!> @param[in] cd_card : cardinal name
258	!> @return file name with cardinal name inside
259	!-------------------------------------------------------------------
260	!> @code
261	FUNCTION boundary_set_filename(cd_file, cd_card)
262	IMPLICIT NONE
263	! Argument
264	CHARACTER(LEN=*), INTENT(IN) :: cd_file
265	CHARACTER(LEN=*), INTENT(IN) :: cd_card
266
267	! function
268	CHARACTER(LEN=lc) :: boundary_set_filename
269
270	! local variable
271	CHARACTER(LEN=lc) :: cl_dirname
272	CHARACTER(LEN=lc) :: cl_basename
273	CHARACTER(LEN=lc) :: cl_base
274	CHARACTER(LEN=lc) :: cl_suffix
275	CHARACTER(LEN=lc) :: cl_name
276	! loop indices
277	!----------------------------------------------------------------
278	! init
279	boundary_set_filename=''
280
281	IF( TRIM(cd_file) /= '' .AND. TRIM(cd_card) /= '' )THEN
282
283	cl_dirname = fct_dirname( TRIM(cd_file))
284	IF( TRIM(cl_dirname) == '' ) cl_dirname='.'
285
286	cl_basename= fct_basename(TRIM(cd_file))
287
288	cl_base =fct_split(TRIM(cl_basename),1,'.')
289	cl_suffix=fct_split(TRIM(cl_basename),2,'.')
290
291	cl_name=TRIM(cl_base)//"_"//TRIM(cd_card)//"."//TRIM(cl_suffix)
292
293	boundary_set_filename=TRIM(cl_dirname)//"/"//TRIM(cl_name)
294	ELSE
295	CALL logger_error("BOUNDARY SET FILENAME: file or cardinal name "//&
296	& " are empty")
297	ENDIF
298
299	END FUNCTION boundary_set_filename
300	!> @endcode
301	!-------------------------------------------------------------------
302	!> @brief This function initialise a boundary structure
303	!
304	!> @details
305	!> Boundaries for each cardinal will be compute with variable structure.
306	!> It means that orthogonal index, first and last indices of each
307	!> sea segment will be compute automatically.
308	!> However you could specify which boundary to use or not with
309	!> arguments ln_north, ln_south, ln_east, ln_west.
310	!> And boundary description could be specify with argument
311	!> cn_north, cn_south, cn_east, cn_west.
312	!> For each cardinal you could specify orthogonal index,
313	!> first and last indices (in this order) and boundary width (between
314	!> parentheses).
315	!> ex : cn_north='index,first,last(width)'
316	!> You could specify more than one segment for each boundary.
317	!> However each segment will have the same width. So you do not need to
318	!> specify it for each segment.
319	!> ex : cn_north='index1,first1,last1(width)\|index2,first2,last2'
320	!
321	!> @author J.Paul
322	!> - Nov, 2013- Initial Version
323	!
324	!> @param[in] td_var : variable structure
325	!> @param[in] ld_north : use north boundary or not
326	!> @param[in] ld_south : use south boundary or not
327	!> @param[in] ld_east : use east boundary or not
328	!> @param[in] ld_west : use west boundary or not
329	!> @param[in] cd_north : north boundary description
330	!> @param[in] cd_south : south boundary description
331	!> @param[in] cd_east : east boundary description
332	!> @param[in] cd_west : west boundary description
333	!> @return boundary structure
334	!> @todo use bondary_get_indices !!!!
335	!-------------------------------------------------------------------
336	!> @code
337	FUNCTION boundary__init_wrapper(td_var, &
338	& ld_north, ld_south, ld_east, ld_west, &
339	& cd_north, cd_south, cd_east, cd_west, &
340	& ld_oneseg )
341	IMPLICIT NONE
342	! Argument
343	TYPE(TVAR) , INTENT(IN) :: td_var
344	LOGICAL , INTENT(IN), OPTIONAL :: ld_north
345	LOGICAL , INTENT(IN), OPTIONAL :: ld_south
346	LOGICAL , INTENT(IN), OPTIONAL :: ld_east
347	LOGICAL , INTENT(IN), OPTIONAL :: ld_west
348	CHARACTER(LEN=lc), INTENT(IN), OPTIONAL :: cd_north
349	CHARACTER(LEN=lc), INTENT(IN), OPTIONAL :: cd_south
350	CHARACTER(LEN=lc), INTENT(IN), OPTIONAL :: cd_east
351	CHARACTER(LEN=lc), INTENT(IN), OPTIONAL :: cd_west
352	LOGICAL , INTENT(IN), OPTIONAL :: ld_oneseg
353
354	! function
355	TYPE(TBDY), DIMENSION(ip_ncard) :: boundary__init_wrapper
356
357	! local variable
358	INTEGER(i4) , DIMENSION(ip_ncard) :: il_index
359	INTEGER(i4) , DIMENSION(ip_ncard) :: il_min
360	INTEGER(i4) , DIMENSION(ip_ncard) :: il_max
361
362	CHARACTER(LEN=lc), DIMENSION(ip_ncard) :: cl_card
363
364	TYPE(TBDY) , DIMENSION(ip_ncard) :: tl_bdy
365	TYPE(TBDY) :: tl_tmp
366
367	TYPE(TSEG) :: tl_seg
368
369	LOGICAL :: ll_oneseg
370
371	! loop indices
372	INTEGER(i4) :: ji
373	INTEGER(i4) :: jk
374	!----------------------------------------------------------------
375	IF( .NOT. ASSOCIATED(td_var%d_value) )THEN
376	CALL logger_error("BOUNDARY INIT: no value associated to variable "//&
377	& TRIM(td_var%c_name) )
378	ELSEIF( TRIM(td_var%c_point) /= 'T' )THEN
379	CALL logger_error("BOUNDARY INIT: can not compute boundary with "//&
380	& "variable "//TRIM(td_var%c_name)//&
381	& ". need a variable on T point." )
382	ELSE
383	ll_oneseg=.TRUE.
384	IF( PRESENT(ld_oneseg) ) ll_oneseg=ld_oneseg
385
386	! init
387	tl_bdy(jp_north)=boundary__init('north',ld_north)
388	tl_bdy(jp_south)=boundary__init('south',ld_south)
389	tl_bdy(jp_east )=boundary__init('east ',ld_east )
390	tl_bdy(jp_west )=boundary__init('west ',ld_west )
391
392	! if EW cyclic no east west boundary
393	IF( td_var%i_ew >= 0 )THEN
394	CALL logger_debug("BOUNDARY INIT: cyclic no East West boundary")
395	tl_bdy(jp_east )%l_use=.FALSE.
396	tl_bdy(jp_west )%l_use=.FALSE.
397	ENDIF
398
399	! attention cas U /= T ???
400	il_index(jp_north)=td_var%t_dim(2)%i_len-ig_ghost
401	il_index(jp_south)=1+ig_ghost
402	il_index(jp_east )=td_var%t_dim(1)%i_len-ig_ghost
403	il_index(jp_west )=1+ig_ghost
404
405	il_min(jp_north)=1
406	il_min(jp_south)=1
407	il_min(jp_east )=1
408	il_min(jp_west )=1
409
410	il_max(jp_north)=td_var%t_dim(1)%i_len
411	il_max(jp_south)=td_var%t_dim(1)%i_len
412	il_max(jp_east )=td_var%t_dim(2)%i_len
413	il_max(jp_west )=td_var%t_dim(2)%i_len
414
415	cl_card=(/'','','',''/)
416	IF( PRESENT(cd_north) ) cl_card(jp_north)=TRIM(cd_north)
417	IF( PRESENT(cd_south) ) cl_card(jp_south)=TRIM(cd_south)
418	IF( PRESENT(cd_east ) ) cl_card(jp_east )=TRIM(cd_east )
419	IF( PRESENT(cd_west ) ) cl_card(jp_west )=TRIM(cd_west )
420
421	DO jk=1,ip_ncard
422
423	! define default segment
424	tl_seg=seg__init(il_index(jk),im_width,il_min(jk),il_max(jk))
425
426	IF( tl_bdy(jk)%l_use )THEN
427
428	! get namelist information
429	tl_tmp=boundary__get_info(cl_card(jk))
430	DO ji=1,tl_tmp%i_nseg
431	CALL boundary__add_seg(tl_bdy(jk),tl_tmp%t_seg(ji))
432	ENDDO
433	CALL boundary_clean(tl_tmp)
434
435	IF( tl_bdy(jk)%i_nseg == 0 )THEN
436	! add default segment
437	CALL boundary__add_seg(tl_bdy(jk),tl_seg)
438	ELSE
439	! fill undefined value
440	WHERE( tl_bdy(jk)%t_seg(:)%i_index == 0 )
441	tl_bdy(jk)%t_seg(:)%i_index = tl_seg%i_index
442	END WHERE
443	WHERE( tl_bdy(jk)%t_seg(:)%i_width == 0 )
444	tl_bdy(jk)%t_seg(:)%i_width = tl_seg%i_width
445	END WHERE
446	WHERE( tl_bdy(jk)%t_seg(:)%i_first == 0 )
447	tl_bdy(jk)%t_seg(:)%i_first = tl_seg%i_first
448	END WHERE
449	WHERE( tl_bdy(jk)%t_seg(:)%i_last == 0 )
450	tl_bdy(jk)%t_seg(:)%i_last = tl_seg%i_last
451	END WHERE
452	ENDIF
453
454	ENDIF
455
456	ENDDO
457
458	CALL boundary_get_indices(tl_bdy(:), td_var, ll_oneseg)
459
460	CALL boundary_check(tl_bdy, td_var)
461
462	boundary__init_wrapper(:)=tl_bdy(:)
463
464	! clean
465	DO jk=1,ip_ncard
466	CALL boundary_clean(tl_bdy(jk))
467	ENDDO
468
469	ENDIF
470
471	END FUNCTION boundary__init_wrapper
472	!> @endcode
473	!-------------------------------------------------------------------
474	!> @brief This function initialise basically a boundary structure with
475	!> cardinal name.
476	!
477	!> @details
478	!> optionnaly you could specify if this boundary is used or not,
479	!> and add one segment structure.
480	!
481	!> @author J.Paul
482	!> - Nov, 2013- Initial Version
483	!
484	!> @param[in] cd_card : cardinal name
485	!> @param[in] ld_use : boundary use or not
486	!> @param[in] td_seg : segment structure
487	!> @return boundary structure
488	!-------------------------------------------------------------------
489	!> @code
490	FUNCTION boundary__init( cd_card, ld_use, td_seg )
491	IMPLICIT NONE
492	! Argument
493	CHARACTER(LEN=*), INTENT(IN) :: cd_card
494	LOGICAL , INTENT(IN), OPTIONAL :: ld_use
495	TYPE(TSEG) , INTENT(IN), OPTIONAL :: td_seg
496
497	! function
498	TYPE(TBDY) :: boundary__init
499
500	! local variable
501
502	! loop indices
503	!----------------------------------------------------------------
504
505	SELECT CASE(TRIM(cd_card))
506	CASE ('north','south','east','west')
507
508	boundary__init%c_card=TRIM(cd_card)
509
510	boundary__init%l_use=.TRUE.
511	IF( PRESENT(ld_use) ) boundary__init%l_use=ld_use
512
513	IF( PRESENT(td_seg) )THEN
514	CALL boundary__add_seg(boundary__init, td_seg)
515	ENDIF
516
517	CASE DEFAULT
518	CALL logger_error("BOUNDARY INIT: invalid cardinal name")
519	END SELECT
520
521	END FUNCTION boundary__init
522	!> @endcode
523	!-------------------------------------------------------------------
524	!> @brief This subroutine add one segment structure to a boundary structure
525	!
526	!> @details
527	!
528	!> @author J.Paul
529	!> - Nov, 2013- Initial Version
530	!
531	!> @param[inout] td_bdy : boundary structure
532	!> @param[in] td_seg : segment structure
533	!-------------------------------------------------------------------
534	!> @code
535	SUBROUTINE boundary__add_seg(td_bdy, td_seg)
536	IMPLICIT NONE
537	! Argument
538	TYPE(TBDY), INTENT(INOUT) :: td_bdy
539	TYPE(TSEG), INTENT(IN ) :: td_seg
540
541	! local variable
542	INTEGER(i4) :: il_status
543	TYPE(TSEG) , DIMENSION(:), ALLOCATABLE :: tl_seg
544
545	! loop indices
546	!----------------------------------------------------------------
547
548	IF( td_bdy%i_nseg > 0 )THEN
549	! already other segment in boundary structure
550	ALLOCATE( tl_seg(td_bdy%i_nseg), stat=il_status )
551	IF(il_status /= 0 )THEN
552	CALL logger_error( &
553	& " BOUNDARY ADD SEG: not enough space to put segments ")
554	ELSE
555	! save temporary segment
556	tl_seg(:)=td_bdy%t_seg(:)
557
558	DEALLOCATE( td_bdy%t_seg )
559	ALLOCATE( td_bdy%t_seg(td_bdy%i_nseg+1), stat=il_status )
560	IF(il_status /= 0 )THEN
561	CALL logger_error( &
562	& " BOUNDARY ADD SEG: not enough space to put segments ")
563	ENDIF
564
565	! copy segment in boundary before
566	td_bdy%t_seg(1:td_bdy%i_nseg)=tl_seg(:)
567
568	DEALLOCATE(tl_seg)
569
570	ENDIF
571	ELSE
572	! no segment in boundary structure
573	IF( ASSOCIATED(td_bdy%t_seg) )THEN
574	DEALLOCATE(td_bdy%t_seg)
575	ENDIF
576	ALLOCATE( td_bdy%t_seg(td_bdy%i_nseg+1), stat=il_status )
577	IF(il_status /= 0 )THEN
578	CALL logger_error( &
579	& " BOUNDARY ADD SEG: not enough space to put segments ")
580	ENDIF
581	ENDIF
582
583	! update number of segment
584	td_bdy%i_nseg=td_bdy%i_nseg+1
585
586	! add new segment
587	td_bdy%t_seg(td_bdy%i_nseg)=td_seg
588
589	END SUBROUTINE boundary__add_seg
590	!> @endcode
591	!-------------------------------------------------------------------
592	!> @brief This subroutine remove all segments of a boundary structure
593	!
594	!> @details
595	!
596	!> @author J.Paul
597	!> - Nov, 2013- Initial Version
598	!
599	!> @param[inout] td_bdy : boundary structure
600	!-------------------------------------------------------------------
601	!> @code
602	SUBROUTINE boundary__del_seg(td_bdy)
603	IMPLICIT NONE
604	! Argument
605	TYPE(TBDY), INTENT(INOUT) :: td_bdy
606
607	! local variable
608	! loop indices
609	!----------------------------------------------------------------
610
611	IF( ASSOCIATED(td_bdy%t_seg) )THEN
612	DEALLOCATE(td_bdy%t_seg)
613	ENDIF
614	!update number of segment
615	td_bdy%i_nseg=0
616
617	END SUBROUTINE boundary__del_seg
618	!> @endcode
619	!-------------------------------------------------------------------
620	!> @brief This function get information about boundary from string character.
621	!
622	!> @details
623	!> This string character that will be passed through namelist could contains
624	!> orthogonal index, first and last indices, of each segment.
625	!> And also the width of all segments of this boundary.
626	!> cn_north='index1,first1,last1(width)\|index2,first2,last2'
627	!>
628	!> @author J.Paul
629	!> - Nov, 2013- Initial Version
630	!
631	!> @param[in] cd_card : boundary description
632	!> @return boundary structure
633	!-------------------------------------------------------------------
634	!> @code
635	FUNCTION boundary__get_info(cd_card)
636	IMPLICIT NONE
637	! Argument
638	CHARACTER(LEN=lc), INTENT(IN) :: cd_card
639
640	! function
641	TYPE(TBDY) :: boundary__get_info
642
643	! local variable
644	INTEGER(i4) :: il_width
645	INTEGER(i4) :: il_ind1
646	INTEGER(i4) :: il_ind2
647
648	CHARACTER(LEN=lc) :: cl_seg
649	CHARACTER(LEN=lc) :: cl_index
650	CHARACTER(LEN=lc) :: cl_width
651	CHARACTER(LEN=lc) :: cl_first
652	CHARACTER(LEN=lc) :: cl_last
653
654	TYPE(TSEG) :: tl_seg
655
656	! loop indices
657	INTEGER(i4) :: ji
658	!----------------------------------------------------------------
659
660	ji=1
661	cl_seg=fct_split(cd_card,ji)
662
663	il_width=0
664	! look for segment width
665	! width should be the same for all segment of one boundary
666	IF( TRIM(cl_seg) /= '' )THEN
667	il_ind1=SCAN(fct_lower(cl_seg),'(')
668	IF( il_ind1 /=0 )THEN
669	cl_width=TRIM(cl_seg(il_ind1+1:))
670
671	il_ind2=SCAN(fct_lower(cl_width),')')
672	IF( il_ind2 /=0 )THEN
673	cl_width=TRIM(cl_width(1:il_ind2-1))
674	READ(cl_width,*) il_width
675	ELSE
676	CALL logger_error("BOUNDARY INIT: unclosed parentheses."//&
677	& " check namelist. ")
678	ENDIF
679	ENDIF
680	ENDIF
681
682	DO WHILE( TRIM(cl_seg) /= '' )
683
684	cl_index=fct_split(cl_seg,1,',')
685	! remove potential width information
686	il_ind1=SCAN(fct_lower(cl_index),'(')
687	IF( il_ind1 /=0 )THEN
688	il_ind2=SCAN(fct_lower(cl_index),'(')
689	IF( il_ind2 /=0 )THEN
690	cl_index=TRIM(cl_index(:il_ind1-1))//TRIM(cl_index(il_ind2+1:))
691	ELSE
692	CALL logger_error("BOUNDARY INIT: unclosed parentheses."//&
693	& " check namelist. ")
694	ENDIF
695	ENDIF
696
697	cl_first=fct_split(cl_seg,2,',')
698	! remove potential width information
699	il_ind1=SCAN(fct_lower(cl_first),'(')
700	IF( il_ind1 /=0 )THEN
701	il_ind2=SCAN(fct_lower(cl_first),'(')
702	IF( il_ind2 /=0 )THEN
703	cl_first=TRIM(cl_first(:il_ind1-1))//TRIM(cl_first(il_ind2+1:))
704	ELSE
705	CALL logger_error("BOUNDARY INIT: unclosed parentheses."//&
706	& " check namelist. ")
707	ENDIF
708	ENDIF
709
710	cl_last =fct_split(cl_seg,3,',')
711	! remove potential width information
712	il_ind1=SCAN(fct_lower(cl_last),'(')
713	IF( il_ind1 /=0 )THEN
714	il_ind2=SCAN(fct_lower(cl_last),'(')
715	IF( il_ind2 /=0 )THEN
716	cl_last=TRIM(cl_last(:il_ind1-1))//TRIM(cl_last(il_ind2+1:))
717	ELSE
718	CALL logger_error("BOUNDARY INIT: unclosed parentheses."//&
719	& " check namelist. ")
720	ENDIF
721	ENDIF
722
723	IF( il_width /= 0 ) tl_seg%i_width=il_width
724
725	IF( TRIM(cl_index) /= '' ) READ(cl_index,*) tl_seg%i_index
726	IF( TRIM(cl_first) /= '' ) READ(cl_first,*) tl_seg%i_first
727	IF( TRIM(cl_last) /= '' ) READ(cl_last ,*) tl_seg%i_last
728
729	IF( (tl_seg%i_first == 0 .AND. tl_seg%i_last == 0) .OR. &
730	& (tl_seg%i_first /= 0 .AND. tl_seg%i_last /= 0) )THEN
731	CALL boundary__add_seg(boundary__get_info, tl_seg)
732	ELSE
733	CALL logger_error("BOUNDARY INIT: first or last segment indices "//&
734	& "are missing . check namelist.")
735	ENDIF
736
737	ji=ji+1
738	cl_seg=fct_split(cd_card,ji)
739	ENDDO
740
741	END FUNCTION boundary__get_info
742	!> @endcode
743	!-------------------------------------------------------------------
744	!> @brief This subroutine get indices of each semgent for each boundary.
745	!
746	!> @details
747	!> indices are compute from variable value, actually variable fill value,
748	!> which is assume to be land mask.
749	!> Boundary structure should have been initialized before running
750	!> this subroutine. Segment indices will be search between first and last
751	!> indies, at this orthogonal index.
752	!>
753	!> Optionnally you could forced to use only one segment for each boundary.
754	!>
755	!> @warning number of segment (i_nseg) will be change, before the number
756	!> of segment structure
757	!
758	!> @author J.Paul
759	!> - Nov, 2013- Initial Version
760	!
761	!> @param[inout] td_bdy : boundary structure
762	!> @param[in] td_var : variable structure
763	!> @param[in] ld_onseg : use only one sgment for each boundary
764	!-------------------------------------------------------------------
765	!> @code
766	SUBROUTINE boundary_get_indices( td_bdy, td_var, ld_oneseg)
767	IMPLICIT NONE
768	! Argument
769	TYPE(TBDY) , DIMENSION(ip_ncard), INTENT(INOUT) :: td_bdy
770	TYPE(TVAR) , INTENT(IN ) :: td_var
771	LOGICAL , INTENT(IN ), OPTIONAL :: ld_oneseg
772
773	! local variable
774	INTEGER(i4) :: il_index
775	INTEGER(i4) :: il_width
776	INTEGER(i4) :: il_first
777	INTEGER(i4) :: il_last
778
779	LOGICAL :: ll_oneseg
780
781	TYPE(TSEG) :: tl_seg
782
783	! loop indices
784	INTEGER(i4) :: jk
785	!----------------------------------------------------------------
786
787	ll_oneseg=.TRUE.
788	IF( PRESENT(ld_oneseg) ) ll_oneseg=ld_oneseg
789
790	DO jk=1,ip_ncard
791	IF( .NOT. td_bdy(jk)%l_use .OR. td_bdy(jk)%i_nseg > 1 )THEN
792	! nothing to be done
793	ELSE
794
795	IF( .NOT. ASSOCIATED(td_bdy(jk)%t_seg) )THEN
796	CALL logger_error("BOUNDARY GET INDICES: no segment "//&
797	& " associated to "//TRIM(td_bdy(jk)%c_card)//&
798	& " boundary. you should have run boundary_init before"//&
799	& " running boundary_get_indices" )
800	ELSE
801	il_index=td_bdy(jk)%t_seg(1)%i_index
802	il_width=td_bdy(jk)%t_seg(1)%i_width
803	il_first=td_bdy(jk)%t_seg(1)%i_first
804	il_last =td_bdy(jk)%t_seg(1)%i_last
805
806	CALL boundary__get_seg_number( td_bdy(jk), td_var)
807
808	CALL boundary__get_seg_indices( td_bdy(jk), td_var, &
809	& il_index, il_width, &
810	& il_first, il_last )
811
812	IF( ll_oneseg .AND. td_bdy(jk)%l_use )THEN
813	tl_seg=td_bdy(jk)%t_seg(1)
814	! use last indice of last segment
815	tl_seg%i_last=td_bdy(jk)%t_seg(td_bdy(jk)%i_nseg)%i_last
816
817	! remove all segment from boundary
818	CALL boundary__del_seg(td_bdy(jk))
819
820	! add one segment
821	CALL boundary__add_seg(td_bdy(jk),tl_seg)
822	ENDIF
823
824	ENDIF
825
826	ENDIF
827
828	ENDDO
829
830	END SUBROUTINE boundary_get_indices
831	!> @endcode
832	!-------------------------------------------------------------------
833	!> @brief This subroutine compute the number of sea segment.
834	!
835	!> @details
836	!> It use variable value, actually variable fill value
837	!> (which is assume to be land mask), to compute the number of segment between
838	!> first and last indices at boundary orthogonal index.
839	!> @warning number of segment (i_nseg) will be change, before the number
840	!> of segment structure
841	!
842	!> @author J.Paul
843	!> - Nov, 2013- Initial Version
844	!
845	!> @param[inout] td_bdy : boundary structure
846	!> @param[in] td_var : variable structure
847	!-------------------------------------------------------------------
848	!> @code
849	SUBROUTINE boundary__get_seg_number( td_bdy, td_var)
850	IMPLICIT NONE
851	! Argument
852	TYPE(TBDY) , INTENT(INOUT) :: td_bdy
853	TYPE(TVAR) , INTENT(IN ) :: td_var
854
855	! local variable
856	REAL(dp) , DIMENSION(:) , ALLOCATABLE :: dl_value
857	LOGICAL :: ll_sea
858	INTEGER(i4) :: il_index
859
860	! loop indices
861	INTEGER(i4) :: ji
862	!----------------------------------------------------------------
863
864	IF( td_bdy%l_use .AND. td_bdy%i_nseg == 1 )THEN
865
866	il_index=td_bdy%t_seg(1)%i_index
867
868	SELECT CASE(TRIM(td_bdy%c_card))
869	CASE('north','south')
870
871	ALLOCATE( dl_value(td_var%t_dim(1)%i_len) )
872	dl_value(:)=td_var%d_value(:,il_index,1,1)
873
874	IF( ANY(dl_value(:) /= td_var%d_fill) )THEN
875
876	td_bdy%l_use=.TRUE.
877	td_bdy%i_nseg=0
878
879	ll_sea=.FALSE.
880	DO ji=1,td_var%t_dim(1)%i_len
881	IF( dl_value(ji)/= td_var%d_fill )THEN
882	IF( .NOT. ll_sea )THEN
883	td_bdy%i_nseg=td_bdy%i_nseg+1
884	ENDIF
885	ll_sea=.TRUE.
886	ELSE
887	ll_sea=.FALSE.
888	ENDIF
889	ENDDO
890
891	ELSE
892	td_bdy%l_use=.FALSE.
893	td_bdy%i_nseg=0
894	ENDIF
895
896	DEALLOCATE( dl_value )
897
898	CASE('east','west')
899
900	ALLOCATE( dl_value(td_var%t_dim(2)%i_len) )
901	dl_value(:)=td_var%d_value(il_index,:,1,1)
902
903	IF( ANY(dl_value(:) /= td_var%d_fill) )THEN
904
905	td_bdy%l_use=.TRUE.
906	td_bdy%i_nseg=0
907
908	ll_sea=.FALSE.
909	DO ji=1,td_var%t_dim(2)%i_len
910	IF( dl_value(ji)/= td_var%d_fill )THEN
911	IF( .NOT. ll_sea )THEN
912	td_bdy%i_nseg=td_bdy%i_nseg+1
913	ENDIF
914	ll_sea=.TRUE.
915	ELSE
916	ll_sea=.FALSE.
917	ENDIF
918	ENDDO
919
920	ELSE
921	td_bdy%l_use=.FALSE.
922	td_bdy%i_nseg=0
923	ENDIF
924
925	DEALLOCATE( dl_value )
926
927	END SELECT
928	ENDIF
929
930
931	END SUBROUTINE boundary__get_seg_number
932	!> @endcode
933	!-------------------------------------------------------------------
934	!> @brief This subroutine get segment indices for one boundary.
935	!
936	!> @details
937	!
938	!> @author J.Paul
939	!> - Nov, 2013- Initial Version
940	!
941	!> @param[inout] td_bdy : boundary structure
942	!> @param[in] td_var : variable structure
943	!> @param[in] id_index : boundary orthogonal index
944	!> @param[in] id_width : bounary width
945	!> @param[in] id_first : boundary first indice
946	!> @param[in] id_last : boundary last indice
947	!-------------------------------------------------------------------
948	!> @code
949	SUBROUTINE boundary__get_seg_indices( td_bdy, td_var, &
950	& id_index, id_width, id_first, id_last)
951	IMPLICIT NONE
952	! Argument
953	TYPE(TBDY) , INTENT(INOUT) :: td_bdy
954	TYPE(TVAR) , INTENT(IN ) :: td_var
955	INTEGER(i4), INTENT(IN ) :: id_index
956	INTEGER(i4), INTENT(IN ) :: id_width
957	INTEGER(i4), INTENT(IN ) :: id_first
958	INTEGER(i4), INTENT(IN ) :: id_last
959
960	! local variable
961	INTEGER(i4) :: il_nseg
962	INTEGER(i4), DIMENSION(ip_ncard) :: il_max
963	INTEGER(i4), DIMENSION(ip_ncard) :: il_min
964
965	REAL(dp) , DIMENSION(:) , ALLOCATABLE :: dl_value
966
967	LOGICAL :: ll_sea
968	LOGICAL :: ll_first
969	LOGICAL :: ll_last
970
971	TYPE(TSEG) :: tl_seg
972
973	! loop indices
974	INTEGER(i4) :: ji
975	INTEGER(i4) :: jk
976	INTEGER(i4) :: jl
977	!----------------------------------------------------------------
978
979	SELECT CASE(TRIM(td_bdy%c_card))
980	CASE('north')
981	jk=jp_north
982
983	ALLOCATE( dl_value(td_var%t_dim(1)%i_len) )
984	dl_value(:)=td_var%d_value(:,id_index,1,1)
985
986	CASE('south')
987	jk=jp_south
988
989	ALLOCATE( dl_value(td_var%t_dim(1)%i_len) )
990	dl_value(:)=td_var%d_value(:,id_index,1,1)
991
992	CASE('east ')
993	jk=jp_east
994
995	ALLOCATE( dl_value(td_var%t_dim(2)%i_len) )
996	dl_value(:)=td_var%d_value(id_index,:,1,1)
997
998	CASE('west ')
999	jk=jp_west
1000
1001	ALLOCATE( dl_value(td_var%t_dim(2)%i_len) )
1002	dl_value(:)=td_var%d_value(id_index,:,1,1)
1003
1004	END SELECT
1005
1006	il_max(jp_north)=td_var%t_dim(1)%i_len-ig_ghost
1007	il_max(jp_south)=td_var%t_dim(1)%i_len-ig_ghost
1008	il_max(jp_east )=td_var%t_dim(2)%i_len-ig_ghost
1009	il_max(jp_west )=td_var%t_dim(2)%i_len-ig_ghost
1010
1011	il_min(jp_north)=1+ig_ghost
1012	il_min(jp_south)=1+ig_ghost
1013	il_min(jp_east )=1+ig_ghost
1014	il_min(jp_west )=1+ig_ghost
1015
1016	! special case for EW cyclic
1017	IF( td_var%i_ew >= 0 )THEN
1018	il_min(jp_north)=1
1019	il_min(jp_south)=1
1020
1021	il_max(jp_north)=td_var%t_dim(1)%i_len
1022	il_max(jp_south)=td_var%t_dim(1)%i_len
1023	ENDIF
1024
1025	il_nseg=td_bdy%i_nseg
1026	! remove all segment from boundary
1027	CALL boundary__del_seg(td_bdy)
1028
1029	ll_first=.FALSE.
1030	ll_last =.FALSE.
1031	DO jl=1,il_nseg
1032
1033	! init
1034	tl_seg=seg__init(id_index,id_width,id_first,id_last)
1035
1036	IF( .NOT. (ll_first .AND. ll_last) )THEN
1037	! first loop
1038	tl_seg%i_first=MAX(id_first,il_min(jk))
1039	tl_seg%i_last =MIN(id_last ,il_max(jk))
1040	ELSE
1041	! load new min and max
1042	tl_seg%i_first=MAX(td_bdy%t_seg(jl-1)%i_last,il_min(jk))
1043	tl_seg%i_last =MIN(id_last ,il_max(jk))
1044	ENDIF
1045
1046	ll_first=.FALSE.
1047	ll_last =.FALSE.
1048	ll_sea =.FALSE.
1049
1050	DO ji=tl_seg%i_first,tl_seg%i_last
1051
1052	IF( ll_first .AND. ll_last )THEN
1053	! first and last point already loaded
1054	! look for next segment
1055	EXIT
1056	ENDIF
1057
1058	IF( dl_value(ji)/= td_var%d_fill )THEN
1059	IF( .NOT. ll_sea )THEN
1060	tl_seg%i_first=MAX(tl_seg%i_first,ji-1)
1061	ll_first=.true.
1062	ENDIF
1063	ll_sea=.TRUE.
1064	ELSE
1065	IF( ll_sea )THEN
1066	tl_seg%i_last=ji
1067	ll_last=.TRUE.
1068	ENDIF
1069	ll_sea=.FALSE.
1070	ENDIF
1071
1072	ENDDO
1073
1074	CALL boundary__add_seg(td_bdy,tl_seg)
1075
1076	CALL seg__clean(tl_seg)
1077
1078	ENDDO
1079
1080	DEALLOCATE(dl_value)
1081
1082	END SUBROUTINE boundary__get_seg_indices
1083	!> @endcode
1084	!-------------------------------------------------------------------
1085	!> @brief This subroutine check if there is boundary at corner, and
1086	!> adjust boundary indices if necessary.
1087	!
1088	!> @details
1089	!> If there is a north west corner, first indices of north boundary
1090	!> should be the same as the west boundary indices.
1091	!> And the last indices of the west boundary should be the same as
1092	!> the north indices.
1093	!> More over the width of west and north boundary should be the same.
1094	!
1095	!> @author J.Paul
1096	!> - Nov, 2013- Initial Version
1097	!
1098	!> @param[inout] td_bdy : boundary structure
1099	!> @param[in] td_var : variable structure
1100	!>
1101	!> @todo add schematic to description
1102	!-------------------------------------------------------------------
1103	!> @code
1104	SUBROUTINE boundary_check_corner( td_bdy, td_var )
1105	IMPLICIT NONE
1106	! Argument
1107	TYPE(TBDY) , DIMENSION(ip_ncard), INTENT(INOUT) :: td_bdy
1108	TYPE(TVAR) , INTENT(IN ) :: td_var
1109
1110	! local variable
1111	TYPE(TSEG) :: tl_north
1112	TYPE(TSEG) :: tl_south
1113	TYPE(TSEG) :: tl_east
1114	TYPE(TSEG) :: tl_west
1115
1116	INTEGER(i4) :: il_width
1117
1118	! loop indices
1119	!----------------------------------------------------------------
1120
1121	IF( .NOT. ASSOCIATED(td_var%d_value) )THEN
1122	CALL logger_error("BOUNDARY CHEKC CORNER: no value associated "//&
1123	& "to variable "//TRIM(td_var%c_name))
1124	ENDIF
1125
1126	! check north west corner
1127	IF( td_bdy(jp_north)%l_use .AND. td_bdy(jp_west)%l_use )THEN
1128	tl_west =td_bdy(jp_west )%t_seg(td_bdy(jp_west)%i_nseg)
1129	tl_north=td_bdy(jp_north)%t_seg(1)
1130
1131	IF( tl_west%i_last >= tl_north%i_index .AND. &
1132	& tl_west%i_index >= tl_north%i_first ) THEN
1133	CALL logger_debug("BOUNDARY CHEKC CORNER: there is "//&
1134	& "a north west corner")
1135
1136	tl_west%i_last = tl_north%i_index
1137	tl_north%i_first = tl_west%i_index
1138
1139	IF( tl_west%i_width /= tl_north%i_width )THEN
1140	CALL logger_error("BOUNDARY CHEKC CORNER: discordant "//&
1141	& " width between north and west boundary ")
1142
1143	il_width=MIN(tl_west%i_width,tl_north%i_width)
1144
1145	tl_west%i_width =il_width
1146	tl_north%i_width=il_width
1147
1148	ENDIF
1149
1150	td_bdy(jp_west )%t_seg(td_bdy(jp_west)%i_nseg)=tl_west
1151	td_bdy(jp_north)%t_seg(1) =tl_north
1152
1153	ELSE
1154
1155	IF( td_var%d_value(tl_north%i_first,tl_north%i_index,1,1) /= &
1156	& td_var%d_fill )THEN
1157	CALL logger_error("BOUNDARY CHEKC CORNER: wrong "//&
1158	& "north boundary first indice ")
1159	ENDIF
1160
1161	IF( td_var%d_value(tl_west%i_index,tl_west%i_last,1,1) /= &
1162	& td_var%d_fill )THEN
1163	CALL logger_error("BOUNDARY CHEKC CORNER: wrong "//&
1164	& "west boundary last indice")
1165	ENDIF
1166	ENDIF
1167	ENDIF
1168
1169	! check north east corner
1170	IF( td_bdy(jp_north)%l_use .AND. td_bdy(jp_east)%l_use )THEN
1171	tl_east =td_bdy(jp_east )%t_seg(td_bdy(jp_east )%i_nseg)
1172	tl_north=td_bdy(jp_north)%t_seg(td_bdy(jp_north)%i_nseg)
1173
1174	IF( tl_east%i_last >= tl_north%i_index .AND. &
1175	& tl_east%i_index <= tl_north%i_last ) THEN
1176	CALL logger_debug("BOUNDARY CHEKC CORNER: there is "//&
1177	& "a north east corner")
1178
1179	tl_east%i_last = tl_north%i_index
1180	tl_north%i_last = tl_east%i_index
1181
1182	IF( tl_east%i_width /= tl_north%i_width )THEN
1183	CALL logger_error("BOUNDARY CHEKC CORNER: discordant "//&
1184	& " width between north and east boundary ")
1185
1186	il_width=MIN(tl_east%i_width,tl_north%i_width)
1187
1188	tl_east%i_width =il_width
1189	tl_north%i_width=il_width
1190
1191	ENDIF
1192
1193	td_bdy(jp_east )%t_seg(td_bdy(jp_east )%i_nseg)=tl_east
1194	td_bdy(jp_north)%t_seg(td_bdy(jp_north)%i_nseg)=tl_north
1195	ELSE
1196
1197	IF( td_var%d_value(tl_north%i_last,tl_north%i_index,1,1) /= &
1198	& td_var%d_fill )THEN
1199	CALL logger_error("BOUNDARY CHEKC CORNER: wrong "//&
1200	& "north boundary last indice ")
1201	ENDIF
1202
1203	IF( td_var%d_value(tl_east%i_index,tl_east%i_last,1,1) /= &
1204	& td_var%d_fill )THEN
1205	CALL logger_error("BOUNDARY CHEKC CORNER: wrong "//&
1206	& "east boundary last indice")
1207	ENDIF
1208	ENDIF
1209	ENDIF
1210
1211	! check south east corner
1212	IF( td_bdy(jp_south)%l_use .AND. td_bdy(jp_east)%l_use )THEN
1213	tl_east =td_bdy(jp_east )%t_seg(1)
1214	tl_south=td_bdy(jp_south)%t_seg(td_bdy(jp_south)%i_nseg)
1215
1216	IF( tl_east%i_first <= tl_south%i_index .AND. &
1217	& tl_east%i_index <= tl_south%i_last ) THEN
1218	CALL logger_debug("BOUNDARY CHEKC CORNER: there is "//&
1219	& "a south east corner")
1220
1221	tl_east%i_first = tl_south%i_index
1222	tl_south%i_last = tl_east%i_index
1223
1224	IF( tl_east%i_width /= tl_south%i_width )THEN
1225	CALL logger_error("BOUNDARY CHEKC CORNER: discordant "//&
1226	& " width between south and east boundary ")
1227
1228	il_width=MIN(tl_east%i_width,tl_south%i_width)
1229
1230	tl_east%i_width =il_width
1231	tl_south%i_width=il_width
1232
1233	ENDIF
1234
1235	td_bdy(jp_east )%t_seg(1) =tl_east
1236	td_bdy(jp_south)%t_seg(td_bdy(jp_south)%i_nseg)=tl_south
1237	ELSE
1238
1239	IF( td_var%d_value(tl_south%i_last,tl_south%i_index,1,1) /= &
1240	& td_var%d_fill )THEN
1241	CALL logger_error("BOUNDARY CHEKC CORNER: wrong "//&
1242	& "south boundary last indice ")
1243	ENDIF
1244
1245	IF( td_var%d_value(tl_east%i_index,tl_east%i_first,1,1) /= &
1246	& td_var%d_fill )THEN
1247	CALL logger_error("BOUNDARY CHEKC CORNER: wrong "//&
1248	& "east boundary first indice")
1249	ENDIF
1250	ENDIF
1251	ENDIF
1252
1253	! check south west corner
1254	IF( td_bdy(jp_south)%l_use .AND. td_bdy(jp_west)%l_use )THEN
1255	tl_west =td_bdy(jp_west )%t_seg(1)
1256	tl_south=td_bdy(jp_south)%t_seg(1)
1257
1258	IF( tl_west%i_first <= tl_south%i_index .AND. &
1259	& tl_west%i_index >= tl_south%i_first ) THEN
1260	CALL logger_debug("BOUNDARY CHEKC CORNER: there is "//&
1261	& "a south west corner")
1262
1263	tl_west%i_first = tl_south%i_index
1264	tl_south%i_first= tl_west%i_index
1265
1266	IF( tl_west%i_width /= tl_south%i_width )THEN
1267	CALL logger_error("BOUNDARY CHEKC CORNER: discordant "//&
1268	& " width between south and west boundary ")
1269
1270	il_width=MIN(tl_west%i_width,tl_south%i_width)
1271
1272	tl_west%i_width =il_width
1273	tl_south%i_width=il_width
1274
1275	ENDIF
1276
1277	td_bdy(jp_west )%t_seg(1) = tl_west
1278	td_bdy(jp_south)%t_seg(1) = tl_south
1279	ELSE
1280
1281	IF( td_var%d_value(tl_south%i_first,tl_south%i_index,1,1) /= &
1282	& td_var%d_fill )THEN
1283	CALL logger_error("BOUNDARY CHEKC CORNER: wrong "//&
1284	& "south boundary first indice ")
1285	ENDIF
1286
1287	IF( td_var%d_value(tl_west%i_index,tl_west%i_first,1,1) /= &
1288	& td_var%d_fill )THEN
1289	CALL logger_error("BOUNDARY CHEKC CORNER: wrong "//&
1290	& "west boundary first indice")
1291	ENDIF
1292	ENDIF
1293	ENDIF
1294
1295	END SUBROUTINE boundary_check_corner
1296	!> @endcode
1297	!-------------------------------------------------------------------
1298	!> @brief This subroutine check boundary.
1299	!
1300	!> @details
1301	!> It checks that first and last indices as well as orthogonal index are
1302	!> inside domain, and check corner (see boundary_check_corner).
1303	!
1304	!> @author J.Paul
1305	!> - Nov, 2013- Initial Version
1306	!
1307	!> @param[inout] td_bdy : boundary structure
1308	!> @param[in] td_var : variable structure
1309	!-------------------------------------------------------------------
1310	!> @code
1311	SUBROUTINE boundary_check(td_bdy, td_var)
1312	IMPLICIT NONE
1313	! Argument
1314	TYPE(TBDY) , DIMENSION(ip_ncard), INTENT(INOUT) :: td_bdy
1315	TYPE(TVAR) , INTENT(IN ) :: td_var
1316
1317	! local variable
1318	INTEGER(i4) , DIMENSION(ip_ncard) :: il_max
1319	INTEGER(i4) , DIMENSION(ip_ncard) :: il_maxindex
1320
1321	! loop indices
1322	INTEGER(i4) :: jk
1323	!----------------------------------------------------------------
1324
1325	il_max(jp_north)=td_var%t_dim(1)%i_len
1326	il_max(jp_south)=td_var%t_dim(1)%i_len
1327	il_max(jp_east )=td_var%t_dim(2)%i_len
1328	il_max(jp_west )=td_var%t_dim(2)%i_len
1329
1330	il_maxindex(jp_north)=td_var%t_dim(2)%i_len-ig_ghost
1331	il_maxindex(jp_south)=td_var%t_dim(2)%i_len-ig_ghost
1332	il_maxindex(jp_east )=td_var%t_dim(1)%i_len-ig_ghost
1333	il_maxindex(jp_west )=td_var%t_dim(1)%i_len-ig_ghost
1334
1335	DO jk=1,ip_ncard
1336	IF( td_bdy(jk)%l_use )THEN
1337	IF( .NOT. ASSOCIATED(td_bdy(jk)%t_seg) )THEN
1338	CALL logger_error("BOUNDARY CHECK: no segment associted "//&
1339	& "to "//TRIM(td_bdy(jk)%c_card)//" boundary")
1340	ELSE
1341	! check indices
1342	IF( ANY(td_bdy(jk)%t_seg(:)%i_first < 1 ) .OR. &
1343	& ANY(td_bdy(jk)%t_seg(:)%i_first > il_max(jk)) .OR. &
1344	& ANY(td_bdy(jk)%t_seg(:)%i_last < 1 ) .OR. &
1345	& ANY(td_bdy(jk)%t_seg(:)%i_last > il_max(jk)) .OR. &
1346	& ANY(td_bdy(jk)%t_seg(:)%i_first > td_bdy(jk)%t_seg(:)%i_last)&
1347	& )THEN
1348	CALL logger_error("BOUNDARY CHECK: invalid segment "//&
1349	& "first and/or last indice for "//&
1350	& TRIM(td_bdy(jk)%c_card)//&
1351	& " boundary. check namelist")
1352	ENDIF
1353
1354	IF( ANY(td_bdy(jk)%t_seg(:)%i_index < 1 ) .OR. &
1355	& ANY(td_bdy(jk)%t_seg(:)%i_index > il_maxindex(jk)) &
1356	& )THEN
1357	CALL logger_error("BOUNDARY CHECK: invalid index "//&
1358	& "for "//TRIM(td_bdy(jk)%c_card)//&
1359	& " boundary. check namelist")
1360	ENDIF
1361	ENDIF
1362	ENDIF
1363	ENDDO
1364
1365	CALL boundary_check_corner(td_bdy, td_var)
1366
1367	END SUBROUTINE boundary_check
1368	!> @endcode
1369	!-------------------------------------------------------------------
1370	!> @brief This subroutine clean interpolated boundary in variable structure.
1371	!
1372	!> @detail
1373	!> interpolation could create more point than needed for boundary (depending
1374	!> on refinement factor). This subroutine keep only useful point on variable
1375	!>
1376	!> @note we use width define in first segment, cause every segment of a
1377	!> boundary should have the same width
1378	!>
1379	!> @author J.Paul
1380	!> - Nov, 2013- Initial Version
1381	!
1382	!> @param[inout] td_var : variable strucutre
1383	!> @param[in ] td_bdy : boundary strucutre
1384	!-------------------------------------------------------------------
1385	!> @code
1386	SUBROUTINE boundary_clean_interp( td_var, td_bdy )
1387	IMPLICIT NONE
1388	! Argument
1389	TYPE(TVAR), INTENT(INOUT) :: td_var
1390	TYPE(TBDY), INTENT(IN ) :: td_bdy
1391
1392	! local variable
1393	TYPE(TVAR) :: tl_var
1394
1395	INTEGER(i4) :: il_imin
1396	INTEGER(i4) :: il_imax
1397	INTEGER(i4) :: il_jmin
1398	INTEGER(i4) :: il_jmax
1399
1400	! loop indices
1401	!----------------------------------------------------------------
1402
1403	! copy input variable
1404	tl_var=td_var
1405
1406	DEALLOCATE(td_var%d_value)
1407
1408	SELECT CASE(TRIM(td_bdy%c_card))
1409	CASE('north')
1410
1411	il_imin=1
1412	il_imax=tl_var%t_dim(1)%i_len
1413	SELECT CASE(td_var%c_point)
1414	CASE('V','F')
1415	il_jmin=td_bdy%t_seg(1)%i_width+1
1416	il_jmax=2
1417	CASE DEFAULT ! 'T','U'
1418	il_jmin=td_bdy%t_seg(1)%i_width
1419	il_jmax=1
1420	END SELECT
1421
1422	! use width as dimension length
1423	td_var%t_dim(2)%i_len=td_bdy%t_seg(1)%i_width
1424
1425	CASE('south')
1426
1427	il_imin=1
1428	il_imax=tl_var%t_dim(1)%i_len
1429
1430	il_jmin=1
1431	il_jmax=td_bdy%t_seg(1)%i_width
1432
1433	! use width as dimension length
1434	td_var%t_dim(2)%i_len=td_bdy%t_seg(1)%i_width
1435
1436	CASE('east')
1437
1438	SELECT CASE(td_var%c_point)
1439	CASE('U','F')
1440	il_imin=td_bdy%t_seg(1)%i_width+1
1441	il_imax=2
1442	CASE DEFAULT ! 'T','V'
1443	il_imin=td_bdy%t_seg(1)%i_width
1444	il_imax=1
1445	END SELECT
1446
1447	il_jmin=1
1448	il_jmax=tl_var%t_dim(2)%i_len
1449
1450	! use width as dimension length
1451	td_var%t_dim(1)%i_len=td_bdy%t_seg(1)%i_width
1452
1453	CASE('west')
1454
1455	il_imin=1
1456	il_imax=td_bdy%t_seg(1)%i_width
1457
1458	il_jmin=1
1459	il_jmax=tl_var%t_dim(2)%i_len
1460
1461	! use width as dimension length
1462	td_var%t_dim(1)%i_len=td_bdy%t_seg(1)%i_width
1463
1464	END SELECT
1465
1466
1467	ALLOCATE( td_var%d_value(td_var%t_dim(1)%i_len, &
1468	& td_var%t_dim(2)%i_len, &
1469	& td_var%t_dim(3)%i_len, &
1470	& td_var%t_dim(4)%i_len) )
1471
1472	IF( il_imin > il_imax )THEN
1473	il_imin=tl_var%t_dim(1)%i_len-il_imin+1
1474	il_imax=tl_var%t_dim(1)%i_len-il_imax+1
1475	ENDIF
1476
1477	IF( il_jmin > il_jmax )THEN
1478	il_jmin=tl_var%t_dim(2)%i_len-il_jmin+1
1479	il_jmax=tl_var%t_dim(2)%i_len-il_jmax+1
1480	ENDIF
1481
1482	td_var%d_value(:,:,:,:)=tl_var%d_value( il_imin:il_imax, &
1483	& il_jmin:il_jmax, &
1484	& :,: )
1485
1486	CALL var_clean(tl_var)
1487
1488
1489	END SUBROUTINE boundary_clean_interp
1490	!> @endcode
1491	!-------------------------------------------------------------------
1492	!> @brief This subroutine swap array for east and north boundary.
1493	!
1494	!> @detail
1495	!>
1496	!> @author J.Paul
1497	!> - Nov, 2013- Initial Version
1498	!
1499	!> @param[inout] td_var : variable strucutre
1500	!> @param[in ] td_bdy : boundary strucutre
1501	!-------------------------------------------------------------------
1502	!> @code
1503	SUBROUTINE boundary_swap( td_var, td_bdy )
1504	IMPLICIT NONE
1505	! Argument
1506	TYPE(TVAR), INTENT(INOUT) :: td_var
1507	TYPE(TBDY), INTENT(IN ) :: td_bdy
1508
1509	! local variable
1510	REAL(dp), DIMENSION(:,:,:,:), ALLOCATABLE :: dl_value
1511
1512	! loop indices
1513	INTEGER(i4) :: ji
1514	INTEGER(i4) :: jj
1515	!----------------------------------------------------------------
1516
1517	IF( .NOT. ASSOCIATED(td_var%d_value) )THEN
1518	CALL logger_error("BOUNDARY SWAP: no table of value "//&
1519	& "associted to variable "//TRIM(td_var%c_name) )
1520	ELSE
1521
1522	SELECT CASE(TRIM(td_bdy%c_card))
1523	CASE('north')
1524	ALLOCATE( dl_value(td_var%t_dim(1)%i_len, &
1525	& td_var%t_dim(2)%i_len, &
1526	& td_var%t_dim(3)%i_len, &
1527	& td_var%t_dim(4)%i_len) )
1528
1529	dl_value(:,:,:,:)=td_var%d_value(:,:,:,:)
1530
1531	DO jj=1, td_var%t_dim(2)%i_len
1532	td_var%d_value(:,jj,:,:) = &
1533	& dl_value(:,td_var%t_dim(2)%i_len-jj+1,:,:)
1534	ENDDO
1535
1536	DEALLOCATE( dl_value )
1537	CASE('east')
1538	ALLOCATE( dl_value(td_var%t_dim(1)%i_len, &
1539	& td_var%t_dim(2)%i_len, &
1540	& td_var%t_dim(3)%i_len, &
1541	& td_var%t_dim(4)%i_len) )
1542
1543	dl_value(:,:,:,:)=td_var%d_value(:,:,:,:)
1544
1545	DO ji=1, td_var%t_dim(1)%i_len
1546	td_var%d_value(ji,:,:,:) = &
1547	& dl_value(td_var%t_dim(1)%i_len-ji+1,:,:,:)
1548	ENDDO
1549
1550	DEALLOCATE( dl_value )
1551	CASE DEFAULT
1552	! nothing to be done
1553	END SELECT
1554
1555	ENDIF
1556	END SUBROUTINE boundary_swap
1557	!> @endcode
1558	!-------------------------------------------------------------------
1559	!> @brief This subroutine print information about one boundary
1560	!
1561	!> @details
1562	!
1563	!> @author J.Paul
1564	!> - Nov, 2013- Initial Version
1565	!
1566	!> @param[in] td_bdy : boundary structure
1567	!-------------------------------------------------------------------
1568	!> @code
1569	SUBROUTINE boundary__print_unit( td_bdy )
1570	IMPLICIT NONE
1571	! Argument
1572	TYPE(TBDY), INTENT(IN) :: td_bdy
1573	! local variable
1574	! loop indices
1575	INTEGER(i4) :: ji
1576	!----------------------------------------------------------------
1577
1578	WRITE(*,'(a,/1x,a,/1x,a)') "Boundary "//TRIM(td_bdy%c_card), &
1579	& " use "//TRIM(fct_str(td_bdy%l_use)), &
1580	& " nseg "//TRIM(fct_str(td_bdy%i_nseg))
1581	DO ji=1,td_bdy%i_nseg
1582	WRITE(*,'(4(/1x,a))') &
1583	& " index "//TRIM(fct_str(td_bdy%t_seg(ji)%i_index)), &
1584	& " width "//TRIM(fct_str(td_bdy%t_seg(ji)%i_width)), &
1585	& " first "//TRIM(fct_str(td_bdy%t_seg(ji)%i_first)), &
1586	& " last "//TRIM(fct_str(td_bdy%t_seg(ji)%i_last))
1587	ENDDO
1588
1589	END SUBROUTINE boundary__print_unit
1590	!> @endcode
1591	!-------------------------------------------------------------------
1592	!> @brief This subroutine print information about a table of boundary
1593	!
1594	!> @details
1595	!
1596	!> @author J.Paul
1597	!> - Nov, 2013- Initial Version
1598	!
1599	!> @param[in] td_bdy : boundary structure
1600	!-------------------------------------------------------------------
1601	!> @code
1602	SUBROUTINE boundary__print_tab( td_bdy )
1603	IMPLICIT NONE
1604	! Argument
1605	TYPE(TBDY), DIMENSION(:), INTENT(IN) :: td_bdy
1606	! local variable
1607	! loop indices
1608	INTEGER(i4) :: ji
1609	!----------------------------------------------------------------
1610
1611	DO ji=1,SIZE(td_bdy(:))
1612	CALL boundary_print(td_bdy(ji))
1613	ENDDO
1614
1615	END SUBROUTINE boundary__print_tab
1616	!> @endcode
1617	!-------------------------------------------------------------------
1618	!> @brief
1619	!> This subroutine copy segment structure in another segment
1620	!> structure
1621	!> @details
1622	!>
1623	!> @warning to avoid infinite loop, do not use any function inside
1624	!> this subroutine
1625	!>
1626	!> @author J.Paul
1627	!> - Nov, 2013- Initial Version
1628	!
1629	!> @param[out] td_seg1 : segment structure
1630	!> @param[in] td_seg2 : segment structure
1631	!-------------------------------------------------------------------
1632	!> @code
1633	SUBROUTINE seg__copy( td_seg1, td_seg2 )
1634	IMPLICIT NONE
1635	! Argument
1636	TYPE(TSEG), INTENT(OUT) :: td_seg1
1637	TYPE(TSEG), INTENT(IN) :: td_seg2
1638
1639	! local variable
1640	! loop indices
1641	!----------------------------------------------------------------
1642
1643	! copy segment index, width, ..
1644	td_seg1%i_index = td_seg2%i_index
1645	td_seg1%i_width = td_seg2%i_width
1646	td_seg1%i_first = td_seg2%i_first
1647	td_seg1%i_last = td_seg2%i_last
1648
1649	END SUBROUTINE seg__copy
1650	!> @endcode
1651	!-------------------------------------------------------------------
1652	!> @brief This function initialise segment structure.
1653	!
1654	!> @details
1655	!> It simply add orthogonal index, and optionnaly width, first
1656	!> and last indices of the segment.
1657	!
1658	!> @author J.Paul
1659	!> - Nov, 2013- Initial Version
1660	!
1661	!> @param[in] id_index : orthogonal index
1662	!> @param[in] id_width : width of the segment
1663	!> @param[in] id_first : first indices
1664	!> @param[in] id_last : last indices
1665	!> @return segment structure
1666	!-------------------------------------------------------------------
1667	!> @code
1668	FUNCTION seg__init( id_index, id_width, id_first, id_last )
1669	IMPLICIT NONE
1670	! Argument
1671	INTEGER(i4), INTENT(IN) :: id_index
1672	INTEGER(i4), INTENT(IN), OPTIONAL :: id_width
1673	INTEGER(i4), INTENT(IN), OPTIONAL :: id_first
1674	INTEGER(i4), INTENT(IN), OPTIONAL :: id_last
1675
1676	! function
1677	TYPE(TSEG) :: seg__init
1678
1679	! local variable
1680
1681	! loop indices
1682	!----------------------------------------------------------------
1683
1684	seg__init%i_index=id_index
1685
1686	IF( PRESENT(id_width) ) seg__init%i_width=id_width
1687	IF( PRESENT(id_first) ) seg__init%i_first=id_first
1688	IF( PRESENT(id_last ) ) seg__init%i_last =id_last
1689
1690	END FUNCTION seg__init
1691	!> @endcode
1692	!-------------------------------------------------------------------
1693	!> @brief This subroutine clean segment structure.
1694	!
1695	!> @details
1696	!
1697	!> @author J.Paul
1698	!> - Nov, 2013- Initial Version
1699	!
1700	!> @param[inout] td_seg : segment structure
1701	!-------------------------------------------------------------------
1702	!> @code
1703	SUBROUTINE seg__clean(td_seg)
1704	IMPLICIT NONE
1705	! Argument
1706	TYPE(TSEG), INTENT(INOUT) :: td_seg
1707	! local variable
1708	TYPE(TSEG) :: tl_seg
1709	! loop indices
1710	!----------------------------------------------------------------
1711
1712	td_seg=tl_seg
1713
1714	END SUBROUTINE seg__clean
1715	!> @endcode
1716	! !-------------------------------------------------------------------
1717	! !> @brief This function
1718	! !
1719	! !> @details
1720	! !
1721	! !> @author J.Paul
1722	! !> - Nov, 2013- Initial Version
1723	! !
1724	! !> @param[in]
1725	! !-------------------------------------------------------------------
1726	! !> @code
1727	! FUNCTION boundary_()
1728	! IMPLICIT NONE
1729	! ! Argument
1730	! ! function
1731	! ! local variable
1732	! ! loop indices
1733	! !----------------------------------------------------------------
1734	!
1735	! END FUNCTION boundary_
1736	! !> @endcode
1737	! !-------------------------------------------------------------------
1738	! !> @brief This subroutine
1739	! !
1740	! !> @details
1741	! !
1742	! !> @author J.Paul
1743	! !> - Nov, 2013- Initial Version
1744	! !
1745	! !> @param[in]
1746	! !-------------------------------------------------------------------
1747	! !> @code
1748	! SUBROUTINE boundary_()
1749	! IMPLICIT NONE
1750	! ! Argument
1751	! ! local variable
1752	! ! loop indices
1753	! !----------------------------------------------------------------
1754	!
1755	! END SUBROUTINE boundary_
1756	! !> @endcode
1757	END MODULE boundary

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

Download in other formats: