diff --git a/base/modules/Makefile b/base/modules/Makefile index 9cf2c9a6..88a17de7 100644 --- a/base/modules/Makefile +++ b/base/modules/Makefile @@ -9,7 +9,7 @@ UTIL_MODS = psb_string_mod.o psb_desc_const_mod.o psb_indx_map_mod.o\ psb_base_tools_mod.o psb_s_tools_mod.o psb_d_tools_mod.o\ psb_c_tools_mod.o psb_z_tools_mod.o psb_tools_mod.o \ psb_penv_mod.o $(COMMINT) psb_error_impl.o \ - psb_linmap_type_mod.o psb_linmap_mod.o \ + psb_base_linmap_mod.o psb_linmap_mod.o \ psb_s_linmap_mod.o psb_d_linmap_mod.o psb_c_linmap_mod.o psb_z_linmap_mod.o \ psb_comm_mod.o psb_i_comm_mod.o psb_s_comm_mod.o psb_d_comm_mod.o\ psb_c_comm_mod.o psb_z_comm_mod.o \ @@ -96,11 +96,11 @@ psb_glist_map_mod.o: psb_list_map_mod.o psb_hash_map_mod.o: psb_hash_mod.o psb_sort_mod.o psb_hash_mod.o: psb_realloc_mod.o psb_const_mod.o psb_linmap_mod.o: psb_s_linmap_mod.o psb_d_linmap_mod.o psb_c_linmap_mod.o psb_z_linmap_mod.o -psb_s_linmap_mod.o: psb_linmap_type_mod.o psb_mat_mod.o psb_s_vect_mod.o -psb_d_linmap_mod.o: psb_linmap_type_mod.o psb_mat_mod.o psb_d_vect_mod.o -psb_c_linmap_mod.o: psb_linmap_type_mod.o psb_mat_mod.o psb_c_vect_mod.o -psb_z_linmap_mod.o: psb_linmap_type_mod.o psb_mat_mod.o psb_z_vect_mod.o -psb_linmap_type_mod.o: psb_desc_type.o psb_serial_mod.o psb_comm_mod.o psb_mat_mod.o +psb_s_linmap_mod.o: psb_base_linmap_mod.o psb_s_mat_mod.o psb_s_vect_mod.o +psb_d_linmap_mod.o: psb_base_linmap_mod.o psb_d_mat_mod.o psb_d_vect_mod.o +psb_c_linmap_mod.o: psb_base_linmap_mod.o psb_c_mat_mod.o psb_c_vect_mod.o +psb_z_linmap_mod.o: psb_base_linmap_mod.o psb_z_mat_mod.o psb_z_vect_mod.o +psb_base_linmap_mod.o: psb_desc_type.o psb_serial_mod.o psb_comm_mod.o psb_comm_mod.o: psb_desc_type.o psb_mat_mod.o psb_check_mod.o: psb_desc_type.o psb_serial_mod.o: psb_mat_mod.o psb_string_mod.o psb_sort_mod.o psi_serial_mod.o diff --git a/base/modules/psb_c_linmap_mod.f90 b/base/modules/psb_c_linmap_mod.f90 index f2105e09..00be7382 100644 --- a/base/modules/psb_c_linmap_mod.f90 +++ b/base/modules/psb_c_linmap_mod.f90 @@ -31,96 +31,96 @@ !!$ ! ! -! package: psb_linmap_mod -! Defines facilities for mapping between vectors belonging +! package: psb_c_linmap_mod +! Defines data types and interfaces for mapping between vectors belonging ! to different spaces. ! module psb_c_linmap_mod use psb_const_mod - use psb_linmap_type_mod + use psb_c_mat_mod, only : psb_cspmat_type + use psb_descriptor_type, only : psb_desc_type + use psb_base_linmap_mod + + + type, extends(psb_base_linmap_type) :: psb_clinmap_type + type(psb_cspmat_type) :: map_X2Y, map_Y2X + contains + procedure, pass(map) :: sizeof => c_map_sizeof + procedure, pass(map) :: is_asb => c_is_asb + procedure, pass(map) :: free => c_free + end type psb_clinmap_type interface psb_map_X2Y subroutine psb_c_map_X2Y(alpha,x,beta,y,map,info,work) - use psb_linmap_type_mod + use psb_const_mod + import :: psb_clinmap_type implicit none type(psb_clinmap_type), intent(in) :: map - complex(psb_spk_), intent(in) :: alpha,beta - complex(psb_spk_), intent(inout) :: x(:) - complex(psb_spk_), intent(out) :: y(:) - integer, intent(out) :: info - complex(psb_spk_), optional :: work(:) + complex(psb_spk_), intent(in) :: alpha,beta + complex(psb_spk_), intent(inout) :: x(:) + complex(psb_spk_), intent(out) :: y(:) + integer, intent(out) :: info + complex(psb_spk_), optional :: work(:) end subroutine psb_c_map_X2Y subroutine psb_c_map_X2Y_vect(alpha,x,beta,y,map,info,work) + use psb_const_mod use psb_c_vect_mod - use psb_linmap_type_mod + import :: psb_clinmap_type implicit none type(psb_clinmap_type), intent(in) :: map - complex(psb_spk_), intent(in) :: alpha,beta + complex(psb_spk_), intent(in) :: alpha,beta type(psb_c_vect_type), intent(inout) :: x,y - integer, intent(out) :: info + integer, intent(out) :: info complex(psb_spk_), optional :: work(:) end subroutine psb_c_map_X2Y_vect end interface interface psb_map_Y2X subroutine psb_c_map_Y2X(alpha,x,beta,y,map,info,work) - use psb_linmap_type_mod + use psb_const_mod + import :: psb_clinmap_type implicit none type(psb_clinmap_type), intent(in) :: map - complex(psb_spk_), intent(in) :: alpha,beta - complex(psb_spk_), intent(inout) :: x(:) - complex(psb_spk_), intent(out) :: y(:) - integer, intent(out) :: info - complex(psb_spk_), optional :: work(:) + complex(psb_spk_), intent(in) :: alpha,beta + complex(psb_spk_), intent(inout) :: x(:) + complex(psb_spk_), intent(out) :: y(:) + integer, intent(out) :: info + complex(psb_spk_), optional :: work(:) end subroutine psb_c_map_Y2X subroutine psb_c_map_Y2X_vect(alpha,x,beta,y,map,info,work) + use psb_const_mod use psb_c_vect_mod - use psb_linmap_type_mod + import :: psb_clinmap_type implicit none type(psb_clinmap_type), intent(in) :: map - complex(psb_spk_), intent(in) :: alpha,beta + complex(psb_spk_), intent(in) :: alpha,beta type(psb_c_vect_type), intent(inout) :: x,y - integer, intent(out) :: info + integer, intent(out) :: info complex(psb_spk_), optional :: work(:) end subroutine psb_c_map_Y2X_vect end interface - interface psb_is_ok_map - module procedure psb_is_ok_clinmap - end interface - - interface psb_get_map_kind - module procedure psb_get_cmap_kind - end interface - - interface psb_set_map_kind - module procedure psb_set_cmap_kind - end interface - interface psb_map_cscnv module procedure psb_c_map_cscnv end interface - interface psb_is_asb_map - module procedure psb_is_asb_clinmap - end interface - interface psb_linmap_sub module procedure psb_c_linmap_sub end interface interface psb_move_alloc - module procedure psb_clinmap_transfer + module procedure psb_clinmap_transfer end interface interface psb_linmap function psb_c_linmap(map_kind,desc_X, desc_Y, map_X2Y, map_Y2X,iaggr,naggr) - use psb_linmap_type_mod + use psb_c_mat_mod, only : psb_cspmat_type + import :: psb_clinmap_type, psb_desc_type implicit none - type(psb_clinmap_type) :: psb_c_linmap + type(psb_clinmap_type) :: psb_c_linmap type(psb_desc_type), target :: desc_X, desc_Y type(psb_cspmat_type), intent(in) :: map_X2Y, map_Y2X integer, intent(in) :: map_kind @@ -128,34 +128,42 @@ module psb_c_linmap_mod end function psb_c_linmap end interface - interface psb_sizeof - module procedure psb_clinmap_sizeof - end interface + private :: c_map_sizeof, c_is_asb, c_free + + + + contains - function psb_get_cmap_kind(map) - implicit none - type(psb_clinmap_type), intent(in) :: map - Integer :: psb_get_cmap_kind - if (allocated(map%itd_data)) then - psb_get_cmap_kind = map%itd_data(psb_map_kind_) - else - psb_get_cmap_kind = -1 - end if - end function psb_get_cmap_kind - - subroutine psb_set_cmap_kind(map_kind,map) - implicit none - integer, intent(in) :: map_kind - type(psb_clinmap_type), intent(inout) :: map + function c_map_sizeof(map) result(val) + use psb_descriptor_type + use psb_c_mat_mod + implicit none + class(psb_clinmap_type), intent(in) :: map + integer(psb_long_int_k_) :: val + + val = map%psb_base_linmap_type%sizeof() + val = val + map%map_X2Y%sizeof() + val = val + map%map_Y2X%sizeof() + + end function c_map_sizeof - map%itd_data(psb_map_kind_) = map_kind - end subroutine psb_set_cmap_kind + function c_is_asb(map) result(val) + use psb_descriptor_type + implicit none + class(psb_clinmap_type), intent(in) :: map + logical :: val + + val = map%psb_base_linmap_type%is_asb() .and. & + & map%map_X2Y%is_asb() .and.map%map_Y2X%is_asb() + + end function c_is_asb + subroutine psb_c_map_cscnv(map,info,type,mold) - use psb_mat_mod + use psb_c_mat_mod implicit none type(psb_clinmap_type), intent(inout) :: map integer, intent(out) :: info @@ -168,74 +176,9 @@ contains end subroutine psb_c_map_cscnv - function psb_is_asb_clinmap(map) result(this) - use psb_descriptor_type - implicit none - type(psb_clinmap_type), intent(in) :: map - logical :: this - - this = .false. - if (.not.allocated(map%itd_data)) return - select case(psb_get_map_kind(map)) - case (psb_map_aggr_) - if (.not.associated(map%p_desc_X)) return - if (.not.associated(map%p_desc_Y)) return - this = & - & psb_is_asb_desc(map%p_desc_X).and.psb_is_asb_desc(map%p_desc_Y) - - case(psb_map_gen_linear_) - - this = & - & psb_is_asb_desc(map%desc_X).and.psb_is_asb_desc(map%desc_Y) - - end select - - end function psb_is_asb_clinmap - - function psb_is_ok_clinmap(map) result(this) - use psb_descriptor_type - implicit none - type(psb_clinmap_type), intent(in) :: map - logical :: this - this = .false. - if (.not.allocated(map%itd_data)) return - select case(psb_get_map_kind(map)) - case (psb_map_aggr_) - if (.not.associated(map%p_desc_X)) return - if (.not.associated(map%p_desc_Y)) return - this = & - & psb_is_ok_desc(map%p_desc_X).and.psb_is_ok_desc(map%p_desc_Y) - case(psb_map_gen_linear_) - this = & - & psb_is_ok_desc(map%desc_X).and.psb_is_ok_desc(map%desc_Y) - end select - - end function psb_is_ok_clinmap - - function psb_clinmap_sizeof(map) result(val) - use psb_descriptor_type - use psb_mat_mod, only : psb_sizeof - implicit none - type(psb_clinmap_type), intent(in) :: map - integer(psb_long_int_k_) :: val - - val = 0 - if (allocated(map%itd_data)) & - & val = val + psb_sizeof_int*size(map%itd_data) - if (allocated(map%iaggr)) & - & val = val + psb_sizeof_int*size(map%iaggr) - if (allocated(map%naggr)) & - & val = val + psb_sizeof_int*size(map%naggr) - val = val + psb_sizeof(map%desc_X) - val = val + psb_sizeof(map%desc_Y) - val = val + psb_sizeof(map%map_X2Y) - val = val + psb_sizeof(map%map_Y2X) - - end function psb_clinmap_sizeof - subroutine psb_c_linmap_sub(out_map,map_kind,desc_X, desc_Y,& & map_X2Y, map_Y2X,iaggr,naggr) - use psb_linmap_type_mod + use psb_c_mat_mod implicit none type(psb_clinmap_type), intent(out) :: out_map type(psb_desc_type), target :: desc_X, desc_Y @@ -253,19 +196,26 @@ contains type(psb_clinmap_type) :: mapin,mapout integer, intent(out) :: info - call psb_move_alloc(mapin%itd_data,mapout%itd_data,info) - call psb_move_alloc(mapin%iaggr,mapout%iaggr,info) - call psb_move_alloc(mapin%naggr,mapout%naggr,info) - mapout%p_desc_X => mapin%p_desc_X - mapin%p_desc_X => null() - mapout%p_desc_Y => mapin%p_desc_Y - mapin%p_desc_Y => null() - call psb_move_alloc(mapin%desc_X,mapout%desc_X,info) - call psb_move_alloc(mapin%desc_Y,mapout%desc_Y,info) + call psb_move_alloc(mapin%psb_base_linmap_type, & + & mapout%psb_base_linmap_type,info) call psb_move_alloc(mapin%map_X2Y,mapout%map_X2Y,info) call psb_move_alloc(mapin%map_Y2X,mapout%map_Y2X,info) end subroutine psb_clinmap_transfer + + subroutine c_free(map,info) + use psb_descriptor_type + implicit none + class(psb_clinmap_type) :: map + integer, intent(out) :: info + + call map%psb_base_linmap_type%free(info) + + call map%map_X2Y%free() + call map%map_Y2X%free() + + end subroutine c_free + end module psb_c_linmap_mod diff --git a/base/modules/psb_d_linmap_mod.f90 b/base/modules/psb_d_linmap_mod.f90 index d486bb75..fb74445a 100644 --- a/base/modules/psb_d_linmap_mod.f90 +++ b/base/modules/psb_d_linmap_mod.f90 @@ -31,19 +31,31 @@ !!$ ! ! -! package: psb_linmap_mod -! Defines facilities for mapping between vectors belonging +! package: psb_d_linmap_mod +! Defines data types and interfaces for mapping between vectors belonging ! to different spaces. ! module psb_d_linmap_mod use psb_const_mod - use psb_linmap_type_mod + use psb_d_mat_mod, only : psb_dspmat_type + use psb_descriptor_type, only : psb_desc_type + use psb_base_linmap_mod + + + type, extends(psb_base_linmap_type) :: psb_dlinmap_type + type(psb_dspmat_type) :: map_X2Y, map_Y2X + contains + procedure, pass(map) :: sizeof => d_map_sizeof + procedure, pass(map) :: is_asb => d_is_asb + procedure, pass(map) :: free => d_free + end type psb_dlinmap_type interface psb_map_X2Y subroutine psb_d_map_X2Y(alpha,x,beta,y,map,info,work) - use psb_linmap_type_mod + use psb_const_mod + import :: psb_dlinmap_type implicit none type(psb_dlinmap_type), intent(in) :: map real(psb_dpk_), intent(in) :: alpha,beta @@ -53,8 +65,9 @@ module psb_d_linmap_mod real(psb_dpk_), optional :: work(:) end subroutine psb_d_map_X2Y subroutine psb_d_map_X2Y_vect(alpha,x,beta,y,map,info,work) + use psb_const_mod use psb_d_vect_mod - use psb_linmap_type_mod + import :: psb_dlinmap_type implicit none type(psb_dlinmap_type), intent(in) :: map real(psb_dpk_), intent(in) :: alpha,beta @@ -66,7 +79,8 @@ module psb_d_linmap_mod interface psb_map_Y2X subroutine psb_d_map_Y2X(alpha,x,beta,y,map,info,work) - use psb_linmap_type_mod + use psb_const_mod + import :: psb_dlinmap_type implicit none type(psb_dlinmap_type), intent(in) :: map real(psb_dpk_), intent(in) :: alpha,beta @@ -76,8 +90,9 @@ module psb_d_linmap_mod real(psb_dpk_), optional :: work(:) end subroutine psb_d_map_Y2X subroutine psb_d_map_Y2X_vect(alpha,x,beta,y,map,info,work) + use psb_const_mod use psb_d_vect_mod - use psb_linmap_type_mod + import :: psb_dlinmap_type implicit none type(psb_dlinmap_type), intent(in) :: map real(psb_dpk_), intent(in) :: alpha,beta @@ -88,26 +103,10 @@ module psb_d_linmap_mod end interface - interface psb_is_ok_map - module procedure psb_is_ok_dlinmap - end interface - - interface psb_get_map_kind - module procedure psb_get_dmap_kind - end interface - - interface psb_set_map_kind - module procedure psb_set_dmap_kind - end interface - interface psb_map_cscnv module procedure psb_d_map_cscnv end interface - interface psb_is_asb_map - module procedure psb_is_asb_dlinmap - end interface - interface psb_linmap_sub module procedure psb_d_linmap_sub end interface @@ -118,9 +117,10 @@ module psb_d_linmap_mod interface psb_linmap function psb_d_linmap(map_kind,desc_X, desc_Y, map_X2Y, map_Y2X,iaggr,naggr) - use psb_linmap_type_mod + use psb_d_mat_mod, only : psb_dspmat_type + import :: psb_dlinmap_type, psb_desc_type implicit none - type(psb_dlinmap_type) :: psb_d_linmap + type(psb_dlinmap_type) :: psb_d_linmap type(psb_desc_type), target :: desc_X, desc_Y type(psb_dspmat_type), intent(in) :: map_X2Y, map_Y2X integer, intent(in) :: map_kind @@ -128,35 +128,42 @@ module psb_d_linmap_mod end function psb_d_linmap end interface - interface psb_sizeof - module procedure psb_dlinmap_sizeof - end interface + private :: d_map_sizeof, d_is_asb, d_free + + + + contains - function psb_get_dmap_kind(map) - implicit none - type(psb_dlinmap_type), intent(in) :: map - Integer :: psb_get_dmap_kind - if (allocated(map%itd_data)) then - psb_get_dmap_kind = map%itd_data(psb_map_kind_) - else - psb_get_dmap_kind = -1 - end if - end function psb_get_dmap_kind + function d_map_sizeof(map) result(val) + use psb_descriptor_type + use psb_d_mat_mod + implicit none + class(psb_dlinmap_type), intent(in) :: map + integer(psb_long_int_k_) :: val + val = map%psb_base_linmap_type%sizeof() + val = val + map%map_X2Y%sizeof() + val = val + map%map_Y2X%sizeof() - subroutine psb_set_dmap_kind(map_kind,map) - implicit none - integer, intent(in) :: map_kind - type(psb_dlinmap_type), intent(inout) :: map + end function d_map_sizeof + + + function d_is_asb(map) result(val) + use psb_descriptor_type + implicit none + class(psb_dlinmap_type), intent(in) :: map + logical :: val - map%itd_data(psb_map_kind_) = map_kind + val = map%psb_base_linmap_type%is_asb() .and. & + & map%map_X2Y%is_asb() .and.map%map_Y2X%is_asb() + + end function d_is_asb - end subroutine psb_set_dmap_kind subroutine psb_d_map_cscnv(map,info,type,mold) - use psb_mat_mod + use psb_d_mat_mod implicit none type(psb_dlinmap_type), intent(inout) :: map integer, intent(out) :: info @@ -169,75 +176,9 @@ contains end subroutine psb_d_map_cscnv - function psb_is_asb_dlinmap(map) result(this) - use psb_descriptor_type - implicit none - type(psb_dlinmap_type), intent(in) :: map - logical :: this - - this = .false. - if (.not.allocated(map%itd_data)) return - select case(psb_get_map_kind(map)) - case (psb_map_aggr_) - if (.not.associated(map%p_desc_X)) return - if (.not.associated(map%p_desc_Y)) return - this = & - & psb_is_asb_desc(map%p_desc_X).and.psb_is_asb_desc(map%p_desc_Y) - - case(psb_map_gen_linear_) - - this = & - & psb_is_asb_desc(map%desc_X).and.psb_is_asb_desc(map%desc_Y) - - end select - - end function psb_is_asb_dlinmap - - function psb_is_ok_dlinmap(map) result(this) - use psb_descriptor_type - implicit none - type(psb_dlinmap_type), intent(in) :: map - logical :: this - this = .false. - if (.not.allocated(map%itd_data)) return - select case(psb_get_map_kind(map)) - case (psb_map_aggr_) - if (.not.associated(map%p_desc_X)) return - if (.not.associated(map%p_desc_Y)) return - this = & - & psb_is_ok_desc(map%p_desc_X).and.psb_is_ok_desc(map%p_desc_Y) - case(psb_map_gen_linear_) - this = & - & psb_is_ok_desc(map%desc_X).and.psb_is_ok_desc(map%desc_Y) - end select - - end function psb_is_ok_dlinmap - - function psb_dlinmap_sizeof(map) result(val) - use psb_descriptor_type - use psb_mat_mod, only : psb_sizeof - implicit none - type(psb_dlinmap_type), intent(in) :: map - integer(psb_long_int_k_) :: val - -!!$ val = 0 -!!$ if (allocated(map%itd_data)) & -!!$ & val = val + psb_sizeof_int*size(map%itd_data) -!!$ if (allocated(map%iaggr)) & -!!$ & val = val + psb_sizeof_int*size(map%iaggr) -!!$ if (allocated(map%naggr)) & -!!$ & val = val + psb_sizeof_int*size(map%naggr) -!!$ val = val + psb_sizeof(map%desc_X) -!!$ val = val + psb_sizeof(map%desc_Y) -!!$ val = val + psb_sizeof(map%map_X2Y) -!!$ val = val + psb_sizeof(map%map_Y2X) - - val = map%sizeof() - end function psb_dlinmap_sizeof - subroutine psb_d_linmap_sub(out_map,map_kind,desc_X, desc_Y,& & map_X2Y, map_Y2X,iaggr,naggr) - use psb_linmap_type_mod + use psb_d_mat_mod implicit none type(psb_dlinmap_type), intent(out) :: out_map type(psb_desc_type), target :: desc_X, desc_Y @@ -255,18 +196,26 @@ contains type(psb_dlinmap_type) :: mapin,mapout integer, intent(out) :: info - call psb_move_alloc(mapin%itd_data,mapout%itd_data,info) - call psb_move_alloc(mapin%iaggr,mapout%iaggr,info) - call psb_move_alloc(mapin%naggr,mapout%naggr,info) - mapout%p_desc_X => mapin%p_desc_X - mapin%p_desc_X => null() - mapout%p_desc_Y => mapin%p_desc_Y - mapin%p_desc_Y => null() - call psb_move_alloc(mapin%desc_X,mapout%desc_X,info) - call psb_move_alloc(mapin%desc_Y,mapout%desc_Y,info) + call psb_move_alloc(mapin%psb_base_linmap_type, & + & mapout%psb_base_linmap_type,info) call psb_move_alloc(mapin%map_X2Y,mapout%map_X2Y,info) call psb_move_alloc(mapin%map_Y2X,mapout%map_Y2X,info) end subroutine psb_dlinmap_transfer + + subroutine d_free(map,info) + use psb_descriptor_type + implicit none + class(psb_dlinmap_type) :: map + integer, intent(out) :: info + + call map%psb_base_linmap_type%free(info) + + call map%map_X2Y%free() + call map%map_Y2X%free() + + end subroutine d_free + end module psb_d_linmap_mod + diff --git a/base/modules/psb_desc_type.f90 b/base/modules/psb_desc_type.f90 index 3b8bfeae..6bf42a17 100644 --- a/base/modules/psb_desc_type.f90 +++ b/base/modules/psb_desc_type.f90 @@ -225,6 +225,8 @@ module psb_descriptor_type procedure, pass(desc) :: get_global_rows => psb_cd_get_global_rows procedure, pass(desc) :: get_global_cols => psb_cd_get_global_cols procedure, pass(desc) :: sizeof => psb_cd_sizeof + procedure, pass(desc) :: free => psb_cdfree + procedure, pass(desc) :: nullify => nullify_desc end type psb_desc_type interface psb_sizeof @@ -239,6 +241,7 @@ module psb_descriptor_type module procedure psb_cdfree end interface psb_free + private :: nullify_desc integer, private, save :: cd_large_threshold=psb_default_large_threshold @@ -305,6 +308,14 @@ contains end subroutine psb_nullify_desc + subroutine nullify_desc(desc) + class(psb_desc_type), intent(inout) :: desc + ! We have nothing left to do here. + ! Perhaps we should delete this subroutine? + nullify(desc%base_desc) + + end subroutine nullify_desc + function psb_is_ok_desc(desc) result(val) class(psb_desc_type), intent(in) :: desc @@ -581,14 +592,14 @@ contains ! Arguments: ! desc_a - type(psb_desc_type). The communication descriptor to be freed. ! info - integer. return code. - subroutine psb_cdfree(desc_a,info) + subroutine psb_cdfree(desc,info) !...free descriptor structure... use psb_const_mod use psb_error_mod use psb_penv_mod implicit none !....parameters... - type(psb_desc_type), intent(inout) :: desc_a + class(psb_desc_type), intent(inout) :: desc integer, intent(out) :: info !...locals.... integer :: ictxt,np,me, err_act @@ -600,7 +611,7 @@ contains name = 'psb_cdfree' - ictxt=psb_cd_get_context(desc_a) + ictxt=psb_cd_get_context(desc) call psb_info(ictxt, me, np) ! ....verify blacs grid correctness.. @@ -611,28 +622,28 @@ contains endif - if (.not.allocated(desc_a%halo_index)) then + if (.not.allocated(desc%halo_index)) then info=298 call psb_errpush(info,name) goto 9999 end if !deallocate halo_index field - deallocate(desc_a%halo_index,stat=info) + deallocate(desc%halo_index,stat=info) if (info /= psb_success_) then info=2053 call psb_errpush(info,name) goto 9999 end if - if (.not.allocated(desc_a%bnd_elem)) then + if (.not.allocated(desc%bnd_elem)) then !!$ info=296 !!$ call psb_errpush(info,name) !!$ goto 9999 !!$ end if else !deallocate halo_index field - deallocate(desc_a%bnd_elem,stat=info) + deallocate(desc%bnd_elem,stat=info) if (info /= psb_success_) then info=2054 call psb_errpush(info,name) @@ -640,14 +651,14 @@ contains end if end if - if (.not.allocated(desc_a%ovrlap_index)) then + if (.not.allocated(desc%ovrlap_index)) then info=299 call psb_errpush(info,name) goto 9999 end if !deallocate ovrlap_index field - deallocate(desc_a%ovrlap_index,stat=info) + deallocate(desc%ovrlap_index,stat=info) if (info /= psb_success_) then info=2055 call psb_errpush(info,name) @@ -655,7 +666,7 @@ contains end if !deallocate ovrlap_elem field - deallocate(desc_a%ovrlap_elem,stat=info) + deallocate(desc%ovrlap_elem,stat=info) if (info /= psb_success_) then info=2056 call psb_errpush(info,name) @@ -663,7 +674,7 @@ contains end if !deallocate ovrlap_index field - deallocate(desc_a%ovr_mst_idx,stat=info) + deallocate(desc%ovr_mst_idx,stat=info) if (info /= psb_success_) then info=2055 call psb_errpush(info,name) @@ -671,20 +682,20 @@ contains end if - if (allocated(desc_a%lprm)) & - & deallocate(desc_a%lprm,stat=info) + if (allocated(desc%lprm)) & + & deallocate(desc%lprm,stat=info) if (info /= psb_success_) then info=2057 call psb_errpush(info,name) goto 9999 end if - if (allocated(desc_a%indxmap)) then - call desc_a%indxmap%free() - deallocate(desc_a%indxmap, stat=info) + if (allocated(desc%indxmap)) then + call desc%indxmap%free() + deallocate(desc%indxmap, stat=info) end if - if (allocated(desc_a%idx_space)) then - deallocate(desc_a%idx_space,stat=info) + if (allocated(desc%idx_space)) then + deallocate(desc%idx_space,stat=info) if (info /= psb_success_) then info=2056 call psb_errpush(info,name) @@ -692,7 +703,7 @@ contains end if end if - call psb_nullify_desc(desc_a) + call desc%nullify() call psb_erractionrestore(err_act) return diff --git a/base/modules/psb_linmap_mod.f90 b/base/modules/psb_linmap_mod.f90 index 125e00b3..5bb14538 100644 --- a/base/modules/psb_linmap_mod.f90 +++ b/base/modules/psb_linmap_mod.f90 @@ -39,7 +39,7 @@ module psb_linmap_mod use psb_const_mod !!$ use psb_descriptor_type - use psb_linmap_type_mod +!!$ use psb_linmap_type_mod use psb_s_linmap_mod use psb_d_linmap_mod use psb_c_linmap_mod diff --git a/base/modules/psb_linmap_type_mod.f90 b/base/modules/psb_linmap_type_mod.f90 deleted file mode 100644 index 0a3c2849..00000000 --- a/base/modules/psb_linmap_type_mod.f90 +++ /dev/null @@ -1,182 +0,0 @@ -!!$ -!!$ Parallel Sparse BLAS version 3.0 -!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010 -!!$ Salvatore Filippone University of Rome Tor Vergata -!!$ Alfredo Buttari CNRS-IRIT, Toulouse -!!$ -!!$ Redistribution and use in source and binary forms, with or without -!!$ modification, are permitted provided that the following conditions -!!$ are met: -!!$ 1. Redistributions of source code must retain the above copyright -!!$ notice, this list of conditions and the following disclaimer. -!!$ 2. Redistributions in binary form must reproduce the above copyright -!!$ notice, this list of conditions, and the following disclaimer in the -!!$ documentation and/or other materials provided with the distribution. -!!$ 3. The name of the PSBLAS group or the names of its contributors may -!!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. -!!$ -!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -!!$ POSSIBILITY OF SUCH DAMAGE. -!!$ -!!$ -! -! -! package: psb_linmap_type_mod -! Defines data types for mapping between vectors belonging -! to different spaces. -! -module psb_linmap_type_mod - use psb_const_mod - use psb_mat_mod, only: psb_dspmat_type, psb_sspmat_type,& - & psb_zspmat_type, psb_cspmat_type - use psb_descriptor_type, only: psb_desc_type - - - ! Inter-descriptor mapping data structures. - integer, parameter :: psb_map_kind_ = 1 - integer, parameter :: psb_map_data_ = 2 - integer, parameter :: psb_map_integer_ = 1 - integer, parameter :: psb_map_single_ = 2 - integer, parameter :: psb_map_double_ = 3 - integer, parameter :: psb_map_complex_ = 4 - integer, parameter :: psb_map_double_complex_ = 5 - - integer, parameter :: psb_itd_data_size_=20 - - - type psb_slinmap_type - integer, allocatable :: itd_data(:), iaggr(:), naggr(:) - type(psb_desc_type), pointer :: p_desc_X=>null(), p_desc_Y=>null() - type(psb_desc_type) :: desc_X, desc_Y - type(psb_sspmat_type) :: map_X2Y, map_Y2X - contains - procedure, pass(map) :: sizeof => s_map_sizeof - end type psb_slinmap_type - - type psb_dlinmap_type - integer, allocatable :: itd_data(:), iaggr(:), naggr(:) - type(psb_desc_type), pointer :: p_desc_X=>null(), p_desc_Y=>null() - type(psb_desc_type) :: desc_X, desc_Y - type(psb_dspmat_type) :: map_X2Y, map_Y2X - contains - procedure, pass(map) :: sizeof => d_map_sizeof - end type psb_dlinmap_type - - type psb_clinmap_type - integer, allocatable :: itd_data(:), iaggr(:), naggr(:) - type(psb_desc_type), pointer :: p_desc_X=>null(), p_desc_Y=>null() - type(psb_desc_type) :: desc_X, desc_Y - type(psb_cspmat_type) :: map_X2Y, map_Y2X - contains - procedure, pass(map) :: sizeof => c_map_sizeof - end type psb_clinmap_type - - type psb_zlinmap_type - integer, allocatable :: itd_data(:), iaggr(:), naggr(:) - type(psb_desc_type), pointer :: p_desc_X=>null(), p_desc_Y=>null() - type(psb_desc_type) :: desc_X, desc_Y - type(psb_zspmat_type) :: map_X2Y, map_Y2X - contains - procedure, pass(map) :: sizeof => z_map_sizeof - end type psb_zlinmap_type - - private :: s_map_sizeof, d_map_sizeof, c_map_sizeof, z_map_sizeof - -contains - - function s_map_sizeof(map) result(val) - use psb_descriptor_type - use psb_s_mat_mod - implicit none - class(psb_slinmap_type), intent(in) :: map - integer(psb_long_int_k_) :: val - - val = 0 - if (allocated(map%itd_data)) & - & val = val + psb_sizeof_int*size(map%itd_data) - if (allocated(map%iaggr)) & - & val = val + psb_sizeof_int*size(map%iaggr) - if (allocated(map%naggr)) & - & val = val + psb_sizeof_int*size(map%naggr) - val = val + map%desc_X%sizeof() - val = val + map%desc_Y%sizeof() - val = val + map%map_X2Y%sizeof() - val = val + map%map_Y2X%sizeof() - - end function s_map_sizeof - - function d_map_sizeof(map) result(val) - use psb_descriptor_type - use psb_d_mat_mod - implicit none - class(psb_dlinmap_type), intent(in) :: map - integer(psb_long_int_k_) :: val - - val = 0 - if (allocated(map%itd_data)) & - & val = val + psb_sizeof_int*size(map%itd_data) - if (allocated(map%iaggr)) & - & val = val + psb_sizeof_int*size(map%iaggr) - if (allocated(map%naggr)) & - & val = val + psb_sizeof_int*size(map%naggr) - val = val + map%desc_X%sizeof() - val = val + map%desc_Y%sizeof() - val = val + map%map_X2Y%sizeof() - val = val + map%map_Y2X%sizeof() - - end function d_map_sizeof - - function c_map_sizeof(map) result(val) - use psb_descriptor_type - use psb_c_mat_mod - implicit none - class(psb_clinmap_type), intent(in) :: map - integer(psb_long_int_k_) :: val - - val = 0 - if (allocated(map%itd_data)) & - & val = val + psb_sizeof_int*size(map%itd_data) - if (allocated(map%iaggr)) & - & val = val + psb_sizeof_int*size(map%iaggr) - if (allocated(map%naggr)) & - & val = val + psb_sizeof_int*size(map%naggr) - val = val + map%desc_X%sizeof() - val = val + map%desc_Y%sizeof() - val = val + map%map_X2Y%sizeof() - val = val + map%map_Y2X%sizeof() - - end function c_map_sizeof - - function z_map_sizeof(map) result(val) - use psb_descriptor_type - use psb_z_mat_mod - implicit none - class(psb_zlinmap_type), intent(in) :: map - integer(psb_long_int_k_) :: val - - val = 0 - if (allocated(map%itd_data)) & - & val = val + psb_sizeof_int*size(map%itd_data) - if (allocated(map%iaggr)) & - & val = val + psb_sizeof_int*size(map%iaggr) - if (allocated(map%naggr)) & - & val = val + psb_sizeof_int*size(map%naggr) - val = val + map%desc_X%sizeof() - val = val + map%desc_Y%sizeof() - val = val + map%map_X2Y%sizeof() - val = val + map%map_Y2X%sizeof() - - end function z_map_sizeof - -end module psb_linmap_type_mod - diff --git a/base/modules/psb_s_linmap_mod.f90 b/base/modules/psb_s_linmap_mod.f90 index 5582da05..9fb6b187 100644 --- a/base/modules/psb_s_linmap_mod.f90 +++ b/base/modules/psb_s_linmap_mod.f90 @@ -31,19 +31,31 @@ !!$ ! ! -! package: psb_linmap_mod -! Defines facilities for mapping between vectors belonging +! package: psb_s_linmap_mod +! Defines data types and interfaces for mapping between vectors belonging ! to different spaces. ! module psb_s_linmap_mod use psb_const_mod - use psb_linmap_type_mod + use psb_s_mat_mod, only : psb_sspmat_type + use psb_descriptor_type, only : psb_desc_type + use psb_base_linmap_mod + + + type, extends(psb_base_linmap_type) :: psb_slinmap_type + type(psb_sspmat_type) :: map_X2Y, map_Y2X + contains + procedure, pass(map) :: sizeof => s_map_sizeof + procedure, pass(map) :: is_asb => s_is_asb + procedure, pass(map) :: free => s_free + end type psb_slinmap_type interface psb_map_X2Y subroutine psb_s_map_X2Y(alpha,x,beta,y,map,info,work) - use psb_linmap_type_mod + use psb_const_mod + import :: psb_slinmap_type implicit none type(psb_slinmap_type), intent(in) :: map real(psb_spk_), intent(in) :: alpha,beta @@ -53,8 +65,9 @@ module psb_s_linmap_mod real(psb_spk_), optional :: work(:) end subroutine psb_s_map_X2Y subroutine psb_s_map_X2Y_vect(alpha,x,beta,y,map,info,work) + use psb_const_mod use psb_s_vect_mod - use psb_linmap_type_mod + import :: psb_slinmap_type implicit none type(psb_slinmap_type), intent(in) :: map real(psb_spk_), intent(in) :: alpha,beta @@ -66,7 +79,8 @@ module psb_s_linmap_mod interface psb_map_Y2X subroutine psb_s_map_Y2X(alpha,x,beta,y,map,info,work) - use psb_linmap_type_mod + use psb_const_mod + import :: psb_slinmap_type implicit none type(psb_slinmap_type), intent(in) :: map real(psb_spk_), intent(in) :: alpha,beta @@ -76,8 +90,9 @@ module psb_s_linmap_mod real(psb_spk_), optional :: work(:) end subroutine psb_s_map_Y2X subroutine psb_s_map_Y2X_vect(alpha,x,beta,y,map,info,work) + use psb_const_mod use psb_s_vect_mod - use psb_linmap_type_mod + import :: psb_slinmap_type implicit none type(psb_slinmap_type), intent(in) :: map real(psb_spk_), intent(in) :: alpha,beta @@ -88,39 +103,24 @@ module psb_s_linmap_mod end interface - interface psb_is_ok_map - module procedure psb_is_ok_slinmap - end interface - - interface psb_get_map_kind - module procedure psb_get_smap_kind - end interface - - interface psb_set_map_kind - module procedure psb_set_smap_kind - end interface - interface psb_map_cscnv module procedure psb_s_map_cscnv end interface - interface psb_is_asb_map - module procedure psb_is_asb_slinmap - end interface - interface psb_linmap_sub module procedure psb_s_linmap_sub end interface interface psb_move_alloc - module procedure psb_slinmap_transfer + module procedure psb_slinmap_transfer end interface interface psb_linmap function psb_s_linmap(map_kind,desc_X, desc_Y, map_X2Y, map_Y2X,iaggr,naggr) - use psb_linmap_type_mod + use psb_s_mat_mod, only : psb_sspmat_type + import :: psb_slinmap_type, psb_desc_type implicit none - type(psb_slinmap_type) :: psb_s_linmap + type(psb_slinmap_type) :: psb_s_linmap type(psb_desc_type), target :: desc_X, desc_Y type(psb_sspmat_type), intent(in) :: map_X2Y, map_Y2X integer, intent(in) :: map_kind @@ -128,35 +128,42 @@ module psb_s_linmap_mod end function psb_s_linmap end interface - interface psb_sizeof - module procedure psb_slinmap_sizeof - end interface + private :: s_map_sizeof, s_is_asb, s_free + + + + contains - function psb_get_smap_kind(map) - implicit none - type(psb_slinmap_type), intent(in) :: map - Integer :: psb_get_smap_kind - if (allocated(map%itd_data)) then - psb_get_smap_kind = map%itd_data(psb_map_kind_) - else - psb_get_smap_kind = -1 - end if - end function psb_get_smap_kind + function s_map_sizeof(map) result(val) + use psb_descriptor_type + use psb_s_mat_mod + implicit none + class(psb_slinmap_type), intent(in) :: map + integer(psb_long_int_k_) :: val + val = map%psb_base_linmap_type%sizeof() + val = val + map%map_X2Y%sizeof() + val = val + map%map_Y2X%sizeof() - subroutine psb_set_smap_kind(map_kind,map) - implicit none - integer, intent(in) :: map_kind - type(psb_slinmap_type), intent(inout) :: map + end function s_map_sizeof - map%itd_data(psb_map_kind_) = map_kind - end subroutine psb_set_smap_kind + function s_is_asb(map) result(val) + use psb_descriptor_type + implicit none + class(psb_slinmap_type), intent(in) :: map + logical :: val + + val = map%psb_base_linmap_type%is_asb() .and. & + & map%map_X2Y%is_asb() .and.map%map_Y2X%is_asb() + + end function s_is_asb + subroutine psb_s_map_cscnv(map,info,type,mold) - use psb_mat_mod + use psb_s_mat_mod implicit none type(psb_slinmap_type), intent(inout) :: map integer, intent(out) :: info @@ -169,76 +176,9 @@ contains end subroutine psb_s_map_cscnv - - function psb_is_asb_slinmap(map) result(this) - use psb_descriptor_type - implicit none - type(psb_slinmap_type), intent(in) :: map - logical :: this - - this = .false. - if (.not.allocated(map%itd_data)) return - select case(psb_get_map_kind(map)) - case (psb_map_aggr_) - if (.not.associated(map%p_desc_X)) return - if (.not.associated(map%p_desc_Y)) return - this = & - & psb_is_asb_desc(map%p_desc_X).and.psb_is_asb_desc(map%p_desc_Y) - - case(psb_map_gen_linear_) - - this = & - & psb_is_asb_desc(map%desc_X).and.psb_is_asb_desc(map%desc_Y) - - end select - - end function psb_is_asb_slinmap - - function psb_is_ok_slinmap(map) result(this) - use psb_descriptor_type - implicit none - type(psb_slinmap_type), intent(in) :: map - logical :: this - this = .false. - if (.not.allocated(map%itd_data)) return - select case(psb_get_map_kind(map)) - case (psb_map_aggr_) - if (.not.associated(map%p_desc_X)) return - if (.not.associated(map%p_desc_Y)) return - this = & - & psb_is_ok_desc(map%p_desc_X).and.psb_is_ok_desc(map%p_desc_Y) - case(psb_map_gen_linear_) - this = & - & psb_is_ok_desc(map%desc_X).and.psb_is_ok_desc(map%desc_Y) - end select - - end function psb_is_ok_slinmap - - function psb_slinmap_sizeof(map) result(val) - use psb_descriptor_type - use psb_mat_mod, only : psb_sizeof - implicit none - type(psb_slinmap_type), intent(in) :: map - integer(psb_long_int_k_) :: val - - val = 0 - if (allocated(map%itd_data)) & - & val = val + psb_sizeof_int*size(map%itd_data) - if (allocated(map%iaggr)) & - & val = val + psb_sizeof_int*size(map%iaggr) - if (allocated(map%naggr)) & - & val = val + psb_sizeof_int*size(map%naggr) - val = val + psb_sizeof(map%desc_X) - val = val + psb_sizeof(map%desc_Y) - val = val + psb_sizeof(map%map_X2Y) - val = val + psb_sizeof(map%map_Y2X) - - end function psb_slinmap_sizeof - - subroutine psb_s_linmap_sub(out_map,map_kind,desc_X, desc_Y,& & map_X2Y, map_Y2X,iaggr,naggr) - use psb_linmap_type_mod + use psb_s_mat_mod implicit none type(psb_slinmap_type), intent(out) :: out_map type(psb_desc_type), target :: desc_X, desc_Y @@ -248,7 +188,6 @@ contains out_map = psb_linmap(map_kind,desc_X,desc_Y,map_X2Y,map_Y2X,iaggr,naggr) end subroutine psb_s_linmap_sub - subroutine psb_slinmap_transfer(mapin,mapout,info) use psb_realloc_mod use psb_descriptor_type @@ -257,19 +196,26 @@ contains type(psb_slinmap_type) :: mapin,mapout integer, intent(out) :: info - call psb_move_alloc(mapin%itd_data,mapout%itd_data,info) - call psb_move_alloc(mapin%iaggr,mapout%iaggr,info) - call psb_move_alloc(mapin%naggr,mapout%naggr,info) - mapout%p_desc_X => mapin%p_desc_X - mapin%p_desc_X => null() - mapout%p_desc_Y => mapin%p_desc_Y - mapin%p_desc_Y => null() - call psb_move_alloc(mapin%desc_X,mapout%desc_X,info) - call psb_move_alloc(mapin%desc_Y,mapout%desc_Y,info) + call psb_move_alloc(mapin%psb_base_linmap_type, & + & mapout%psb_base_linmap_type,info) call psb_move_alloc(mapin%map_X2Y,mapout%map_X2Y,info) call psb_move_alloc(mapin%map_Y2X,mapout%map_Y2X,info) end subroutine psb_slinmap_transfer + + subroutine s_free(map,info) + use psb_descriptor_type + implicit none + class(psb_slinmap_type) :: map + integer, intent(out) :: info + + call map%psb_base_linmap_type%free(info) + + call map%map_X2Y%free() + call map%map_Y2X%free() + + end subroutine s_free end module psb_s_linmap_mod + diff --git a/base/modules/psb_z_linmap_mod.f90 b/base/modules/psb_z_linmap_mod.f90 index ad37049f..6ff6fa11 100644 --- a/base/modules/psb_z_linmap_mod.f90 +++ b/base/modules/psb_z_linmap_mod.f90 @@ -31,96 +31,96 @@ !!$ ! ! -! package: psb_linmap_mod -! Defines facilities for mapping between vectors belonging +! package: psb_z_linmap_mod +! Defines data types and interfaces for mapping between vectors belonging ! to different spaces. ! module psb_z_linmap_mod use psb_const_mod - use psb_linmap_type_mod + use psb_z_mat_mod, only : psb_zspmat_type + use psb_descriptor_type, only : psb_desc_type + use psb_base_linmap_mod + + + type, extends(psb_base_linmap_type) :: psb_zlinmap_type + type(psb_zspmat_type) :: map_X2Y, map_Y2X + contains + procedure, pass(map) :: sizeof => z_map_sizeof + procedure, pass(map) :: is_asb => z_is_asb + procedure, pass(map) :: free => z_free + end type psb_zlinmap_type interface psb_map_X2Y subroutine psb_z_map_X2Y(alpha,x,beta,y,map,info,work) - use psb_linmap_type_mod + use psb_const_mod + import :: psb_zlinmap_type implicit none type(psb_zlinmap_type), intent(in) :: map - complex(psb_dpk_), intent(in) :: alpha,beta - complex(psb_dpk_), intent(inout) :: x(:) - complex(psb_dpk_), intent(out) :: y(:) - integer, intent(out) :: info - complex(psb_dpk_), optional :: work(:) + complex(psb_dpk_), intent(in) :: alpha,beta + complex(psb_dpk_), intent(inout) :: x(:) + complex(psb_dpk_), intent(out) :: y(:) + integer, intent(out) :: info + complex(psb_dpk_), optional :: work(:) end subroutine psb_z_map_X2Y subroutine psb_z_map_X2Y_vect(alpha,x,beta,y,map,info,work) + use psb_const_mod use psb_z_vect_mod - use psb_linmap_type_mod + import :: psb_zlinmap_type implicit none type(psb_zlinmap_type), intent(in) :: map - complex(psb_dpk_), intent(in) :: alpha,beta + complex(psb_dpk_), intent(in) :: alpha,beta type(psb_z_vect_type), intent(inout) :: x,y - integer, intent(out) :: info + integer, intent(out) :: info complex(psb_dpk_), optional :: work(:) end subroutine psb_z_map_X2Y_vect end interface interface psb_map_Y2X subroutine psb_z_map_Y2X(alpha,x,beta,y,map,info,work) - use psb_linmap_type_mod + use psb_const_mod + import :: psb_zlinmap_type implicit none type(psb_zlinmap_type), intent(in) :: map - complex(psb_dpk_), intent(in) :: alpha,beta - complex(psb_dpk_), intent(inout) :: x(:) - complex(psb_dpk_), intent(out) :: y(:) - integer, intent(out) :: info - complex(psb_dpk_), optional :: work(:) + complex(psb_dpk_), intent(in) :: alpha,beta + complex(psb_dpk_), intent(inout) :: x(:) + complex(psb_dpk_), intent(out) :: y(:) + integer, intent(out) :: info + complex(psb_dpk_), optional :: work(:) end subroutine psb_z_map_Y2X subroutine psb_z_map_Y2X_vect(alpha,x,beta,y,map,info,work) + use psb_const_mod use psb_z_vect_mod - use psb_linmap_type_mod + import :: psb_zlinmap_type implicit none type(psb_zlinmap_type), intent(in) :: map - complex(psb_dpk_), intent(in) :: alpha,beta + complex(psb_dpk_), intent(in) :: alpha,beta type(psb_z_vect_type), intent(inout) :: x,y - integer, intent(out) :: info + integer, intent(out) :: info complex(psb_dpk_), optional :: work(:) end subroutine psb_z_map_Y2X_vect end interface - interface psb_is_ok_map - module procedure psb_is_ok_zlinmap - end interface - - interface psb_get_map_kind - module procedure psb_get_zmap_kind - end interface - - interface psb_set_map_kind - module procedure psb_set_zmap_kind - end interface - interface psb_map_cscnv module procedure psb_z_map_cscnv end interface - interface psb_is_asb_map - module procedure psb_is_asb_zlinmap - end interface - interface psb_linmap_sub module procedure psb_z_linmap_sub end interface interface psb_move_alloc - module procedure psb_zlinmap_transfer + module procedure psb_zlinmap_transfer end interface interface psb_linmap function psb_z_linmap(map_kind,desc_X, desc_Y, map_X2Y, map_Y2X,iaggr,naggr) - use psb_linmap_type_mod + use psb_z_mat_mod, only : psb_zspmat_type + import :: psb_zlinmap_type, psb_desc_type implicit none - type(psb_zlinmap_type) :: psb_z_linmap + type(psb_zlinmap_type) :: psb_z_linmap type(psb_desc_type), target :: desc_X, desc_Y type(psb_zspmat_type), intent(in) :: map_X2Y, map_Y2X integer, intent(in) :: map_kind @@ -128,34 +128,42 @@ module psb_z_linmap_mod end function psb_z_linmap end interface - interface psb_sizeof - module procedure psb_zlinmap_sizeof - end interface + private :: z_map_sizeof, z_is_asb, z_free + + + + contains - function psb_get_zmap_kind(map) - implicit none - type(psb_zlinmap_type), intent(in) :: map - Integer :: psb_get_zmap_kind - if (allocated(map%itd_data)) then - psb_get_zmap_kind = map%itd_data(psb_map_kind_) - else - psb_get_zmap_kind = -1 - end if - end function psb_get_zmap_kind - - subroutine psb_set_zmap_kind(map_kind,map) - implicit none - integer, intent(in) :: map_kind - type(psb_zlinmap_type), intent(inout) :: map + function z_map_sizeof(map) result(val) + use psb_descriptor_type + use psb_z_mat_mod + implicit none + class(psb_zlinmap_type), intent(in) :: map + integer(psb_long_int_k_) :: val + + val = map%psb_base_linmap_type%sizeof() + val = val + map%map_X2Y%sizeof() + val = val + map%map_Y2X%sizeof() + + end function z_map_sizeof + + + function z_is_asb(map) result(val) + use psb_descriptor_type + implicit none + class(psb_zlinmap_type), intent(in) :: map + logical :: val - map%itd_data(psb_map_kind_) = map_kind + val = map%psb_base_linmap_type%is_asb() .and. & + & map%map_X2Y%is_asb() .and.map%map_Y2X%is_asb() + + end function z_is_asb - end subroutine psb_set_zmap_kind subroutine psb_z_map_cscnv(map,info,type,mold) - use psb_mat_mod + use psb_z_mat_mod implicit none type(psb_zlinmap_type), intent(inout) :: map integer, intent(out) :: info @@ -168,74 +176,9 @@ contains end subroutine psb_z_map_cscnv - function psb_is_asb_zlinmap(map) result(this) - use psb_descriptor_type - implicit none - type(psb_zlinmap_type), intent(in) :: map - logical :: this - - this = .false. - if (.not.allocated(map%itd_data)) return - select case(psb_get_map_kind(map)) - case (psb_map_aggr_) - if (.not.associated(map%p_desc_X)) return - if (.not.associated(map%p_desc_Y)) return - this = & - & psb_is_asb_desc(map%p_desc_X).and.psb_is_asb_desc(map%p_desc_Y) - - case(psb_map_gen_linear_) - - this = & - & psb_is_asb_desc(map%desc_X).and.psb_is_asb_desc(map%desc_Y) - - end select - - end function psb_is_asb_zlinmap - - function psb_is_ok_zlinmap(map) result(this) - use psb_descriptor_type - implicit none - type(psb_zlinmap_type), intent(in) :: map - logical :: this - this = .false. - if (.not.allocated(map%itd_data)) return - select case(psb_get_map_kind(map)) - case (psb_map_aggr_) - if (.not.associated(map%p_desc_X)) return - if (.not.associated(map%p_desc_Y)) return - this = & - & psb_is_ok_desc(map%p_desc_X).and.psb_is_ok_desc(map%p_desc_Y) - case(psb_map_gen_linear_) - this = & - & psb_is_ok_desc(map%desc_X).and.psb_is_ok_desc(map%desc_Y) - end select - - end function psb_is_ok_zlinmap - - function psb_zlinmap_sizeof(map) result(val) - use psb_descriptor_type - use psb_mat_mod, only : psb_sizeof - implicit none - type(psb_zlinmap_type), intent(in) :: map - integer(psb_long_int_k_) :: val - - val = 0 - if (allocated(map%itd_data)) & - & val = val + psb_sizeof_int*size(map%itd_data) - if (allocated(map%iaggr)) & - & val = val + psb_sizeof_int*size(map%iaggr) - if (allocated(map%naggr)) & - & val = val + psb_sizeof_int*size(map%naggr) - val = val + psb_sizeof(map%desc_X) - val = val + psb_sizeof(map%desc_Y) - val = val + psb_sizeof(map%map_X2Y) - val = val + psb_sizeof(map%map_Y2X) - - end function psb_zlinmap_sizeof - subroutine psb_z_linmap_sub(out_map,map_kind,desc_X, desc_Y,& & map_X2Y, map_Y2X,iaggr,naggr) - use psb_linmap_type_mod + use psb_z_mat_mod implicit none type(psb_zlinmap_type), intent(out) :: out_map type(psb_desc_type), target :: desc_X, desc_Y @@ -253,19 +196,26 @@ contains type(psb_zlinmap_type) :: mapin,mapout integer, intent(out) :: info - call psb_move_alloc(mapin%itd_data,mapout%itd_data,info) - call psb_move_alloc(mapin%iaggr,mapout%iaggr,info) - call psb_move_alloc(mapin%naggr,mapout%naggr,info) - mapout%p_desc_X => mapin%p_desc_X - mapin%p_desc_X => null() - mapout%p_desc_Y => mapin%p_desc_Y - mapin%p_desc_Y => null() - call psb_move_alloc(mapin%desc_X,mapout%desc_X,info) - call psb_move_alloc(mapin%desc_Y,mapout%desc_Y,info) + call psb_move_alloc(mapin%psb_base_linmap_type, & + & mapout%psb_base_linmap_type,info) call psb_move_alloc(mapin%map_X2Y,mapout%map_X2Y,info) call psb_move_alloc(mapin%map_Y2X,mapout%map_Y2X,info) end subroutine psb_zlinmap_transfer + + subroutine z_free(map,info) + use psb_descriptor_type + implicit none + class(psb_zlinmap_type) :: map + integer, intent(out) :: info + + call map%psb_base_linmap_type%free(info) + call map%map_X2Y%free() + call map%map_Y2X%free() + + end subroutine z_free + end module psb_z_linmap_mod + diff --git a/base/serial/impl/psb_d_csc_impl.f90 b/base/serial/impl/psb_d_csc_impl.f90 index 31e8bac9..c31fa7a0 100644 --- a/base/serial/impl/psb_d_csc_impl.f90 +++ b/base/serial/impl/psb_d_csc_impl.f90 @@ -2309,7 +2309,7 @@ subroutine psb_d_mv_csc_from_coo(a,b,info) if (i >= icl) exit inner if (i > nc) then write(debug_unit,*) trim(name),& - & 'Strange situation: i>nr ',i,nc,j,nza,icl + & ' Strange situation: i>nr ',i,nc,j,nza,icl exit outer end if a%icp(i+1) = a%icp(i) diff --git a/base/serial/impl/psb_d_csr_impl.f90 b/base/serial/impl/psb_d_csr_impl.f90 index bcd75004..2ffa5134 100644 --- a/base/serial/impl/psb_d_csr_impl.f90 +++ b/base/serial/impl/psb_d_csr_impl.f90 @@ -2609,7 +2609,7 @@ subroutine psb_d_mv_csr_from_coo(a,b,info) Integer :: nza, nr, i,j,irw, err_act, nc Integer, Parameter :: maxtry=8 integer :: debug_level, debug_unit - character(len=20) :: name='mv_from_coo' + character(len=20) :: name='csr_mv_from_coo' info = psb_success_ debug_unit = psb_get_debug_unit() diff --git a/base/tools/psb_c_map.f90 b/base/tools/psb_c_map.f90 index f14ac208..554ec25e 100644 --- a/base/tools/psb_c_map.f90 +++ b/base/tools/psb_c_map.f90 @@ -42,26 +42,26 @@ subroutine psb_c_map_X2Y(alpha,x,beta,y,map,info,work) implicit none type(psb_clinmap_type), intent(in) :: map - complex(psb_spk_), intent(in) :: alpha,beta - complex(psb_spk_), intent(inout) :: x(:) - complex(psb_spk_), intent(out) :: y(:) + complex(psb_spk_), intent(in) :: alpha,beta + complex(psb_spk_), intent(inout) :: x(:) + complex(psb_spk_), intent(out) :: y(:) integer, intent(out) :: info - complex(psb_spk_), optional :: work(:) + complex(psb_spk_), optional :: work(:) ! complex(psb_spk_), allocatable :: xt(:), yt(:) integer :: i, j, nr1, nc1,nr2, nc2,& - & map_kind, map_data, nr, ictxt + & map_kind, nr, ictxt character(len=20), parameter :: name='psb_map_X2Y' info = psb_success_ - if (.not.psb_is_asb_map(map)) then - write(psb_err_unit,*) trim(name),' Invalid descriptor input' + if (.not.map%is_asb()) then + write(psb_err_unit,*) trim(name),' Invalid map input: unassembled' info = 1 return end if - map_kind = psb_get_map_kind(map) + map_kind = map%get_kind() select case(map_kind) case(psb_map_aggr_) @@ -111,7 +111,6 @@ subroutine psb_c_map_X2Y(alpha,x,beta,y,map,info,work) end subroutine psb_c_map_X2Y - subroutine psb_c_map_X2Y_vect(alpha,x,beta,y,map,info,work) use psb_base_mod, psb_protect_name => psb_c_map_X2Y_vect implicit none @@ -124,17 +123,17 @@ subroutine psb_c_map_X2Y_vect(alpha,x,beta,y,map,info,work) type(psb_c_vect_type) :: xt, yt complex(psb_spk_), allocatable :: xta(:), yta(:) integer :: i, j, nr1, nc1,nr2, nc2 ,& - & map_kind, map_data, nr, ictxt + & map_kind, nr, ictxt character(len=20), parameter :: name='psb_map_X2Y' info = psb_success_ - if (.not.psb_is_asb_map(map)) then - write(psb_err_unit,*) trim(name),' Invalid descriptor input: unassembled' + if (.not.map%is_asb()) then + write(psb_err_unit,*) trim(name),' Invalid map input: unassembled' info = 1 return end if - map_kind = psb_get_map_kind(map) + map_kind = map%get_kind() select case(map_kind) case(psb_map_aggr_) @@ -210,23 +209,23 @@ subroutine psb_c_map_Y2X(alpha,x,beta,y,map,info,work) complex(psb_spk_), intent(in) :: alpha,beta complex(psb_spk_), intent(inout) :: x(:) complex(psb_spk_), intent(out) :: y(:) - integer, intent(out) :: info + integer, intent(out) :: info complex(psb_spk_), optional :: work(:) ! complex(psb_spk_), allocatable :: xt(:), yt(:) integer :: i, j, nr1, nc1,nr2, nc2,& - & map_kind, map_data, nr, ictxt + & map_kind, nr, ictxt character(len=20), parameter :: name='psb_map_Y2X' info = psb_success_ - if (.not.psb_is_asb_map(map)) then - write(psb_err_unit,*) trim(name),' Invalid descriptor input' + if (.not.map%is_asb()) then + write(psb_err_unit,*) trim(name),' Invalid map input: unassembled' info = 1 return end if - map_kind = psb_get_map_kind(map) + map_kind = map%get_kind() select case(map_kind) case(psb_map_aggr_) @@ -287,17 +286,17 @@ subroutine psb_c_map_Y2X_vect(alpha,x,beta,y,map,info,work) type(psb_c_vect_type) :: xt, yt complex(psb_spk_), allocatable :: xta(:), yta(:) integer :: i, j, nr1, nc1,nr2, nc2,& - & map_kind, map_data, nr, ictxt + & map_kind, nr, ictxt character(len=20), parameter :: name='psb_map_Y2X' info = psb_success_ - if (.not.psb_is_asb_map(map)) then - write(psb_err_unit,*) trim(name),' Invalid descriptor input' + if (.not.map%is_asb()) then + write(psb_err_unit,*) trim(name),' Invalid map input: unassembled' info = 1 return end if - map_kind = psb_get_map_kind(map) + map_kind = map%get_kind() select case(map_kind) case(psb_map_aggr_) @@ -356,10 +355,10 @@ subroutine psb_c_map_Y2X_vect(alpha,x,beta,y,map,info,work) end subroutine psb_c_map_Y2X_vect -function psb_c_linmap(map_kind,desc_X, desc_Y, map_X2Y, map_Y2X,iaggr,naggr) result(this) +function psb_c_linmap(map_kind,desc_X, desc_Y, map_X2Y, map_Y2X,iaggr,naggr) & + & result(this) use psb_base_mod, psb_protect_name => psb_c_linmap - implicit none type(psb_clinmap_type) :: this type(psb_desc_type), target :: desc_X, desc_Y @@ -373,7 +372,8 @@ function psb_c_linmap(map_kind,desc_X, desc_Y, map_X2Y, map_Y2X,iaggr,naggr) res info = psb_success_ select case(map_kind) case (psb_map_aggr_) - ! OK + ! OK + if (psb_is_ok_desc(desc_X)) then this%p_desc_X=>desc_X else @@ -401,12 +401,12 @@ function psb_c_linmap(map_kind,desc_X, desc_Y, map_X2Y, map_Y2X,iaggr,naggr) res case(psb_map_gen_linear_) - if (psb_is_ok_desc(desc_X)) then + if (desc_X%is_ok()) then call psb_cdcpy(desc_X, this%desc_X,info) else info = psb_err_pivot_too_small_ endif - if (psb_is_ok_desc(desc_Y)) then + if (desc_Y%is_ok()) then call psb_cdcpy(desc_Y, this%desc_Y,info) else info = psb_err_invalid_ovr_num_ @@ -421,9 +421,8 @@ function psb_c_linmap(map_kind,desc_X, desc_Y, map_X2Y, map_Y2X,iaggr,naggr) res if (info == psb_success_) call psb_clone(map_X2Y,this%map_X2Y,info) if (info == psb_success_) call psb_clone(map_Y2X,this%map_Y2X,info) - if (info == psb_success_) call psb_realloc(psb_itd_data_size_,this%itd_data,info) if (info == psb_success_) then - call psb_set_map_kind(map_kind, this) + call this%set_kind(map_kind) end if if (info /= psb_success_) then write(psb_err_unit,*) trim(name),' Invalid descriptor input' diff --git a/base/tools/psb_d_map.f90 b/base/tools/psb_d_map.f90 index 92d214b7..bcd789ea 100644 --- a/base/tools/psb_d_map.f90 +++ b/base/tools/psb_d_map.f90 @@ -39,28 +39,29 @@ ! subroutine psb_d_map_X2Y(alpha,x,beta,y,map,info,work) use psb_base_mod, psb_protect_name => psb_d_map_X2Y + implicit none type(psb_dlinmap_type), intent(in) :: map - real(psb_dpk_), intent(in) :: alpha,beta - real(psb_dpk_), intent(inout) :: x(:) - real(psb_dpk_), intent(out) :: y(:) - integer, intent(out) :: info - real(psb_dpk_), optional :: work(:) + real(psb_dpk_), intent(in) :: alpha,beta + real(psb_dpk_), intent(inout) :: x(:) + real(psb_dpk_), intent(out) :: y(:) + integer, intent(out) :: info + real(psb_dpk_), optional :: work(:) ! real(psb_dpk_), allocatable :: xt(:), yt(:) - integer :: i, j, nr1, nc1,nr2, nc2 ,& - & map_kind, map_data, nr, ictxt + integer :: i, j, nr1, nc1,nr2, nc2,& + & map_kind, nr, ictxt character(len=20), parameter :: name='psb_map_X2Y' info = psb_success_ - if (.not.psb_is_asb_map(map)) then - write(psb_err_unit,*) trim(name),' Invalid descriptor input: unassembled' + if (.not.map%is_asb()) then + write(psb_err_unit,*) trim(name),' Invalid map input: unassembled' info = 1 return end if - map_kind = psb_get_map_kind(map) + map_kind = map%get_kind() select case(map_kind) case(psb_map_aggr_) @@ -110,30 +111,29 @@ subroutine psb_d_map_X2Y(alpha,x,beta,y,map,info,work) end subroutine psb_d_map_X2Y - subroutine psb_d_map_X2Y_vect(alpha,x,beta,y,map,info,work) use psb_base_mod, psb_protect_name => psb_d_map_X2Y_vect implicit none - type(psb_dlinmap_type), intent(in) :: map - real(psb_dpk_), intent(in) :: alpha,beta - type(psb_d_vect_type), intent(inout) :: x,y - integer, intent(out) :: info - real(psb_dpk_), optional :: work(:) + type(psb_dlinmap_type), intent(in) :: map + real(psb_dpk_), intent(in) :: alpha,beta + type(psb_d_vect_type), intent(inout) :: x,y + integer, intent(out) :: info + real(psb_dpk_), optional :: work(:) ! Local - type(psb_d_vect_type) :: xt, yt - real(psb_dpk_), allocatable :: xta(:), yta(:) - integer :: i, j, nr1, nc1,nr2, nc2 ,& - & map_kind, map_data, nr, ictxt - character(len=20), parameter :: name='psb_map_X2Y' - + type(psb_d_vect_type) :: xt, yt + real(psb_dpk_), allocatable :: xta(:), yta(:) + integer :: i, j, nr1, nc1,nr2, nc2 ,& + & map_kind, nr, ictxt + character(len=20), parameter :: name='psb_map_X2Y' + info = psb_success_ - if (.not.psb_is_asb_map(map)) then - write(psb_err_unit,*) trim(name),' Invalid descriptor input: unassembled' + if (.not.map%is_asb()) then + write(psb_err_unit,*) trim(name),' Invalid map input: unassembled' info = 1 return end if - map_kind = psb_get_map_kind(map) + map_kind = map%get_kind() select case(map_kind) case(psb_map_aggr_) @@ -206,26 +206,26 @@ subroutine psb_d_map_Y2X(alpha,x,beta,y,map,info,work) implicit none type(psb_dlinmap_type), intent(in) :: map - real(psb_dpk_), intent(in) :: alpha,beta - real(psb_dpk_), intent(inout) :: x(:) - real(psb_dpk_), intent(out) :: y(:) - integer, intent(out) :: info - real(psb_dpk_), optional :: work(:) + real(psb_dpk_), intent(in) :: alpha,beta + real(psb_dpk_), intent(inout) :: x(:) + real(psb_dpk_), intent(out) :: y(:) + integer, intent(out) :: info + real(psb_dpk_), optional :: work(:) ! real(psb_dpk_), allocatable :: xt(:), yt(:) integer :: i, j, nr1, nc1,nr2, nc2,& - & map_kind, map_data, nr, ictxt + & map_kind, nr, ictxt character(len=20), parameter :: name='psb_map_Y2X' info = psb_success_ - if (.not.psb_is_asb_map(map)) then - write(psb_err_unit,*) trim(name),' Invalid descriptor input' + if (.not.map%is_asb()) then + write(psb_err_unit,*) trim(name),' Invalid map input: unassembled' info = 1 return end if - map_kind = psb_get_map_kind(map) + map_kind = map%get_kind() select case(map_kind) case(psb_map_aggr_) @@ -277,26 +277,26 @@ end subroutine psb_d_map_Y2X subroutine psb_d_map_Y2X_vect(alpha,x,beta,y,map,info,work) use psb_base_mod, psb_protect_name => psb_d_map_Y2X_vect implicit none - type(psb_dlinmap_type), intent(in) :: map - real(psb_dpk_), intent(in) :: alpha,beta - type(psb_d_vect_type), intent(inout) :: x,y - integer, intent(out) :: info - real(psb_dpk_), optional :: work(:) + type(psb_dlinmap_type), intent(in) :: map + real(psb_dpk_), intent(in) :: alpha,beta + type(psb_d_vect_type), intent(inout) :: x,y + integer, intent(out) :: info + real(psb_dpk_), optional :: work(:) ! - type(psb_d_vect_type) :: xt, yt + type(psb_d_vect_type) :: xt, yt real(psb_dpk_), allocatable :: xta(:), yta(:) - integer :: i, j, nr1, nc1,nr2, nc2,& - & map_kind, map_data, nr, ictxt - character(len=20), parameter :: name='psb_map_Y2X' + integer :: i, j, nr1, nc1,nr2, nc2,& + & map_kind, nr, ictxt + character(len=20), parameter :: name='psb_map_Y2X' info = psb_success_ - if (.not.psb_is_asb_map(map)) then - write(psb_err_unit,*) trim(name),' Invalid descriptor input' + if (.not.map%is_asb()) then + write(psb_err_unit,*) trim(name),' Invalid map input: unassembled' info = 1 return end if - map_kind = psb_get_map_kind(map) + map_kind = map%get_kind() select case(map_kind) case(psb_map_aggr_) @@ -355,10 +355,10 @@ subroutine psb_d_map_Y2X_vect(alpha,x,beta,y,map,info,work) end subroutine psb_d_map_Y2X_vect -function psb_d_linmap(map_kind,desc_X, desc_Y, map_X2Y, map_Y2X,iaggr,naggr) result(this) +function psb_d_linmap(map_kind,desc_X, desc_Y, map_X2Y, map_Y2X,iaggr,naggr) & + & result(this) use psb_base_mod, psb_protect_name => psb_d_linmap - implicit none type(psb_dlinmap_type) :: this type(psb_desc_type), target :: desc_X, desc_Y @@ -368,7 +368,6 @@ function psb_d_linmap(map_kind,desc_X, desc_Y, map_X2Y, map_Y2X,iaggr,naggr) res ! integer :: info character(len=20), parameter :: name='psb_linmap' - logical, parameter :: debug=.false. info = psb_success_ select case(map_kind) @@ -402,12 +401,12 @@ function psb_d_linmap(map_kind,desc_X, desc_Y, map_X2Y, map_Y2X,iaggr,naggr) res case(psb_map_gen_linear_) - if (psb_is_ok_desc(desc_X)) then + if (desc_X%is_ok()) then call psb_cdcpy(desc_X, this%desc_X,info) else info = psb_err_pivot_too_small_ endif - if (psb_is_ok_desc(desc_Y)) then + if (desc_Y%is_ok()) then call psb_cdcpy(desc_Y, this%desc_Y,info) else info = psb_err_invalid_ovr_num_ @@ -422,17 +421,12 @@ function psb_d_linmap(map_kind,desc_X, desc_Y, map_X2Y, map_Y2X,iaggr,naggr) res if (info == psb_success_) call psb_clone(map_X2Y,this%map_X2Y,info) if (info == psb_success_) call psb_clone(map_Y2X,this%map_Y2X,info) - if (info == psb_success_) call psb_realloc(psb_itd_data_size_,this%itd_data,info) if (info == psb_success_) then - call psb_set_map_kind(map_kind, this) + call this%set_kind(map_kind) end if if (info /= psb_success_) then write(psb_err_unit,*) trim(name),' Invalid descriptor input' return end if - if (debug) then -!!$ write(psb_err_unit,*) trim(name),' forward map:',allocated(this%map_X2Y%aspk) -!!$ write(psb_err_unit,*) trim(name),' backward map:',allocated(this%map_Y2X%aspk) - end if end function psb_d_linmap diff --git a/base/tools/psb_s_map.f90 b/base/tools/psb_s_map.f90 index 79ab1bd8..ca94dfa4 100644 --- a/base/tools/psb_s_map.f90 +++ b/base/tools/psb_s_map.f90 @@ -39,28 +39,29 @@ ! subroutine psb_s_map_X2Y(alpha,x,beta,y,map,info,work) use psb_base_mod, psb_protect_name => psb_s_map_X2Y + implicit none type(psb_slinmap_type), intent(in) :: map - real(psb_spk_), intent(in) :: alpha,beta - real(psb_spk_), intent(inout) :: x(:) - real(psb_spk_), intent(out) :: y(:) - integer, intent(out) :: info - real(psb_spk_), optional :: work(:) + real(psb_spk_), intent(in) :: alpha,beta + real(psb_spk_), intent(inout) :: x(:) + real(psb_spk_), intent(out) :: y(:) + integer, intent(out) :: info + real(psb_spk_), optional :: work(:) ! - real(psb_spk_), allocatable :: xt(:), yt(:) + real(psb_spk_), allocatable :: xt(:), yt(:) integer :: i, j, nr1, nc1,nr2, nc2,& - & map_kind, map_data, nr, ictxt + & map_kind, nr, ictxt character(len=20), parameter :: name='psb_map_X2Y' info = psb_success_ - if (.not.psb_is_asb_map(map)) then - write(psb_err_unit,*) trim(name),' Invalid descriptor input: unassembled' + if (.not.map%is_asb()) then + write(psb_err_unit,*) trim(name),' Invalid map input: unassembled' info = 1 return end if - map_kind = psb_get_map_kind(map) + map_kind = map%get_kind() select case(map_kind) case(psb_map_aggr_) @@ -99,7 +100,7 @@ subroutine psb_s_map_X2Y(alpha,x,beta,y,map,info,work) write(psb_err_unit,*) trim(name),' Error from inner routines',info info = -1 end if - + case default write(psb_err_unit,*) trim(name),' Invalid descriptor input', & @@ -110,30 +111,29 @@ subroutine psb_s_map_X2Y(alpha,x,beta,y,map,info,work) end subroutine psb_s_map_X2Y - subroutine psb_s_map_X2Y_vect(alpha,x,beta,y,map,info,work) use psb_base_mod, psb_protect_name => psb_s_map_X2Y_vect implicit none - type(psb_slinmap_type), intent(in) :: map - real(psb_spk_), intent(in) :: alpha,beta - type(psb_s_vect_type), intent(inout) :: x,y - integer, intent(out) :: info - real(psb_spk_), optional :: work(:) + type(psb_slinmap_type), intent(in) :: map + real(psb_spk_), intent(in) :: alpha,beta + type(psb_s_vect_type), intent(inout) :: x,y + integer, intent(out) :: info + real(psb_spk_), optional :: work(:) ! Local - type(psb_s_vect_type) :: xt, yt + type(psb_s_vect_type) :: xt, yt real(psb_spk_), allocatable :: xta(:), yta(:) - integer :: i, j, nr1, nc1,nr2, nc2 ,& - & map_kind, map_data, nr, ictxt - character(len=20), parameter :: name='psb_map_X2Y' + integer :: i, j, nr1, nc1,nr2, nc2 ,& + & map_kind, nr, ictxt + character(len=20), parameter :: name='psb_map_X2Y' info = psb_success_ - if (.not.psb_is_asb_map(map)) then - write(psb_err_unit,*) trim(name),' Invalid descriptor input: unassembled' + if (.not.map%is_asb()) then + write(psb_err_unit,*) trim(name),' Invalid map input: unassembled' info = 1 return end if - map_kind = psb_get_map_kind(map) + map_kind = map%get_kind() select case(map_kind) case(psb_map_aggr_) @@ -206,26 +206,26 @@ subroutine psb_s_map_Y2X(alpha,x,beta,y,map,info,work) implicit none type(psb_slinmap_type), intent(in) :: map - real(psb_spk_), intent(in) :: alpha,beta - real(psb_spk_), intent(inout) :: x(:) - real(psb_spk_), intent(out) :: y(:) - integer, intent(out) :: info - real(psb_spk_), optional :: work(:) + real(psb_spk_), intent(in) :: alpha,beta + real(psb_spk_), intent(inout) :: x(:) + real(psb_spk_), intent(out) :: y(:) + integer, intent(out) :: info + real(psb_spk_), optional :: work(:) ! real(psb_spk_), allocatable :: xt(:), yt(:) integer :: i, j, nr1, nc1,nr2, nc2,& - & map_kind, map_data, nr, ictxt + & map_kind, nr, ictxt character(len=20), parameter :: name='psb_map_Y2X' info = psb_success_ - if (.not.psb_is_asb_map(map)) then - write(psb_err_unit,*) trim(name),' Invalid descriptor input' + if (.not.map%is_asb()) then + write(psb_err_unit,*) trim(name),' Invalid map input: unassembled' info = 1 return end if - map_kind = psb_get_map_kind(map) + map_kind = map%get_kind() select case(map_kind) case(psb_map_aggr_) @@ -264,7 +264,7 @@ subroutine psb_s_map_Y2X(alpha,x,beta,y,map,info,work) write(psb_err_unit,*) trim(name),' Error from inner routines',info info = -1 end if - + case default write(psb_err_unit,*) trim(name),' Invalid descriptor input' @@ -277,26 +277,26 @@ end subroutine psb_s_map_Y2X subroutine psb_s_map_Y2X_vect(alpha,x,beta,y,map,info,work) use psb_base_mod, psb_protect_name => psb_s_map_Y2X_vect implicit none - type(psb_slinmap_type), intent(in) :: map - real(psb_spk_), intent(in) :: alpha,beta - type(psb_s_vect_type), intent(inout) :: x,y - integer, intent(out) :: info - real(psb_spk_), optional :: work(:) + type(psb_slinmap_type), intent(in) :: map + real(psb_spk_), intent(in) :: alpha,beta + type(psb_s_vect_type), intent(inout) :: x,y + integer, intent(out) :: info + real(psb_spk_), optional :: work(:) ! - type(psb_s_vect_type) :: xt, yt + type(psb_s_vect_type) :: xt, yt real(psb_spk_), allocatable :: xta(:), yta(:) - integer :: i, j, nr1, nc1,nr2, nc2,& - & map_kind, map_data, nr, ictxt - character(len=20), parameter :: name='psb_map_Y2X' + integer :: i, j, nr1, nc1,nr2, nc2,& + & map_kind, nr, ictxt + character(len=20), parameter :: name='psb_map_Y2X' info = psb_success_ - if (.not.psb_is_asb_map(map)) then - write(psb_err_unit,*) trim(name),' Invalid descriptor input' + if (.not.map%is_asb()) then + write(psb_err_unit,*) trim(name),' Invalid map input: unassembled' info = 1 return end if - map_kind = psb_get_map_kind(map) + map_kind = map%get_kind() select case(map_kind) case(psb_map_aggr_) @@ -355,22 +355,21 @@ subroutine psb_s_map_Y2X_vect(alpha,x,beta,y,map,info,work) end subroutine psb_s_map_Y2X_vect -function psb_s_linmap(map_kind,desc_X, desc_Y, map_X2Y, map_Y2X,iaggr,naggr) result(this) +function psb_s_linmap(map_kind,desc_X, desc_Y, map_X2Y, map_Y2X,iaggr,naggr) & + & result(this) use psb_base_mod, psb_protect_name => psb_s_linmap - implicit none - type(psb_slinmap_type) :: this - type(psb_desc_type), target :: desc_X, desc_Y + type(psb_slinmap_type) :: this + type(psb_desc_type), target :: desc_X, desc_Y type(psb_sspmat_type), intent(in) :: map_X2Y, map_Y2X - integer, intent(in) :: map_kind - integer, intent(in), optional :: iaggr(:), naggr(:) + integer, intent(in) :: map_kind + integer, intent(in), optional :: iaggr(:), naggr(:) ! integer :: info character(len=20), parameter :: name='psb_linmap' info = psb_success_ - select case(map_kind) case (psb_map_aggr_) ! OK @@ -402,12 +401,12 @@ function psb_s_linmap(map_kind,desc_X, desc_Y, map_X2Y, map_Y2X,iaggr,naggr) res case(psb_map_gen_linear_) - if (psb_is_ok_desc(desc_X)) then + if (desc_X%is_ok()) then call psb_cdcpy(desc_X, this%desc_X,info) else info = psb_err_pivot_too_small_ endif - if (psb_is_ok_desc(desc_Y)) then + if (desc_Y%is_ok()) then call psb_cdcpy(desc_Y, this%desc_Y,info) else info = psb_err_invalid_ovr_num_ @@ -419,13 +418,11 @@ function psb_s_linmap(map_kind,desc_X, desc_Y, map_X2Y, map_Y2X,iaggr,naggr) res write(psb_err_unit,*) 'Bad map kind into psb_linmap ',map_kind info = 1 end select - if (info == psb_success_) call psb_clone(map_X2Y,this%map_X2Y,info) if (info == psb_success_) call psb_clone(map_Y2X,this%map_Y2X,info) - if (info == psb_success_) call psb_realloc(psb_itd_data_size_,this%itd_data,info) if (info == psb_success_) then - call psb_set_map_kind(map_kind, this) + call this%set_kind(map_kind) end if if (info /= psb_success_) then write(psb_err_unit,*) trim(name),' Invalid descriptor input' @@ -433,4 +430,3 @@ function psb_s_linmap(map_kind,desc_X, desc_Y, map_X2Y, map_Y2X,iaggr,naggr) res end if end function psb_s_linmap - diff --git a/base/tools/psb_z_map.f90 b/base/tools/psb_z_map.f90 index 46025d7c..cf50c09b 100644 --- a/base/tools/psb_z_map.f90 +++ b/base/tools/psb_z_map.f90 @@ -51,17 +51,17 @@ subroutine psb_z_map_X2Y(alpha,x,beta,y,map,info,work) ! complex(psb_dpk_), allocatable :: xt(:), yt(:) integer :: i, j, nr1, nc1,nr2, nc2,& - & map_kind, map_data, nr, ictxt + & map_kind, nr, ictxt character(len=20), parameter :: name='psb_map_X2Y' info = psb_success_ - if (.not.psb_is_asb_map(map)) then - write(psb_err_unit,*) trim(name),' Invalid descriptor input' + if (.not.map%is_asb()) then + write(psb_err_unit,*) trim(name),' Invalid map input: unassembled' info = 1 return end if - map_kind = psb_get_map_kind(map) + map_kind = map%get_kind() select case(map_kind) case(psb_map_aggr_) @@ -123,17 +123,17 @@ subroutine psb_z_map_X2Y_vect(alpha,x,beta,y,map,info,work) type(psb_z_vect_type) :: xt, yt complex(psb_dpk_), allocatable :: xta(:), yta(:) integer :: i, j, nr1, nc1,nr2, nc2 ,& - & map_kind, map_data, nr, ictxt + & map_kind, nr, ictxt character(len=20), parameter :: name='psb_map_X2Y' info = psb_success_ - if (.not.psb_is_asb_map(map)) then - write(psb_err_unit,*) trim(name),' Invalid descriptor input: unassembled' + if (.not.map%is_asb()) then + write(psb_err_unit,*) trim(name),' Invalid map input: unassembled' info = 1 return end if - map_kind = psb_get_map_kind(map) + map_kind = map%get_kind() select case(map_kind) case(psb_map_aggr_) @@ -215,17 +215,17 @@ subroutine psb_z_map_Y2X(alpha,x,beta,y,map,info,work) ! complex(psb_dpk_), allocatable :: xt(:), yt(:) integer :: i, j, nr1, nc1,nr2, nc2,& - & map_kind, map_data, nr, ictxt + & map_kind, nr, ictxt character(len=20), parameter :: name='psb_map_Y2X' info = psb_success_ - if (.not.psb_is_asb_map(map)) then - write(psb_err_unit,*) trim(name),' Invalid descriptor input' + if (.not.map%is_asb()) then + write(psb_err_unit,*) trim(name),' Invalid map input: unassembled' info = 1 return end if - map_kind = psb_get_map_kind(map) + map_kind = map%get_kind() select case(map_kind) case(psb_map_aggr_) @@ -286,17 +286,17 @@ subroutine psb_z_map_Y2X_vect(alpha,x,beta,y,map,info,work) type(psb_z_vect_type) :: xt, yt complex(psb_dpk_), allocatable :: xta(:), yta(:) integer :: i, j, nr1, nc1,nr2, nc2,& - & map_kind, map_data, nr, ictxt + & map_kind, nr, ictxt character(len=20), parameter :: name='psb_map_Y2X' info = psb_success_ - if (.not.psb_is_asb_map(map)) then - write(psb_err_unit,*) trim(name),' Invalid descriptor input' + if (.not.map%is_asb()) then + write(psb_err_unit,*) trim(name),' Invalid map input: unassembled' info = 1 return end if - map_kind = psb_get_map_kind(map) + map_kind = map%get_kind() select case(map_kind) case(psb_map_aggr_) @@ -355,10 +355,10 @@ subroutine psb_z_map_Y2X_vect(alpha,x,beta,y,map,info,work) end subroutine psb_z_map_Y2X_vect -function psb_z_linmap(map_kind,desc_X, desc_Y, map_X2Y, map_Y2X,iaggr,naggr) result(this) +function psb_z_linmap(map_kind,desc_X, desc_Y, map_X2Y, map_Y2X,iaggr,naggr) & + & result(this) use psb_base_mod, psb_protect_name => psb_z_linmap - implicit none type(psb_zlinmap_type) :: this type(psb_desc_type), target :: desc_X, desc_Y @@ -401,12 +401,12 @@ function psb_z_linmap(map_kind,desc_X, desc_Y, map_X2Y, map_Y2X,iaggr,naggr) res case(psb_map_gen_linear_) - if (psb_is_ok_desc(desc_X)) then + if (desc_X%is_ok()) then call psb_cdcpy(desc_X, this%desc_X,info) else info = psb_err_pivot_too_small_ endif - if (psb_is_ok_desc(desc_Y)) then + if (desc_Y%is_ok()) then call psb_cdcpy(desc_Y, this%desc_Y,info) else info = psb_err_invalid_ovr_num_ @@ -421,9 +421,8 @@ function psb_z_linmap(map_kind,desc_X, desc_Y, map_X2Y, map_Y2X,iaggr,naggr) res if (info == psb_success_) call psb_clone(map_X2Y,this%map_X2Y,info) if (info == psb_success_) call psb_clone(map_Y2X,this%map_Y2X,info) - if (info == psb_success_) call psb_realloc(psb_itd_data_size_,this%itd_data,info) if (info == psb_success_) then - call psb_set_map_kind(map_kind, this) + call this%set_kind(map_kind) end if if (info /= psb_success_) then write(psb_err_unit,*) trim(name),' Invalid descriptor input'