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 utils/tools/SIREN/src – NEMO

source: utils/tools/SIREN/src/boundary.f90 @ 12080

Last change on this file since 12080 was 12080, checked in by jpaul, 4 years ago

update nemo trunk

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