!---------------------------------------------------------------------- ! NEMO system team, System and Interface for oceanic RElocable Nesting !---------------------------------------------------------------------- ! ! MODULE: boundary ! ! DESCRIPTION: !> @brief !> This module manage boundary. !> !> @details !> define type TBDY:
!> @code !> TYPE(TBDY) :: tl_bdy
!> @endcode !> !> to initialise boundary structure:
!> @code !> tl_bdy=boundary_init(td_var, [ld_north,] [ld_south,] [ld_east,] [ld_west,] !> [cd_north,] [cd_south,] [cd_east,] [cd_west,] [ld_oneseg]) !> @endcode !> - td_var is variable structure !> - ld_north is logical to force used of north boundary [optional] !> - ld_south is logical to force used of north boundary [optional] !> - ld_east is logical to force used of north boundary [optional] !> - ld_west is logical to force used of north boundary [optional] !> - cd_north is string character description of north boundary [optional] !> - cd_south is string character description of north boundary [optional] !> - cd_east is string character description of north boundary [optional] !> - cd_west is string character description of north boundary [optional] !> - ld_oneseg is logical to force to use only one segment for each boundary [optional] !> !> to get boundary cardinal:
!> - tl_bdy\%c_card !> !> to know if boundary is use:
!> - tl_bdy\%l_use !> !> to get the number of segment in boundary:
!> - tl_bdy\%i_nseg !> !> to get array of segment in boundary:
!> - tl_bdy\%t_seg(:) !> !> to get orthogonal segment index of north boundary:
!> - tl_bdy\%t_seg(jp_north)%\i_index !> !> to get segment width of south boundary:
!> - tl_bdy\%t_seg(jp_south)%\i_width !> !> to get segment first indice of east boundary:
!> - tl_bdy\%t_seg(jp_east)%\i_first !> !> to get segment last indice of west boundary:
!> - tl_bdy\%t_seg(jp_west)%\i_last !> !> to print information about boundary:
!> @code !> CALL boundary_print(td_bdy) !> @endcode !> - td_bdy is boundary structure or a array of boundary structure !> !> to clean boundary structure:
!> @code !> CALL boundary_clean(td_bdy) !> @endcode !> !> to get indices of each semgent for each boundary:
!> @code !> CALL boundary_get_indices( td_bdy, td_var, ld_oneseg) !> @endcode !> - td_bdy is boundary structure !> - td_var is variable structure !> - ld_oneseg is logical to force to use only one segment for each boundary [optional] !> !> to check boundary indices and corner:
!> @code !> CALL boundary_check(td_bdy, td_var) !> @endcode !> - td_bdy is boundary structure !> - td_var is variable structure !> !> to check boundary corner:
!> @code !> CALL boundary_check_corner(td_bdy, td_var) !> @endcode !> - td_bdy is boundary structure !> - td_var is variable structure !> !> to create filename with cardinal name inside:
!> @code !> cl_filename=boundary_set_filename(cd_file, cd_card) !> @endcode !> - cd_file = original file name !> - cd_card = cardinal name !> !> to swap array for east and north boundary:
!> @code !> CALL boundary_swap( td_var, td_bdy ) !> @endcode !> - td_var is variable strucutre !> - td_bdy is boundary strucutre !> !> @author J.Paul ! REVISION HISTORY: !> @date November, 2013 - Initial Version !> @date September, 2014 - add boundary description !> @date November, 2014 - Fix memory leaks bug !> !> @todo add schematic to boundary structure description !> !> @note Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) !---------------------------------------------------------------------- MODULE boundary USE netcdf ! nf90 library USE global ! global parameter USE phycst ! physical constant USE kind ! F90 kind parameter USE logger ! log file manager USE fct ! basic useful function USE var ! variable manager IMPLICIT NONE ! NOTE_avoid_public_variables_if_possible ! type and variable PUBLIC :: TBDY !< boundary structure PUBLIC :: TSEG !< segment structure PRIVATE :: im_width !< boundary width ! function and subroutine PUBLIC :: boundary_copy !< copy boundary structure PUBLIC :: boundary_init !< initialise boundary structure PUBLIC :: boundary_print !< print information about boundary PUBLIC :: boundary_clean !< clean boundary structure PUBLIC :: boundary_get_indices !< get indices of each semgent for each boundary. PUBLIC :: boundary_check !< check boundary indices and corner. PUBLIC :: boundary_check_corner !< check boundary corner PUBLIC :: boundary_set_filename !< set boundary filename PUBLIC :: boundary_swap !< swap array for north and east boundary PRIVATE :: boundary__clean_unit ! clean boundary structure PRIVATE :: boundary__clean_arr ! clean array of boundary structure PRIVATE :: boundary__init_wrapper ! initialise a boundary structure PRIVATE :: boundary__init ! initialise basically a boundary structure PRIVATE :: boundary__copy_unit ! copy boundary structure in another PRIVATE :: boundary__copy_arr ! copy boundary structure in another PRIVATE :: boundary__add_seg ! add one segment structure to a boundary PRIVATE :: boundary__del_seg ! remove all segments of a boundary PRIVATE :: boundary__get_info ! get boundary information from boundary description string character. PRIVATE :: boundary__get_seg_number ! compute the number of sea segment for one boundary PRIVATE :: boundary__get_seg_indices ! get segment indices for one boundary PRIVATE :: boundary__print_unit ! print information about one boundary PRIVATE :: boundary__print_arr ! print information about a array of boundary PRIVATE :: seg__init ! initialise segment structure PRIVATE :: seg__clean ! clean segment structure PRIVATE :: seg__clean_unit ! clean segment structure PRIVATE :: seg__clean_arr ! clean array of segment structure PRIVATE :: seg__copy ! copy segment structure in another PRIVATE :: seg__copy_unit ! copy segment structure in another PRIVATE :: seg__copy_arr ! copy array of segment structure in another TYPE TSEG !< segment structure INTEGER(i4) :: i_index = 0 !< segment index INTEGER(i4) :: i_width = 0 !< segment width INTEGER(i4) :: i_first = 0 !< segment first indice INTEGER(i4) :: i_last = 0 !< segment last indices END TYPE TSEG TYPE TBDY !< boundary structure CHARACTER(LEN=lc) :: c_card = '' !< boundary cardinal LOGICAL :: l_use = .FALSE. !< boundary use or not INTEGER(i4) :: i_nseg = 0 !< number of segment in boundary TYPE(TSEG), DIMENSION(:), POINTER :: t_seg => NULL() !< array of segment structure END TYPE TBDY INTEGER(i4), PARAMETER :: im_width=10 INTERFACE boundary_init MODULE PROCEDURE boundary__init_wrapper END INTERFACE boundary_init INTERFACE boundary_print MODULE PROCEDURE boundary__print_unit MODULE PROCEDURE boundary__print_arr END INTERFACE boundary_print INTERFACE boundary_clean MODULE PROCEDURE boundary__clean_unit MODULE PROCEDURE boundary__clean_arr END INTERFACE INTERFACE seg__clean MODULE PROCEDURE seg__clean_unit MODULE PROCEDURE seg__clean_arr END INTERFACE INTERFACE boundary_copy MODULE PROCEDURE boundary__copy_unit MODULE PROCEDURE boundary__copy_arr END INTERFACE INTERFACE seg__copy MODULE PROCEDURE seg__copy_unit ! copy segment structure MODULE PROCEDURE seg__copy_arr ! copy array of segment structure END INTERFACE CONTAINS !------------------------------------------------------------------- !> @brief !> This subroutine copy a array of boundary structure in another one !> @details !> !> @warning do not use on the output of a function who create or read an !> attribute (ex: tl_bdy=boundary_copy(boundary_init()) is forbidden). !> This will create memory leaks. !> @warning to avoid infinite loop, do not use any function inside !> this subroutine !> !> @author J.Paul !> @date November, 2013 - Initial Version !> @date November, 2014 !> - use function instead of overload assignment operator !> (to avoid memory leak) ! !> @param[in] td_bdy array of boundary structure !> @return copy of input array of boundary structure !------------------------------------------------------------------- FUNCTION boundary__copy_arr( td_bdy ) IMPLICIT NONE ! Argument TYPE(TBDY), DIMENSION(:), INTENT(IN) :: td_bdy ! function TYPE(TBDY), DIMENSION(SIZE(td_bdy(:))) :: boundary__copy_arr ! local variable ! loop indices INTEGER(i4) :: jk !---------------------------------------------------------------- DO jk=1,SIZE(td_bdy(:)) boundary__copy_arr(jk)=boundary_copy(td_bdy(jk)) ENDDO END FUNCTION boundary__copy_arr !------------------------------------------------------------------- !> @brief !> This subroutine copy boundary structure in another one !> @details !> !> @warning do not use on the output of a function who create or read an !> attribute (ex: tl_bdy=boundary_copy(boundary_init()) is forbidden). !> This will create memory leaks. !> @warning to avoid infinite loop, do not use any function inside !> this subroutine !> !> @author J.Paul !> @date November, 2013 - Initial Version !> @date November, 2014 !> - use function instead of overload assignment operator !> (to avoid memory leak) ! !> @param[in] td_bdy boundary structure !> @return copy of input boundary structure !------------------------------------------------------------------- FUNCTION boundary__copy_unit( td_bdy ) IMPLICIT NONE ! Argument TYPE(TBDY), INTENT(IN) :: td_bdy ! function TYPE(TBDY) :: boundary__copy_unit ! local variable ! loop indices INTEGER(i4) :: ji !---------------------------------------------------------------- ! copy variable name, id, .. boundary__copy_unit%c_card = TRIM(td_bdy%c_card) boundary__copy_unit%i_nseg = td_bdy%i_nseg boundary__copy_unit%l_use = td_bdy%l_use ! copy segment IF( ASSOCIATED(boundary__copy_unit%t_seg) )THEN CALL seg__clean(boundary__copy_unit%t_seg(:)) DEALLOCATE(boundary__copy_unit%t_seg) ENDIF IF( ASSOCIATED(td_bdy%t_seg) .AND. boundary__copy_unit%i_nseg > 0 )THEN ALLOCATE( boundary__copy_unit%t_seg(boundary__copy_unit%i_nseg) ) DO ji=1,boundary__copy_unit%i_nseg boundary__copy_unit%t_seg(ji)=td_bdy%t_seg(ji) ENDDO ENDIF END FUNCTION boundary__copy_unit !------------------------------------------------------------------- !> @brief This subroutine clean boundary structure ! !> @author J.Paul !> @date November, 2013 - Initial Version ! !> @param[inout] td_bdy boundary strucutre !------------------------------------------------------------------- SUBROUTINE boundary__clean_unit( td_bdy ) IMPLICIT NONE ! Argument TYPE(TBDY), INTENT(INOUT) :: td_bdy ! local variable TYPE(TBDY) :: tl_bdy ! empty boundary strucutre ! loop indices !---------------------------------------------------------------- CALL logger_info( & & " CLEAN: reset boundary "//TRIM(td_bdy%c_card) ) ! del segment IF( ASSOCIATED(td_bdy%t_seg) )THEN ! clean each segment CALL seg__clean(td_bdy%t_seg(:) ) DEALLOCATE( td_bdy%t_seg ) ENDIF ! replace by empty structure td_bdy=boundary_copy(tl_bdy) END SUBROUTINE boundary__clean_unit !------------------------------------------------------------------- !> @brief This subroutine clean array of boundary structure ! !> @author J.Paul !> @date September, 2014 - Initial Version ! !> @param[inout] td_bdy boundary strucutre !------------------------------------------------------------------- SUBROUTINE boundary__clean_arr( td_bdy ) IMPLICIT NONE ! Argument TYPE(TBDY), DIMENSION(:), INTENT(INOUT) :: td_bdy ! local variable ! loop indices INTEGER(i4) :: ji !---------------------------------------------------------------- DO ji=SIZE(td_bdy(:)),1,-1 CALL boundary_clean( td_bdy(ji) ) ENDDO END SUBROUTINE boundary__clean_arr !------------------------------------------------------------------- !> @brief This function put cardinal name inside file name. ! !> @details ! !> @author J.Paul !> @date November, 2013 - Initial Version ! !> @param[in] cd_file file name !> @param[in] cd_card cardinal name !> @param[in] id_seg segment number !> @param[in] cd_date file date (format: y????m??d??) !> @return file name with cardinal name inside !------------------------------------------------------------------- FUNCTION boundary_set_filename(cd_file, cd_card, id_seg, cd_date) IMPLICIT NONE ! Argument CHARACTER(LEN=*), INTENT(IN) :: cd_file CHARACTER(LEN=*), INTENT(IN) :: cd_card INTEGER(i4) , INTENT(IN), OPTIONAL :: id_seg CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_date ! function CHARACTER(LEN=lc) :: boundary_set_filename ! local variable CHARACTER(LEN=lc) :: cl_dirname CHARACTER(LEN=lc) :: cl_basename CHARACTER(LEN=lc) :: cl_base CHARACTER(LEN=lc) :: cl_suffix CHARACTER(LEN=lc) :: cl_segnum CHARACTER(LEN=lc) :: cl_date CHARACTER(LEN=lc) :: cl_name ! loop indices !---------------------------------------------------------------- ! init boundary_set_filename='' IF( TRIM(cd_file) /= '' .AND. TRIM(cd_card) /= '' )THEN cl_dirname = fct_dirname( TRIM(cd_file)) IF( TRIM(cl_dirname) == '' ) cl_dirname='.' cl_basename= fct_basename(TRIM(cd_file)) cl_base =fct_split(TRIM(cl_basename),1,'.') cl_suffix=fct_split(TRIM(cl_basename),2,'.') IF( PRESENT(id_seg) )THEN cl_segnum="_"//TRIM(fct_str(id_seg))//"_" ELSE cl_segnum="" ENDIF IF( PRESENT(cd_date) )THEN cl_date=TRIM(ADJUSTL(cd_date)) ELSE cl_date="" ENDIF cl_name=TRIM(cl_base)//"_"//TRIM(cd_card)//TRIM(cl_segnum)//& & TRIM(cl_date)//"."//TRIM(cl_suffix) boundary_set_filename=TRIM(cl_dirname)//"/"//TRIM(cl_name) ELSE CALL logger_error("BOUNDARY SET FILENAME: file or cardinal name "//& & " are empty") ENDIF END FUNCTION boundary_set_filename !------------------------------------------------------------------- !> @brief This function initialise a boundary structure. ! !> @details !> Boundaries for each cardinal will be compute with variable structure. !> It means that orthogonal index, first and last indices of each !> sea segment will be compute automatically. !> However you could specify which boundary to use or not with !> arguments ln_north, ln_south, ln_east, ln_west. !> And boundary description could be specify with argument !> cn_north, cn_south, cn_east, cn_west. !> For each cardinal you could specify orthogonal index, !> first and last indices (in this order) and boundary width (between !> parentheses). !> ex : cn_north='index,first,last(width)' !> You could specify more than one segment for each boundary. !> However each segment will have the same width. So you do not need to !> specify it for each segment. !> ex : cn_north='index1,first1,last1(width)|index2,first2,last2' !> !> @note boundaries are compute on T point. change will be done to get data !> on other point when need be. !> !> @author J.Paul !> @date November, 2013 - Initial Version !> @date September, 2014 !> - add boolean to use only one segment for each boundary !> - check boundary width ! !> @param[in] td_var variable structure !> @param[in] ld_north use north boundary or not !> @param[in] ld_south use south boundary or not !> @param[in] ld_east use east boundary or not !> @param[in] ld_west use west boundary or not !> @param[in] cd_north north boundary description !> @param[in] cd_south south boundary description !> @param[in] cd_east east boundary description !> @param[in] cd_west west boundary description !> @param[in] ld_oneseg force to use only one segment for each boundary !> @return boundary structure !------------------------------------------------------------------- FUNCTION boundary__init_wrapper(td_var, & & ld_north, ld_south, ld_east, ld_west, & & cd_north, cd_south, cd_east, cd_west, & & ld_oneseg ) IMPLICIT NONE ! Argument TYPE(TVAR) , INTENT(IN) :: td_var LOGICAL , INTENT(IN), OPTIONAL :: ld_north LOGICAL , INTENT(IN), OPTIONAL :: ld_south LOGICAL , INTENT(IN), OPTIONAL :: ld_east LOGICAL , INTENT(IN), OPTIONAL :: ld_west CHARACTER(LEN=lc), INTENT(IN), OPTIONAL :: cd_north CHARACTER(LEN=lc), INTENT(IN), OPTIONAL :: cd_south CHARACTER(LEN=lc), INTENT(IN), OPTIONAL :: cd_east CHARACTER(LEN=lc), INTENT(IN), OPTIONAL :: cd_west LOGICAL , INTENT(IN), OPTIONAL :: ld_oneseg ! function TYPE(TBDY), DIMENSION(ip_ncard) :: boundary__init_wrapper ! local variable INTEGER(i4) :: il_width INTEGER(i4) , DIMENSION(ip_ncard) :: il_max_width INTEGER(i4) , DIMENSION(ip_ncard) :: il_index INTEGER(i4) , DIMENSION(ip_ncard) :: il_min INTEGER(i4) , DIMENSION(ip_ncard) :: il_max CHARACTER(LEN=lc), DIMENSION(ip_ncard) :: cl_card TYPE(TBDY) , DIMENSION(ip_ncard) :: tl_bdy TYPE(TBDY) :: tl_tmp TYPE(TSEG) :: tl_seg LOGICAL :: ll_oneseg ! loop indices INTEGER(i4) :: ji INTEGER(i4) :: jk !---------------------------------------------------------------- IF( .NOT. ASSOCIATED(td_var%d_value) )THEN CALL logger_error("BOUNDARY INIT: no value associated to variable "//& & TRIM(td_var%c_name) ) ELSEIF( TRIM(td_var%c_point) /= 'T' )THEN CALL logger_error("BOUNDARY INIT: can not compute boundary with "//& & "variable "//TRIM(td_var%c_name)//& & ". need a variable on T point." ) ELSE ll_oneseg=.TRUE. IF( PRESENT(ld_oneseg) ) ll_oneseg=ld_oneseg ! init tl_bdy(jp_north)=boundary__init('north',ld_north) tl_bdy(jp_south)=boundary__init('south',ld_south) tl_bdy(jp_east )=boundary__init('east ',ld_east ) tl_bdy(jp_west )=boundary__init('west ',ld_west ) ! if EW cyclic no east west boundary and force to use one segment IF( td_var%i_ew >= 0 )THEN CALL logger_info("BOUNDARY INIT: cyclic domain, "//& & "no East West boundary") tl_bdy(jp_east )%l_use=.FALSE. tl_bdy(jp_west )%l_use=.FALSE. CALL logger_info("BOUNDARY INIT: force to use one segment due"//& & " to EW cyclic domain") ll_oneseg=.TRUE. ENDIF il_index(jp_north)=td_var%t_dim(2)%i_len-ip_ghost il_index(jp_south)=1+ip_ghost il_index(jp_east )=td_var%t_dim(1)%i_len-ip_ghost il_index(jp_west )=1+ip_ghost il_min(jp_north)=1 il_min(jp_south)=1 il_min(jp_east )=1 il_min(jp_west )=1 il_max(jp_north)=td_var%t_dim(1)%i_len il_max(jp_south)=td_var%t_dim(1)%i_len il_max(jp_east )=td_var%t_dim(2)%i_len il_max(jp_west )=td_var%t_dim(2)%i_len cl_card=(/'','','',''/) IF( PRESENT(cd_north) ) cl_card(jp_north)=TRIM(cd_north) IF( PRESENT(cd_south) ) cl_card(jp_south)=TRIM(cd_south) IF( PRESENT(cd_east ) ) cl_card(jp_east )=TRIM(cd_east ) IF( PRESENT(cd_west ) ) cl_card(jp_west )=TRIM(cd_west ) il_max_width(jp_north)=INT(0.5*(td_var%t_dim(2)%i_len-2*ip_ghost)) il_max_width(jp_south)=INT(0.5*(td_var%t_dim(2)%i_len-2*ip_ghost)) il_max_width(jp_east )=INT(0.5*(td_var%t_dim(1)%i_len-2*ip_ghost)) il_max_width(jp_west )=INT(0.5*(td_var%t_dim(1)%i_len-2*ip_ghost)) DO jk=1,ip_ncard ! check boundary width IF( il_max_width(jk) <= im_width )THEN IF( il_max_width(jk) <= 0 )THEN CALL logger_fatal("BOUNDARY INIT: domain too small to define"//& & " boundaries.") ELSE CALL logger_warn("BOUNDARY INIT: default boundary width too "//& & "large for boundaries. force to use boundary"//& & " on one point") il_width=1 ENDIF ELSE il_width=im_width ENDIF ! define default segment tl_seg=seg__init(il_index(jk),il_width,il_min(jk),il_max(jk)) IF( tl_bdy(jk)%l_use )THEN ! get namelist information tl_tmp=boundary__get_info(cl_card(jk)) DO ji=1,tl_tmp%i_nseg CALL boundary__add_seg(tl_bdy(jk),tl_tmp%t_seg(ji)) ENDDO CALL boundary_clean(tl_tmp) IF( tl_bdy(jk)%i_nseg == 0 )THEN ! add default segment CALL boundary__add_seg(tl_bdy(jk),tl_seg) ELSE ! fill undefined value WHERE( tl_bdy(jk)%t_seg(:)%i_index == 0 ) tl_bdy(jk)%t_seg(:)%i_index = tl_seg%i_index END WHERE WHERE( tl_bdy(jk)%t_seg(:)%i_width == 0 ) tl_bdy(jk)%t_seg(:)%i_width = tl_seg%i_width END WHERE WHERE( tl_bdy(jk)%t_seg(:)%i_first == 0 ) tl_bdy(jk)%t_seg(:)%i_first = tl_seg%i_first END WHERE WHERE( tl_bdy(jk)%t_seg(:)%i_last == 0 ) tl_bdy(jk)%t_seg(:)%i_last = tl_seg%i_last END WHERE ENDIF ENDIF ! clean CALL seg__clean(tl_seg) ENDDO CALL boundary_get_indices(tl_bdy(:), td_var, ll_oneseg) CALL boundary_check(tl_bdy, td_var) boundary__init_wrapper(:)=boundary_copy(tl_bdy(:)) ! clean DO jk=1,ip_ncard CALL boundary_clean(tl_bdy(jk)) ENDDO ENDIF END FUNCTION boundary__init_wrapper !------------------------------------------------------------------- !> @brief This function initialise basically a boundary structure with !> cardinal name. ! !> @details !> optionnaly you could specify if this boundary is used or not, !> and add one segment structure. ! !> @author J.Paul !> @date November, 2013 - Initial Version ! !> @param[in] cd_card cardinal name !> @param[in] ld_use boundary use or not !> @param[in] td_seg segment structure !> @return boundary structure !------------------------------------------------------------------- FUNCTION boundary__init( cd_card, ld_use, td_seg ) IMPLICIT NONE ! Argument CHARACTER(LEN=*), INTENT(IN) :: cd_card LOGICAL , INTENT(IN), OPTIONAL :: ld_use TYPE(TSEG) , INTENT(IN), OPTIONAL :: td_seg ! function TYPE(TBDY) :: boundary__init ! local variable ! loop indices !---------------------------------------------------------------- SELECT CASE(TRIM(cd_card)) CASE ('north','south','east','west') boundary__init%c_card=TRIM(cd_card) boundary__init%l_use=.TRUE. IF( PRESENT(ld_use) ) boundary__init%l_use=ld_use IF( PRESENT(td_seg) )THEN CALL boundary__add_seg(boundary__init, td_seg) ENDIF CASE DEFAULT CALL logger_error("BOUNDARY INIT: invalid cardinal name") END SELECT END FUNCTION boundary__init !------------------------------------------------------------------- !> @brief This subroutine add one segment structure to a boundary structure ! !> @details ! !> @author J.Paul !> @date November, 2013 - Initial Version ! !> @param[inout] td_bdy boundary structure !> @param[in] td_seg segment structure !------------------------------------------------------------------- SUBROUTINE boundary__add_seg(td_bdy, td_seg) IMPLICIT NONE ! Argument TYPE(TBDY), INTENT(INOUT) :: td_bdy TYPE(TSEG), INTENT(IN ) :: td_seg ! local variable INTEGER(i4) :: il_status TYPE(TSEG) , DIMENSION(:), ALLOCATABLE :: tl_seg ! loop indices !---------------------------------------------------------------- IF( td_bdy%i_nseg > 0 )THEN ! already other segment in boundary structure ALLOCATE( tl_seg(td_bdy%i_nseg), stat=il_status ) IF(il_status /= 0 )THEN CALL logger_error( & & " BOUNDARY ADD SEG: not enough space to put segments ") ELSE ! save temporary segment tl_seg(:)=seg__copy(td_bdy%t_seg(:)) CALL seg__clean(td_bdy%t_seg(:)) DEALLOCATE( td_bdy%t_seg ) ALLOCATE( td_bdy%t_seg(td_bdy%i_nseg+1), stat=il_status ) IF(il_status /= 0 )THEN CALL logger_error( & & " BOUNDARY ADD SEG: not enough space to put segments ") ENDIF ! copy segment in boundary before td_bdy%t_seg(1:td_bdy%i_nseg)=seg__copy(tl_seg(:)) ! clean CALL seg__clean(tl_seg(:)) DEALLOCATE(tl_seg) ENDIF ELSE ! no segment in boundary structure IF( ASSOCIATED(td_bdy%t_seg) )THEN CALL seg__clean(td_bdy%t_seg(:)) DEALLOCATE(td_bdy%t_seg) ENDIF ALLOCATE( td_bdy%t_seg(td_bdy%i_nseg+1), stat=il_status ) IF(il_status /= 0 )THEN CALL logger_error( & & " BOUNDARY ADD SEG: not enough space to put segments ") ENDIF ENDIF ! update number of segment td_bdy%i_nseg=td_bdy%i_nseg+1 ! add new segment td_bdy%t_seg(td_bdy%i_nseg)=seg__copy(td_seg) END SUBROUTINE boundary__add_seg !------------------------------------------------------------------- !> @brief This subroutine remove all segments of a boundary structure ! !> @details ! !> @author J.Paul !> @date November, 2013 - Initial Version ! !> @param[inout] td_bdy boundary structure !------------------------------------------------------------------- SUBROUTINE boundary__del_seg(td_bdy) IMPLICIT NONE ! Argument TYPE(TBDY), INTENT(INOUT) :: td_bdy ! local variable ! loop indices !---------------------------------------------------------------- IF( ASSOCIATED(td_bdy%t_seg) )THEN CALL seg__clean(td_bdy%t_seg(:)) DEALLOCATE(td_bdy%t_seg) ENDIF !update number of segment td_bdy%i_nseg=0 END SUBROUTINE boundary__del_seg !------------------------------------------------------------------- !> @brief This function get information about boundary from string character. ! !> @details !> This string character that will be passed through namelist could contains !> orthogonal index, first and last indices, of each segment. !> And also the width of all segments of this boundary. !> cn_north='index1,first1,last1(width)|index2,first2,last2' !> !> @author J.Paul !> @date November, 2013 - Initial Version ! !> @param[in] cd_card boundary description !> @return boundary structure !------------------------------------------------------------------- FUNCTION boundary__get_info(cd_card) IMPLICIT NONE ! Argument CHARACTER(LEN=lc), INTENT(IN) :: cd_card ! function TYPE(TBDY) :: boundary__get_info ! local variable INTEGER(i4) :: il_width INTEGER(i4) :: il_ind1 INTEGER(i4) :: il_ind2 CHARACTER(LEN=lc) :: cl_seg CHARACTER(LEN=lc) :: cl_index CHARACTER(LEN=lc) :: cl_width CHARACTER(LEN=lc) :: cl_first CHARACTER(LEN=lc) :: cl_last TYPE(TSEG) :: tl_seg ! loop indices INTEGER(i4) :: ji !---------------------------------------------------------------- ji=1 cl_seg=fct_split(cd_card,ji) il_width=0 ! look for segment width ! width should be the same for all segment of one boundary IF( TRIM(cl_seg) /= '' )THEN il_ind1=SCAN(fct_lower(cl_seg),'(') IF( il_ind1 /=0 )THEN cl_width=TRIM(cl_seg(il_ind1+1:)) il_ind2=SCAN(fct_lower(cl_width),')') IF( il_ind2 /=0 )THEN cl_width=TRIM(cl_width(1:il_ind2-1)) READ(cl_width,*) il_width ELSE CALL logger_error("BOUNDARY INIT: unclosed parentheses."//& & " check namelist. ") ENDIF ENDIF ENDIF DO WHILE( TRIM(cl_seg) /= '' ) cl_index=fct_split(cl_seg,1,',') ! remove potential width information il_ind1=SCAN(fct_lower(cl_index),'(') IF( il_ind1 /=0 )THEN il_ind2=SCAN(fct_lower(cl_index),'(') IF( il_ind2 /=0 )THEN cl_index=TRIM(cl_index(:il_ind1-1))//TRIM(cl_index(il_ind2+1:)) ELSE CALL logger_error("BOUNDARY INIT: unclosed parentheses."//& & " check namelist. ") ENDIF ENDIF cl_first=fct_split(cl_seg,2,',') ! remove potential width information il_ind1=SCAN(fct_lower(cl_first),'(') IF( il_ind1 /=0 )THEN il_ind2=SCAN(fct_lower(cl_first),'(') IF( il_ind2 /=0 )THEN cl_first=TRIM(cl_first(:il_ind1-1))//TRIM(cl_first(il_ind2+1:)) ELSE CALL logger_error("BOUNDARY INIT: unclosed parentheses."//& & " check namelist. ") ENDIF ENDIF cl_last =fct_split(cl_seg,3,',') ! remove potential width information il_ind1=SCAN(fct_lower(cl_last),'(') IF( il_ind1 /=0 )THEN il_ind2=SCAN(fct_lower(cl_last),'(') IF( il_ind2 /=0 )THEN cl_last=TRIM(cl_last(:il_ind1-1))//TRIM(cl_last(il_ind2+1:)) ELSE CALL logger_error("BOUNDARY INIT: unclosed parentheses."//& & " check namelist. ") ENDIF ENDIF IF( il_width /= 0 ) tl_seg%i_width=il_width IF( TRIM(cl_index) /= '' ) READ(cl_index,*) tl_seg%i_index IF( TRIM(cl_first) /= '' ) READ(cl_first,*) tl_seg%i_first IF( TRIM(cl_last) /= '' ) READ(cl_last ,*) tl_seg%i_last IF( (tl_seg%i_first == 0 .AND. tl_seg%i_last == 0) .OR. & & (tl_seg%i_first /= 0 .AND. tl_seg%i_last /= 0) )THEN CALL boundary__add_seg(boundary__get_info, tl_seg) ELSE CALL logger_error("BOUNDARY INIT: first or last segment indices "//& & "are missing . check namelist.") ENDIF ji=ji+1 cl_seg=fct_split(cd_card,ji) ! clean CALL seg__clean(tl_seg) ENDDO END FUNCTION boundary__get_info !------------------------------------------------------------------- !> @brief This subroutine get indices of each semgent for each boundary. ! !> @details !> indices are compute from variable value, actually variable fill value, !> which is assume to be land mask. !> Boundary structure should have been initialized before running !> this subroutine. Segment indices will be search between first and last !> indies, at this orthogonal index. !> !> Optionnally you could forced to use only one segment for each boundary. !> !> @warning number of segment (i_nseg) will be change, before the number !> of segment structure ! !> @author J.Paul !> @date November, 2013 - Initial Version ! !> @param[inout] td_bdy boundary structure !> @param[in] td_var variable structure !> @param[in] ld_onseg use only one sgment for each boundary !------------------------------------------------------------------- SUBROUTINE boundary_get_indices( td_bdy, td_var, ld_oneseg) IMPLICIT NONE ! Argument TYPE(TBDY) , DIMENSION(ip_ncard), INTENT(INOUT) :: td_bdy TYPE(TVAR) , INTENT(IN ) :: td_var LOGICAL , INTENT(IN ), OPTIONAL :: ld_oneseg ! local variable INTEGER(i4) :: il_index INTEGER(i4) :: il_width INTEGER(i4) :: il_first INTEGER(i4) :: il_last LOGICAL :: ll_oneseg TYPE(TSEG) :: tl_seg ! loop indices INTEGER(i4) :: jk !---------------------------------------------------------------- ll_oneseg=.TRUE. IF( PRESENT(ld_oneseg) ) ll_oneseg=ld_oneseg DO jk=1,ip_ncard IF( .NOT. td_bdy(jk)%l_use .OR. td_bdy(jk)%i_nseg > 1 )THEN ! nothing to be done ELSE IF( .NOT. ASSOCIATED(td_bdy(jk)%t_seg) )THEN CALL logger_error("BOUNDARY GET INDICES: no segment "//& & " associated to "//TRIM(td_bdy(jk)%c_card)//& & " boundary. you should have run boundary_init before"//& & " running boundary_get_indices" ) ELSE il_index=td_bdy(jk)%t_seg(1)%i_index il_width=td_bdy(jk)%t_seg(1)%i_width il_first=td_bdy(jk)%t_seg(1)%i_first il_last =td_bdy(jk)%t_seg(1)%i_last CALL boundary__get_seg_number( td_bdy(jk), td_var) CALL boundary__get_seg_indices( td_bdy(jk), td_var, & & il_index, il_width, & & il_first, il_last ) IF( ll_oneseg .AND. td_bdy(jk)%l_use )THEN tl_seg=seg__copy(td_bdy(jk)%t_seg(1)) ! use last indice of last segment tl_seg%i_last=td_bdy(jk)%t_seg(td_bdy(jk)%i_nseg)%i_last ! remove all segment from boundary CALL boundary__del_seg(td_bdy(jk)) ! add one segment CALL boundary__add_seg(td_bdy(jk),tl_seg) ! clean CALL seg__clean(tl_seg) ENDIF ENDIF ENDIF ENDDO END SUBROUTINE boundary_get_indices !------------------------------------------------------------------- !> @brief This subroutine compute the number of sea segment. ! !> @details !> It use variable value, actually variable fill value !> (which is assume to be land mask), to compute the number of segment between !> first and last indices at boundary orthogonal index. !> @warning number of segment (i_nseg) will be change, before the number !> of segment structure ! !> @author J.Paul !> @date November, 2013 - Initial Version ! !> @param[inout] td_bdy boundary structure !> @param[in] td_var variable structure !------------------------------------------------------------------- SUBROUTINE boundary__get_seg_number( td_bdy, td_var) IMPLICIT NONE ! Argument TYPE(TBDY) , INTENT(INOUT) :: td_bdy TYPE(TVAR) , INTENT(IN ) :: td_var ! local variable REAL(dp) , DIMENSION(:) , ALLOCATABLE :: dl_value LOGICAL :: ll_sea INTEGER(i4) :: il_index ! loop indices INTEGER(i4) :: ji !---------------------------------------------------------------- IF( td_bdy%l_use .AND. td_bdy%i_nseg == 1 )THEN il_index=td_bdy%t_seg(1)%i_index SELECT CASE(TRIM(td_bdy%c_card)) CASE('north','south') ALLOCATE( dl_value(td_var%t_dim(1)%i_len) ) dl_value(:)=td_var%d_value(:,il_index,1,1) IF( ANY(dl_value(:) /= td_var%d_fill) )THEN td_bdy%l_use=.TRUE. td_bdy%i_nseg=0 ll_sea=.FALSE. DO ji=1,td_var%t_dim(1)%i_len IF( dl_value(ji)/= td_var%d_fill )THEN IF( .NOT. ll_sea )THEN td_bdy%i_nseg=td_bdy%i_nseg+1 ENDIF ll_sea=.TRUE. ELSE ll_sea=.FALSE. ENDIF ENDDO ELSE td_bdy%l_use=.FALSE. td_bdy%i_nseg=0 ENDIF DEALLOCATE( dl_value ) CASE('east','west') ALLOCATE( dl_value(td_var%t_dim(2)%i_len) ) dl_value(:)=td_var%d_value(il_index,:,1,1) IF( ANY(dl_value(:) /= td_var%d_fill) )THEN td_bdy%l_use=.TRUE. td_bdy%i_nseg=0 ll_sea=.FALSE. DO ji=1,td_var%t_dim(2)%i_len IF( dl_value(ji)/= td_var%d_fill )THEN IF( .NOT. ll_sea )THEN td_bdy%i_nseg=td_bdy%i_nseg+1 ENDIF ll_sea=.TRUE. ELSE ll_sea=.FALSE. ENDIF ENDDO ELSE td_bdy%l_use=.FALSE. td_bdy%i_nseg=0 ENDIF DEALLOCATE( dl_value ) END SELECT ENDIF END SUBROUTINE boundary__get_seg_number !------------------------------------------------------------------- !> @brief This subroutine get segment indices for one boundary. ! !> @details ! !> @author J.Paul !> @date November, 2013 - Initial Version ! !> @param[inout] td_bdy boundary structure !> @param[in] td_var variable structure !> @param[in] id_index boundary orthogonal index !> @param[in] id_width bounary width !> @param[in] id_first boundary first indice !> @param[in] id_last boundary last indice !------------------------------------------------------------------- SUBROUTINE boundary__get_seg_indices( td_bdy, td_var, & & id_index, id_width, id_first, id_last) IMPLICIT NONE ! Argument TYPE(TBDY) , INTENT(INOUT) :: td_bdy TYPE(TVAR) , INTENT(IN ) :: td_var INTEGER(i4), INTENT(IN ) :: id_index INTEGER(i4), INTENT(IN ) :: id_width INTEGER(i4), INTENT(IN ) :: id_first INTEGER(i4), INTENT(IN ) :: id_last ! local variable INTEGER(i4) :: il_nseg INTEGER(i4), DIMENSION(ip_ncard) :: il_max INTEGER(i4), DIMENSION(ip_ncard) :: il_min REAL(dp) , DIMENSION(:) , ALLOCATABLE :: dl_value LOGICAL :: ll_sea LOGICAL :: ll_first LOGICAL :: ll_last TYPE(TSEG) :: tl_seg ! loop indices INTEGER(i4) :: ji INTEGER(i4) :: jk INTEGER(i4) :: jl !---------------------------------------------------------------- SELECT CASE(TRIM(td_bdy%c_card)) CASE('north') jk=jp_north ALLOCATE( dl_value(td_var%t_dim(1)%i_len) ) dl_value(:)=td_var%d_value(:,id_index,1,1) CASE('south') jk=jp_south ALLOCATE( dl_value(td_var%t_dim(1)%i_len) ) dl_value(:)=td_var%d_value(:,id_index,1,1) CASE('east ') jk=jp_east ALLOCATE( dl_value(td_var%t_dim(2)%i_len) ) dl_value(:)=td_var%d_value(id_index,:,1,1) CASE('west ') jk=jp_west ALLOCATE( dl_value(td_var%t_dim(2)%i_len) ) dl_value(:)=td_var%d_value(id_index,:,1,1) END SELECT il_max(jp_north)=td_var%t_dim(1)%i_len-ip_ghost il_max(jp_south)=td_var%t_dim(1)%i_len-ip_ghost il_max(jp_east )=td_var%t_dim(2)%i_len-ip_ghost il_max(jp_west )=td_var%t_dim(2)%i_len-ip_ghost il_min(jp_north)=1+ip_ghost il_min(jp_south)=1+ip_ghost il_min(jp_east )=1+ip_ghost il_min(jp_west )=1+ip_ghost ! special case for EW cyclic IF( td_var%i_ew >= 0 )THEN il_min(jp_north)=1 il_min(jp_south)=1 il_max(jp_north)=td_var%t_dim(1)%i_len il_max(jp_south)=td_var%t_dim(1)%i_len ENDIF il_nseg=td_bdy%i_nseg ! remove all segment from boundary CALL boundary__del_seg(td_bdy) ll_first=.FALSE. ll_last =.FALSE. DO jl=1,il_nseg ! init tl_seg=seg__init(id_index,id_width,id_first,id_last) IF( .NOT. (ll_first .AND. ll_last) )THEN ! first loop tl_seg%i_first=MAX(id_first,il_min(jk)) tl_seg%i_last =MIN(id_last ,il_max(jk)) ELSE ! load new min and max tl_seg%i_first=MAX(td_bdy%t_seg(jl-1)%i_last,il_min(jk)) tl_seg%i_last =MIN(id_last ,il_max(jk)) ENDIF ll_first=.FALSE. ll_last =.FALSE. ll_sea =.FALSE. DO ji=tl_seg%i_first,tl_seg%i_last IF( ll_first .AND. ll_last )THEN ! first and last point already loaded ! look for next segment EXIT ENDIF IF( dl_value(ji)/= td_var%d_fill )THEN IF( .NOT. ll_sea )THEN tl_seg%i_first=MAX(tl_seg%i_first,ji-1) ll_first=.true. ENDIF ll_sea=.TRUE. ELSE IF( ll_sea )THEN tl_seg%i_last=ji ll_last=.TRUE. ENDIF ll_sea=.FALSE. ENDIF ENDDO CALL boundary__add_seg(td_bdy,tl_seg) ! clean CALL seg__clean(tl_seg) ENDDO DEALLOCATE(dl_value) END SUBROUTINE boundary__get_seg_indices !------------------------------------------------------------------- !> @brief This subroutine check if there is boundary at corner, and !> adjust boundary indices if necessary. ! !> @details !> If there is a north west corner, first indices of north boundary !> should be the same as the west boundary indices. !> And the last indices of the west boundary should be the same as !> the north indices. !> More over the width of west and north boundary should be the same. ! !> @author J.Paul !> @date November, 2013 - Initial Version ! !> @param[inout] td_bdy boundary structure !> @param[in] td_var variable structure !------------------------------------------------------------------- SUBROUTINE boundary_check_corner( td_bdy, td_var ) IMPLICIT NONE ! Argument TYPE(TBDY) , DIMENSION(ip_ncard), INTENT(INOUT) :: td_bdy TYPE(TVAR) , INTENT(IN ) :: td_var ! local variable TYPE(TSEG) :: tl_north TYPE(TSEG) :: tl_south TYPE(TSEG) :: tl_east TYPE(TSEG) :: tl_west INTEGER(i4) :: il_width ! loop indices !---------------------------------------------------------------- IF( .NOT. ASSOCIATED(td_var%d_value) )THEN CALL logger_error("BOUNDARY CHEKC CORNER: no value associated "//& & "to variable "//TRIM(td_var%c_name)) ENDIF ! check north west corner IF( td_bdy(jp_north)%l_use .AND. td_bdy(jp_west)%l_use )THEN tl_west =seg__copy(td_bdy(jp_west )%t_seg(td_bdy(jp_west)%i_nseg)) tl_north=seg__copy(td_bdy(jp_north)%t_seg(1)) IF( tl_west%i_last >= tl_north%i_index .AND. & & tl_west%i_index >= tl_north%i_first ) THEN CALL logger_debug("BOUNDARY CHEKC CORNER: there is "//& & "a north west corner") tl_west%i_last = tl_north%i_index tl_north%i_first = tl_west%i_index IF( tl_west%i_width /= tl_north%i_width )THEN CALL logger_error("BOUNDARY CHEKC CORNER: discordant "//& & " width between north and west boundary ") il_width=MIN(tl_west%i_width,tl_north%i_width) tl_west%i_width =il_width tl_north%i_width=il_width ENDIF td_bdy(jp_west )%t_seg(td_bdy(jp_west)%i_nseg)=seg__copy(tl_west) td_bdy(jp_north)%t_seg(1) =seg__copy(tl_north) ELSE IF( td_var%d_value(tl_north%i_first,tl_north%i_index,1,1) /= & & td_var%d_fill )THEN CALL logger_error("BOUNDARY CHEKC CORNER: wrong "//& & "north boundary first indice ") ENDIF IF( td_var%d_value(tl_west%i_index,tl_west%i_last,1,1) /= & & td_var%d_fill )THEN CALL logger_error("BOUNDARY CHEKC CORNER: wrong "//& & "west boundary last indice") ENDIF ENDIF ENDIF ! check north east corner IF( td_bdy(jp_north)%l_use .AND. td_bdy(jp_east)%l_use )THEN tl_east =seg__copy(td_bdy(jp_east )%t_seg(td_bdy(jp_east )%i_nseg)) tl_north=seg__copy(td_bdy(jp_north)%t_seg(td_bdy(jp_north)%i_nseg)) IF( tl_east%i_last >= tl_north%i_index .AND. & & tl_east%i_index <= tl_north%i_last ) THEN CALL logger_debug("BOUNDARY CHEKC CORNER: there is "//& & "a north east corner") tl_east%i_last = tl_north%i_index tl_north%i_last = tl_east%i_index IF( tl_east%i_width /= tl_north%i_width )THEN CALL logger_error("BOUNDARY CHEKC CORNER: discordant "//& & " width between north and east boundary ") il_width=MIN(tl_east%i_width,tl_north%i_width) tl_east%i_width =il_width tl_north%i_width=il_width ENDIF td_bdy(jp_east )%t_seg(td_bdy(jp_east )%i_nseg)=seg__copy(tl_east) td_bdy(jp_north)%t_seg(td_bdy(jp_north)%i_nseg)=seg__copy(tl_north) ELSE IF( td_var%d_value(tl_north%i_last,tl_north%i_index,1,1) /= & & td_var%d_fill )THEN CALL logger_error("BOUNDARY CHEKC CORNER: wrong "//& & "north boundary last indice ") ENDIF IF( td_var%d_value(tl_east%i_index,tl_east%i_last,1,1) /= & & td_var%d_fill )THEN CALL logger_error("BOUNDARY CHEKC CORNER: wrong "//& & "east boundary last indice") ENDIF ENDIF ENDIF ! check south east corner IF( td_bdy(jp_south)%l_use .AND. td_bdy(jp_east)%l_use )THEN tl_east =seg__copy(td_bdy(jp_east )%t_seg(1)) tl_south=seg__copy(td_bdy(jp_south)%t_seg(td_bdy(jp_south)%i_nseg)) IF( tl_east%i_first <= tl_south%i_index .AND. & & tl_east%i_index <= tl_south%i_last ) THEN CALL logger_debug("BOUNDARY CHEKC CORNER: there is "//& & "a south east corner") tl_east%i_first = tl_south%i_index tl_south%i_last = tl_east%i_index IF( tl_east%i_width /= tl_south%i_width )THEN CALL logger_error("BOUNDARY CHEKC CORNER: discordant "//& & " width between south and east boundary ") il_width=MIN(tl_east%i_width,tl_south%i_width) tl_east%i_width =il_width tl_south%i_width=il_width ENDIF td_bdy(jp_east )%t_seg(1) =seg__copy(tl_east) td_bdy(jp_south)%t_seg(td_bdy(jp_south)%i_nseg)=seg__copy(tl_south) ELSE IF( td_var%d_value(tl_south%i_last,tl_south%i_index,1,1) /= & & td_var%d_fill )THEN CALL logger_error("BOUNDARY CHEKC CORNER: wrong "//& & "south boundary last indice ") ENDIF IF( td_var%d_value(tl_east%i_index,tl_east%i_first,1,1) /= & & td_var%d_fill )THEN CALL logger_error("BOUNDARY CHEKC CORNER: wrong "//& & "east boundary first indice") ENDIF ENDIF ENDIF ! check south west corner IF( td_bdy(jp_south)%l_use .AND. td_bdy(jp_west)%l_use )THEN tl_west =seg__copy(td_bdy(jp_west )%t_seg(1)) tl_south=seg__copy(td_bdy(jp_south)%t_seg(1)) IF( tl_west%i_first <= tl_south%i_index .AND. & & tl_west%i_index >= tl_south%i_first ) THEN CALL logger_debug("BOUNDARY CHEKC CORNER: there is "//& & "a south west corner") tl_west%i_first = tl_south%i_index tl_south%i_first= tl_west%i_index IF( tl_west%i_width /= tl_south%i_width )THEN CALL logger_error("BOUNDARY CHEKC CORNER: discordant "//& & " width between south and west boundary ") il_width=MIN(tl_west%i_width,tl_south%i_width) tl_west%i_width =il_width tl_south%i_width=il_width ENDIF td_bdy(jp_west )%t_seg(1) = seg__copy(tl_west) td_bdy(jp_south)%t_seg(1) = seg__copy(tl_south) ELSE IF( td_var%d_value(tl_south%i_first,tl_south%i_index,1,1) /= & & td_var%d_fill )THEN CALL logger_error("BOUNDARY CHEKC CORNER: wrong "//& & "south boundary first indice ") ENDIF IF( td_var%d_value(tl_west%i_index,tl_west%i_first,1,1) /= & & td_var%d_fill )THEN CALL logger_error("BOUNDARY CHEKC CORNER: wrong "//& & "west boundary first indice") ENDIF ENDIF ENDIF ! clean CALL seg__clean(tl_north) CALL seg__clean(tl_south) CALL seg__clean(tl_east ) CALL seg__clean(tl_west ) END SUBROUTINE boundary_check_corner !------------------------------------------------------------------- !> @brief This subroutine check boundary. ! !> @details !> It checks that first and last indices as well as orthogonal index are !> inside domain, and check corner (see boundary_check_corner). ! !> @author J.Paul !> @date November, 2013 - Initial Version ! !> @param[inout] td_bdy boundary structure !> @param[in] td_var variable structure !------------------------------------------------------------------- SUBROUTINE boundary_check(td_bdy, td_var) IMPLICIT NONE ! Argument TYPE(TBDY) , DIMENSION(ip_ncard), INTENT(INOUT) :: td_bdy TYPE(TVAR) , INTENT(IN ) :: td_var ! local variable INTEGER(i4) , DIMENSION(ip_ncard) :: il_max INTEGER(i4) , DIMENSION(ip_ncard) :: il_maxindex ! loop indices INTEGER(i4) :: jk !---------------------------------------------------------------- il_max(jp_north)=td_var%t_dim(1)%i_len il_max(jp_south)=td_var%t_dim(1)%i_len il_max(jp_east )=td_var%t_dim(2)%i_len il_max(jp_west )=td_var%t_dim(2)%i_len il_maxindex(jp_north)=td_var%t_dim(2)%i_len-ip_ghost il_maxindex(jp_south)=td_var%t_dim(2)%i_len-ip_ghost il_maxindex(jp_east )=td_var%t_dim(1)%i_len-ip_ghost il_maxindex(jp_west )=td_var%t_dim(1)%i_len-ip_ghost DO jk=1,ip_ncard IF( td_bdy(jk)%l_use )THEN IF( .NOT. ASSOCIATED(td_bdy(jk)%t_seg) )THEN CALL logger_error("BOUNDARY CHECK: no segment associted "//& & "to "//TRIM(td_bdy(jk)%c_card)//" boundary") ELSE ! check indices IF( ANY(td_bdy(jk)%t_seg(:)%i_first < 1 ) .OR. & & ANY(td_bdy(jk)%t_seg(:)%i_first > il_max(jk)) .OR. & & ANY(td_bdy(jk)%t_seg(:)%i_last < 1 ) .OR. & & ANY(td_bdy(jk)%t_seg(:)%i_last > il_max(jk)) .OR. & & ANY(td_bdy(jk)%t_seg(:)%i_first > td_bdy(jk)%t_seg(:)%i_last)& & )THEN CALL logger_error("BOUNDARY CHECK: invalid segment "//& & "first and/or last indice for "//& & TRIM(td_bdy(jk)%c_card)//& & " boundary. check namelist") ENDIF IF( ANY(td_bdy(jk)%t_seg(:)%i_index < 1 ) .OR. & & ANY(td_bdy(jk)%t_seg(:)%i_index > il_maxindex(jk)) & & )THEN CALL logger_error("BOUNDARY CHECK: invalid index "//& & "for "//TRIM(td_bdy(jk)%c_card)//& & " boundary. check namelist") ENDIF ENDIF ENDIF ENDDO CALL boundary_check_corner(td_bdy, td_var) END SUBROUTINE boundary_check !------------------------------------------------------------------- !> @brief This subroutine swap array for east and north boundary. ! !> @detail !> !> @author J.Paul !> @date November, 2013 - Initial Version ! !> @param[inout] td_var variable strucutre !> @param[in ] td_bdy boundary strucutre !------------------------------------------------------------------- SUBROUTINE boundary_swap( td_var, td_bdy ) IMPLICIT NONE ! Argument TYPE(TVAR), INTENT(INOUT) :: td_var TYPE(TBDY), INTENT(IN ) :: td_bdy ! local variable REAL(dp), DIMENSION(:,:,:,:), ALLOCATABLE :: dl_value ! loop indices INTEGER(i4) :: ji INTEGER(i4) :: jj !---------------------------------------------------------------- IF( .NOT. ASSOCIATED(td_var%d_value) )THEN CALL logger_error("BOUNDARY SWAP: no array of value "//& & "associted to variable "//TRIM(td_var%c_name) ) ELSE SELECT CASE(TRIM(td_bdy%c_card)) CASE('north') ALLOCATE( dl_value(td_var%t_dim(1)%i_len, & & td_var%t_dim(2)%i_len, & & td_var%t_dim(3)%i_len, & & td_var%t_dim(4)%i_len) ) dl_value(:,:,:,:)=td_var%d_value(:,:,:,:) DO jj=1, td_var%t_dim(2)%i_len td_var%d_value(:,jj,:,:) = & & dl_value(:,td_var%t_dim(2)%i_len-jj+1,:,:) ENDDO DEALLOCATE( dl_value ) CASE('east') ALLOCATE( dl_value(td_var%t_dim(1)%i_len, & & td_var%t_dim(2)%i_len, & & td_var%t_dim(3)%i_len, & & td_var%t_dim(4)%i_len) ) dl_value(:,:,:,:)=td_var%d_value(:,:,:,:) DO ji=1, td_var%t_dim(1)%i_len td_var%d_value(ji,:,:,:) = & & dl_value(td_var%t_dim(1)%i_len-ji+1,:,:,:) ENDDO DEALLOCATE( dl_value ) CASE DEFAULT ! nothing to be done END SELECT ENDIF END SUBROUTINE boundary_swap !------------------------------------------------------------------- !> @brief This subroutine print information about one boundary. ! !> @author J.Paul !> @date November, 2013 - Initial Version ! !> @param[in] td_bdy boundary structure !------------------------------------------------------------------- SUBROUTINE boundary__print_unit( td_bdy ) IMPLICIT NONE ! Argument TYPE(TBDY), INTENT(IN) :: td_bdy ! local variable ! loop indices INTEGER(i4) :: ji !---------------------------------------------------------------- WRITE(*,'(a,/1x,a,/1x,a)') "Boundary "//TRIM(td_bdy%c_card), & & " use "//TRIM(fct_str(td_bdy%l_use)), & & " nseg "//TRIM(fct_str(td_bdy%i_nseg)) DO ji=1,td_bdy%i_nseg WRITE(*,'(4(/1x,a))') & & " index "//TRIM(fct_str(td_bdy%t_seg(ji)%i_index)), & & " width "//TRIM(fct_str(td_bdy%t_seg(ji)%i_width)), & & " first "//TRIM(fct_str(td_bdy%t_seg(ji)%i_first)), & & " last "//TRIM(fct_str(td_bdy%t_seg(ji)%i_last)) ENDDO END SUBROUTINE boundary__print_unit !------------------------------------------------------------------- !> @brief This subroutine print information about a array of boundary ! !> @details ! !> @author J.Paul !> @date November, 2013 - Initial Version ! !> @param[in] td_bdy boundary structure !------------------------------------------------------------------- SUBROUTINE boundary__print_arr( td_bdy ) IMPLICIT NONE ! Argument TYPE(TBDY), DIMENSION(:), INTENT(IN) :: td_bdy ! local variable ! loop indices INTEGER(i4) :: ji !---------------------------------------------------------------- DO ji=1,SIZE(td_bdy(:)) CALL boundary_print(td_bdy(ji)) ENDDO END SUBROUTINE boundary__print_arr !------------------------------------------------------------------- !> @brief !> This subroutine copy segment structure in another one. !> !> @warning do not use on the output of a function who create or read a !> structure (ex: tl_seg=seg__copy(seg__init()) is forbidden). !> This will create memory leaks. !> @warning to avoid infinite loop, do not use any function inside !> this subroutine !> !> @author J.Paul !> @date November, 2013 - Initial Version !> @date November, 2014 !> - use function instead of overload assignment operator !> (to avoid memory leak) ! !> @param[in] td_seg segment structure !> @return copy of input segment structure !------------------------------------------------------------------- FUNCTION seg__copy_unit( td_seg ) IMPLICIT NONE ! Argument TYPE(TSEG), INTENT(IN) :: td_seg ! function TYPE(TSEG) :: seg__copy_unit ! local variable ! loop indices !---------------------------------------------------------------- ! copy segment index, width, .. seg__copy_unit%i_index = td_seg%i_index seg__copy_unit%i_width = td_seg%i_width seg__copy_unit%i_first = td_seg%i_first seg__copy_unit%i_last = td_seg%i_last END FUNCTION seg__copy_unit !------------------------------------------------------------------- !> @brief !> This subroutine copy segment structure in another one. !> !> @warning do not use on the output of a function who create or read a !> structure (ex: tl_seg=seg__copy(seg__init()) is forbidden). !> This will create memory leaks. !> @warning to avoid infinite loop, do not use any function inside !> this subroutine !> !> @author J.Paul !> @date November, 2013 - Initial Version !> @date November, 2014 !> - use function instead of overload assignment operator !> (to avoid memory leak) ! !> @param[in] td_seg segment structure !> @return copy of input array of segment structure !------------------------------------------------------------------- FUNCTION seg__copy_arr( td_seg ) IMPLICIT NONE ! Argument TYPE(TSEG), DIMENSION(:), INTENT(IN) :: td_seg ! function TYPE(TSEG), DIMENSION(SIZE(td_seg(:))) :: seg__copy_arr ! local variable ! loop indices INTEGER(i4) :: ji !---------------------------------------------------------------- DO ji=1,SIZE(td_seg(:)) seg__copy_arr(ji)=seg__copy(td_seg(ji)) ENDDO END FUNCTION seg__copy_arr !------------------------------------------------------------------- !> @brief This function initialise segment structure. ! !> @details !> It simply add orthogonal index, and optionnaly width, first !> and last indices of the segment. ! !> @author J.Paul !> @date November, 2013 - Initial Version ! !> @param[in] id_index orthogonal index !> @param[in] id_width width of the segment !> @param[in] id_first first indices !> @param[in] id_last last indices !> @return segment structure !------------------------------------------------------------------- FUNCTION seg__init( id_index, id_width, id_first, id_last ) IMPLICIT NONE ! Argument INTEGER(i4), INTENT(IN) :: id_index INTEGER(i4), INTENT(IN), OPTIONAL :: id_width INTEGER(i4), INTENT(IN), OPTIONAL :: id_first INTEGER(i4), INTENT(IN), OPTIONAL :: id_last ! function TYPE(TSEG) :: seg__init ! local variable ! loop indices !---------------------------------------------------------------- seg__init%i_index=id_index IF( PRESENT(id_width) ) seg__init%i_width=id_width IF( PRESENT(id_first) ) seg__init%i_first=id_first IF( PRESENT(id_last ) ) seg__init%i_last =id_last END FUNCTION seg__init !------------------------------------------------------------------- !> @brief This subroutine clean segment structure. ! !> @author J.Paul !> @date November, 2013 - Initial Version ! !> @param[inout] td_seg segment structure !------------------------------------------------------------------- SUBROUTINE seg__clean_unit(td_seg) IMPLICIT NONE ! Argument TYPE(TSEG), INTENT(INOUT) :: td_seg ! local variable TYPE(TSEG) :: tl_seg ! loop indices !---------------------------------------------------------------- td_seg=seg__copy(tl_seg) END SUBROUTINE seg__clean_unit !------------------------------------------------------------------- !> @brief This subroutine clean segment structure. ! !> @author J.Paul !> @date November, 2013 - Initial Version ! !> @param[inout] td_seg array of segment structure !------------------------------------------------------------------- SUBROUTINE seg__clean_arr(td_seg) IMPLICIT NONE ! Argument TYPE(TSEG), DIMENSION(:), INTENT(INOUT) :: td_seg ! local variable ! loop indices INTEGER(i4) :: ji !---------------------------------------------------------------- DO ji=SIZE(td_seg(:)),1,-1 CALL seg__clean(td_seg(ji)) ENDDO END SUBROUTINE seg__clean_arr END MODULE boundary