diff --git a/base/modules/Makefile b/base/modules/Makefile index 31c509ad..8d50011f 100644 --- a/base/modules/Makefile +++ b/base/modules/Makefile @@ -257,7 +257,7 @@ serial/psb_c_csc_mat_mod.o serial/psb_c_csr_mat_mod.o serial/psb_lc_csr_mat_mod. serial/psb_z_csc_mat_mod.o serial/psb_z_csr_mat_mod.o serial/psb_lz_csr_mat_mod.o: serial/psb_z_base_mat_mod.o serial/psb_mat_mod.o: serial/psb_vect_mod.o serial/psb_s_mat_mod.o serial/psb_d_mat_mod.o serial/psb_c_mat_mod.o serial/psb_z_mat_mod.o -serial/psb_serial_mod.o: serial/psb_s_serial_mod.o serial/psb_d_serial_mod.o serial/psb_c_serial_mod.o serial/psb_z_serial_mod.o +serial/psb_serial_mod.o: serial/psb_s_serial_mod.o serial/psb_d_serial_mod.o serial/psb_c_serial_mod.o serial/psb_z_serial_mod.o auxil/psi_serial_mod.o serial/psb_i_vect_mod.o: serial/psb_i_base_vect_mod.o serial/psb_l_vect_mod.o: serial/psb_l_base_vect_mod.o serial/psb_i_vect_mod.o serial/psb_s_vect_mod.o: serial/psb_s_base_vect_mod.o serial/psb_i_vect_mod.o diff --git a/base/serial/Makefile b/base/serial/Makefile index 5bff0b64..0f17a0a4 100644 --- a/base/serial/Makefile +++ b/base/serial/Makefile @@ -11,10 +11,10 @@ FOBJS = psb_lsame.o psi_m_serial_impl.o psi_e_serial_impl.o \ smmp.o lsmmp.o \ psb_sgeprt.o psb_dgeprt.o psb_cgeprt.o psb_zgeprt.o\ psb_spdot_srtd.o psb_aspxpby.o psb_spge_dot.o\ - psb_sgelp.o psb_dgelp.o psb_cgelp.o psb_zgelp.o \ psb_samax_s.o psb_damax_s.o psb_camax_s.o psb_zamax_s.o \ psb_sasum_s.o psb_dasum_s.o psb_casum_s.o psb_zasum_s.o + LIBDIR=.. INCDIR=.. MODDIR=../modules diff --git a/base/serial/psb_cgelp.f90 b/base/serial/psb_cgelp.f90 deleted file mode 100644 index 5a24417a..00000000 --- a/base/serial/psb_cgelp.f90 +++ /dev/null @@ -1,443 +0,0 @@ -! -! Parallel Sparse BLAS version 3.5 -! (C) Copyright 2006-2018 -! Salvatore Filippone -! Alfredo Buttari University of Rome Tor Vergata -! -! 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. -! -! -! File: psb_cgelp.f90 -! -! -! Subroutine: psb_cgelp -! Apply a left permutation to a dense matrix -! -! Arguments: -! trans - character. -! iperm - integer. -! x - real, dimension(:,:). -! info - integer. Return code. -subroutine psb_m_cgelp(trans,iperm,x,info) - use psb_serial_mod, psb_protect_name => psb_m_cgelp - use psb_const_mod - use psb_error_mod - implicit none - - complex(psb_spk_), intent(inout) :: x(:,:) - integer(psb_mpk_), intent(in) :: iperm(:) - integer(psb_ipk_), intent(out) :: info - character, intent(in) :: trans - - ! local variables - complex(psb_spk_),allocatable :: temp(:) - integer(psb_ipk_) :: int_err(5), i1sz, i2sz, err_act,i,j - integer(psb_ipk_), allocatable :: itemp(:) - complex(psb_spk_),parameter :: one=1 - integer(psb_ipk_) :: debug_level, debug_unit - character(len=20) :: name - name = 'psb_cgelp' - - if(psb_get_errstatus() /= 0) return - info=psb_success_ - call psb_erractionsave(err_act) - debug_unit = psb_get_debug_unit() - debug_level = psb_get_debug_level() - - i1sz = size(x,dim=1) - i2sz = size(x,dim=2) - - if (debug_level >= psb_debug_serial_)& - & write(debug_unit,*) trim(name),': size',i1sz,i2sz - - allocate(temp(i1sz),itemp(size(iperm)),stat=info) - if (info /= psb_success_) then - info=2040 - call psb_errpush(info,name) - goto 9999 - end if - itemp(:) = iperm(:) - - if (.not.psb_isaperm(i1sz,itemp)) then - info=psb_err_iarg_invalid_value_ - int_err(1) = 1 - call psb_errpush(info,name,i_err=int_err) - goto 9999 - endif - select case( psb_toupper(trans)) - case('N') - do j=1,i2sz - do i=1,i1sz - temp(i) = x(itemp(i),j) - end do - do i=1,i1sz - x(i,j) = temp(i) - end do - end do - case('T') - do j=1,i2sz - do i=1,i1sz - temp(itemp(i)) = x(i,j) - end do - do i=1,i1sz - x(i,j) = temp(i) - end do - end do - case default - info=psb_err_from_subroutine_ - call psb_errpush(info,name,a_err='cgelp') - end select - - deallocate(temp,itemp) - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - - return - -end subroutine psb_m_cgelp - - - -!!$ -!!$ Parallel Sparse BLAS version 3.5 -!!$ (C) Copyright 2006-2018 -!!$ Salvatore Filippone University of Rome Tor Vergata -!!$ Alfredo Buttari University of Rome Tor Vergata -!!$ -!!$ 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. -!!$ -!!$ -! -! -! Subroutine: psb_cgelpv -! Apply a left permutation to a dense matrix -! -! Arguments: -! trans - character. -! iperm - integer. -! x - real, dimension(:). -! info - integer. Return code. -subroutine psb_m_cgelpv(trans,iperm,x,info) - use psb_serial_mod, psb_protect_name => psb_m_cgelpv - use psb_const_mod - use psb_error_mod - implicit none - - complex(psb_spk_), intent(inout) :: x(:) - integer(psb_mpk_), intent(in) :: iperm(:) - integer(psb_ipk_), intent(out) :: info - character, intent(in) :: trans - - ! local variables - integer(psb_ipk_) :: int_err(5), i1sz, err_act, i - complex(psb_spk_),allocatable :: temp(:) - integer(psb_ipk_), allocatable :: itemp(:) - complex(psb_spk_),parameter :: one=1 - integer(psb_ipk_) :: debug_level, debug_unit - character(len=20) :: name - name = 'psb_cgelpv' - - if(psb_get_errstatus() /= 0) return - info=psb_success_ - call psb_erractionsave(err_act) - debug_unit = psb_get_debug_unit() - debug_level = psb_get_debug_level() - - i1sz = min(size(x),size(iperm)) - - if (debug_level >= psb_debug_serial_)& - & write(debug_unit,*) trim(name),': size',i1sz - allocate(temp(i1sz),itemp(size(iperm)),stat=info) - if (info /= psb_success_) then - info=2040 - call psb_errpush(info,name) - goto 9999 - end if - itemp(:) = iperm(:) - - if (.not.psb_isaperm(i1sz,itemp)) then - info=psb_err_iarg_invalid_value_ - int_err(1) = 1 - call psb_errpush(info,name,i_err=int_err) - goto 9999 - endif - - select case( psb_toupper(trans)) - case('N') - do i=1,i1sz - temp(i) = x(itemp(i)) - end do - do i=1,i1sz - x(i) = temp(i) - end do - case('T') - do i=1,i1sz - temp(itemp(i)) = x(i) - end do - do i=1,i1sz - x(i) = temp(i) - end do - case default - info=psb_err_from_subroutine_ - call psb_errpush(info,name,a_err='cgelp') - end select - - deallocate(temp,itemp) - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - - return - -end subroutine psb_m_cgelpv - -subroutine psb_e_cgelp(trans,iperm,x,info) - use psb_serial_mod, psb_protect_name => psb_e_cgelp - use psb_const_mod - use psb_error_mod - implicit none - - complex(psb_spk_), intent(inout) :: x(:,:) - integer(psb_epk_), intent(in) :: iperm(:) - integer(psb_ipk_), intent(out) :: info - character, intent(in) :: trans - - ! local variables - complex(psb_spk_),allocatable :: temp(:) - integer(psb_ipk_) :: int_err(5), err_act - integer(psb_epk_) :: i1sz, i2sz, i, j - integer(psb_epk_), allocatable :: itemp(:) - complex(psb_spk_),parameter :: one=1 - integer(psb_ipk_) :: debug_level, debug_unit - character(len=20) :: name - name = 'psb_cgelp' - - if(psb_get_errstatus() /= 0) return - info=psb_success_ - call psb_erractionsave(err_act) - debug_unit = psb_get_debug_unit() - debug_level = psb_get_debug_level() - - i1sz = size(x,dim=1) - i2sz = size(x,dim=2) - - if (debug_level >= psb_debug_serial_)& - & write(debug_unit,*) trim(name),': size',i1sz,i2sz - - allocate(temp(i1sz),itemp(size(iperm)),stat=info) - if (info /= psb_success_) then - info=2040 - call psb_errpush(info,name) - goto 9999 - end if - itemp(:) = iperm(:) - - if (.not.psb_isaperm(i1sz,itemp)) then - info=psb_err_iarg_invalid_value_ - int_err(1) = 1 - call psb_errpush(info,name,i_err=int_err) - goto 9999 - endif - select case( psb_toupper(trans)) - case('N') - do j=1,i2sz - do i=1,i1sz - temp(i) = x(itemp(i),j) - end do - do i=1,i1sz - x(i,j) = temp(i) - end do - end do - case('T') - do j=1,i2sz - do i=1,i1sz - temp(itemp(i)) = x(i,j) - end do - do i=1,i1sz - x(i,j) = temp(i) - end do - end do - case default - info=psb_err_from_subroutine_ - call psb_errpush(info,name,a_err='cgelp') - end select - - deallocate(temp,itemp) - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - - return - -end subroutine psb_e_cgelp - - - -!!$ -!!$ Parallel Sparse BLAS version 3.5 -!!$ (C) Copyright 2006-2018 -!!$ Salvatore Filippone University of Rome Tor Vergata -!!$ Alfredo Buttari University of Rome Tor Vergata -!!$ -!!$ 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. -!!$ -!!$ -! -! -! Subroutine: psb_cgelpv -! Apply a left permutation to a dense matrix -! -! Arguments: -! trans - character. -! iperm - integer. -! x - real, dimension(:). -! info - integer. Return code. -subroutine psb_e_cgelpv(trans,iperm,x,info) - use psb_serial_mod, psb_protect_name => psb_e_cgelpv - use psb_const_mod - use psb_error_mod - implicit none - - complex(psb_spk_), intent(inout) :: x(:) - integer(psb_epk_), intent(in) :: iperm(:) - integer(psb_ipk_), intent(out) :: info - character, intent(in) :: trans - - ! local variables - integer(psb_ipk_) :: int_err(5), err_act - complex(psb_spk_),allocatable :: temp(:) - integer(psb_epk_) :: i1sz, i - integer(psb_epk_), allocatable :: itemp(:) - integer(psb_ipk_) :: debug_level, debug_unit - character(len=20) :: name - - name = 'psb_cgelp' - if(psb_get_errstatus() /= 0) return - info=psb_success_ - call psb_erractionsave(err_act) - debug_unit = psb_get_debug_unit() - debug_level = psb_get_debug_level() - - i1sz = min(size(x),size(iperm)) - - if (debug_level >= psb_debug_serial_)& - & write(debug_unit,*) trim(name),': size',i1sz - allocate(temp(i1sz),itemp(size(iperm)),stat=info) - if (info /= psb_success_) then - info=2040 - call psb_errpush(info,name) - goto 9999 - end if - itemp(:) = iperm(:) - - if (.not.psb_isaperm(i1sz,itemp)) then - info=psb_err_iarg_invalid_value_ - int_err(1) = 1 - call psb_errpush(info,name,i_err=int_err) - goto 9999 - endif - - select case( psb_toupper(trans)) - case('N') - do i=1,i1sz - temp(i) = x(itemp(i)) - end do - do i=1,i1sz - x(i) = temp(i) - end do - case('T') - do i=1,i1sz - temp(itemp(i)) = x(i) - end do - do i=1,i1sz - x(i) = temp(i) - end do - case default - info=psb_err_from_subroutine_ - call psb_errpush(info,name,a_err='cgelp') - end select - - deallocate(temp,itemp) - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - - return - -end subroutine psb_e_cgelpv - diff --git a/base/serial/psb_dgelp.f90 b/base/serial/psb_dgelp.f90 deleted file mode 100644 index 956529ec..00000000 --- a/base/serial/psb_dgelp.f90 +++ /dev/null @@ -1,443 +0,0 @@ -! -! Parallel Sparse BLAS version 3.5 -! (C) Copyright 2006-2018 -! Salvatore Filippone -! Alfredo Buttari University of Rome Tor Vergata -! -! 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. -! -! -! File: psb_dgelp.f90 -! -! -! Subroutine: psb_dgelp -! Apply a left permutation to a dense matrix -! -! Arguments: -! trans - character. -! iperm - integer. -! x - real, dimension(:,:). -! info - integer. Return code. -subroutine psb_m_dgelp(trans,iperm,x,info) - use psb_serial_mod, psb_protect_name => psb_m_dgelp - use psb_const_mod - use psb_error_mod - implicit none - - real(psb_dpk_), intent(inout) :: x(:,:) - integer(psb_mpk_), intent(in) :: iperm(:) - integer(psb_ipk_), intent(out) :: info - character, intent(in) :: trans - - ! local variables - real(psb_dpk_),allocatable :: temp(:) - integer(psb_ipk_) :: int_err(5), i1sz, i2sz, err_act,i,j - integer(psb_ipk_), allocatable :: itemp(:) - real(psb_dpk_),parameter :: one=1 - integer(psb_ipk_) :: debug_level, debug_unit - character(len=20) :: name - name = 'psb_dgelp' - - if(psb_get_errstatus() /= 0) return - info=psb_success_ - call psb_erractionsave(err_act) - debug_unit = psb_get_debug_unit() - debug_level = psb_get_debug_level() - - i1sz = size(x,dim=1) - i2sz = size(x,dim=2) - - if (debug_level >= psb_debug_serial_)& - & write(debug_unit,*) trim(name),': size',i1sz,i2sz - - allocate(temp(i1sz),itemp(size(iperm)),stat=info) - if (info /= psb_success_) then - info=2040 - call psb_errpush(info,name) - goto 9999 - end if - itemp(:) = iperm(:) - - if (.not.psb_isaperm(i1sz,itemp)) then - info=psb_err_iarg_invalid_value_ - int_err(1) = 1 - call psb_errpush(info,name,i_err=int_err) - goto 9999 - endif - select case( psb_toupper(trans)) - case('N') - do j=1,i2sz - do i=1,i1sz - temp(i) = x(itemp(i),j) - end do - do i=1,i1sz - x(i,j) = temp(i) - end do - end do - case('T') - do j=1,i2sz - do i=1,i1sz - temp(itemp(i)) = x(i,j) - end do - do i=1,i1sz - x(i,j) = temp(i) - end do - end do - case default - info=psb_err_from_subroutine_ - call psb_errpush(info,name,a_err='dgelp') - end select - - deallocate(temp,itemp) - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - - return - -end subroutine psb_m_dgelp - - - -!!$ -!!$ Parallel Sparse BLAS version 3.5 -!!$ (C) Copyright 2006-2018 -!!$ Salvatore Filippone University of Rome Tor Vergata -!!$ Alfredo Buttari University of Rome Tor Vergata -!!$ -!!$ 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. -!!$ -!!$ -! -! -! Subroutine: psb_dgelpv -! Apply a left permutation to a dense matrix -! -! Arguments: -! trans - character. -! iperm - integer. -! x - real, dimension(:). -! info - integer. Return code. -subroutine psb_m_dgelpv(trans,iperm,x,info) - use psb_serial_mod, psb_protect_name => psb_m_dgelpv - use psb_const_mod - use psb_error_mod - implicit none - - real(psb_dpk_), intent(inout) :: x(:) - integer(psb_mpk_), intent(in) :: iperm(:) - integer(psb_ipk_), intent(out) :: info - character, intent(in) :: trans - - ! local variables - integer(psb_ipk_) :: int_err(5), i1sz, err_act, i - real(psb_dpk_),allocatable :: temp(:) - integer(psb_ipk_), allocatable :: itemp(:) - real(psb_dpk_),parameter :: one=1 - integer(psb_ipk_) :: debug_level, debug_unit - character(len=20) :: name - name = 'psb_dgelpv' - - if(psb_get_errstatus() /= 0) return - info=psb_success_ - call psb_erractionsave(err_act) - debug_unit = psb_get_debug_unit() - debug_level = psb_get_debug_level() - - i1sz = min(size(x),size(iperm)) - - if (debug_level >= psb_debug_serial_)& - & write(debug_unit,*) trim(name),': size',i1sz - allocate(temp(i1sz),itemp(size(iperm)),stat=info) - if (info /= psb_success_) then - info=2040 - call psb_errpush(info,name) - goto 9999 - end if - itemp(:) = iperm(:) - - if (.not.psb_isaperm(i1sz,itemp)) then - info=psb_err_iarg_invalid_value_ - int_err(1) = 1 - call psb_errpush(info,name,i_err=int_err) - goto 9999 - endif - - select case( psb_toupper(trans)) - case('N') - do i=1,i1sz - temp(i) = x(itemp(i)) - end do - do i=1,i1sz - x(i) = temp(i) - end do - case('T') - do i=1,i1sz - temp(itemp(i)) = x(i) - end do - do i=1,i1sz - x(i) = temp(i) - end do - case default - info=psb_err_from_subroutine_ - call psb_errpush(info,name,a_err='dgelp') - end select - - deallocate(temp,itemp) - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - - return - -end subroutine psb_m_dgelpv - -subroutine psb_e_dgelp(trans,iperm,x,info) - use psb_serial_mod, psb_protect_name => psb_e_dgelp - use psb_const_mod - use psb_error_mod - implicit none - - real(psb_dpk_), intent(inout) :: x(:,:) - integer(psb_epk_), intent(in) :: iperm(:) - integer(psb_ipk_), intent(out) :: info - character, intent(in) :: trans - - ! local variables - real(psb_dpk_),allocatable :: temp(:) - integer(psb_ipk_) :: int_err(5), err_act - integer(psb_epk_) :: i1sz, i2sz, i, j - integer(psb_epk_), allocatable :: itemp(:) - real(psb_dpk_),parameter :: one=1 - integer(psb_ipk_) :: debug_level, debug_unit - character(len=20) :: name - name = 'psb_dgelp' - - if(psb_get_errstatus() /= 0) return - info=psb_success_ - call psb_erractionsave(err_act) - debug_unit = psb_get_debug_unit() - debug_level = psb_get_debug_level() - - i1sz = size(x,dim=1) - i2sz = size(x,dim=2) - - if (debug_level >= psb_debug_serial_)& - & write(debug_unit,*) trim(name),': size',i1sz,i2sz - - allocate(temp(i1sz),itemp(size(iperm)),stat=info) - if (info /= psb_success_) then - info=2040 - call psb_errpush(info,name) - goto 9999 - end if - itemp(:) = iperm(:) - - if (.not.psb_isaperm(i1sz,itemp)) then - info=psb_err_iarg_invalid_value_ - int_err(1) = 1 - call psb_errpush(info,name,i_err=int_err) - goto 9999 - endif - select case( psb_toupper(trans)) - case('N') - do j=1,i2sz - do i=1,i1sz - temp(i) = x(itemp(i),j) - end do - do i=1,i1sz - x(i,j) = temp(i) - end do - end do - case('T') - do j=1,i2sz - do i=1,i1sz - temp(itemp(i)) = x(i,j) - end do - do i=1,i1sz - x(i,j) = temp(i) - end do - end do - case default - info=psb_err_from_subroutine_ - call psb_errpush(info,name,a_err='dgelp') - end select - - deallocate(temp,itemp) - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - - return - -end subroutine psb_e_dgelp - - - -!!$ -!!$ Parallel Sparse BLAS version 3.5 -!!$ (C) Copyright 2006-2018 -!!$ Salvatore Filippone University of Rome Tor Vergata -!!$ Alfredo Buttari University of Rome Tor Vergata -!!$ -!!$ 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. -!!$ -!!$ -! -! -! Subroutine: psb_dgelpv -! Apply a left permutation to a dense matrix -! -! Arguments: -! trans - character. -! iperm - integer. -! x - real, dimension(:). -! info - integer. Return code. -subroutine psb_e_dgelpv(trans,iperm,x,info) - use psb_serial_mod, psb_protect_name => psb_e_dgelpv - use psb_const_mod - use psb_error_mod - implicit none - - real(psb_dpk_), intent(inout) :: x(:) - integer(psb_epk_), intent(in) :: iperm(:) - integer(psb_ipk_), intent(out) :: info - character, intent(in) :: trans - - ! local variables - integer(psb_ipk_) :: int_err(5), err_act - real(psb_dpk_),allocatable :: temp(:) - integer(psb_epk_) :: i1sz, i - integer(psb_epk_), allocatable :: itemp(:) - integer(psb_ipk_) :: debug_level, debug_unit - character(len=20) :: name - - name = 'psb_dgelp' - if(psb_get_errstatus() /= 0) return - info=psb_success_ - call psb_erractionsave(err_act) - debug_unit = psb_get_debug_unit() - debug_level = psb_get_debug_level() - - i1sz = min(size(x),size(iperm)) - - if (debug_level >= psb_debug_serial_)& - & write(debug_unit,*) trim(name),': size',i1sz - allocate(temp(i1sz),itemp(size(iperm)),stat=info) - if (info /= psb_success_) then - info=2040 - call psb_errpush(info,name) - goto 9999 - end if - itemp(:) = iperm(:) - - if (.not.psb_isaperm(i1sz,itemp)) then - info=psb_err_iarg_invalid_value_ - int_err(1) = 1 - call psb_errpush(info,name,i_err=int_err) - goto 9999 - endif - - select case( psb_toupper(trans)) - case('N') - do i=1,i1sz - temp(i) = x(itemp(i)) - end do - do i=1,i1sz - x(i) = temp(i) - end do - case('T') - do i=1,i1sz - temp(itemp(i)) = x(i) - end do - do i=1,i1sz - x(i) = temp(i) - end do - case default - info=psb_err_from_subroutine_ - call psb_errpush(info,name,a_err='dgelp') - end select - - deallocate(temp,itemp) - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - - return - -end subroutine psb_e_dgelpv - diff --git a/base/serial/psb_sgelp.f90 b/base/serial/psb_sgelp.f90 deleted file mode 100644 index b6028616..00000000 --- a/base/serial/psb_sgelp.f90 +++ /dev/null @@ -1,443 +0,0 @@ -! -! Parallel Sparse BLAS version 3.5 -! (C) Copyright 2006-2018 -! Salvatore Filippone -! Alfredo Buttari University of Rome Tor Vergata -! -! 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. -! -! -! File: psb_sgelp.f90 -! -! -! Subroutine: psb_sgelp -! Apply a left permutation to a dense matrix -! -! Arguments: -! trans - character. -! iperm - integer. -! x - real, dimension(:,:). -! info - integer. Return code. -subroutine psb_m_sgelp(trans,iperm,x,info) - use psb_serial_mod, psb_protect_name => psb_m_sgelp - use psb_const_mod - use psb_error_mod - implicit none - - real(psb_spk_), intent(inout) :: x(:,:) - integer(psb_mpk_), intent(in) :: iperm(:) - integer(psb_ipk_), intent(out) :: info - character, intent(in) :: trans - - ! local variables - real(psb_spk_),allocatable :: temp(:) - integer(psb_ipk_) :: int_err(5), i1sz, i2sz, err_act,i,j - integer(psb_ipk_), allocatable :: itemp(:) - real(psb_spk_),parameter :: one=1 - integer(psb_ipk_) :: debug_level, debug_unit - character(len=20) :: name - name = 'psb_sgelp' - - if(psb_get_errstatus() /= 0) return - info=psb_success_ - call psb_erractionsave(err_act) - debug_unit = psb_get_debug_unit() - debug_level = psb_get_debug_level() - - i1sz = size(x,dim=1) - i2sz = size(x,dim=2) - - if (debug_level >= psb_debug_serial_)& - & write(debug_unit,*) trim(name),': size',i1sz,i2sz - - allocate(temp(i1sz),itemp(size(iperm)),stat=info) - if (info /= psb_success_) then - info=2040 - call psb_errpush(info,name) - goto 9999 - end if - itemp(:) = iperm(:) - - if (.not.psb_isaperm(i1sz,itemp)) then - info=psb_err_iarg_invalid_value_ - int_err(1) = 1 - call psb_errpush(info,name,i_err=int_err) - goto 9999 - endif - select case( psb_toupper(trans)) - case('N') - do j=1,i2sz - do i=1,i1sz - temp(i) = x(itemp(i),j) - end do - do i=1,i1sz - x(i,j) = temp(i) - end do - end do - case('T') - do j=1,i2sz - do i=1,i1sz - temp(itemp(i)) = x(i,j) - end do - do i=1,i1sz - x(i,j) = temp(i) - end do - end do - case default - info=psb_err_from_subroutine_ - call psb_errpush(info,name,a_err='sgelp') - end select - - deallocate(temp,itemp) - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - - return - -end subroutine psb_m_sgelp - - - -!!$ -!!$ Parallel Sparse BLAS version 3.5 -!!$ (C) Copyright 2006-2018 -!!$ Salvatore Filippone University of Rome Tor Vergata -!!$ Alfredo Buttari University of Rome Tor Vergata -!!$ -!!$ 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. -!!$ -!!$ -! -! -! Subroutine: psb_sgelpv -! Apply a left permutation to a dense matrix -! -! Arguments: -! trans - character. -! iperm - integer. -! x - real, dimension(:). -! info - integer. Return code. -subroutine psb_m_sgelpv(trans,iperm,x,info) - use psb_serial_mod, psb_protect_name => psb_m_sgelpv - use psb_const_mod - use psb_error_mod - implicit none - - real(psb_spk_), intent(inout) :: x(:) - integer(psb_mpk_), intent(in) :: iperm(:) - integer(psb_ipk_), intent(out) :: info - character, intent(in) :: trans - - ! local variables - integer(psb_ipk_) :: int_err(5), i1sz, err_act, i - real(psb_spk_),allocatable :: temp(:) - integer(psb_ipk_), allocatable :: itemp(:) - real(psb_spk_),parameter :: one=1 - integer(psb_ipk_) :: debug_level, debug_unit - character(len=20) :: name - name = 'psb_sgelpv' - - if(psb_get_errstatus() /= 0) return - info=psb_success_ - call psb_erractionsave(err_act) - debug_unit = psb_get_debug_unit() - debug_level = psb_get_debug_level() - - i1sz = min(size(x),size(iperm)) - - if (debug_level >= psb_debug_serial_)& - & write(debug_unit,*) trim(name),': size',i1sz - allocate(temp(i1sz),itemp(size(iperm)),stat=info) - if (info /= psb_success_) then - info=2040 - call psb_errpush(info,name) - goto 9999 - end if - itemp(:) = iperm(:) - - if (.not.psb_isaperm(i1sz,itemp)) then - info=psb_err_iarg_invalid_value_ - int_err(1) = 1 - call psb_errpush(info,name,i_err=int_err) - goto 9999 - endif - - select case( psb_toupper(trans)) - case('N') - do i=1,i1sz - temp(i) = x(itemp(i)) - end do - do i=1,i1sz - x(i) = temp(i) - end do - case('T') - do i=1,i1sz - temp(itemp(i)) = x(i) - end do - do i=1,i1sz - x(i) = temp(i) - end do - case default - info=psb_err_from_subroutine_ - call psb_errpush(info,name,a_err='sgelp') - end select - - deallocate(temp,itemp) - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - - return - -end subroutine psb_m_sgelpv - -subroutine psb_e_sgelp(trans,iperm,x,info) - use psb_serial_mod, psb_protect_name => psb_e_sgelp - use psb_const_mod - use psb_error_mod - implicit none - - real(psb_spk_), intent(inout) :: x(:,:) - integer(psb_epk_), intent(in) :: iperm(:) - integer(psb_ipk_), intent(out) :: info - character, intent(in) :: trans - - ! local variables - real(psb_spk_),allocatable :: temp(:) - integer(psb_ipk_) :: int_err(5), err_act - integer(psb_epk_) :: i1sz, i2sz, i, j - integer(psb_epk_), allocatable :: itemp(:) - real(psb_spk_),parameter :: one=1 - integer(psb_ipk_) :: debug_level, debug_unit - character(len=20) :: name - name = 'psb_sgelp' - - if(psb_get_errstatus() /= 0) return - info=psb_success_ - call psb_erractionsave(err_act) - debug_unit = psb_get_debug_unit() - debug_level = psb_get_debug_level() - - i1sz = size(x,dim=1) - i2sz = size(x,dim=2) - - if (debug_level >= psb_debug_serial_)& - & write(debug_unit,*) trim(name),': size',i1sz,i2sz - - allocate(temp(i1sz),itemp(size(iperm)),stat=info) - if (info /= psb_success_) then - info=2040 - call psb_errpush(info,name) - goto 9999 - end if - itemp(:) = iperm(:) - - if (.not.psb_isaperm(i1sz,itemp)) then - info=psb_err_iarg_invalid_value_ - int_err(1) = 1 - call psb_errpush(info,name,i_err=int_err) - goto 9999 - endif - select case( psb_toupper(trans)) - case('N') - do j=1,i2sz - do i=1,i1sz - temp(i) = x(itemp(i),j) - end do - do i=1,i1sz - x(i,j) = temp(i) - end do - end do - case('T') - do j=1,i2sz - do i=1,i1sz - temp(itemp(i)) = x(i,j) - end do - do i=1,i1sz - x(i,j) = temp(i) - end do - end do - case default - info=psb_err_from_subroutine_ - call psb_errpush(info,name,a_err='sgelp') - end select - - deallocate(temp,itemp) - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - - return - -end subroutine psb_e_sgelp - - - -!!$ -!!$ Parallel Sparse BLAS version 3.5 -!!$ (C) Copyright 2006-2018 -!!$ Salvatore Filippone University of Rome Tor Vergata -!!$ Alfredo Buttari University of Rome Tor Vergata -!!$ -!!$ 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. -!!$ -!!$ -! -! -! Subroutine: psb_sgelpv -! Apply a left permutation to a dense matrix -! -! Arguments: -! trans - character. -! iperm - integer. -! x - real, dimension(:). -! info - integer. Return code. -subroutine psb_e_sgelpv(trans,iperm,x,info) - use psb_serial_mod, psb_protect_name => psb_e_sgelpv - use psb_const_mod - use psb_error_mod - implicit none - - real(psb_spk_), intent(inout) :: x(:) - integer(psb_epk_), intent(in) :: iperm(:) - integer(psb_ipk_), intent(out) :: info - character, intent(in) :: trans - - ! local variables - integer(psb_ipk_) :: int_err(5), err_act - real(psb_spk_),allocatable :: temp(:) - integer(psb_epk_) :: i1sz, i - integer(psb_epk_), allocatable :: itemp(:) - integer(psb_ipk_) :: debug_level, debug_unit - character(len=20) :: name - - name = 'psb_sgelp' - if(psb_get_errstatus() /= 0) return - info=psb_success_ - call psb_erractionsave(err_act) - debug_unit = psb_get_debug_unit() - debug_level = psb_get_debug_level() - - i1sz = min(size(x),size(iperm)) - - if (debug_level >= psb_debug_serial_)& - & write(debug_unit,*) trim(name),': size',i1sz - allocate(temp(i1sz),itemp(size(iperm)),stat=info) - if (info /= psb_success_) then - info=2040 - call psb_errpush(info,name) - goto 9999 - end if - itemp(:) = iperm(:) - - if (.not.psb_isaperm(i1sz,itemp)) then - info=psb_err_iarg_invalid_value_ - int_err(1) = 1 - call psb_errpush(info,name,i_err=int_err) - goto 9999 - endif - - select case( psb_toupper(trans)) - case('N') - do i=1,i1sz - temp(i) = x(itemp(i)) - end do - do i=1,i1sz - x(i) = temp(i) - end do - case('T') - do i=1,i1sz - temp(itemp(i)) = x(i) - end do - do i=1,i1sz - x(i) = temp(i) - end do - case default - info=psb_err_from_subroutine_ - call psb_errpush(info,name,a_err='sgelp') - end select - - deallocate(temp,itemp) - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - - return - -end subroutine psb_e_sgelpv - diff --git a/base/serial/psb_zgelp.f90 b/base/serial/psb_zgelp.f90 deleted file mode 100644 index c7222481..00000000 --- a/base/serial/psb_zgelp.f90 +++ /dev/null @@ -1,443 +0,0 @@ -! -! Parallel Sparse BLAS version 3.5 -! (C) Copyright 2006-2018 -! Salvatore Filippone -! Alfredo Buttari University of Rome Tor Vergata -! -! 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. -! -! -! File: psb_zgelp.f90 -! -! -! Subroutine: psb_zgelp -! Apply a left permutation to a dense matrix -! -! Arguments: -! trans - character. -! iperm - integer. -! x - real, dimension(:,:). -! info - integer. Return code. -subroutine psb_m_zgelp(trans,iperm,x,info) - use psb_serial_mod, psb_protect_name => psb_m_zgelp - use psb_const_mod - use psb_error_mod - implicit none - - complex(psb_dpk_), intent(inout) :: x(:,:) - integer(psb_mpk_), intent(in) :: iperm(:) - integer(psb_ipk_), intent(out) :: info - character, intent(in) :: trans - - ! local variables - complex(psb_dpk_),allocatable :: temp(:) - integer(psb_ipk_) :: int_err(5), i1sz, i2sz, err_act,i,j - integer(psb_ipk_), allocatable :: itemp(:) - complex(psb_dpk_),parameter :: one=1 - integer(psb_ipk_) :: debug_level, debug_unit - character(len=20) :: name - name = 'psb_zgelp' - - if(psb_get_errstatus() /= 0) return - info=psb_success_ - call psb_erractionsave(err_act) - debug_unit = psb_get_debug_unit() - debug_level = psb_get_debug_level() - - i1sz = size(x,dim=1) - i2sz = size(x,dim=2) - - if (debug_level >= psb_debug_serial_)& - & write(debug_unit,*) trim(name),': size',i1sz,i2sz - - allocate(temp(i1sz),itemp(size(iperm)),stat=info) - if (info /= psb_success_) then - info=2040 - call psb_errpush(info,name) - goto 9999 - end if - itemp(:) = iperm(:) - - if (.not.psb_isaperm(i1sz,itemp)) then - info=psb_err_iarg_invalid_value_ - int_err(1) = 1 - call psb_errpush(info,name,i_err=int_err) - goto 9999 - endif - select case( psb_toupper(trans)) - case('N') - do j=1,i2sz - do i=1,i1sz - temp(i) = x(itemp(i),j) - end do - do i=1,i1sz - x(i,j) = temp(i) - end do - end do - case('T') - do j=1,i2sz - do i=1,i1sz - temp(itemp(i)) = x(i,j) - end do - do i=1,i1sz - x(i,j) = temp(i) - end do - end do - case default - info=psb_err_from_subroutine_ - call psb_errpush(info,name,a_err='zgelp') - end select - - deallocate(temp,itemp) - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - - return - -end subroutine psb_m_zgelp - - - -!!$ -!!$ Parallel Sparse BLAS version 3.5 -!!$ (C) Copyright 2006-2018 -!!$ Salvatore Filippone University of Rome Tor Vergata -!!$ Alfredo Buttari University of Rome Tor Vergata -!!$ -!!$ 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. -!!$ -!!$ -! -! -! Subroutine: psb_zgelpv -! Apply a left permutation to a dense matrix -! -! Arguments: -! trans - character. -! iperm - integer. -! x - real, dimension(:). -! info - integer. Return code. -subroutine psb_m_zgelpv(trans,iperm,x,info) - use psb_serial_mod, psb_protect_name => psb_m_zgelpv - use psb_const_mod - use psb_error_mod - implicit none - - complex(psb_dpk_), intent(inout) :: x(:) - integer(psb_mpk_), intent(in) :: iperm(:) - integer(psb_ipk_), intent(out) :: info - character, intent(in) :: trans - - ! local variables - integer(psb_ipk_) :: int_err(5), i1sz, err_act, i - complex(psb_dpk_),allocatable :: temp(:) - integer(psb_ipk_), allocatable :: itemp(:) - complex(psb_dpk_),parameter :: one=1 - integer(psb_ipk_) :: debug_level, debug_unit - character(len=20) :: name - name = 'psb_zgelpv' - - if(psb_get_errstatus() /= 0) return - info=psb_success_ - call psb_erractionsave(err_act) - debug_unit = psb_get_debug_unit() - debug_level = psb_get_debug_level() - - i1sz = min(size(x),size(iperm)) - - if (debug_level >= psb_debug_serial_)& - & write(debug_unit,*) trim(name),': size',i1sz - allocate(temp(i1sz),itemp(size(iperm)),stat=info) - if (info /= psb_success_) then - info=2040 - call psb_errpush(info,name) - goto 9999 - end if - itemp(:) = iperm(:) - - if (.not.psb_isaperm(i1sz,itemp)) then - info=psb_err_iarg_invalid_value_ - int_err(1) = 1 - call psb_errpush(info,name,i_err=int_err) - goto 9999 - endif - - select case( psb_toupper(trans)) - case('N') - do i=1,i1sz - temp(i) = x(itemp(i)) - end do - do i=1,i1sz - x(i) = temp(i) - end do - case('T') - do i=1,i1sz - temp(itemp(i)) = x(i) - end do - do i=1,i1sz - x(i) = temp(i) - end do - case default - info=psb_err_from_subroutine_ - call psb_errpush(info,name,a_err='zgelp') - end select - - deallocate(temp,itemp) - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - - return - -end subroutine psb_m_zgelpv - -subroutine psb_e_zgelp(trans,iperm,x,info) - use psb_serial_mod, psb_protect_name => psb_e_zgelp - use psb_const_mod - use psb_error_mod - implicit none - - complex(psb_dpk_), intent(inout) :: x(:,:) - integer(psb_epk_), intent(in) :: iperm(:) - integer(psb_ipk_), intent(out) :: info - character, intent(in) :: trans - - ! local variables - complex(psb_dpk_),allocatable :: temp(:) - integer(psb_ipk_) :: int_err(5), err_act - integer(psb_epk_) :: i1sz, i2sz, i, j - integer(psb_epk_), allocatable :: itemp(:) - complex(psb_dpk_),parameter :: one=1 - integer(psb_ipk_) :: debug_level, debug_unit - character(len=20) :: name - name = 'psb_zgelp' - - if(psb_get_errstatus() /= 0) return - info=psb_success_ - call psb_erractionsave(err_act) - debug_unit = psb_get_debug_unit() - debug_level = psb_get_debug_level() - - i1sz = size(x,dim=1) - i2sz = size(x,dim=2) - - if (debug_level >= psb_debug_serial_)& - & write(debug_unit,*) trim(name),': size',i1sz,i2sz - - allocate(temp(i1sz),itemp(size(iperm)),stat=info) - if (info /= psb_success_) then - info=2040 - call psb_errpush(info,name) - goto 9999 - end if - itemp(:) = iperm(:) - - if (.not.psb_isaperm(i1sz,itemp)) then - info=psb_err_iarg_invalid_value_ - int_err(1) = 1 - call psb_errpush(info,name,i_err=int_err) - goto 9999 - endif - select case( psb_toupper(trans)) - case('N') - do j=1,i2sz - do i=1,i1sz - temp(i) = x(itemp(i),j) - end do - do i=1,i1sz - x(i,j) = temp(i) - end do - end do - case('T') - do j=1,i2sz - do i=1,i1sz - temp(itemp(i)) = x(i,j) - end do - do i=1,i1sz - x(i,j) = temp(i) - end do - end do - case default - info=psb_err_from_subroutine_ - call psb_errpush(info,name,a_err='zgelp') - end select - - deallocate(temp,itemp) - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - - return - -end subroutine psb_e_zgelp - - - -!!$ -!!$ Parallel Sparse BLAS version 3.5 -!!$ (C) Copyright 2006-2018 -!!$ Salvatore Filippone University of Rome Tor Vergata -!!$ Alfredo Buttari University of Rome Tor Vergata -!!$ -!!$ 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. -!!$ -!!$ -! -! -! Subroutine: psb_zgelpv -! Apply a left permutation to a dense matrix -! -! Arguments: -! trans - character. -! iperm - integer. -! x - real, dimension(:). -! info - integer. Return code. -subroutine psb_e_zgelpv(trans,iperm,x,info) - use psb_serial_mod, psb_protect_name => psb_e_zgelpv - use psb_const_mod - use psb_error_mod - implicit none - - complex(psb_dpk_), intent(inout) :: x(:) - integer(psb_epk_), intent(in) :: iperm(:) - integer(psb_ipk_), intent(out) :: info - character, intent(in) :: trans - - ! local variables - integer(psb_ipk_) :: int_err(5), err_act - complex(psb_dpk_),allocatable :: temp(:) - integer(psb_epk_) :: i1sz, i - integer(psb_epk_), allocatable :: itemp(:) - integer(psb_ipk_) :: debug_level, debug_unit - character(len=20) :: name - - name = 'psb_zgelp' - if(psb_get_errstatus() /= 0) return - info=psb_success_ - call psb_erractionsave(err_act) - debug_unit = psb_get_debug_unit() - debug_level = psb_get_debug_level() - - i1sz = min(size(x),size(iperm)) - - if (debug_level >= psb_debug_serial_)& - & write(debug_unit,*) trim(name),': size',i1sz - allocate(temp(i1sz),itemp(size(iperm)),stat=info) - if (info /= psb_success_) then - info=2040 - call psb_errpush(info,name) - goto 9999 - end if - itemp(:) = iperm(:) - - if (.not.psb_isaperm(i1sz,itemp)) then - info=psb_err_iarg_invalid_value_ - int_err(1) = 1 - call psb_errpush(info,name,i_err=int_err) - goto 9999 - endif - - select case( psb_toupper(trans)) - case('N') - do i=1,i1sz - temp(i) = x(itemp(i)) - end do - do i=1,i1sz - x(i) = temp(i) - end do - case('T') - do i=1,i1sz - temp(itemp(i)) = x(i) - end do - do i=1,i1sz - x(i) = temp(i) - end do - case default - info=psb_err_from_subroutine_ - call psb_errpush(info,name,a_err='zgelp') - end select - - deallocate(temp,itemp) - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - - return - -end subroutine psb_e_zgelpv - diff --git a/base/serial/psi_c_serial_impl.f90 b/base/serial/psi_c_serial_impl.f90 index 2120683d..07f28553 100644 --- a/base/serial/psi_c_serial_impl.f90 +++ b/base/serial/psi_c_serial_impl.f90 @@ -29,6 +29,407 @@ ! POSSIBILITY OF SUCH DAMAGE. ! ! +subroutine psb_m_cgelp(trans,iperm,x,info) + use psb_serial_mod, psb_protect_name => psb_m_cgelp + use psb_const_mod + use psb_error_mod + implicit none + + complex(psb_spk_), intent(inout) :: x(:,:) + integer(psb_mpk_), intent(in) :: iperm(:) + integer(psb_ipk_), intent(out) :: info + character, intent(in) :: trans + + ! local variables + complex(psb_spk_),allocatable :: temp(:) + integer(psb_ipk_) :: int_err(5), i1sz, i2sz, err_act,i,j + integer(psb_ipk_), allocatable :: itemp(:) + complex(psb_spk_),parameter :: one=1 + integer(psb_ipk_) :: debug_level, debug_unit + character(len=20) :: name + name = 'psb_cgelp' + + if(psb_get_errstatus() /= 0) return + info=psb_success_ + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + i1sz = size(x,dim=1) + i2sz = size(x,dim=2) + + if (debug_level >= psb_debug_serial_)& + & write(debug_unit,*) trim(name),': size',i1sz,i2sz + + allocate(temp(i1sz),itemp(size(iperm)),stat=info) + if (info /= psb_success_) then + info=2040 + call psb_errpush(info,name) + goto 9999 + end if + itemp(:) = iperm(:) + + if (.not.psb_isaperm(i1sz,itemp)) then + info=psb_err_iarg_invalid_value_ + int_err(1) = 1 + call psb_errpush(info,name,i_err=int_err) + goto 9999 + endif + select case( psb_toupper(trans)) + case('N') + do j=1,i2sz + do i=1,i1sz + temp(i) = x(itemp(i),j) + end do + do i=1,i1sz + x(i,j) = temp(i) + end do + end do + case('T') + do j=1,i2sz + do i=1,i1sz + temp(itemp(i)) = x(i,j) + end do + do i=1,i1sz + x(i,j) = temp(i) + end do + end do + case default + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='cgelp') + end select + + deallocate(temp,itemp) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_m_cgelp + + + +!!$ +!!$ Parallel Sparse BLAS version 3.5 +!!$ (C) Copyright 2006-2018 +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari University of Rome Tor Vergata +!!$ +!!$ 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. +!!$ +!!$ +! +! +! Subroutine: psb_cgelpv +! Apply a left permutation to a dense matrix +! +! Arguments: +! trans - character. +! iperm - integer. +! x - real, dimension(:). +! info - integer. Return code. +subroutine psb_m_cgelpv(trans,iperm,x,info) + use psb_serial_mod, psb_protect_name => psb_m_cgelpv + use psb_const_mod + use psb_error_mod + implicit none + + complex(psb_spk_), intent(inout) :: x(:) + integer(psb_mpk_), intent(in) :: iperm(:) + integer(psb_ipk_), intent(out) :: info + character, intent(in) :: trans + + ! local variables + integer(psb_ipk_) :: int_err(5), i1sz, err_act, i + complex(psb_spk_),allocatable :: temp(:) + integer(psb_ipk_), allocatable :: itemp(:) + complex(psb_spk_),parameter :: one=1 + integer(psb_ipk_) :: debug_level, debug_unit + character(len=20) :: name + name = 'psb_cgelpv' + + if(psb_get_errstatus() /= 0) return + info=psb_success_ + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + i1sz = min(size(x),size(iperm)) + + if (debug_level >= psb_debug_serial_)& + & write(debug_unit,*) trim(name),': size',i1sz + allocate(temp(i1sz),itemp(size(iperm)),stat=info) + if (info /= psb_success_) then + info=2040 + call psb_errpush(info,name) + goto 9999 + end if + itemp(:) = iperm(:) + + if (.not.psb_isaperm(i1sz,itemp)) then + info=psb_err_iarg_invalid_value_ + int_err(1) = 1 + call psb_errpush(info,name,i_err=int_err) + goto 9999 + endif + + select case( psb_toupper(trans)) + case('N') + do i=1,i1sz + temp(i) = x(itemp(i)) + end do + do i=1,i1sz + x(i) = temp(i) + end do + case('T') + do i=1,i1sz + temp(itemp(i)) = x(i) + end do + do i=1,i1sz + x(i) = temp(i) + end do + case default + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='cgelp') + end select + + deallocate(temp,itemp) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_m_cgelpv + +subroutine psb_e_cgelp(trans,iperm,x,info) + use psb_serial_mod, psb_protect_name => psb_e_cgelp + use psb_const_mod + use psb_error_mod + implicit none + + complex(psb_spk_), intent(inout) :: x(:,:) + integer(psb_epk_), intent(in) :: iperm(:) + integer(psb_ipk_), intent(out) :: info + character, intent(in) :: trans + + ! local variables + complex(psb_spk_),allocatable :: temp(:) + integer(psb_ipk_) :: int_err(5), err_act + integer(psb_epk_) :: i1sz, i2sz, i, j + integer(psb_epk_), allocatable :: itemp(:) + complex(psb_spk_),parameter :: one=1 + integer(psb_ipk_) :: debug_level, debug_unit + character(len=20) :: name + name = 'psb_cgelp' + + if(psb_get_errstatus() /= 0) return + info=psb_success_ + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + i1sz = size(x,dim=1) + i2sz = size(x,dim=2) + + if (debug_level >= psb_debug_serial_)& + & write(debug_unit,*) trim(name),': size',i1sz,i2sz + + allocate(temp(i1sz),itemp(size(iperm)),stat=info) + if (info /= psb_success_) then + info=2040 + call psb_errpush(info,name) + goto 9999 + end if + itemp(:) = iperm(:) + + if (.not.psb_isaperm(i1sz,itemp)) then + info=psb_err_iarg_invalid_value_ + int_err(1) = 1 + call psb_errpush(info,name,i_err=int_err) + goto 9999 + endif + select case( psb_toupper(trans)) + case('N') + do j=1,i2sz + do i=1,i1sz + temp(i) = x(itemp(i),j) + end do + do i=1,i1sz + x(i,j) = temp(i) + end do + end do + case('T') + do j=1,i2sz + do i=1,i1sz + temp(itemp(i)) = x(i,j) + end do + do i=1,i1sz + x(i,j) = temp(i) + end do + end do + case default + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='cgelp') + end select + + deallocate(temp,itemp) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_e_cgelp + + + +!!$ +!!$ Parallel Sparse BLAS version 3.5 +!!$ (C) Copyright 2006-2018 +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari University of Rome Tor Vergata +!!$ +!!$ 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. +!!$ +!!$ +! +! +! Subroutine: psb_cgelpv +! Apply a left permutation to a dense matrix +! +! Arguments: +! trans - character. +! iperm - integer. +! x - real, dimension(:). +! info - integer. Return code. +subroutine psb_e_cgelpv(trans,iperm,x,info) + use psb_serial_mod, psb_protect_name => psb_e_cgelpv + use psb_const_mod + use psb_error_mod + implicit none + + complex(psb_spk_), intent(inout) :: x(:) + integer(psb_epk_), intent(in) :: iperm(:) + integer(psb_ipk_), intent(out) :: info + character, intent(in) :: trans + + ! local variables + integer(psb_ipk_) :: int_err(5), err_act + complex(psb_spk_),allocatable :: temp(:) + integer(psb_epk_) :: i1sz, i + integer(psb_epk_), allocatable :: itemp(:) + integer(psb_ipk_) :: debug_level, debug_unit + character(len=20) :: name + + name = 'psb_cgelp' + if(psb_get_errstatus() /= 0) return + info=psb_success_ + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + i1sz = min(size(x),size(iperm)) + + if (debug_level >= psb_debug_serial_)& + & write(debug_unit,*) trim(name),': size',i1sz + allocate(temp(i1sz),itemp(size(iperm)),stat=info) + if (info /= psb_success_) then + info=2040 + call psb_errpush(info,name) + goto 9999 + end if + itemp(:) = iperm(:) + + if (.not.psb_isaperm(i1sz,itemp)) then + info=psb_err_iarg_invalid_value_ + int_err(1) = 1 + call psb_errpush(info,name,i_err=int_err) + goto 9999 + endif + + select case( psb_toupper(trans)) + case('N') + do i=1,i1sz + temp(i) = x(itemp(i)) + end do + do i=1,i1sz + x(i) = temp(i) + end do + case('T') + do i=1,i1sz + temp(itemp(i)) = x(i) + end do + do i=1,i1sz + x(i) = temp(i) + end do + case default + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='cgelp') + end select + + deallocate(temp,itemp) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_e_cgelpv + subroutine psi_caxpby(m,n,alpha, x, beta, y, info) use psb_const_mod diff --git a/base/serial/psi_d_serial_impl.f90 b/base/serial/psi_d_serial_impl.f90 index 0d80f459..7e51785f 100644 --- a/base/serial/psi_d_serial_impl.f90 +++ b/base/serial/psi_d_serial_impl.f90 @@ -29,6 +29,407 @@ ! POSSIBILITY OF SUCH DAMAGE. ! ! +subroutine psb_m_dgelp(trans,iperm,x,info) + use psb_serial_mod, psb_protect_name => psb_m_dgelp + use psb_const_mod + use psb_error_mod + implicit none + + real(psb_dpk_), intent(inout) :: x(:,:) + integer(psb_mpk_), intent(in) :: iperm(:) + integer(psb_ipk_), intent(out) :: info + character, intent(in) :: trans + + ! local variables + real(psb_dpk_),allocatable :: temp(:) + integer(psb_ipk_) :: int_err(5), i1sz, i2sz, err_act,i,j + integer(psb_ipk_), allocatable :: itemp(:) + real(psb_dpk_),parameter :: one=1 + integer(psb_ipk_) :: debug_level, debug_unit + character(len=20) :: name + name = 'psb_dgelp' + + if(psb_get_errstatus() /= 0) return + info=psb_success_ + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + i1sz = size(x,dim=1) + i2sz = size(x,dim=2) + + if (debug_level >= psb_debug_serial_)& + & write(debug_unit,*) trim(name),': size',i1sz,i2sz + + allocate(temp(i1sz),itemp(size(iperm)),stat=info) + if (info /= psb_success_) then + info=2040 + call psb_errpush(info,name) + goto 9999 + end if + itemp(:) = iperm(:) + + if (.not.psb_isaperm(i1sz,itemp)) then + info=psb_err_iarg_invalid_value_ + int_err(1) = 1 + call psb_errpush(info,name,i_err=int_err) + goto 9999 + endif + select case( psb_toupper(trans)) + case('N') + do j=1,i2sz + do i=1,i1sz + temp(i) = x(itemp(i),j) + end do + do i=1,i1sz + x(i,j) = temp(i) + end do + end do + case('T') + do j=1,i2sz + do i=1,i1sz + temp(itemp(i)) = x(i,j) + end do + do i=1,i1sz + x(i,j) = temp(i) + end do + end do + case default + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='dgelp') + end select + + deallocate(temp,itemp) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_m_dgelp + + + +!!$ +!!$ Parallel Sparse BLAS version 3.5 +!!$ (C) Copyright 2006-2018 +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari University of Rome Tor Vergata +!!$ +!!$ 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. +!!$ +!!$ +! +! +! Subroutine: psb_dgelpv +! Apply a left permutation to a dense matrix +! +! Arguments: +! trans - character. +! iperm - integer. +! x - real, dimension(:). +! info - integer. Return code. +subroutine psb_m_dgelpv(trans,iperm,x,info) + use psb_serial_mod, psb_protect_name => psb_m_dgelpv + use psb_const_mod + use psb_error_mod + implicit none + + real(psb_dpk_), intent(inout) :: x(:) + integer(psb_mpk_), intent(in) :: iperm(:) + integer(psb_ipk_), intent(out) :: info + character, intent(in) :: trans + + ! local variables + integer(psb_ipk_) :: int_err(5), i1sz, err_act, i + real(psb_dpk_),allocatable :: temp(:) + integer(psb_ipk_), allocatable :: itemp(:) + real(psb_dpk_),parameter :: one=1 + integer(psb_ipk_) :: debug_level, debug_unit + character(len=20) :: name + name = 'psb_dgelpv' + + if(psb_get_errstatus() /= 0) return + info=psb_success_ + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + i1sz = min(size(x),size(iperm)) + + if (debug_level >= psb_debug_serial_)& + & write(debug_unit,*) trim(name),': size',i1sz + allocate(temp(i1sz),itemp(size(iperm)),stat=info) + if (info /= psb_success_) then + info=2040 + call psb_errpush(info,name) + goto 9999 + end if + itemp(:) = iperm(:) + + if (.not.psb_isaperm(i1sz,itemp)) then + info=psb_err_iarg_invalid_value_ + int_err(1) = 1 + call psb_errpush(info,name,i_err=int_err) + goto 9999 + endif + + select case( psb_toupper(trans)) + case('N') + do i=1,i1sz + temp(i) = x(itemp(i)) + end do + do i=1,i1sz + x(i) = temp(i) + end do + case('T') + do i=1,i1sz + temp(itemp(i)) = x(i) + end do + do i=1,i1sz + x(i) = temp(i) + end do + case default + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='dgelp') + end select + + deallocate(temp,itemp) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_m_dgelpv + +subroutine psb_e_dgelp(trans,iperm,x,info) + use psb_serial_mod, psb_protect_name => psb_e_dgelp + use psb_const_mod + use psb_error_mod + implicit none + + real(psb_dpk_), intent(inout) :: x(:,:) + integer(psb_epk_), intent(in) :: iperm(:) + integer(psb_ipk_), intent(out) :: info + character, intent(in) :: trans + + ! local variables + real(psb_dpk_),allocatable :: temp(:) + integer(psb_ipk_) :: int_err(5), err_act + integer(psb_epk_) :: i1sz, i2sz, i, j + integer(psb_epk_), allocatable :: itemp(:) + real(psb_dpk_),parameter :: one=1 + integer(psb_ipk_) :: debug_level, debug_unit + character(len=20) :: name + name = 'psb_dgelp' + + if(psb_get_errstatus() /= 0) return + info=psb_success_ + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + i1sz = size(x,dim=1) + i2sz = size(x,dim=2) + + if (debug_level >= psb_debug_serial_)& + & write(debug_unit,*) trim(name),': size',i1sz,i2sz + + allocate(temp(i1sz),itemp(size(iperm)),stat=info) + if (info /= psb_success_) then + info=2040 + call psb_errpush(info,name) + goto 9999 + end if + itemp(:) = iperm(:) + + if (.not.psb_isaperm(i1sz,itemp)) then + info=psb_err_iarg_invalid_value_ + int_err(1) = 1 + call psb_errpush(info,name,i_err=int_err) + goto 9999 + endif + select case( psb_toupper(trans)) + case('N') + do j=1,i2sz + do i=1,i1sz + temp(i) = x(itemp(i),j) + end do + do i=1,i1sz + x(i,j) = temp(i) + end do + end do + case('T') + do j=1,i2sz + do i=1,i1sz + temp(itemp(i)) = x(i,j) + end do + do i=1,i1sz + x(i,j) = temp(i) + end do + end do + case default + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='dgelp') + end select + + deallocate(temp,itemp) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_e_dgelp + + + +!!$ +!!$ Parallel Sparse BLAS version 3.5 +!!$ (C) Copyright 2006-2018 +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari University of Rome Tor Vergata +!!$ +!!$ 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. +!!$ +!!$ +! +! +! Subroutine: psb_dgelpv +! Apply a left permutation to a dense matrix +! +! Arguments: +! trans - character. +! iperm - integer. +! x - real, dimension(:). +! info - integer. Return code. +subroutine psb_e_dgelpv(trans,iperm,x,info) + use psb_serial_mod, psb_protect_name => psb_e_dgelpv + use psb_const_mod + use psb_error_mod + implicit none + + real(psb_dpk_), intent(inout) :: x(:) + integer(psb_epk_), intent(in) :: iperm(:) + integer(psb_ipk_), intent(out) :: info + character, intent(in) :: trans + + ! local variables + integer(psb_ipk_) :: int_err(5), err_act + real(psb_dpk_),allocatable :: temp(:) + integer(psb_epk_) :: i1sz, i + integer(psb_epk_), allocatable :: itemp(:) + integer(psb_ipk_) :: debug_level, debug_unit + character(len=20) :: name + + name = 'psb_dgelp' + if(psb_get_errstatus() /= 0) return + info=psb_success_ + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + i1sz = min(size(x),size(iperm)) + + if (debug_level >= psb_debug_serial_)& + & write(debug_unit,*) trim(name),': size',i1sz + allocate(temp(i1sz),itemp(size(iperm)),stat=info) + if (info /= psb_success_) then + info=2040 + call psb_errpush(info,name) + goto 9999 + end if + itemp(:) = iperm(:) + + if (.not.psb_isaperm(i1sz,itemp)) then + info=psb_err_iarg_invalid_value_ + int_err(1) = 1 + call psb_errpush(info,name,i_err=int_err) + goto 9999 + endif + + select case( psb_toupper(trans)) + case('N') + do i=1,i1sz + temp(i) = x(itemp(i)) + end do + do i=1,i1sz + x(i) = temp(i) + end do + case('T') + do i=1,i1sz + temp(itemp(i)) = x(i) + end do + do i=1,i1sz + x(i) = temp(i) + end do + case default + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='dgelp') + end select + + deallocate(temp,itemp) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_e_dgelpv + subroutine psi_daxpby(m,n,alpha, x, beta, y, info) use psb_const_mod diff --git a/base/serial/psi_e_serial_impl.f90 b/base/serial/psi_e_serial_impl.f90 index 0595d87e..988bad52 100644 --- a/base/serial/psi_e_serial_impl.f90 +++ b/base/serial/psi_e_serial_impl.f90 @@ -29,6 +29,407 @@ ! POSSIBILITY OF SUCH DAMAGE. ! ! +subroutine psb_m_egelp(trans,iperm,x,info) + use psb_serial_mod, psb_protect_name => psb_m_egelp + use psb_const_mod + use psb_error_mod + implicit none + + integer(psb_epk_), intent(inout) :: x(:,:) + integer(psb_mpk_), intent(in) :: iperm(:) + integer(psb_ipk_), intent(out) :: info + character, intent(in) :: trans + + ! local variables + integer(psb_epk_),allocatable :: temp(:) + integer(psb_ipk_) :: int_err(5), i1sz, i2sz, err_act,i,j + integer(psb_ipk_), allocatable :: itemp(:) + integer(psb_epk_),parameter :: one=1 + integer(psb_ipk_) :: debug_level, debug_unit + character(len=20) :: name + name = 'psb_egelp' + + if(psb_get_errstatus() /= 0) return + info=psb_success_ + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + i1sz = size(x,dim=1) + i2sz = size(x,dim=2) + + if (debug_level >= psb_debug_serial_)& + & write(debug_unit,*) trim(name),': size',i1sz,i2sz + + allocate(temp(i1sz),itemp(size(iperm)),stat=info) + if (info /= psb_success_) then + info=2040 + call psb_errpush(info,name) + goto 9999 + end if + itemp(:) = iperm(:) + + if (.not.psb_isaperm(i1sz,itemp)) then + info=psb_err_iarg_invalid_value_ + int_err(1) = 1 + call psb_errpush(info,name,i_err=int_err) + goto 9999 + endif + select case( psb_toupper(trans)) + case('N') + do j=1,i2sz + do i=1,i1sz + temp(i) = x(itemp(i),j) + end do + do i=1,i1sz + x(i,j) = temp(i) + end do + end do + case('T') + do j=1,i2sz + do i=1,i1sz + temp(itemp(i)) = x(i,j) + end do + do i=1,i1sz + x(i,j) = temp(i) + end do + end do + case default + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='egelp') + end select + + deallocate(temp,itemp) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_m_egelp + + + +!!$ +!!$ Parallel Sparse BLAS version 3.5 +!!$ (C) Copyright 2006-2018 +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari University of Rome Tor Vergata +!!$ +!!$ 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. +!!$ +!!$ +! +! +! Subroutine: psb_egelpv +! Apply a left permutation to a dense matrix +! +! Arguments: +! trans - character. +! iperm - integer. +! x - real, dimension(:). +! info - integer. Return code. +subroutine psb_m_egelpv(trans,iperm,x,info) + use psb_serial_mod, psb_protect_name => psb_m_egelpv + use psb_const_mod + use psb_error_mod + implicit none + + integer(psb_epk_), intent(inout) :: x(:) + integer(psb_mpk_), intent(in) :: iperm(:) + integer(psb_ipk_), intent(out) :: info + character, intent(in) :: trans + + ! local variables + integer(psb_ipk_) :: int_err(5), i1sz, err_act, i + integer(psb_epk_),allocatable :: temp(:) + integer(psb_ipk_), allocatable :: itemp(:) + integer(psb_epk_),parameter :: one=1 + integer(psb_ipk_) :: debug_level, debug_unit + character(len=20) :: name + name = 'psb_egelpv' + + if(psb_get_errstatus() /= 0) return + info=psb_success_ + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + i1sz = min(size(x),size(iperm)) + + if (debug_level >= psb_debug_serial_)& + & write(debug_unit,*) trim(name),': size',i1sz + allocate(temp(i1sz),itemp(size(iperm)),stat=info) + if (info /= psb_success_) then + info=2040 + call psb_errpush(info,name) + goto 9999 + end if + itemp(:) = iperm(:) + + if (.not.psb_isaperm(i1sz,itemp)) then + info=psb_err_iarg_invalid_value_ + int_err(1) = 1 + call psb_errpush(info,name,i_err=int_err) + goto 9999 + endif + + select case( psb_toupper(trans)) + case('N') + do i=1,i1sz + temp(i) = x(itemp(i)) + end do + do i=1,i1sz + x(i) = temp(i) + end do + case('T') + do i=1,i1sz + temp(itemp(i)) = x(i) + end do + do i=1,i1sz + x(i) = temp(i) + end do + case default + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='egelp') + end select + + deallocate(temp,itemp) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_m_egelpv + +subroutine psb_e_egelp(trans,iperm,x,info) + use psb_serial_mod, psb_protect_name => psb_e_egelp + use psb_const_mod + use psb_error_mod + implicit none + + integer(psb_epk_), intent(inout) :: x(:,:) + integer(psb_epk_), intent(in) :: iperm(:) + integer(psb_ipk_), intent(out) :: info + character, intent(in) :: trans + + ! local variables + integer(psb_epk_),allocatable :: temp(:) + integer(psb_ipk_) :: int_err(5), err_act + integer(psb_epk_) :: i1sz, i2sz, i, j + integer(psb_epk_), allocatable :: itemp(:) + integer(psb_epk_),parameter :: one=1 + integer(psb_ipk_) :: debug_level, debug_unit + character(len=20) :: name + name = 'psb_egelp' + + if(psb_get_errstatus() /= 0) return + info=psb_success_ + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + i1sz = size(x,dim=1) + i2sz = size(x,dim=2) + + if (debug_level >= psb_debug_serial_)& + & write(debug_unit,*) trim(name),': size',i1sz,i2sz + + allocate(temp(i1sz),itemp(size(iperm)),stat=info) + if (info /= psb_success_) then + info=2040 + call psb_errpush(info,name) + goto 9999 + end if + itemp(:) = iperm(:) + + if (.not.psb_isaperm(i1sz,itemp)) then + info=psb_err_iarg_invalid_value_ + int_err(1) = 1 + call psb_errpush(info,name,i_err=int_err) + goto 9999 + endif + select case( psb_toupper(trans)) + case('N') + do j=1,i2sz + do i=1,i1sz + temp(i) = x(itemp(i),j) + end do + do i=1,i1sz + x(i,j) = temp(i) + end do + end do + case('T') + do j=1,i2sz + do i=1,i1sz + temp(itemp(i)) = x(i,j) + end do + do i=1,i1sz + x(i,j) = temp(i) + end do + end do + case default + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='egelp') + end select + + deallocate(temp,itemp) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_e_egelp + + + +!!$ +!!$ Parallel Sparse BLAS version 3.5 +!!$ (C) Copyright 2006-2018 +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari University of Rome Tor Vergata +!!$ +!!$ 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. +!!$ +!!$ +! +! +! Subroutine: psb_egelpv +! Apply a left permutation to a dense matrix +! +! Arguments: +! trans - character. +! iperm - integer. +! x - real, dimension(:). +! info - integer. Return code. +subroutine psb_e_egelpv(trans,iperm,x,info) + use psb_serial_mod, psb_protect_name => psb_e_egelpv + use psb_const_mod + use psb_error_mod + implicit none + + integer(psb_epk_), intent(inout) :: x(:) + integer(psb_epk_), intent(in) :: iperm(:) + integer(psb_ipk_), intent(out) :: info + character, intent(in) :: trans + + ! local variables + integer(psb_ipk_) :: int_err(5), err_act + integer(psb_epk_),allocatable :: temp(:) + integer(psb_epk_) :: i1sz, i + integer(psb_epk_), allocatable :: itemp(:) + integer(psb_ipk_) :: debug_level, debug_unit + character(len=20) :: name + + name = 'psb_egelp' + if(psb_get_errstatus() /= 0) return + info=psb_success_ + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + i1sz = min(size(x),size(iperm)) + + if (debug_level >= psb_debug_serial_)& + & write(debug_unit,*) trim(name),': size',i1sz + allocate(temp(i1sz),itemp(size(iperm)),stat=info) + if (info /= psb_success_) then + info=2040 + call psb_errpush(info,name) + goto 9999 + end if + itemp(:) = iperm(:) + + if (.not.psb_isaperm(i1sz,itemp)) then + info=psb_err_iarg_invalid_value_ + int_err(1) = 1 + call psb_errpush(info,name,i_err=int_err) + goto 9999 + endif + + select case( psb_toupper(trans)) + case('N') + do i=1,i1sz + temp(i) = x(itemp(i)) + end do + do i=1,i1sz + x(i) = temp(i) + end do + case('T') + do i=1,i1sz + temp(itemp(i)) = x(i) + end do + do i=1,i1sz + x(i) = temp(i) + end do + case default + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='egelp') + end select + + deallocate(temp,itemp) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_e_egelpv + subroutine psi_eaxpby(m,n,alpha, x, beta, y, info) use psb_const_mod diff --git a/base/serial/psi_i2_serial_impl.f90 b/base/serial/psi_i2_serial_impl.f90 index 59d579f2..83b078f0 100644 --- a/base/serial/psi_i2_serial_impl.f90 +++ b/base/serial/psi_i2_serial_impl.f90 @@ -29,6 +29,407 @@ ! POSSIBILITY OF SUCH DAMAGE. ! ! +subroutine psb_m_i2gelp(trans,iperm,x,info) + use psb_serial_mod, psb_protect_name => psb_m_i2gelp + use psb_const_mod + use psb_error_mod + implicit none + + integer(psb_i2pk_), intent(inout) :: x(:,:) + integer(psb_mpk_), intent(in) :: iperm(:) + integer(psb_ipk_), intent(out) :: info + character, intent(in) :: trans + + ! local variables + integer(psb_i2pk_),allocatable :: temp(:) + integer(psb_ipk_) :: int_err(5), i1sz, i2sz, err_act,i,j + integer(psb_ipk_), allocatable :: itemp(:) + integer(psb_i2pk_),parameter :: one=1 + integer(psb_ipk_) :: debug_level, debug_unit + character(len=20) :: name + name = 'psb_i2gelp' + + if(psb_get_errstatus() /= 0) return + info=psb_success_ + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + i1sz = size(x,dim=1) + i2sz = size(x,dim=2) + + if (debug_level >= psb_debug_serial_)& + & write(debug_unit,*) trim(name),': size',i1sz,i2sz + + allocate(temp(i1sz),itemp(size(iperm)),stat=info) + if (info /= psb_success_) then + info=2040 + call psb_errpush(info,name) + goto 9999 + end if + itemp(:) = iperm(:) + + if (.not.psb_isaperm(i1sz,itemp)) then + info=psb_err_iarg_invalid_value_ + int_err(1) = 1 + call psb_errpush(info,name,i_err=int_err) + goto 9999 + endif + select case( psb_toupper(trans)) + case('N') + do j=1,i2sz + do i=1,i1sz + temp(i) = x(itemp(i),j) + end do + do i=1,i1sz + x(i,j) = temp(i) + end do + end do + case('T') + do j=1,i2sz + do i=1,i1sz + temp(itemp(i)) = x(i,j) + end do + do i=1,i1sz + x(i,j) = temp(i) + end do + end do + case default + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='i2gelp') + end select + + deallocate(temp,itemp) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_m_i2gelp + + + +!!$ +!!$ Parallel Sparse BLAS version 3.5 +!!$ (C) Copyright 2006-2018 +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari University of Rome Tor Vergata +!!$ +!!$ 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. +!!$ +!!$ +! +! +! Subroutine: psb_i2gelpv +! Apply a left permutation to a dense matrix +! +! Arguments: +! trans - character. +! iperm - integer. +! x - real, dimension(:). +! info - integer. Return code. +subroutine psb_m_i2gelpv(trans,iperm,x,info) + use psb_serial_mod, psb_protect_name => psb_m_i2gelpv + use psb_const_mod + use psb_error_mod + implicit none + + integer(psb_i2pk_), intent(inout) :: x(:) + integer(psb_mpk_), intent(in) :: iperm(:) + integer(psb_ipk_), intent(out) :: info + character, intent(in) :: trans + + ! local variables + integer(psb_ipk_) :: int_err(5), i1sz, err_act, i + integer(psb_i2pk_),allocatable :: temp(:) + integer(psb_ipk_), allocatable :: itemp(:) + integer(psb_i2pk_),parameter :: one=1 + integer(psb_ipk_) :: debug_level, debug_unit + character(len=20) :: name + name = 'psb_i2gelpv' + + if(psb_get_errstatus() /= 0) return + info=psb_success_ + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + i1sz = min(size(x),size(iperm)) + + if (debug_level >= psb_debug_serial_)& + & write(debug_unit,*) trim(name),': size',i1sz + allocate(temp(i1sz),itemp(size(iperm)),stat=info) + if (info /= psb_success_) then + info=2040 + call psb_errpush(info,name) + goto 9999 + end if + itemp(:) = iperm(:) + + if (.not.psb_isaperm(i1sz,itemp)) then + info=psb_err_iarg_invalid_value_ + int_err(1) = 1 + call psb_errpush(info,name,i_err=int_err) + goto 9999 + endif + + select case( psb_toupper(trans)) + case('N') + do i=1,i1sz + temp(i) = x(itemp(i)) + end do + do i=1,i1sz + x(i) = temp(i) + end do + case('T') + do i=1,i1sz + temp(itemp(i)) = x(i) + end do + do i=1,i1sz + x(i) = temp(i) + end do + case default + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='i2gelp') + end select + + deallocate(temp,itemp) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_m_i2gelpv + +subroutine psb_e_i2gelp(trans,iperm,x,info) + use psb_serial_mod, psb_protect_name => psb_e_i2gelp + use psb_const_mod + use psb_error_mod + implicit none + + integer(psb_i2pk_), intent(inout) :: x(:,:) + integer(psb_epk_), intent(in) :: iperm(:) + integer(psb_ipk_), intent(out) :: info + character, intent(in) :: trans + + ! local variables + integer(psb_i2pk_),allocatable :: temp(:) + integer(psb_ipk_) :: int_err(5), err_act + integer(psb_epk_) :: i1sz, i2sz, i, j + integer(psb_epk_), allocatable :: itemp(:) + integer(psb_i2pk_),parameter :: one=1 + integer(psb_ipk_) :: debug_level, debug_unit + character(len=20) :: name + name = 'psb_i2gelp' + + if(psb_get_errstatus() /= 0) return + info=psb_success_ + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + i1sz = size(x,dim=1) + i2sz = size(x,dim=2) + + if (debug_level >= psb_debug_serial_)& + & write(debug_unit,*) trim(name),': size',i1sz,i2sz + + allocate(temp(i1sz),itemp(size(iperm)),stat=info) + if (info /= psb_success_) then + info=2040 + call psb_errpush(info,name) + goto 9999 + end if + itemp(:) = iperm(:) + + if (.not.psb_isaperm(i1sz,itemp)) then + info=psb_err_iarg_invalid_value_ + int_err(1) = 1 + call psb_errpush(info,name,i_err=int_err) + goto 9999 + endif + select case( psb_toupper(trans)) + case('N') + do j=1,i2sz + do i=1,i1sz + temp(i) = x(itemp(i),j) + end do + do i=1,i1sz + x(i,j) = temp(i) + end do + end do + case('T') + do j=1,i2sz + do i=1,i1sz + temp(itemp(i)) = x(i,j) + end do + do i=1,i1sz + x(i,j) = temp(i) + end do + end do + case default + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='i2gelp') + end select + + deallocate(temp,itemp) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_e_i2gelp + + + +!!$ +!!$ Parallel Sparse BLAS version 3.5 +!!$ (C) Copyright 2006-2018 +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari University of Rome Tor Vergata +!!$ +!!$ 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. +!!$ +!!$ +! +! +! Subroutine: psb_i2gelpv +! Apply a left permutation to a dense matrix +! +! Arguments: +! trans - character. +! iperm - integer. +! x - real, dimension(:). +! info - integer. Return code. +subroutine psb_e_i2gelpv(trans,iperm,x,info) + use psb_serial_mod, psb_protect_name => psb_e_i2gelpv + use psb_const_mod + use psb_error_mod + implicit none + + integer(psb_i2pk_), intent(inout) :: x(:) + integer(psb_epk_), intent(in) :: iperm(:) + integer(psb_ipk_), intent(out) :: info + character, intent(in) :: trans + + ! local variables + integer(psb_ipk_) :: int_err(5), err_act + integer(psb_i2pk_),allocatable :: temp(:) + integer(psb_epk_) :: i1sz, i + integer(psb_epk_), allocatable :: itemp(:) + integer(psb_ipk_) :: debug_level, debug_unit + character(len=20) :: name + + name = 'psb_i2gelp' + if(psb_get_errstatus() /= 0) return + info=psb_success_ + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + i1sz = min(size(x),size(iperm)) + + if (debug_level >= psb_debug_serial_)& + & write(debug_unit,*) trim(name),': size',i1sz + allocate(temp(i1sz),itemp(size(iperm)),stat=info) + if (info /= psb_success_) then + info=2040 + call psb_errpush(info,name) + goto 9999 + end if + itemp(:) = iperm(:) + + if (.not.psb_isaperm(i1sz,itemp)) then + info=psb_err_iarg_invalid_value_ + int_err(1) = 1 + call psb_errpush(info,name,i_err=int_err) + goto 9999 + endif + + select case( psb_toupper(trans)) + case('N') + do i=1,i1sz + temp(i) = x(itemp(i)) + end do + do i=1,i1sz + x(i) = temp(i) + end do + case('T') + do i=1,i1sz + temp(itemp(i)) = x(i) + end do + do i=1,i1sz + x(i) = temp(i) + end do + case default + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='i2gelp') + end select + + deallocate(temp,itemp) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_e_i2gelpv + subroutine psi_i2axpby(m,n,alpha, x, beta, y, info) use psb_const_mod diff --git a/base/serial/psi_m_serial_impl.f90 b/base/serial/psi_m_serial_impl.f90 index cc8b9f4f..950e2358 100644 --- a/base/serial/psi_m_serial_impl.f90 +++ b/base/serial/psi_m_serial_impl.f90 @@ -29,6 +29,407 @@ ! POSSIBILITY OF SUCH DAMAGE. ! ! +subroutine psb_m_mgelp(trans,iperm,x,info) + use psb_serial_mod, psb_protect_name => psb_m_mgelp + use psb_const_mod + use psb_error_mod + implicit none + + integer(psb_mpk_), intent(inout) :: x(:,:) + integer(psb_mpk_), intent(in) :: iperm(:) + integer(psb_ipk_), intent(out) :: info + character, intent(in) :: trans + + ! local variables + integer(psb_mpk_),allocatable :: temp(:) + integer(psb_ipk_) :: int_err(5), i1sz, i2sz, err_act,i,j + integer(psb_ipk_), allocatable :: itemp(:) + integer(psb_mpk_),parameter :: one=1 + integer(psb_ipk_) :: debug_level, debug_unit + character(len=20) :: name + name = 'psb_mgelp' + + if(psb_get_errstatus() /= 0) return + info=psb_success_ + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + i1sz = size(x,dim=1) + i2sz = size(x,dim=2) + + if (debug_level >= psb_debug_serial_)& + & write(debug_unit,*) trim(name),': size',i1sz,i2sz + + allocate(temp(i1sz),itemp(size(iperm)),stat=info) + if (info /= psb_success_) then + info=2040 + call psb_errpush(info,name) + goto 9999 + end if + itemp(:) = iperm(:) + + if (.not.psb_isaperm(i1sz,itemp)) then + info=psb_err_iarg_invalid_value_ + int_err(1) = 1 + call psb_errpush(info,name,i_err=int_err) + goto 9999 + endif + select case( psb_toupper(trans)) + case('N') + do j=1,i2sz + do i=1,i1sz + temp(i) = x(itemp(i),j) + end do + do i=1,i1sz + x(i,j) = temp(i) + end do + end do + case('T') + do j=1,i2sz + do i=1,i1sz + temp(itemp(i)) = x(i,j) + end do + do i=1,i1sz + x(i,j) = temp(i) + end do + end do + case default + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='mgelp') + end select + + deallocate(temp,itemp) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_m_mgelp + + + +!!$ +!!$ Parallel Sparse BLAS version 3.5 +!!$ (C) Copyright 2006-2018 +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari University of Rome Tor Vergata +!!$ +!!$ 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. +!!$ +!!$ +! +! +! Subroutine: psb_mgelpv +! Apply a left permutation to a dense matrix +! +! Arguments: +! trans - character. +! iperm - integer. +! x - real, dimension(:). +! info - integer. Return code. +subroutine psb_m_mgelpv(trans,iperm,x,info) + use psb_serial_mod, psb_protect_name => psb_m_mgelpv + use psb_const_mod + use psb_error_mod + implicit none + + integer(psb_mpk_), intent(inout) :: x(:) + integer(psb_mpk_), intent(in) :: iperm(:) + integer(psb_ipk_), intent(out) :: info + character, intent(in) :: trans + + ! local variables + integer(psb_ipk_) :: int_err(5), i1sz, err_act, i + integer(psb_mpk_),allocatable :: temp(:) + integer(psb_ipk_), allocatable :: itemp(:) + integer(psb_mpk_),parameter :: one=1 + integer(psb_ipk_) :: debug_level, debug_unit + character(len=20) :: name + name = 'psb_mgelpv' + + if(psb_get_errstatus() /= 0) return + info=psb_success_ + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + i1sz = min(size(x),size(iperm)) + + if (debug_level >= psb_debug_serial_)& + & write(debug_unit,*) trim(name),': size',i1sz + allocate(temp(i1sz),itemp(size(iperm)),stat=info) + if (info /= psb_success_) then + info=2040 + call psb_errpush(info,name) + goto 9999 + end if + itemp(:) = iperm(:) + + if (.not.psb_isaperm(i1sz,itemp)) then + info=psb_err_iarg_invalid_value_ + int_err(1) = 1 + call psb_errpush(info,name,i_err=int_err) + goto 9999 + endif + + select case( psb_toupper(trans)) + case('N') + do i=1,i1sz + temp(i) = x(itemp(i)) + end do + do i=1,i1sz + x(i) = temp(i) + end do + case('T') + do i=1,i1sz + temp(itemp(i)) = x(i) + end do + do i=1,i1sz + x(i) = temp(i) + end do + case default + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='mgelp') + end select + + deallocate(temp,itemp) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_m_mgelpv + +subroutine psb_e_mgelp(trans,iperm,x,info) + use psb_serial_mod, psb_protect_name => psb_e_mgelp + use psb_const_mod + use psb_error_mod + implicit none + + integer(psb_mpk_), intent(inout) :: x(:,:) + integer(psb_epk_), intent(in) :: iperm(:) + integer(psb_ipk_), intent(out) :: info + character, intent(in) :: trans + + ! local variables + integer(psb_mpk_),allocatable :: temp(:) + integer(psb_ipk_) :: int_err(5), err_act + integer(psb_epk_) :: i1sz, i2sz, i, j + integer(psb_epk_), allocatable :: itemp(:) + integer(psb_mpk_),parameter :: one=1 + integer(psb_ipk_) :: debug_level, debug_unit + character(len=20) :: name + name = 'psb_mgelp' + + if(psb_get_errstatus() /= 0) return + info=psb_success_ + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + i1sz = size(x,dim=1) + i2sz = size(x,dim=2) + + if (debug_level >= psb_debug_serial_)& + & write(debug_unit,*) trim(name),': size',i1sz,i2sz + + allocate(temp(i1sz),itemp(size(iperm)),stat=info) + if (info /= psb_success_) then + info=2040 + call psb_errpush(info,name) + goto 9999 + end if + itemp(:) = iperm(:) + + if (.not.psb_isaperm(i1sz,itemp)) then + info=psb_err_iarg_invalid_value_ + int_err(1) = 1 + call psb_errpush(info,name,i_err=int_err) + goto 9999 + endif + select case( psb_toupper(trans)) + case('N') + do j=1,i2sz + do i=1,i1sz + temp(i) = x(itemp(i),j) + end do + do i=1,i1sz + x(i,j) = temp(i) + end do + end do + case('T') + do j=1,i2sz + do i=1,i1sz + temp(itemp(i)) = x(i,j) + end do + do i=1,i1sz + x(i,j) = temp(i) + end do + end do + case default + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='mgelp') + end select + + deallocate(temp,itemp) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_e_mgelp + + + +!!$ +!!$ Parallel Sparse BLAS version 3.5 +!!$ (C) Copyright 2006-2018 +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari University of Rome Tor Vergata +!!$ +!!$ 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. +!!$ +!!$ +! +! +! Subroutine: psb_mgelpv +! Apply a left permutation to a dense matrix +! +! Arguments: +! trans - character. +! iperm - integer. +! x - real, dimension(:). +! info - integer. Return code. +subroutine psb_e_mgelpv(trans,iperm,x,info) + use psb_serial_mod, psb_protect_name => psb_e_mgelpv + use psb_const_mod + use psb_error_mod + implicit none + + integer(psb_mpk_), intent(inout) :: x(:) + integer(psb_epk_), intent(in) :: iperm(:) + integer(psb_ipk_), intent(out) :: info + character, intent(in) :: trans + + ! local variables + integer(psb_ipk_) :: int_err(5), err_act + integer(psb_mpk_),allocatable :: temp(:) + integer(psb_epk_) :: i1sz, i + integer(psb_epk_), allocatable :: itemp(:) + integer(psb_ipk_) :: debug_level, debug_unit + character(len=20) :: name + + name = 'psb_mgelp' + if(psb_get_errstatus() /= 0) return + info=psb_success_ + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + i1sz = min(size(x),size(iperm)) + + if (debug_level >= psb_debug_serial_)& + & write(debug_unit,*) trim(name),': size',i1sz + allocate(temp(i1sz),itemp(size(iperm)),stat=info) + if (info /= psb_success_) then + info=2040 + call psb_errpush(info,name) + goto 9999 + end if + itemp(:) = iperm(:) + + if (.not.psb_isaperm(i1sz,itemp)) then + info=psb_err_iarg_invalid_value_ + int_err(1) = 1 + call psb_errpush(info,name,i_err=int_err) + goto 9999 + endif + + select case( psb_toupper(trans)) + case('N') + do i=1,i1sz + temp(i) = x(itemp(i)) + end do + do i=1,i1sz + x(i) = temp(i) + end do + case('T') + do i=1,i1sz + temp(itemp(i)) = x(i) + end do + do i=1,i1sz + x(i) = temp(i) + end do + case default + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='mgelp') + end select + + deallocate(temp,itemp) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_e_mgelpv + subroutine psi_maxpby(m,n,alpha, x, beta, y, info) use psb_const_mod diff --git a/base/serial/psi_s_serial_impl.f90 b/base/serial/psi_s_serial_impl.f90 index dfe2559b..e9d4392c 100644 --- a/base/serial/psi_s_serial_impl.f90 +++ b/base/serial/psi_s_serial_impl.f90 @@ -29,6 +29,407 @@ ! POSSIBILITY OF SUCH DAMAGE. ! ! +subroutine psb_m_sgelp(trans,iperm,x,info) + use psb_serial_mod, psb_protect_name => psb_m_sgelp + use psb_const_mod + use psb_error_mod + implicit none + + real(psb_spk_), intent(inout) :: x(:,:) + integer(psb_mpk_), intent(in) :: iperm(:) + integer(psb_ipk_), intent(out) :: info + character, intent(in) :: trans + + ! local variables + real(psb_spk_),allocatable :: temp(:) + integer(psb_ipk_) :: int_err(5), i1sz, i2sz, err_act,i,j + integer(psb_ipk_), allocatable :: itemp(:) + real(psb_spk_),parameter :: one=1 + integer(psb_ipk_) :: debug_level, debug_unit + character(len=20) :: name + name = 'psb_sgelp' + + if(psb_get_errstatus() /= 0) return + info=psb_success_ + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + i1sz = size(x,dim=1) + i2sz = size(x,dim=2) + + if (debug_level >= psb_debug_serial_)& + & write(debug_unit,*) trim(name),': size',i1sz,i2sz + + allocate(temp(i1sz),itemp(size(iperm)),stat=info) + if (info /= psb_success_) then + info=2040 + call psb_errpush(info,name) + goto 9999 + end if + itemp(:) = iperm(:) + + if (.not.psb_isaperm(i1sz,itemp)) then + info=psb_err_iarg_invalid_value_ + int_err(1) = 1 + call psb_errpush(info,name,i_err=int_err) + goto 9999 + endif + select case( psb_toupper(trans)) + case('N') + do j=1,i2sz + do i=1,i1sz + temp(i) = x(itemp(i),j) + end do + do i=1,i1sz + x(i,j) = temp(i) + end do + end do + case('T') + do j=1,i2sz + do i=1,i1sz + temp(itemp(i)) = x(i,j) + end do + do i=1,i1sz + x(i,j) = temp(i) + end do + end do + case default + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='sgelp') + end select + + deallocate(temp,itemp) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_m_sgelp + + + +!!$ +!!$ Parallel Sparse BLAS version 3.5 +!!$ (C) Copyright 2006-2018 +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari University of Rome Tor Vergata +!!$ +!!$ 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. +!!$ +!!$ +! +! +! Subroutine: psb_sgelpv +! Apply a left permutation to a dense matrix +! +! Arguments: +! trans - character. +! iperm - integer. +! x - real, dimension(:). +! info - integer. Return code. +subroutine psb_m_sgelpv(trans,iperm,x,info) + use psb_serial_mod, psb_protect_name => psb_m_sgelpv + use psb_const_mod + use psb_error_mod + implicit none + + real(psb_spk_), intent(inout) :: x(:) + integer(psb_mpk_), intent(in) :: iperm(:) + integer(psb_ipk_), intent(out) :: info + character, intent(in) :: trans + + ! local variables + integer(psb_ipk_) :: int_err(5), i1sz, err_act, i + real(psb_spk_),allocatable :: temp(:) + integer(psb_ipk_), allocatable :: itemp(:) + real(psb_spk_),parameter :: one=1 + integer(psb_ipk_) :: debug_level, debug_unit + character(len=20) :: name + name = 'psb_sgelpv' + + if(psb_get_errstatus() /= 0) return + info=psb_success_ + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + i1sz = min(size(x),size(iperm)) + + if (debug_level >= psb_debug_serial_)& + & write(debug_unit,*) trim(name),': size',i1sz + allocate(temp(i1sz),itemp(size(iperm)),stat=info) + if (info /= psb_success_) then + info=2040 + call psb_errpush(info,name) + goto 9999 + end if + itemp(:) = iperm(:) + + if (.not.psb_isaperm(i1sz,itemp)) then + info=psb_err_iarg_invalid_value_ + int_err(1) = 1 + call psb_errpush(info,name,i_err=int_err) + goto 9999 + endif + + select case( psb_toupper(trans)) + case('N') + do i=1,i1sz + temp(i) = x(itemp(i)) + end do + do i=1,i1sz + x(i) = temp(i) + end do + case('T') + do i=1,i1sz + temp(itemp(i)) = x(i) + end do + do i=1,i1sz + x(i) = temp(i) + end do + case default + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='sgelp') + end select + + deallocate(temp,itemp) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_m_sgelpv + +subroutine psb_e_sgelp(trans,iperm,x,info) + use psb_serial_mod, psb_protect_name => psb_e_sgelp + use psb_const_mod + use psb_error_mod + implicit none + + real(psb_spk_), intent(inout) :: x(:,:) + integer(psb_epk_), intent(in) :: iperm(:) + integer(psb_ipk_), intent(out) :: info + character, intent(in) :: trans + + ! local variables + real(psb_spk_),allocatable :: temp(:) + integer(psb_ipk_) :: int_err(5), err_act + integer(psb_epk_) :: i1sz, i2sz, i, j + integer(psb_epk_), allocatable :: itemp(:) + real(psb_spk_),parameter :: one=1 + integer(psb_ipk_) :: debug_level, debug_unit + character(len=20) :: name + name = 'psb_sgelp' + + if(psb_get_errstatus() /= 0) return + info=psb_success_ + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + i1sz = size(x,dim=1) + i2sz = size(x,dim=2) + + if (debug_level >= psb_debug_serial_)& + & write(debug_unit,*) trim(name),': size',i1sz,i2sz + + allocate(temp(i1sz),itemp(size(iperm)),stat=info) + if (info /= psb_success_) then + info=2040 + call psb_errpush(info,name) + goto 9999 + end if + itemp(:) = iperm(:) + + if (.not.psb_isaperm(i1sz,itemp)) then + info=psb_err_iarg_invalid_value_ + int_err(1) = 1 + call psb_errpush(info,name,i_err=int_err) + goto 9999 + endif + select case( psb_toupper(trans)) + case('N') + do j=1,i2sz + do i=1,i1sz + temp(i) = x(itemp(i),j) + end do + do i=1,i1sz + x(i,j) = temp(i) + end do + end do + case('T') + do j=1,i2sz + do i=1,i1sz + temp(itemp(i)) = x(i,j) + end do + do i=1,i1sz + x(i,j) = temp(i) + end do + end do + case default + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='sgelp') + end select + + deallocate(temp,itemp) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_e_sgelp + + + +!!$ +!!$ Parallel Sparse BLAS version 3.5 +!!$ (C) Copyright 2006-2018 +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari University of Rome Tor Vergata +!!$ +!!$ 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. +!!$ +!!$ +! +! +! Subroutine: psb_sgelpv +! Apply a left permutation to a dense matrix +! +! Arguments: +! trans - character. +! iperm - integer. +! x - real, dimension(:). +! info - integer. Return code. +subroutine psb_e_sgelpv(trans,iperm,x,info) + use psb_serial_mod, psb_protect_name => psb_e_sgelpv + use psb_const_mod + use psb_error_mod + implicit none + + real(psb_spk_), intent(inout) :: x(:) + integer(psb_epk_), intent(in) :: iperm(:) + integer(psb_ipk_), intent(out) :: info + character, intent(in) :: trans + + ! local variables + integer(psb_ipk_) :: int_err(5), err_act + real(psb_spk_),allocatable :: temp(:) + integer(psb_epk_) :: i1sz, i + integer(psb_epk_), allocatable :: itemp(:) + integer(psb_ipk_) :: debug_level, debug_unit + character(len=20) :: name + + name = 'psb_sgelp' + if(psb_get_errstatus() /= 0) return + info=psb_success_ + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + i1sz = min(size(x),size(iperm)) + + if (debug_level >= psb_debug_serial_)& + & write(debug_unit,*) trim(name),': size',i1sz + allocate(temp(i1sz),itemp(size(iperm)),stat=info) + if (info /= psb_success_) then + info=2040 + call psb_errpush(info,name) + goto 9999 + end if + itemp(:) = iperm(:) + + if (.not.psb_isaperm(i1sz,itemp)) then + info=psb_err_iarg_invalid_value_ + int_err(1) = 1 + call psb_errpush(info,name,i_err=int_err) + goto 9999 + endif + + select case( psb_toupper(trans)) + case('N') + do i=1,i1sz + temp(i) = x(itemp(i)) + end do + do i=1,i1sz + x(i) = temp(i) + end do + case('T') + do i=1,i1sz + temp(itemp(i)) = x(i) + end do + do i=1,i1sz + x(i) = temp(i) + end do + case default + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='sgelp') + end select + + deallocate(temp,itemp) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_e_sgelpv + subroutine psi_saxpby(m,n,alpha, x, beta, y, info) use psb_const_mod diff --git a/base/serial/psi_z_serial_impl.f90 b/base/serial/psi_z_serial_impl.f90 index 5b7036e6..da459f3b 100644 --- a/base/serial/psi_z_serial_impl.f90 +++ b/base/serial/psi_z_serial_impl.f90 @@ -29,6 +29,407 @@ ! POSSIBILITY OF SUCH DAMAGE. ! ! +subroutine psb_m_zgelp(trans,iperm,x,info) + use psb_serial_mod, psb_protect_name => psb_m_zgelp + use psb_const_mod + use psb_error_mod + implicit none + + complex(psb_dpk_), intent(inout) :: x(:,:) + integer(psb_mpk_), intent(in) :: iperm(:) + integer(psb_ipk_), intent(out) :: info + character, intent(in) :: trans + + ! local variables + complex(psb_dpk_),allocatable :: temp(:) + integer(psb_ipk_) :: int_err(5), i1sz, i2sz, err_act,i,j + integer(psb_ipk_), allocatable :: itemp(:) + complex(psb_dpk_),parameter :: one=1 + integer(psb_ipk_) :: debug_level, debug_unit + character(len=20) :: name + name = 'psb_zgelp' + + if(psb_get_errstatus() /= 0) return + info=psb_success_ + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + i1sz = size(x,dim=1) + i2sz = size(x,dim=2) + + if (debug_level >= psb_debug_serial_)& + & write(debug_unit,*) trim(name),': size',i1sz,i2sz + + allocate(temp(i1sz),itemp(size(iperm)),stat=info) + if (info /= psb_success_) then + info=2040 + call psb_errpush(info,name) + goto 9999 + end if + itemp(:) = iperm(:) + + if (.not.psb_isaperm(i1sz,itemp)) then + info=psb_err_iarg_invalid_value_ + int_err(1) = 1 + call psb_errpush(info,name,i_err=int_err) + goto 9999 + endif + select case( psb_toupper(trans)) + case('N') + do j=1,i2sz + do i=1,i1sz + temp(i) = x(itemp(i),j) + end do + do i=1,i1sz + x(i,j) = temp(i) + end do + end do + case('T') + do j=1,i2sz + do i=1,i1sz + temp(itemp(i)) = x(i,j) + end do + do i=1,i1sz + x(i,j) = temp(i) + end do + end do + case default + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='zgelp') + end select + + deallocate(temp,itemp) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_m_zgelp + + + +!!$ +!!$ Parallel Sparse BLAS version 3.5 +!!$ (C) Copyright 2006-2018 +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari University of Rome Tor Vergata +!!$ +!!$ 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. +!!$ +!!$ +! +! +! Subroutine: psb_zgelpv +! Apply a left permutation to a dense matrix +! +! Arguments: +! trans - character. +! iperm - integer. +! x - real, dimension(:). +! info - integer. Return code. +subroutine psb_m_zgelpv(trans,iperm,x,info) + use psb_serial_mod, psb_protect_name => psb_m_zgelpv + use psb_const_mod + use psb_error_mod + implicit none + + complex(psb_dpk_), intent(inout) :: x(:) + integer(psb_mpk_), intent(in) :: iperm(:) + integer(psb_ipk_), intent(out) :: info + character, intent(in) :: trans + + ! local variables + integer(psb_ipk_) :: int_err(5), i1sz, err_act, i + complex(psb_dpk_),allocatable :: temp(:) + integer(psb_ipk_), allocatable :: itemp(:) + complex(psb_dpk_),parameter :: one=1 + integer(psb_ipk_) :: debug_level, debug_unit + character(len=20) :: name + name = 'psb_zgelpv' + + if(psb_get_errstatus() /= 0) return + info=psb_success_ + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + i1sz = min(size(x),size(iperm)) + + if (debug_level >= psb_debug_serial_)& + & write(debug_unit,*) trim(name),': size',i1sz + allocate(temp(i1sz),itemp(size(iperm)),stat=info) + if (info /= psb_success_) then + info=2040 + call psb_errpush(info,name) + goto 9999 + end if + itemp(:) = iperm(:) + + if (.not.psb_isaperm(i1sz,itemp)) then + info=psb_err_iarg_invalid_value_ + int_err(1) = 1 + call psb_errpush(info,name,i_err=int_err) + goto 9999 + endif + + select case( psb_toupper(trans)) + case('N') + do i=1,i1sz + temp(i) = x(itemp(i)) + end do + do i=1,i1sz + x(i) = temp(i) + end do + case('T') + do i=1,i1sz + temp(itemp(i)) = x(i) + end do + do i=1,i1sz + x(i) = temp(i) + end do + case default + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='zgelp') + end select + + deallocate(temp,itemp) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_m_zgelpv + +subroutine psb_e_zgelp(trans,iperm,x,info) + use psb_serial_mod, psb_protect_name => psb_e_zgelp + use psb_const_mod + use psb_error_mod + implicit none + + complex(psb_dpk_), intent(inout) :: x(:,:) + integer(psb_epk_), intent(in) :: iperm(:) + integer(psb_ipk_), intent(out) :: info + character, intent(in) :: trans + + ! local variables + complex(psb_dpk_),allocatable :: temp(:) + integer(psb_ipk_) :: int_err(5), err_act + integer(psb_epk_) :: i1sz, i2sz, i, j + integer(psb_epk_), allocatable :: itemp(:) + complex(psb_dpk_),parameter :: one=1 + integer(psb_ipk_) :: debug_level, debug_unit + character(len=20) :: name + name = 'psb_zgelp' + + if(psb_get_errstatus() /= 0) return + info=psb_success_ + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + i1sz = size(x,dim=1) + i2sz = size(x,dim=2) + + if (debug_level >= psb_debug_serial_)& + & write(debug_unit,*) trim(name),': size',i1sz,i2sz + + allocate(temp(i1sz),itemp(size(iperm)),stat=info) + if (info /= psb_success_) then + info=2040 + call psb_errpush(info,name) + goto 9999 + end if + itemp(:) = iperm(:) + + if (.not.psb_isaperm(i1sz,itemp)) then + info=psb_err_iarg_invalid_value_ + int_err(1) = 1 + call psb_errpush(info,name,i_err=int_err) + goto 9999 + endif + select case( psb_toupper(trans)) + case('N') + do j=1,i2sz + do i=1,i1sz + temp(i) = x(itemp(i),j) + end do + do i=1,i1sz + x(i,j) = temp(i) + end do + end do + case('T') + do j=1,i2sz + do i=1,i1sz + temp(itemp(i)) = x(i,j) + end do + do i=1,i1sz + x(i,j) = temp(i) + end do + end do + case default + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='zgelp') + end select + + deallocate(temp,itemp) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_e_zgelp + + + +!!$ +!!$ Parallel Sparse BLAS version 3.5 +!!$ (C) Copyright 2006-2018 +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari University of Rome Tor Vergata +!!$ +!!$ 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. +!!$ +!!$ +! +! +! Subroutine: psb_zgelpv +! Apply a left permutation to a dense matrix +! +! Arguments: +! trans - character. +! iperm - integer. +! x - real, dimension(:). +! info - integer. Return code. +subroutine psb_e_zgelpv(trans,iperm,x,info) + use psb_serial_mod, psb_protect_name => psb_e_zgelpv + use psb_const_mod + use psb_error_mod + implicit none + + complex(psb_dpk_), intent(inout) :: x(:) + integer(psb_epk_), intent(in) :: iperm(:) + integer(psb_ipk_), intent(out) :: info + character, intent(in) :: trans + + ! local variables + integer(psb_ipk_) :: int_err(5), err_act + complex(psb_dpk_),allocatable :: temp(:) + integer(psb_epk_) :: i1sz, i + integer(psb_epk_), allocatable :: itemp(:) + integer(psb_ipk_) :: debug_level, debug_unit + character(len=20) :: name + + name = 'psb_zgelp' + if(psb_get_errstatus() /= 0) return + info=psb_success_ + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + i1sz = min(size(x),size(iperm)) + + if (debug_level >= psb_debug_serial_)& + & write(debug_unit,*) trim(name),': size',i1sz + allocate(temp(i1sz),itemp(size(iperm)),stat=info) + if (info /= psb_success_) then + info=2040 + call psb_errpush(info,name) + goto 9999 + end if + itemp(:) = iperm(:) + + if (.not.psb_isaperm(i1sz,itemp)) then + info=psb_err_iarg_invalid_value_ + int_err(1) = 1 + call psb_errpush(info,name,i_err=int_err) + goto 9999 + endif + + select case( psb_toupper(trans)) + case('N') + do i=1,i1sz + temp(i) = x(itemp(i)) + end do + do i=1,i1sz + x(i) = temp(i) + end do + case('T') + do i=1,i1sz + temp(itemp(i)) = x(i) + end do + do i=1,i1sz + x(i) = temp(i) + end do + case default + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='zgelp') + end select + + deallocate(temp,itemp) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_e_zgelpv + subroutine psi_zaxpby(m,n,alpha, x, beta, y, info) use psb_const_mod