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, 7 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!----------------------------------------------------------------------
26MODULE 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
130CONTAINS
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
1757END MODULE boundary
Note: See TracBrowser for help on using the repository browser.