From e9a8814338beed912bbe8cf7c989f38931af63ff Mon Sep 17 00:00:00 2001 From: Salvatore Filippone Date: Thu, 7 May 2020 12:45:03 +0200 Subject: [PATCH 1/4] Change default order for DUPL constants. --- base/modules/psb_const_mod.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/base/modules/psb_const_mod.F90 b/base/modules/psb_const_mod.F90 index 648a1669..26a100a7 100644 --- a/base/modules/psb_const_mod.F90 +++ b/base/modules/psb_const_mod.F90 @@ -215,8 +215,8 @@ module psb_const_mod ! Duplicate coefficients handling ! These are usually set while calling spcnv as one of its ! optional arugments. - integer(psb_ipk_), parameter :: psb_dupl_ovwrt_ = 0 - integer(psb_ipk_), parameter :: psb_dupl_add_ = 1 + integer(psb_ipk_), parameter :: psb_dupl_add_ = 0 + integer(psb_ipk_), parameter :: psb_dupl_ovwrt_ = 1 integer(psb_ipk_), parameter :: psb_dupl_err_ = 2 integer(psb_ipk_), parameter :: psb_dupl_def_ = psb_dupl_add_ ! Matrix update mode From 82d4e3704316103363c4529ea43e4930842014ea Mon Sep 17 00:00:00 2001 From: Salvatore Filippone Date: Thu, 7 May 2020 12:45:29 +0200 Subject: [PATCH 2/4] Fix METIS partition module for Intel compilers. --- util/psb_metispart_mod.F90 | 89 +++++++++++++++++--------------------- 1 file changed, 39 insertions(+), 50 deletions(-) diff --git a/util/psb_metispart_mod.F90 b/util/psb_metispart_mod.F90 index 2e5c3c8b..7657a91a 100644 --- a/util/psb_metispart_mod.F90 +++ b/util/psb_metispart_mod.F90 @@ -65,12 +65,8 @@ module psb_metispart_mod integer(psb_ipk_), allocatable, save :: graph_vect(:) interface build_mtpart - module procedure build_mtpart,& - & d_mat_build_mtpart, s_mat_build_mtpart,& - & z_mat_build_mtpart, c_mat_build_mtpart, & - & d_csr_build_mtpart, s_csr_build_mtpart,& - & z_csr_build_mtpart, c_csr_build_mtpart - + module procedure d_mat_build_mtpart, s_mat_build_mtpart,& + & z_mat_build_mtpart, c_mat_build_mtpart end interface contains @@ -180,9 +176,9 @@ contains end if end if if (allocated(wgh_)) then - call build_mtpart(a%get_nrows(),a%get_fmt(),a%ja,a%irp,nparts,wgh_) + call inner_build_mtpart(a%get_nrows(),a%ja,a%irp,nparts,wgh_) else - call build_mtpart(a%get_nrows(),a%get_fmt(),a%ja,a%irp,nparts) + call inner_build_mtpart(a%get_nrows(),a%ja,a%irp,nparts) end if end subroutine d_csr_build_mtpart @@ -219,9 +215,9 @@ contains end if end if if (allocated(wgh_)) then - call build_mtpart(a%get_nrows(),a%get_fmt(),a%ja,a%irp,nparts,wgh_) + call inner_build_mtpart(a%get_nrows(),a%ja,a%irp,nparts,wgh_) else - call build_mtpart(a%get_nrows(),a%get_fmt(),a%ja,a%irp,nparts) + call inner_build_mtpart(a%get_nrows(),a%ja,a%irp,nparts) end if end subroutine z_csr_build_mtpart @@ -268,7 +264,7 @@ contains real(psb_spk_), optional :: weights(:) - call build_mtpart(a%get_nrows(),a%get_fmt(),a%ja,a%irp,nparts,weights) + call inner_build_mtpart(a%get_nrows(),a%ja,a%irp,nparts,weights) end subroutine c_csr_build_mtpart @@ -280,21 +276,20 @@ contains real(psb_spk_), optional :: weights(:) - call build_mtpart(a%get_nrows(),a%get_fmt(),a%ja,a%irp,nparts,weights) + call inner_build_mtpart(a%get_nrows(),a%ja,a%irp,nparts,weights) end subroutine s_csr_build_mtpart - subroutine build_mtpart(n,fida,ja,irp,nparts,weights) + subroutine inner_build_mtpart(n,ja,irp,nparts,weights) use psb_base_mod + use iso_c_binding implicit none - integer(psb_ipk_) :: nparts - integer(psb_ipk_) :: ja(:), irp(:) + integer(psb_ipk_), intent(in) :: nparts + integer(psb_ipk_), intent(in) :: ja(:), irp(:) + real(psb_spk_),optional, intent(in) :: weights(:) + ! local variables integer(psb_ipk_) :: n, i,numflag,nedc,wgflag - character(len=5) :: fida - integer(psb_ipk_), parameter :: nb=512 - real(psb_dpk_), parameter :: seed=12345.d0 integer(psb_ipk_) :: iopt(10),idummy(2),jdummy(2), info - real(psb_spk_),optional :: weights(:) integer(psb_ipk_) :: nl,nptl integer(psb_ipk_), allocatable :: irpl(:),jal(:),gvl(:) real(psb_spk_),allocatable :: wgh_(:) @@ -332,46 +327,40 @@ contains return endif if (nparts > 1) then - if (psb_toupper(fida) == 'CSR') then - iopt(1) = 0 - numflag = 1 - wgflag = 0 + iopt(1) = 0 + numflag = 1 + wgflag = 0 !!$ write(*,*) 'Before allocation',nparts - irpl=irp - jal = ja - nl = n - nptl = nparts - wgh_ = -1.0 - if(present(weights)) then - if (size(weights) == nptl) then + irpl=irp + jal = ja + nl = n + nptl = nparts + wgh_ = -1.0 + if(present(weights)) then + if (size(weights) == nptl) then !!$ write(*,*) 'weights present',weights - ! call METIS_PartGraphKway(n,irp,ja,idummy,jdummy,& - ! & wgflag,numflag,nparts,weights,iopt,nedc,graph_vect) - info = METIS_PartGraphKway(nl,irpl,jal,idummy,jdummy,& - & nptl,weights,gvl) + ! call METIS_PartGraphKway(n,irp,ja,idummy,jdummy,& + ! & wgflag,numflag,nparts,weights,iopt,nedc,graph_vect) + info = METIS_PartGraphKway(nl,irpl,jal,idummy,jdummy,& + & nptl,weights,gvl) - else -!!$ write(*,*) 'weights absent',wgh_ - info = METIS_PartGraphKway(nl,irpl,jal,idummy,jdummy,& - & nptl,wgh_,gvl) - end if else -!!$ write(*,*) 'weights absent',wgh_ +!!$ write(*,*) 'weights absent',wgh_ info = METIS_PartGraphKway(nl,irpl,jal,idummy,jdummy,& & nptl,wgh_,gvl) - endif -!!$ write(*,*) 'after allocation',info - - do i=1, n - graph_vect(i) = gvl(i) - 1 - enddo + end if else - write(psb_err_unit,*) 'Fatal error in BUILD_MTPART: matrix format ',& - & ' failure. ', FIDA - return +!!$ write(*,*) 'weights absent',wgh_ + info = METIS_PartGraphKway(nl,irpl,jal,idummy,jdummy,& + & nptl,wgh_,gvl) endif +!!$ write(*,*) 'after allocation',info + + do i=1, n + graph_vect(i) = gvl(i) - 1 + enddo else do i=1, n graph_vect(i) = 0 @@ -383,7 +372,7 @@ contains return - end subroutine build_mtpart + end subroutine inner_build_mtpart ! ! WARNING: called IRET otherwise Intel compiler complains, From b41e57f7c0c846faa6b164cd330d045b3d95aec9 Mon Sep 17 00:00:00 2001 From: Salvatore Filippone Date: Sun, 10 May 2020 17:47:24 +0200 Subject: [PATCH 3/4] Fix METIS interface for Intel compiler. --- util/Makefile | 2 +- util/psb_metispart_mod.F90 | 122 ++++++------------------------------- util/psi_build_mtpart.F90 | 95 +++++++++++++++++++++++++++++ 3 files changed, 116 insertions(+), 103 deletions(-) create mode 100644 util/psi_build_mtpart.F90 diff --git a/util/Makefile b/util/Makefile index 1359a762..0f572e9c 100644 --- a/util/Makefile +++ b/util/Makefile @@ -18,7 +18,7 @@ IMPLOBJS= psb_s_hbio_impl.o psb_d_hbio_impl.o \ psb_s_mat_dist_impl.o psb_d_mat_dist_impl.o \ psb_c_mat_dist_impl.o psb_z_mat_dist_impl.o \ psb_s_renum_impl.o psb_d_renum_impl.o \ - psb_c_renum_impl.o psb_z_renum_impl.o + psb_c_renum_impl.o psb_z_renum_impl.o psi_build_mtpart.o MODOBJS=psb_util_mod.o $(BASEOBJS) COBJS=metis_int.o psb_amd_order.o diff --git a/util/psb_metispart_mod.F90 b/util/psb_metispart_mod.F90 index 7657a91a..425d8106 100644 --- a/util/psb_metispart_mod.F90 +++ b/util/psb_metispart_mod.F90 @@ -56,7 +56,7 @@ module psb_metispart_mod use psb_base_mod, only : psb_sspmat_type, psb_cspmat_type,& & psb_dspmat_type, psb_zspmat_type, psb_err_unit, & - & psb_ipk_, psb_lpk_, psb_mpk_, psb_epk_, & + & psb_ipk_, psb_lpk_, psb_mpk_, psb_epk_, psb_spk_,& & psb_s_csr_sparse_mat, psb_d_csr_sparse_mat, & & psb_c_csr_sparse_mat, psb_z_csr_sparse_mat public part_graph, build_mtpart, distr_mtpart,& @@ -69,10 +69,22 @@ module psb_metispart_mod & z_mat_build_mtpart, c_mat_build_mtpart end interface + interface + subroutine psi_build_mtpart(n,ja,irp,nparts,vect, weights) + import :: psb_ipk_, psb_spk_ + implicit none + integer(psb_ipk_), intent(in) :: n, nparts + integer(psb_ipk_), intent(in) :: ja(:), irp(:) + integer(psb_ipk_), allocatable, intent(inout) :: vect(:) + real(psb_spk_),optional, intent(in) :: weights(:) + + end subroutine psi_build_mtpart + end interface + contains subroutine part_graph(global_indx,n,np,pv,nv) - implicit none + implicit none integer(psb_lpk_), intent(in) :: global_indx, n integer(psb_ipk_), intent(in) :: np integer(psb_ipk_), intent(out) :: nv @@ -176,9 +188,9 @@ contains end if end if if (allocated(wgh_)) then - call inner_build_mtpart(a%get_nrows(),a%ja,a%irp,nparts,wgh_) + call psi_build_mtpart(a%get_nrows(),a%ja,a%irp,nparts,graph_vect,wgh_) else - call inner_build_mtpart(a%get_nrows(),a%ja,a%irp,nparts) + call psi_build_mtpart(a%get_nrows(),a%ja,a%irp,nparts,graph_vect) end if end subroutine d_csr_build_mtpart @@ -215,9 +227,9 @@ contains end if end if if (allocated(wgh_)) then - call inner_build_mtpart(a%get_nrows(),a%ja,a%irp,nparts,wgh_) + call psi_build_mtpart(a%get_nrows(),a%ja,a%irp,nparts,graph_vect,wgh_) else - call inner_build_mtpart(a%get_nrows(),a%ja,a%irp,nparts) + call psi_build_mtpart(a%get_nrows(),a%ja,a%irp,nparts,graph_vect) end if end subroutine z_csr_build_mtpart @@ -264,7 +276,7 @@ contains real(psb_spk_), optional :: weights(:) - call inner_build_mtpart(a%get_nrows(),a%ja,a%irp,nparts,weights) + call psi_build_mtpart(a%get_nrows(),a%ja,a%irp,nparts,graph_vect,weights) end subroutine c_csr_build_mtpart @@ -276,104 +288,10 @@ contains real(psb_spk_), optional :: weights(:) - call inner_build_mtpart(a%get_nrows(),a%ja,a%irp,nparts,weights) + call psi_build_mtpart(a%get_nrows(),a%ja,a%irp,nparts,graph_vect,weights) end subroutine s_csr_build_mtpart - subroutine inner_build_mtpart(n,ja,irp,nparts,weights) - use psb_base_mod - use iso_c_binding - implicit none - integer(psb_ipk_), intent(in) :: nparts - integer(psb_ipk_), intent(in) :: ja(:), irp(:) - real(psb_spk_),optional, intent(in) :: weights(:) - ! local variables - integer(psb_ipk_) :: n, i,numflag,nedc,wgflag - integer(psb_ipk_) :: iopt(10),idummy(2),jdummy(2), info - integer(psb_ipk_) :: nl,nptl - integer(psb_ipk_), allocatable :: irpl(:),jal(:),gvl(:) - real(psb_spk_),allocatable :: wgh_(:) - -#if defined(HAVE_METIS) && defined(IPK4) - interface - ! subroutine METIS_PartGraphKway(n,ixadj,iadj,ivwg,iajw,& - ! & wgflag,numflag,nparts,weights,iopt,nedc,part) bind(c) - ! use iso_c_binding - ! integer(c_int) :: n,wgflag,numflag,nparts,nedc - ! integer(c_int) :: ixadj(*),iadj(*),ivwg(*),iajw(*),iopt(*),part(*) - ! real(c_float) :: weights(*) - ! !integer(psb_ipk_) :: n,wgflag,numflag,nparts,nedc - ! !integer(psb_ipk_) :: ixadj(*),iadj(*),ivwg(*),iajw(*),iopt(*),part(*) - ! end subroutine METIS_PartGraphKway - - function METIS_PartGraphKway(n,ixadj,iadj,ivwg,iajw,& - & nparts,weights,part) bind(c,name="metis_PartGraphKway_C") result(res) - use iso_c_binding - integer(c_int) :: res - integer(c_int) :: n,nparts - integer(c_int) :: ixadj(*),iadj(*),ivwg(*),iajw(*),part(*) - real(c_float) :: weights(*) - !integer(psb_ipk_) :: n,wgflag,numflag,nparts,nedc - !integer(psb_ipk_) :: ixadj(*),iadj(*),ivwg(*),iajw(*),iopt(*),part(*) - end function METIS_PartGraphKway - end interface - - call psb_realloc(n,graph_vect,info) - if (info == psb_success_) allocate(gvl(n),wgh_(nparts),stat=info) - - if (info /= psb_success_) then - write(psb_err_unit,*) 'Fatal error in BUILD_MTPART: memory allocation ',& - & ' failure.' - return - endif - if (nparts > 1) then - iopt(1) = 0 - numflag = 1 - wgflag = 0 - -!!$ write(*,*) 'Before allocation',nparts - - irpl=irp - jal = ja - nl = n - nptl = nparts - wgh_ = -1.0 - if(present(weights)) then - if (size(weights) == nptl) then -!!$ write(*,*) 'weights present',weights - ! call METIS_PartGraphKway(n,irp,ja,idummy,jdummy,& - ! & wgflag,numflag,nparts,weights,iopt,nedc,graph_vect) - info = METIS_PartGraphKway(nl,irpl,jal,idummy,jdummy,& - & nptl,weights,gvl) - - else -!!$ write(*,*) 'weights absent',wgh_ - info = METIS_PartGraphKway(nl,irpl,jal,idummy,jdummy,& - & nptl,wgh_,gvl) - end if - else -!!$ write(*,*) 'weights absent',wgh_ - info = METIS_PartGraphKway(nl,irpl,jal,idummy,jdummy,& - & nptl,wgh_,gvl) - endif -!!$ write(*,*) 'after allocation',info - - do i=1, n - graph_vect(i) = gvl(i) - 1 - enddo - else - do i=1, n - graph_vect(i) = 0 - enddo - endif -#else - write(psb_err_unit,*) 'Warning: METIS was not configured at PSBLAS compile time !' -#endif - - return - - end subroutine inner_build_mtpart - ! ! WARNING: called IRET otherwise Intel compiler complains, ! methinks it's a compiler bug, will need to report. diff --git a/util/psi_build_mtpart.F90 b/util/psi_build_mtpart.F90 new file mode 100644 index 00000000..b8974185 --- /dev/null +++ b/util/psi_build_mtpart.F90 @@ -0,0 +1,95 @@ + +subroutine psi_build_mtpart(n,ja,irp,nparts,graph_vect,weights) + use psb_base_mod + use iso_c_binding + implicit none + integer(psb_ipk_), intent(in) :: n, nparts + integer(psb_ipk_), intent(in) :: ja(:), irp(:) + integer(psb_ipk_), allocatable, intent(inout) :: graph_vect(:) + real(psb_spk_),optional, intent(in) :: weights(:) + ! local variables + integer(psb_ipk_) :: i,numflag, nedc,wgflag + integer(psb_ipk_) :: iopt(10),idummy(2),jdummy(2), info + integer(psb_ipk_) :: nl,nptl + integer(psb_ipk_), allocatable :: irpl(:),jal(:),gvl(:) + real(psb_spk_),allocatable :: wgh_(:) + +#if defined(HAVE_METIS) && defined(IPK4) + interface + ! subroutine METIS_PartGraphKway(n,ixadj,iadj,ivwg,iajw,& + ! & wgflag,numflag,nparts,weights,iopt,nedc,part) bind(c) + ! use iso_c_binding + ! integer(c_int) :: n,wgflag,numflag,nparts,nedc + ! integer(c_int) :: ixadj(*),iadj(*),ivwg(*),iajw(*),iopt(*),part(*) + ! real(c_float) :: weights(*) + ! !integer(psb_ipk_) :: n,wgflag,numflag,nparts,nedc + ! !integer(psb_ipk_) :: ixadj(*),iadj(*),ivwg(*),iajw(*),iopt(*),part(*) + ! end subroutine METIS_PartGraphKway + + function METIS_PartGraphKway(n,ixadj,iadj,ivwg,iajw,& + & nparts,weights,part) bind(c,name="metis_PartGraphKway_C") result(res) + use iso_c_binding + integer(c_int) :: res + integer(c_int) :: n,nparts + integer(c_int) :: ixadj(*),iadj(*),ivwg(*),iajw(*),part(*) + real(c_float) :: weights(*) + !integer(psb_ipk_) :: n,wgflag,numflag,nparts,nedc + !integer(psb_ipk_) :: ixadj(*),iadj(*),ivwg(*),iajw(*),iopt(*),part(*) + end function METIS_PartGraphKway + end interface + + call psb_realloc(n,graph_vect,info) + if (info == psb_success_) allocate(gvl(n),wgh_(nparts),stat=info) + + if (info /= psb_success_) then + write(psb_err_unit,*) 'Fatal error in BUILD_MTPART: memory allocation ',& + & ' failure.' + return + endif + if (nparts > 1) then + iopt(1) = 0 + numflag = 1 + wgflag = 0 + +!!$ write(*,*) 'Before allocation',nparts + + irpl=irp + jal = ja + nl = n + nptl = nparts + wgh_ = -1.0 + if(present(weights)) then + if (size(weights) == nptl) then +!!$ write(*,*) 'weights present',weights + ! call METIS_PartGraphKway(n,irp,ja,idummy,jdummy,& + ! & wgflag,numflag,nparts,weights,iopt,nedc,graph_vect) + info = METIS_PartGraphKway(nl,irpl,jal,idummy,jdummy,& + & nptl,weights,gvl) + + else +!!$ write(*,*) 'weights absent',wgh_ + info = METIS_PartGraphKway(nl,irpl,jal,idummy,jdummy,& + & nptl,wgh_,gvl) + end if + else +!!$ write(*,*) 'weights absent',wgh_ + info = METIS_PartGraphKway(nl,irpl,jal,idummy,jdummy,& + & nptl,wgh_,gvl) + endif +!!$ write(*,*) 'after allocation',info + + do i=1, n + graph_vect(i) = gvl(i) - 1 + enddo + else + do i=1, n + graph_vect(i) = 0 + enddo + endif +#else + write(psb_err_unit,*) 'Warning: METIS was not configured at PSBLAS compile time !' +#endif + + return + +end subroutine psi_build_mtpart From 487b2c2e1d156848804d3a452a2e0411bd20883c Mon Sep 17 00:00:00 2001 From: Salvatore Filippone Date: Wed, 13 May 2020 11:57:06 +0200 Subject: [PATCH 4/4] Defined reallocate and safe_ab_cpy for intrinsic scalars. --- base/modules/auxil/psb_c_realloc_mod.F90 | 81 ++++++++++++++++++++++- base/modules/auxil/psb_d_realloc_mod.F90 | 81 ++++++++++++++++++++++- base/modules/auxil/psb_e_realloc_mod.F90 | 81 ++++++++++++++++++++++- base/modules/auxil/psb_i2_realloc_mod.F90 | 81 ++++++++++++++++++++++- base/modules/auxil/psb_m_realloc_mod.F90 | 81 ++++++++++++++++++++++- base/modules/auxil/psb_s_realloc_mod.F90 | 81 ++++++++++++++++++++++- base/modules/auxil/psb_z_realloc_mod.F90 | 81 ++++++++++++++++++++++- 7 files changed, 560 insertions(+), 7 deletions(-) diff --git a/base/modules/auxil/psb_c_realloc_mod.F90 b/base/modules/auxil/psb_c_realloc_mod.F90 index b9f3642b..e8f169d8 100644 --- a/base/modules/auxil/psb_c_realloc_mod.F90 +++ b/base/modules/auxil/psb_c_realloc_mod.F90 @@ -39,6 +39,7 @@ module psb_c_realloc_mod ! the size specified, possibly shortening it. ! Interface psb_realloc + module procedure psb_r_c_s module procedure psb_r_m_c_rk1 module procedure psb_r_m_c_rk2 module procedure psb_r_e_c_rk1 @@ -56,7 +57,7 @@ module psb_c_realloc_mod end interface psb_move_alloc Interface psb_safe_ab_cpy - module procedure psb_ab_cpy_c_rk1, psb_ab_cpy_c_rk2 + module procedure psb_ab_cpy_c_s, psb_ab_cpy_c_rk1, psb_ab_cpy_c_rk2 end Interface psb_safe_ab_cpy Interface psb_safe_cpy @@ -82,6 +83,42 @@ module psb_c_realloc_mod Contains + Subroutine psb_r_c_s(rrax,info) + use psb_error_mod + + ! ...Subroutine Arguments + complex(psb_spk_), allocatable, intent(inout) :: rrax + integer(psb_ipk_) :: info + + ! ...Local Variables + integer(psb_ipk_) :: err_act,err + character(len=20) :: name + logical, parameter :: debug=.false. + + name='psb_r_c_s' + call psb_erractionsave(err_act) + info=psb_success_ + + if (.not.allocated(rrax)) then + Allocate(rrax,stat=info) + if (info /= psb_success_) then + err=4025 + call psb_errpush(err,name, l_err=(/1_psb_lpk_/), & + & a_err='complex(psb_spk_)') + goto 9999 + end if + endif + + call psb_erractionrestore(err_act) + return + +9999 continue + info = err + call psb_error_handler(err_act) + return + + End Subroutine psb_r_c_s + Subroutine psb_r_m_c_rk1(len,rrax,info,pad,lb) use psb_error_mod @@ -687,6 +724,48 @@ Contains + subroutine psb_ab_cpy_c_s(vin,vout,info) + use psb_error_mod + + ! ...Subroutine Arguments + complex(psb_spk_), allocatable, intent(in) :: vin + complex(psb_spk_), allocatable, intent(out) :: vout + integer(psb_ipk_) :: info + ! ...Local Variables + + integer(psb_ipk_) :: isz,err_act,lb + character(len=20) :: name, char_err + logical, parameter :: debug=.false. + + name='psb_ab_cpy_c_s' + call psb_erractionsave(err_act) + info=psb_success_ + if(psb_errstatus_fatal()) then + info=psb_err_from_subroutine_ + goto 9999 + end if + + if (allocated(vin)) then + call psb_realloc(vout,info) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + char_err='psb_realloc' + call psb_errpush(info,name,a_err=char_err) + goto 9999 + else + vout = vin + endif + endif + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + + end subroutine psb_ab_cpy_c_s + subroutine psb_ab_cpy_c_rk1(vin,vout,info) use psb_error_mod diff --git a/base/modules/auxil/psb_d_realloc_mod.F90 b/base/modules/auxil/psb_d_realloc_mod.F90 index 43ac9125..f8326f41 100644 --- a/base/modules/auxil/psb_d_realloc_mod.F90 +++ b/base/modules/auxil/psb_d_realloc_mod.F90 @@ -39,6 +39,7 @@ module psb_d_realloc_mod ! the size specified, possibly shortening it. ! Interface psb_realloc + module procedure psb_r_d_s module procedure psb_r_m_d_rk1 module procedure psb_r_m_d_rk2 module procedure psb_r_e_d_rk1 @@ -56,7 +57,7 @@ module psb_d_realloc_mod end interface psb_move_alloc Interface psb_safe_ab_cpy - module procedure psb_ab_cpy_d_rk1, psb_ab_cpy_d_rk2 + module procedure psb_ab_cpy_d_s, psb_ab_cpy_d_rk1, psb_ab_cpy_d_rk2 end Interface psb_safe_ab_cpy Interface psb_safe_cpy @@ -82,6 +83,42 @@ module psb_d_realloc_mod Contains + Subroutine psb_r_d_s(rrax,info) + use psb_error_mod + + ! ...Subroutine Arguments + real(psb_dpk_), allocatable, intent(inout) :: rrax + integer(psb_ipk_) :: info + + ! ...Local Variables + integer(psb_ipk_) :: err_act,err + character(len=20) :: name + logical, parameter :: debug=.false. + + name='psb_r_d_s' + call psb_erractionsave(err_act) + info=psb_success_ + + if (.not.allocated(rrax)) then + Allocate(rrax,stat=info) + if (info /= psb_success_) then + err=4025 + call psb_errpush(err,name, l_err=(/1_psb_lpk_/), & + & a_err='real(psb_dpk_)') + goto 9999 + end if + endif + + call psb_erractionrestore(err_act) + return + +9999 continue + info = err + call psb_error_handler(err_act) + return + + End Subroutine psb_r_d_s + Subroutine psb_r_m_d_rk1(len,rrax,info,pad,lb) use psb_error_mod @@ -687,6 +724,48 @@ Contains + subroutine psb_ab_cpy_d_s(vin,vout,info) + use psb_error_mod + + ! ...Subroutine Arguments + real(psb_dpk_), allocatable, intent(in) :: vin + real(psb_dpk_), allocatable, intent(out) :: vout + integer(psb_ipk_) :: info + ! ...Local Variables + + integer(psb_ipk_) :: isz,err_act,lb + character(len=20) :: name, char_err + logical, parameter :: debug=.false. + + name='psb_ab_cpy_d_s' + call psb_erractionsave(err_act) + info=psb_success_ + if(psb_errstatus_fatal()) then + info=psb_err_from_subroutine_ + goto 9999 + end if + + if (allocated(vin)) then + call psb_realloc(vout,info) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + char_err='psb_realloc' + call psb_errpush(info,name,a_err=char_err) + goto 9999 + else + vout = vin + endif + endif + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + + end subroutine psb_ab_cpy_d_s + subroutine psb_ab_cpy_d_rk1(vin,vout,info) use psb_error_mod diff --git a/base/modules/auxil/psb_e_realloc_mod.F90 b/base/modules/auxil/psb_e_realloc_mod.F90 index 56e04dfb..4ad49a2c 100644 --- a/base/modules/auxil/psb_e_realloc_mod.F90 +++ b/base/modules/auxil/psb_e_realloc_mod.F90 @@ -39,6 +39,7 @@ module psb_e_realloc_mod ! the size specified, possibly shortening it. ! Interface psb_realloc + module procedure psb_r_e_s module procedure psb_r_m_e_rk1 module procedure psb_r_m_e_rk2 module procedure psb_r_e_e_rk1 @@ -56,7 +57,7 @@ module psb_e_realloc_mod end interface psb_move_alloc Interface psb_safe_ab_cpy - module procedure psb_ab_cpy_e_rk1, psb_ab_cpy_e_rk2 + module procedure psb_ab_cpy_e_s, psb_ab_cpy_e_rk1, psb_ab_cpy_e_rk2 end Interface psb_safe_ab_cpy Interface psb_safe_cpy @@ -82,6 +83,42 @@ module psb_e_realloc_mod Contains + Subroutine psb_r_e_s(rrax,info) + use psb_error_mod + + ! ...Subroutine Arguments + integer(psb_epk_), allocatable, intent(inout) :: rrax + integer(psb_ipk_) :: info + + ! ...Local Variables + integer(psb_ipk_) :: err_act,err + character(len=20) :: name + logical, parameter :: debug=.false. + + name='psb_r_e_s' + call psb_erractionsave(err_act) + info=psb_success_ + + if (.not.allocated(rrax)) then + Allocate(rrax,stat=info) + if (info /= psb_success_) then + err=4025 + call psb_errpush(err,name, l_err=(/1_psb_lpk_/), & + & a_err='integer(psb_epk_)') + goto 9999 + end if + endif + + call psb_erractionrestore(err_act) + return + +9999 continue + info = err + call psb_error_handler(err_act) + return + + End Subroutine psb_r_e_s + Subroutine psb_r_m_e_rk1(len,rrax,info,pad,lb) use psb_error_mod @@ -687,6 +724,48 @@ Contains + subroutine psb_ab_cpy_e_s(vin,vout,info) + use psb_error_mod + + ! ...Subroutine Arguments + integer(psb_epk_), allocatable, intent(in) :: vin + integer(psb_epk_), allocatable, intent(out) :: vout + integer(psb_ipk_) :: info + ! ...Local Variables + + integer(psb_ipk_) :: isz,err_act,lb + character(len=20) :: name, char_err + logical, parameter :: debug=.false. + + name='psb_ab_cpy_e_s' + call psb_erractionsave(err_act) + info=psb_success_ + if(psb_errstatus_fatal()) then + info=psb_err_from_subroutine_ + goto 9999 + end if + + if (allocated(vin)) then + call psb_realloc(vout,info) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + char_err='psb_realloc' + call psb_errpush(info,name,a_err=char_err) + goto 9999 + else + vout = vin + endif + endif + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + + end subroutine psb_ab_cpy_e_s + subroutine psb_ab_cpy_e_rk1(vin,vout,info) use psb_error_mod diff --git a/base/modules/auxil/psb_i2_realloc_mod.F90 b/base/modules/auxil/psb_i2_realloc_mod.F90 index 4bc4da32..6528372f 100644 --- a/base/modules/auxil/psb_i2_realloc_mod.F90 +++ b/base/modules/auxil/psb_i2_realloc_mod.F90 @@ -39,6 +39,7 @@ module psb_i2_realloc_mod ! the size specified, possibly shortening it. ! Interface psb_realloc + module procedure psb_r_i2_s module procedure psb_r_m_i2_rk1 module procedure psb_r_m_i2_rk2 module procedure psb_r_e_i2_rk1 @@ -56,7 +57,7 @@ module psb_i2_realloc_mod end interface psb_move_alloc Interface psb_safe_ab_cpy - module procedure psb_ab_cpy_i2_rk1, psb_ab_cpy_i2_rk2 + module procedure psb_ab_cpy_i2_s, psb_ab_cpy_i2_rk1, psb_ab_cpy_i2_rk2 end Interface psb_safe_ab_cpy Interface psb_safe_cpy @@ -82,6 +83,42 @@ module psb_i2_realloc_mod Contains + Subroutine psb_r_i2_s(rrax,info) + use psb_error_mod + + ! ...Subroutine Arguments + integer(psb_i2pk_), allocatable, intent(inout) :: rrax + integer(psb_ipk_) :: info + + ! ...Local Variables + integer(psb_ipk_) :: err_act,err + character(len=20) :: name + logical, parameter :: debug=.false. + + name='psb_r_i2_s' + call psb_erractionsave(err_act) + info=psb_success_ + + if (.not.allocated(rrax)) then + Allocate(rrax,stat=info) + if (info /= psb_success_) then + err=4025 + call psb_errpush(err,name, l_err=(/1_psb_lpk_/), & + & a_err='integer(psb_i2pk_)') + goto 9999 + end if + endif + + call psb_erractionrestore(err_act) + return + +9999 continue + info = err + call psb_error_handler(err_act) + return + + End Subroutine psb_r_i2_s + Subroutine psb_r_m_i2_rk1(len,rrax,info,pad,lb) use psb_error_mod @@ -687,6 +724,48 @@ Contains + subroutine psb_ab_cpy_i2_s(vin,vout,info) + use psb_error_mod + + ! ...Subroutine Arguments + integer(psb_i2pk_), allocatable, intent(in) :: vin + integer(psb_i2pk_), allocatable, intent(out) :: vout + integer(psb_ipk_) :: info + ! ...Local Variables + + integer(psb_ipk_) :: isz,err_act,lb + character(len=20) :: name, char_err + logical, parameter :: debug=.false. + + name='psb_ab_cpy_i2_s' + call psb_erractionsave(err_act) + info=psb_success_ + if(psb_errstatus_fatal()) then + info=psb_err_from_subroutine_ + goto 9999 + end if + + if (allocated(vin)) then + call psb_realloc(vout,info) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + char_err='psb_realloc' + call psb_errpush(info,name,a_err=char_err) + goto 9999 + else + vout = vin + endif + endif + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + + end subroutine psb_ab_cpy_i2_s + subroutine psb_ab_cpy_i2_rk1(vin,vout,info) use psb_error_mod diff --git a/base/modules/auxil/psb_m_realloc_mod.F90 b/base/modules/auxil/psb_m_realloc_mod.F90 index 993be571..b60e7ae2 100644 --- a/base/modules/auxil/psb_m_realloc_mod.F90 +++ b/base/modules/auxil/psb_m_realloc_mod.F90 @@ -39,6 +39,7 @@ module psb_m_realloc_mod ! the size specified, possibly shortening it. ! Interface psb_realloc + module procedure psb_r_m_s module procedure psb_r_m_m_rk1 module procedure psb_r_m_m_rk2 module procedure psb_r_e_m_rk1 @@ -56,7 +57,7 @@ module psb_m_realloc_mod end interface psb_move_alloc Interface psb_safe_ab_cpy - module procedure psb_ab_cpy_m_rk1, psb_ab_cpy_m_rk2 + module procedure psb_ab_cpy_m_s, psb_ab_cpy_m_rk1, psb_ab_cpy_m_rk2 end Interface psb_safe_ab_cpy Interface psb_safe_cpy @@ -82,6 +83,42 @@ module psb_m_realloc_mod Contains + Subroutine psb_r_m_s(rrax,info) + use psb_error_mod + + ! ...Subroutine Arguments + integer(psb_mpk_), allocatable, intent(inout) :: rrax + integer(psb_ipk_) :: info + + ! ...Local Variables + integer(psb_ipk_) :: err_act,err + character(len=20) :: name + logical, parameter :: debug=.false. + + name='psb_r_m_s' + call psb_erractionsave(err_act) + info=psb_success_ + + if (.not.allocated(rrax)) then + Allocate(rrax,stat=info) + if (info /= psb_success_) then + err=4025 + call psb_errpush(err,name, l_err=(/1_psb_lpk_/), & + & a_err='integer(psb_mpk_)') + goto 9999 + end if + endif + + call psb_erractionrestore(err_act) + return + +9999 continue + info = err + call psb_error_handler(err_act) + return + + End Subroutine psb_r_m_s + Subroutine psb_r_m_m_rk1(len,rrax,info,pad,lb) use psb_error_mod @@ -687,6 +724,48 @@ Contains + subroutine psb_ab_cpy_m_s(vin,vout,info) + use psb_error_mod + + ! ...Subroutine Arguments + integer(psb_mpk_), allocatable, intent(in) :: vin + integer(psb_mpk_), allocatable, intent(out) :: vout + integer(psb_ipk_) :: info + ! ...Local Variables + + integer(psb_ipk_) :: isz,err_act,lb + character(len=20) :: name, char_err + logical, parameter :: debug=.false. + + name='psb_ab_cpy_m_s' + call psb_erractionsave(err_act) + info=psb_success_ + if(psb_errstatus_fatal()) then + info=psb_err_from_subroutine_ + goto 9999 + end if + + if (allocated(vin)) then + call psb_realloc(vout,info) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + char_err='psb_realloc' + call psb_errpush(info,name,a_err=char_err) + goto 9999 + else + vout = vin + endif + endif + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + + end subroutine psb_ab_cpy_m_s + subroutine psb_ab_cpy_m_rk1(vin,vout,info) use psb_error_mod diff --git a/base/modules/auxil/psb_s_realloc_mod.F90 b/base/modules/auxil/psb_s_realloc_mod.F90 index 4d29a28a..f7cfdbfe 100644 --- a/base/modules/auxil/psb_s_realloc_mod.F90 +++ b/base/modules/auxil/psb_s_realloc_mod.F90 @@ -39,6 +39,7 @@ module psb_s_realloc_mod ! the size specified, possibly shortening it. ! Interface psb_realloc + module procedure psb_r_s_s module procedure psb_r_m_s_rk1 module procedure psb_r_m_s_rk2 module procedure psb_r_e_s_rk1 @@ -56,7 +57,7 @@ module psb_s_realloc_mod end interface psb_move_alloc Interface psb_safe_ab_cpy - module procedure psb_ab_cpy_s_rk1, psb_ab_cpy_s_rk2 + module procedure psb_ab_cpy_s_s, psb_ab_cpy_s_rk1, psb_ab_cpy_s_rk2 end Interface psb_safe_ab_cpy Interface psb_safe_cpy @@ -82,6 +83,42 @@ module psb_s_realloc_mod Contains + Subroutine psb_r_s_s(rrax,info) + use psb_error_mod + + ! ...Subroutine Arguments + real(psb_spk_), allocatable, intent(inout) :: rrax + integer(psb_ipk_) :: info + + ! ...Local Variables + integer(psb_ipk_) :: err_act,err + character(len=20) :: name + logical, parameter :: debug=.false. + + name='psb_r_s_s' + call psb_erractionsave(err_act) + info=psb_success_ + + if (.not.allocated(rrax)) then + Allocate(rrax,stat=info) + if (info /= psb_success_) then + err=4025 + call psb_errpush(err,name, l_err=(/1_psb_lpk_/), & + & a_err='real(psb_spk_)') + goto 9999 + end if + endif + + call psb_erractionrestore(err_act) + return + +9999 continue + info = err + call psb_error_handler(err_act) + return + + End Subroutine psb_r_s_s + Subroutine psb_r_m_s_rk1(len,rrax,info,pad,lb) use psb_error_mod @@ -687,6 +724,48 @@ Contains + subroutine psb_ab_cpy_s_s(vin,vout,info) + use psb_error_mod + + ! ...Subroutine Arguments + real(psb_spk_), allocatable, intent(in) :: vin + real(psb_spk_), allocatable, intent(out) :: vout + integer(psb_ipk_) :: info + ! ...Local Variables + + integer(psb_ipk_) :: isz,err_act,lb + character(len=20) :: name, char_err + logical, parameter :: debug=.false. + + name='psb_ab_cpy_s_s' + call psb_erractionsave(err_act) + info=psb_success_ + if(psb_errstatus_fatal()) then + info=psb_err_from_subroutine_ + goto 9999 + end if + + if (allocated(vin)) then + call psb_realloc(vout,info) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + char_err='psb_realloc' + call psb_errpush(info,name,a_err=char_err) + goto 9999 + else + vout = vin + endif + endif + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + + end subroutine psb_ab_cpy_s_s + subroutine psb_ab_cpy_s_rk1(vin,vout,info) use psb_error_mod diff --git a/base/modules/auxil/psb_z_realloc_mod.F90 b/base/modules/auxil/psb_z_realloc_mod.F90 index bf849a1e..230d4f8e 100644 --- a/base/modules/auxil/psb_z_realloc_mod.F90 +++ b/base/modules/auxil/psb_z_realloc_mod.F90 @@ -39,6 +39,7 @@ module psb_z_realloc_mod ! the size specified, possibly shortening it. ! Interface psb_realloc + module procedure psb_r_z_s module procedure psb_r_m_z_rk1 module procedure psb_r_m_z_rk2 module procedure psb_r_e_z_rk1 @@ -56,7 +57,7 @@ module psb_z_realloc_mod end interface psb_move_alloc Interface psb_safe_ab_cpy - module procedure psb_ab_cpy_z_rk1, psb_ab_cpy_z_rk2 + module procedure psb_ab_cpy_z_s, psb_ab_cpy_z_rk1, psb_ab_cpy_z_rk2 end Interface psb_safe_ab_cpy Interface psb_safe_cpy @@ -82,6 +83,42 @@ module psb_z_realloc_mod Contains + Subroutine psb_r_z_s(rrax,info) + use psb_error_mod + + ! ...Subroutine Arguments + complex(psb_dpk_), allocatable, intent(inout) :: rrax + integer(psb_ipk_) :: info + + ! ...Local Variables + integer(psb_ipk_) :: err_act,err + character(len=20) :: name + logical, parameter :: debug=.false. + + name='psb_r_z_s' + call psb_erractionsave(err_act) + info=psb_success_ + + if (.not.allocated(rrax)) then + Allocate(rrax,stat=info) + if (info /= psb_success_) then + err=4025 + call psb_errpush(err,name, l_err=(/1_psb_lpk_/), & + & a_err='complex(psb_dpk_)') + goto 9999 + end if + endif + + call psb_erractionrestore(err_act) + return + +9999 continue + info = err + call psb_error_handler(err_act) + return + + End Subroutine psb_r_z_s + Subroutine psb_r_m_z_rk1(len,rrax,info,pad,lb) use psb_error_mod @@ -687,6 +724,48 @@ Contains + subroutine psb_ab_cpy_z_s(vin,vout,info) + use psb_error_mod + + ! ...Subroutine Arguments + complex(psb_dpk_), allocatable, intent(in) :: vin + complex(psb_dpk_), allocatable, intent(out) :: vout + integer(psb_ipk_) :: info + ! ...Local Variables + + integer(psb_ipk_) :: isz,err_act,lb + character(len=20) :: name, char_err + logical, parameter :: debug=.false. + + name='psb_ab_cpy_z_s' + call psb_erractionsave(err_act) + info=psb_success_ + if(psb_errstatus_fatal()) then + info=psb_err_from_subroutine_ + goto 9999 + end if + + if (allocated(vin)) then + call psb_realloc(vout,info) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + char_err='psb_realloc' + call psb_errpush(info,name,a_err=char_err) + goto 9999 + else + vout = vin + endif + endif + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + + end subroutine psb_ab_cpy_z_s + subroutine psb_ab_cpy_z_rk1(vin,vout,info) use psb_error_mod