!---------------------------------------------------------------------- ! NEMO system team, System and Interface for oceanic RElocable Nesting !---------------------------------------------------------------------- ! ! MODULE: boundary ! ! DESCRIPTION: !> @brief !> This module manage boundary. ! !> @details !> !> !> !> !> !> @author !> J.Paul ! REVISION HISTORY: !> @date Nov, 2013 - Initial Version !> @todo !> - add description generique de l'objet boundary !> !> @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 date ! date manager ! USE att ! attribute manager ! USE dim ! dimension manager USE var ! variable manager ! USE file ! file manager ! USE iom ! I/O manager ! USE dom ! domain manager ! USE grid ! grid manager ! USE extrap ! extrapolation manager ! USE interp ! interpolation manager ! USE filter ! filter manager ! USE mpp ! MPP manager ! USE iom_mpp ! MPP I/O manager IMPLICIT NONE PRIVATE ! NOTE_avoid_public_variables_if_possible ! type and variable PUBLIC :: ip_ncard !< number of cardinal point PUBLIC :: ip_card !< table of cardinal point PUBLIC :: TBDY !< boundary structure PUBLIC :: TSEG !< segment structure ! function and subroutine 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_clean_interp !< clean interpolated boundary PUBLIC :: boundary_swap !< swap array for north and east boundary PRIVATE :: boundary__init_wrapper !< initialise a boundary structure PRIVATE :: boundary__init !< initialise basically a boundary structure ! PRIVATE :: boundary__copy !< copy boundary structure in another PRIVATE :: boundary__copy_unit !< copy boundary structure in another PRIVATE :: boundary__copy_tab !< 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_tab !< print information about a table of boundary PRIVATE :: seg__init !< initialise segment structure PRIVATE :: seg__clean !< clean segment structure PRIVATE :: seg__copy !< copy segment structure in another !> @struct TYPE TSEG 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 !> @struct TYPE TBDY CHARACTER(LEN=lc) :: c_card = '' LOGICAL :: l_use = .FALSE. INTEGER(i4) :: i_nseg = 0 TYPE(TSEG), DIMENSION(:), POINTER :: t_seg => NULL() END TYPE TBDY INTEGER(i4), PARAMETER :: ip_ncard=4 CHARACTER(LEN=lc), DIMENSION(ip_ncard), PARAMETER :: ip_card = & & (/ 'north', & & 'south', & & 'east ', & & 'west ' /) INTEGER(i4), PARAMETER :: jp_north=1 INTEGER(i4), PARAMETER :: jp_south=2 INTEGER(i4), PARAMETER :: jp_east =3 INTEGER(i4), PARAMETER :: jp_west =4 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_tab END INTERFACE boundary_print INTERFACE ASSIGNMENT(=) MODULE PROCEDURE boundary__copy_unit MODULE PROCEDURE boundary__copy_tab MODULE PROCEDURE seg__copy ! copy segment structure END INTERFACE CONTAINS !------------------------------------------------------------------- !> @brief !> This subroutine copy boundary structure in another boundary !> structure !> @details !> !> @warning to avoid infinite loop, do not use any function inside !> this subroutine !> !> @author J.Paul !> - Nov, 2013- Initial Version ! !> @param[out] td_bdy1 : boundary structure !> @param[in] td_bdy2 : boundary structure !------------------------------------------------------------------- !> @code SUBROUTINE boundary__copy_tab( td_bdy1, td_bdy2 ) IMPLICIT NONE ! Argument TYPE(TBDY), DIMENSION(:), INTENT(OUT) :: td_bdy1 TYPE(TBDY), DIMENSION(:), INTENT(IN) :: td_bdy2 ! local variable ! loop indices INTEGER(i4) :: jk !---------------------------------------------------------------- IF( SIZE(td_bdy1(:)) /= SIZE(td_bdy2(:)) )THEN CALL logger_error("BOUNDARY COPY: dimension of table of boundary differ") ELSE DO jk=1,SIZE(td_bdy1(:)) td_bdy1(jk)=td_bdy2(jk) ENDDO ENDIF END SUBROUTINE boundary__copy_tab !> @endcode !------------------------------------------------------------------- !> @brief !> This subroutine copy boundary structure in another boundary !> structure !> @details !> !> @warning to avoid infinite loop, do not use any function inside !> this subroutine !> !> @author J.Paul !> - Nov, 2013- Initial Version ! !> @param[out] td_bdy1 : boundary structure !> @param[in] td_bdy2 : boundary structure !------------------------------------------------------------------- !> @code SUBROUTINE boundary__copy_unit( td_bdy1, td_bdy2 ) IMPLICIT NONE ! Argument TYPE(TBDY), INTENT(OUT) :: td_bdy1 TYPE(TBDY), INTENT(IN) :: td_bdy2 ! local variable ! loop indices INTEGER(i4) :: ji !---------------------------------------------------------------- ! copy variable name, id, .. td_bdy1%c_card = TRIM(td_bdy2%c_card) td_bdy1%i_nseg = td_bdy2%i_nseg td_bdy1%l_use = td_bdy2%l_use ! copy segment IF( ASSOCIATED(td_bdy1%t_seg) ) DEALLOCATE(td_bdy1%t_seg) IF( ASSOCIATED(td_bdy2%t_seg) .AND. td_bdy1%i_nseg > 0 )THEN ALLOCATE( td_bdy1%t_seg(td_bdy1%i_nseg) ) DO ji=1,td_bdy1%i_nseg td_bdy1%t_seg(ji)=td_bdy2%t_seg(ji) ENDDO ENDIF END SUBROUTINE boundary__copy_unit !> @endcode !------------------------------------------------------------------- !> @brief This subroutine clean boundary structure ! !> @author J.Paul !> - Nov, 2013- Initial Version ! !> @param[inout] td_bdy : boundary strucutre !------------------------------------------------------------------- !> @code SUBROUTINE boundary_clean( td_bdy ) IMPLICIT NONE ! Argument TYPE(TBDY), INTENT(INOUT) :: td_bdy ! local variable TYPE(TBDY) :: tl_bdy ! empty boundary strucutre ! loop indices INTEGER(i4) :: ji !---------------------------------------------------------------- CALL logger_info( & & " CLEAN: reset boundary "//TRIM(td_bdy%c_card) ) ! del segment IF( ASSOCIATED(td_bdy%t_seg) )THEN ! clean each attribute DO ji=td_bdy%i_nseg,1,-1 CALL seg__clean(td_bdy%t_seg(ji) ) ENDDO DEALLOCATE( td_bdy%t_seg ) ENDIF ! replace by empty structure td_bdy=tl_bdy END SUBROUTINE boundary_clean !> @endcode !------------------------------------------------------------------- !> @brief This function put cardinal name inside file name ! !> @details ! !> @author J.Paul !> - Nov, 2013- Initial Version ! !> @param[in] cd_file : file name !> @param[in] cd_card : cardinal name !> @return file name with cardinal name inside !------------------------------------------------------------------- !> @code FUNCTION boundary_set_filename(cd_file, cd_card) IMPLICIT NONE ! Argument CHARACTER(LEN=*), INTENT(IN) :: cd_file CHARACTER(LEN=*), INTENT(IN) :: cd_card ! 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_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,'.') cl_name=TRIM(cl_base)//"_"//TRIM(cd_card)//"."//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 !> @endcode !------------------------------------------------------------------- !> @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' ! !> @author J.Paul !> - Nov, 2013- Initial Version ! !> @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 !> @return boundary structure !> @todo use bondary_get_indices !!!! !------------------------------------------------------------------- !> @code 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) , 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 IF( td_var%i_ew >= 0 )THEN CALL logger_debug("BOUNDARY INIT: cyclic no East West boundary") tl_bdy(jp_east )%l_use=.FALSE. tl_bdy(jp_west )%l_use=.FALSE. ENDIF ! attention cas U /= T ??? il_index(jp_north)=td_var%t_dim(2)%i_len-ig_ghost il_index(jp_south)=1+ig_ghost il_index(jp_east )=td_var%t_dim(1)%i_len-ig_ghost il_index(jp_west )=1+ig_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 ) DO jk=1,ip_ncard ! define default segment tl_seg=seg__init(il_index(jk),im_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 ENDDO CALL boundary_get_indices(tl_bdy(:), td_var, ll_oneseg) CALL boundary_check(tl_bdy, td_var) boundary__init_wrapper(:)=tl_bdy(:) ! clean DO jk=1,ip_ncard CALL boundary_clean(tl_bdy(jk)) ENDDO ENDIF END FUNCTION boundary__init_wrapper !> @endcode !------------------------------------------------------------------- !> @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 !> - Nov, 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 !------------------------------------------------------------------- !> @code 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 !> @endcode !------------------------------------------------------------------- !> @brief This subroutine add one segment structure to a boundary structure ! !> @details ! !> @author J.Paul !> - Nov, 2013- Initial Version ! !> @param[inout] td_bdy : boundary structure !> @param[in] td_seg : segment structure !------------------------------------------------------------------- !> @code 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(:)=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)=tl_seg(:) DEALLOCATE(tl_seg) ENDIF ELSE ! no segment in boundary structure IF( ASSOCIATED(td_bdy%t_seg) )THEN 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)=td_seg END SUBROUTINE boundary__add_seg !> @endcode !------------------------------------------------------------------- !> @brief This subroutine remove all segments of a boundary structure ! !> @details ! !> @author J.Paul !> - Nov, 2013- Initial Version ! !> @param[inout] td_bdy : boundary structure !------------------------------------------------------------------- !> @code 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 DEALLOCATE(td_bdy%t_seg) ENDIF !update number of segment td_bdy%i_nseg=0 END SUBROUTINE boundary__del_seg !> @endcode !------------------------------------------------------------------- !> @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 !> - Nov, 2013- Initial Version ! !> @param[in] cd_card : boundary description !> @return boundary structure !------------------------------------------------------------------- !> @code 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) ENDDO END FUNCTION boundary__get_info !> @endcode !------------------------------------------------------------------- !> @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 !> - Nov, 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 !------------------------------------------------------------------- !> @code 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=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) ENDIF ENDIF ENDIF ENDDO END SUBROUTINE boundary_get_indices !> @endcode !------------------------------------------------------------------- !> @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 !> - Nov, 2013- Initial Version ! !> @param[inout] td_bdy : boundary structure !> @param[in] td_var : variable structure !------------------------------------------------------------------- !> @code 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 !> @endcode !------------------------------------------------------------------- !> @brief This subroutine get segment indices for one boundary. ! !> @details ! !> @author J.Paul !> - Nov, 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 !------------------------------------------------------------------- !> @code 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-ig_ghost il_max(jp_south)=td_var%t_dim(1)%i_len-ig_ghost il_max(jp_east )=td_var%t_dim(2)%i_len-ig_ghost il_max(jp_west )=td_var%t_dim(2)%i_len-ig_ghost il_min(jp_north)=1+ig_ghost il_min(jp_south)=1+ig_ghost il_min(jp_east )=1+ig_ghost il_min(jp_west )=1+ig_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) CALL seg__clean(tl_seg) ENDDO DEALLOCATE(dl_value) END SUBROUTINE boundary__get_seg_indices !> @endcode !------------------------------------------------------------------- !> @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 !> - Nov, 2013- Initial Version ! !> @param[inout] td_bdy : boundary structure !> @param[in] td_var : variable structure !> !> @todo add schematic to description !------------------------------------------------------------------- !> @code 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 =td_bdy(jp_west )%t_seg(td_bdy(jp_west)%i_nseg) tl_north=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)=tl_west td_bdy(jp_north)%t_seg(1) =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 =td_bdy(jp_east )%t_seg(td_bdy(jp_east )%i_nseg) tl_north=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)=tl_east td_bdy(jp_north)%t_seg(td_bdy(jp_north)%i_nseg)=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 =td_bdy(jp_east )%t_seg(1) tl_south=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) =tl_east td_bdy(jp_south)%t_seg(td_bdy(jp_south)%i_nseg)=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 =td_bdy(jp_west )%t_seg(1) tl_south=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) = tl_west td_bdy(jp_south)%t_seg(1) = 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 END SUBROUTINE boundary_check_corner !> @endcode !------------------------------------------------------------------- !> @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 !> - Nov, 2013- Initial Version ! !> @param[inout] td_bdy : boundary structure !> @param[in] td_var : variable structure !------------------------------------------------------------------- !> @code 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-ig_ghost il_maxindex(jp_south)=td_var%t_dim(2)%i_len-ig_ghost il_maxindex(jp_east )=td_var%t_dim(1)%i_len-ig_ghost il_maxindex(jp_west )=td_var%t_dim(1)%i_len-ig_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 !> @endcode !------------------------------------------------------------------- !> @brief This subroutine clean interpolated boundary in variable structure. ! !> @detail !> interpolation could create more point than needed for boundary (depending !> on refinement factor). This subroutine keep only useful point on variable !> !> @note we use width define in first segment, cause every segment of a !> boundary should have the same width !> !> @author J.Paul !> - Nov, 2013- Initial Version ! !> @param[inout] td_var : variable strucutre !> @param[in ] td_bdy : boundary strucutre !------------------------------------------------------------------- !> @code SUBROUTINE boundary_clean_interp( td_var, td_bdy ) IMPLICIT NONE ! Argument TYPE(TVAR), INTENT(INOUT) :: td_var TYPE(TBDY), INTENT(IN ) :: td_bdy ! local variable TYPE(TVAR) :: tl_var INTEGER(i4) :: il_imin INTEGER(i4) :: il_imax INTEGER(i4) :: il_jmin INTEGER(i4) :: il_jmax ! loop indices !---------------------------------------------------------------- ! copy input variable tl_var=td_var DEALLOCATE(td_var%d_value) SELECT CASE(TRIM(td_bdy%c_card)) CASE('north') il_imin=1 il_imax=tl_var%t_dim(1)%i_len SELECT CASE(td_var%c_point) CASE('V','F') il_jmin=td_bdy%t_seg(1)%i_width+1 il_jmax=2 CASE DEFAULT ! 'T','U' il_jmin=td_bdy%t_seg(1)%i_width il_jmax=1 END SELECT ! use width as dimension length td_var%t_dim(2)%i_len=td_bdy%t_seg(1)%i_width CASE('south') il_imin=1 il_imax=tl_var%t_dim(1)%i_len il_jmin=1 il_jmax=td_bdy%t_seg(1)%i_width ! use width as dimension length td_var%t_dim(2)%i_len=td_bdy%t_seg(1)%i_width CASE('east') SELECT CASE(td_var%c_point) CASE('U','F') il_imin=td_bdy%t_seg(1)%i_width+1 il_imax=2 CASE DEFAULT ! 'T','V' il_imin=td_bdy%t_seg(1)%i_width il_imax=1 END SELECT il_jmin=1 il_jmax=tl_var%t_dim(2)%i_len ! use width as dimension length td_var%t_dim(1)%i_len=td_bdy%t_seg(1)%i_width CASE('west') il_imin=1 il_imax=td_bdy%t_seg(1)%i_width il_jmin=1 il_jmax=tl_var%t_dim(2)%i_len ! use width as dimension length td_var%t_dim(1)%i_len=td_bdy%t_seg(1)%i_width END SELECT ALLOCATE( td_var%d_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) ) IF( il_imin > il_imax )THEN il_imin=tl_var%t_dim(1)%i_len-il_imin+1 il_imax=tl_var%t_dim(1)%i_len-il_imax+1 ENDIF IF( il_jmin > il_jmax )THEN il_jmin=tl_var%t_dim(2)%i_len-il_jmin+1 il_jmax=tl_var%t_dim(2)%i_len-il_jmax+1 ENDIF td_var%d_value(:,:,:,:)=tl_var%d_value( il_imin:il_imax, & & il_jmin:il_jmax, & & :,: ) CALL var_clean(tl_var) END SUBROUTINE boundary_clean_interp !> @endcode !------------------------------------------------------------------- !> @brief This subroutine swap array for east and north boundary. ! !> @detail !> !> @author J.Paul !> - Nov, 2013- Initial Version ! !> @param[inout] td_var : variable strucutre !> @param[in ] td_bdy : boundary strucutre !------------------------------------------------------------------- !> @code 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 table 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 !> @endcode !------------------------------------------------------------------- !> @brief This subroutine print information about one boundary ! !> @details ! !> @author J.Paul !> - Nov, 2013- Initial Version ! !> @param[in] td_bdy : boundary structure !------------------------------------------------------------------- !> @code 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 !> @endcode !------------------------------------------------------------------- !> @brief This subroutine print information about a table of boundary ! !> @details ! !> @author J.Paul !> - Nov, 2013- Initial Version ! !> @param[in] td_bdy : boundary structure !------------------------------------------------------------------- !> @code SUBROUTINE boundary__print_tab( 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_tab !> @endcode !------------------------------------------------------------------- !> @brief !> This subroutine copy segment structure in another segment !> structure !> @details !> !> @warning to avoid infinite loop, do not use any function inside !> this subroutine !> !> @author J.Paul !> - Nov, 2013- Initial Version ! !> @param[out] td_seg1 : segment structure !> @param[in] td_seg2 : segment structure !------------------------------------------------------------------- !> @code SUBROUTINE seg__copy( td_seg1, td_seg2 ) IMPLICIT NONE ! Argument TYPE(TSEG), INTENT(OUT) :: td_seg1 TYPE(TSEG), INTENT(IN) :: td_seg2 ! local variable ! loop indices !---------------------------------------------------------------- ! copy segment index, width, .. td_seg1%i_index = td_seg2%i_index td_seg1%i_width = td_seg2%i_width td_seg1%i_first = td_seg2%i_first td_seg1%i_last = td_seg2%i_last END SUBROUTINE seg__copy !> @endcode !------------------------------------------------------------------- !> @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 !> - Nov, 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 !------------------------------------------------------------------- !> @code 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 !> @endcode !------------------------------------------------------------------- !> @brief This subroutine clean segment structure. ! !> @details ! !> @author J.Paul !> - Nov, 2013- Initial Version ! !> @param[inout] td_seg : segment structure !------------------------------------------------------------------- !> @code SUBROUTINE seg__clean(td_seg) IMPLICIT NONE ! Argument TYPE(TSEG), INTENT(INOUT) :: td_seg ! local variable TYPE(TSEG) :: tl_seg ! loop indices !---------------------------------------------------------------- td_seg=tl_seg END SUBROUTINE seg__clean !> @endcode ! !------------------------------------------------------------------- ! !> @brief This function ! ! ! !> @details ! ! ! !> @author J.Paul ! !> - Nov, 2013- Initial Version ! ! ! !> @param[in] ! !------------------------------------------------------------------- ! !> @code ! FUNCTION boundary_() ! IMPLICIT NONE ! ! Argument ! ! function ! ! local variable ! ! loop indices ! !---------------------------------------------------------------- ! ! END FUNCTION boundary_ ! !> @endcode ! !------------------------------------------------------------------- ! !> @brief This subroutine ! ! ! !> @details ! ! ! !> @author J.Paul ! !> - Nov, 2013- Initial Version ! ! ! !> @param[in] ! !------------------------------------------------------------------- ! !> @code ! SUBROUTINE boundary_() ! IMPLICIT NONE ! ! Argument ! ! local variable ! ! loop indices ! !---------------------------------------------------------------- ! ! END SUBROUTINE boundary_ ! !> @endcode END MODULE boundary