diff --git a/base/modules/Makefile b/base/modules/Makefile index 19b43558..915cc09e 100644 --- a/base/modules/Makefile +++ b/base/modules/Makefile @@ -1,6 +1,13 @@ include ../../Make.inc -BASIC_MODS= psb_const_mod.o psb_error_mod.o psb_realloc_mod.o +BASIC_MODS= psb_const_mod.o psb_error_mod.o psb_realloc_mod.o \ + basics/psb_m_realloc_mod.o \ + basics/psb_e_realloc_mod.o \ + basics/psb_s_realloc_mod.o \ + basics/psb_d_realloc_mod.o \ + basics/psb_c_realloc_mod.o \ + basics/psb_z_realloc_mod.o + COMMINT=psi_comm_buffers_mod.o psi_penv_mod.o psi_bcast_mod.o psi_reduce_mod.o psi_p2p_mod.o UTIL_MODS = aux/psb_string_mod.o desc/psb_desc_const_mod.o desc/psb_indx_map_mod.o\ desc/psb_gen_block_map_mod.o desc/psb_list_map_mod.o desc/psb_repl_map_mod.o\ @@ -63,6 +70,12 @@ $(UTIL_MODS): $(BASIC_MODS) psi_penv_mod.o: psi_comm_buffers_mod.o psi_bcast_mod.o psi_reduce_mod.o psi_p2p_mod.o: psi_penv_mod.o +psb_realloc_mod.o: basics/psb_m_realloc_mod.o \ + basics/psb_e_realloc_mod.o \ + basics/psb_s_realloc_mod.o \ + basics/psb_d_realloc_mod.o \ + basics/psb_c_realloc_mod.o \ + basics/psb_z_realloc_mod.o aux/psb_string_mod.o desc/psb_desc_const_mod.o psi_comm_buffers_mod.o: psb_const_mod.o aux/psb_hash_mod.o: psb_realloc_mod.o psb_const_mod.o diff --git a/base/modules/basics/psb_c_realloc_mod.F90 b/base/modules/basics/psb_c_realloc_mod.F90 new file mode 100644 index 00000000..f9545591 --- /dev/null +++ b/base/modules/basics/psb_c_realloc_mod.F90 @@ -0,0 +1,1027 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! 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. +! +! +module psb_c_realloc_mod + use psb_const_mod + + implicit none + + ! + ! psb_realloc will reallocate the input array to have exactly + ! the size specified, possibly shortening it. + ! + Interface psb_realloc + module procedure psb_r_m_c_rk1 + module procedure psb_r_m_c_rk2 + module procedure psb_r_e_c_rk1 + module procedure psb_r_e_c_rk2 + module procedure psb_r_me_c_rk2 + module procedure psb_r_em_c_rk2 + + module procedure psb_r_m_2_c_rk1 + module procedure psb_r_e_2_c_rk1 + + end Interface psb_realloc + + interface psb_move_alloc + module procedure psb_move_alloc_c_rk1, psb_move_alloc_c_rk2 + end interface psb_move_alloc + + Interface psb_safe_ab_cpy + module procedure psb_ab_cpy_c_rk1, psb_ab_cpy_c_rk2 + end Interface psb_safe_ab_cpy + + Interface psb_safe_cpy + module procedure psb_cpy_c_rk1, psb_cpy_c_rk2 + end Interface psb_safe_cpy + + ! + ! psb_ensure_size will reallocate the input array if necessary + ! to guarantee that its size is at least as large as the + ! value required, usually with some room to spare. + ! + interface psb_ensure_size + module procedure psb_ensure_m_sz_c_rk1, psb_ensure_e_sz_c_rk1 + end Interface psb_ensure_size + + ! + ! psb_size returns 0 if argument is not allocated. + ! + interface psb_size + module procedure psb_size_c_rk1, psb_size_c_rk2 + end interface psb_size + + +Contains + + Subroutine psb_r_m_c_rk1(len,rrax,info,pad,lb) + use psb_error_mod + + ! ...Subroutine Arguments + integer(psb_mpk_),Intent(in) :: len + complex(psb_spk_), allocatable, intent(inout) :: rrax(:) + integer(psb_ipk_) :: info + complex(psb_spk_), optional, intent(in) :: pad + integer(psb_mpk_), optional, intent(in) :: lb + + ! ...Local Variables + complex(psb_spk_),allocatable :: tmp(:) + integer(psb_mpk_) :: dim, lb_, lbi,ub_ + integer(psb_ipk_) :: err_act,err + character(len=20) :: name + logical, parameter :: debug=.false. + + name='psb_r_m_c_rk1' + call psb_erractionsave(err_act) + info=psb_success_ + if (debug) write(psb_err_unit,*) 'reallocate D',len + + if (present(lb)) then + lb_ = lb + else + lb_ = 1 + endif + if ((len<0)) then + err=4025 + call psb_errpush(err,name, & + & i_err=(/len,izero,izero,izero,izero/),a_err='complex(psb_spk_)') + goto 9999 + end if + ub_ = lb_ + len-1 + + if (allocated(rrax)) then + dim = size(rrax) + lbi = lbound(rrax,1) + If ((dim /= len).or.(lbi /= lb_)) Then + Allocate(tmp(lb_:ub_),stat=info) + if (info /= psb_success_) then + err=4025 + call psb_errpush(err,name, & + & i_err=(/len,izero,izero,izero,izero/),a_err='complex(psb_spk_)') + goto 9999 + end if + tmp(lb_:lb_-1+min(len,dim))=rrax(lbi:lbi-1+min(len,dim)) + call psb_move_alloc(tmp,rrax,info) + End If + else + dim = 0 + Allocate(rrax(lb_:ub_),stat=info) + if (info /= psb_success_) then + err=4025 + call psb_errpush(err,name, & + & i_err=(/len,izero,izero,izero,izero/),a_err='complex(psb_spk_)') + goto 9999 + end if + endif + if (present(pad)) then + rrax(lb_-1+dim+1:lb_-1+len) = pad + endif + call psb_erractionrestore(err_act) + return + +9999 continue + info = err + call psb_error_handler(err_act) + return + + End Subroutine psb_r_m_c_rk1 + + Subroutine psb_r_m_c_rk2(len1,len2,rrax,info,pad,lb1,lb2) + use psb_error_mod + ! ...Subroutine Arguments + integer(psb_mpk_),Intent(in) :: len1,len2 + complex(psb_spk_),allocatable :: rrax(:,:) + integer(psb_ipk_) :: info + complex(psb_spk_), optional, intent(in) :: pad + integer(psb_mpk_),Intent(in), optional :: lb1,lb2 + + ! ...Local Variables + + complex(psb_spk_),allocatable :: tmp(:,:) + integer(psb_ipk_) :: err_act,err + integer(psb_mpk_) :: dim,dim2,lb1_, lb2_, ub1_, ub2_,lbi1, lbi2 + character(len=20) :: name + + name='psb_r_m_c_rk2' + call psb_erractionsave(err_act) + info=psb_success_ + if (present(lb1)) then + lb1_ = lb1 + else + lb1_ = 1 + endif + if (present(lb2)) then + lb2_ = lb2 + else + lb2_ = 1 + endif + ub1_ = lb1_ + len1 -1 + ub2_ = lb2_ + len2 -1 + + if (len1 < 0) then + err=4025 + call psb_errpush(err,name, & + & i_err=(/len1,izero,izero,izero,izero/),a_err='complex(psb_spk_)') + goto 9999 + end if + if (len2 < 0) then + err=4025 + call psb_errpush(err,name, & + & i_err=(/len2,izero,izero,izero,izero/),a_err='complex(psb_spk_)') + goto 9999 + end if + + + if (allocated(rrax)) then + dim = size(rrax,1) + lbi1 = lbound(rrax,1) + dim2 = size(rrax,2) + lbi2 = lbound(rrax,2) + If ((dim /= len1).or.(dim2 /= len2).or.(lbi1 /= lb1_)& + & .or.(lbi2 /= lb2_)) Then + Allocate(tmp(lb1_:ub1_,lb2_:ub2_),stat=info) + if (info /= psb_success_) then + err=4025 + call psb_errpush(err,name, & + & i_err=(/len1*len2,izero,izero,izero,izero/),a_err='complex(psb_spk_)') + goto 9999 + end if + tmp(lb1_:lb1_-1+min(len1,dim),lb2_:lb2_-1+min(len2,dim2)) = & + & rrax(lbi1:lbi1-1+min(len1,dim),lbi2:lbi2-1+min(len2,dim2)) + call psb_move_alloc(tmp,rrax,info) + End If + else + dim = 0 + dim2 = 0 + Allocate(rrax(lb1_:ub1_,lb2_:ub2_),stat=info) + if (info /= psb_success_) then + err=4025 + call psb_errpush(err,name, & + & i_err=(/len1*len2,izero,izero,izero,izero/),a_err='complex(psb_spk_)') + goto 9999 + end if + endif + if (present(pad)) then + rrax(lb1_-1+dim+1:lb1_-1+len1,:) = pad + rrax(lb1_:lb1_-1+dim,lb2_-1+dim2+1:lb2_-1+len2) = pad + endif + call psb_erractionrestore(err_act) + return + +9999 continue + info = err + call psb_error_handler(err_act) + return + + End Subroutine psb_r_m_c_rk2 + + + Subroutine psb_r_e_c_rk1(len,rrax,info,pad,lb) + use psb_error_mod + + ! ...Subroutine Arguments + integer(psb_epk_),Intent(in) :: len + complex(psb_spk_), allocatable, intent(inout) :: rrax(:) + integer(psb_ipk_) :: info + complex(psb_spk_), optional, intent(in) :: pad + integer(psb_epk_), optional, intent(in) :: lb + + ! ...Local Variables + complex(psb_spk_),allocatable :: tmp(:) + integer(psb_epk_) :: dim, lb_, lbi,ub_ + integer(psb_ipk_) :: iplen + integer(psb_ipk_) :: err_act,err + character(len=20) :: name + logical, parameter :: debug=.false. + + name='psb_r_m_c_rk1' + call psb_erractionsave(err_act) + info=psb_success_ + if (debug) write(psb_err_unit,*) 'reallocate D',len + + if (present(lb)) then + lb_ = lb + else + lb_ = 1 + endif + if ((len<0)) then + err=4025 + iplen = len + call psb_errpush(err,name, & + & i_err=(/iplen,izero,izero,izero,izero/),a_err='complex(psb_spk_)') + goto 9999 + end if + ub_ = lb_ + len-1 + + if (allocated(rrax)) then + dim = size(rrax) + lbi = lbound(rrax,1) + If ((dim /= len).or.(lbi /= lb_)) Then + Allocate(tmp(lb_:ub_),stat=info) + if (info /= psb_success_) then + err=4025 + iplen = len + call psb_errpush(err,name, & + & i_err=(/iplen,izero,izero,izero,izero/),a_err='complex(psb_spk_)') + goto 9999 + end if + tmp(lb_:lb_-1+min(len,dim))=rrax(lbi:lbi-1+min(len,dim)) + call psb_move_alloc(tmp,rrax,info) + End If + else + dim = 0 + Allocate(rrax(lb_:ub_),stat=info) + if (info /= psb_success_) then + err=4025 + iplen = len + call psb_errpush(err,name, & + & i_err=(/iplen,izero,izero,izero,izero/),a_err='complex(psb_spk_)') + goto 9999 + end if + endif + if (present(pad)) then + rrax(lb_-1+dim+1:lb_-1+len) = pad + endif + call psb_erractionrestore(err_act) + return + +9999 continue + info = err + call psb_error_handler(err_act) + return + + End Subroutine psb_r_e_c_rk1 + + Subroutine psb_r_e_c_rk2(len1,len2,rrax,info,pad,lb1,lb2) + use psb_error_mod + ! ...Subroutine Arguments + integer(psb_epk_),Intent(in) :: len1,len2 + complex(psb_spk_),allocatable :: rrax(:,:) + integer(psb_ipk_) :: info + complex(psb_spk_), optional, intent(in) :: pad + integer(psb_epk_),Intent(in), optional :: lb1,lb2 + + ! ...Local Variables + + complex(psb_spk_),allocatable :: tmp(:,:) + integer(psb_ipk_) :: err_act,err, iplen + integer(psb_epk_) :: dim,dim2,lb1_, lb2_, ub1_, ub2_,lbi1, lbi2 + character(len=20) :: name + + name='psb_r_e_c_rk2' + call psb_erractionsave(err_act) + info=psb_success_ + if (present(lb1)) then + lb1_ = lb1 + else + lb1_ = 1 + endif + if (present(lb2)) then + lb2_ = lb2 + else + lb2_ = 1 + endif + ub1_ = lb1_ + len1 -1 + ub2_ = lb2_ + len2 -1 + + if (len1 < 0) then + err=4025 + iplen = len1 + call psb_errpush(err,name, & + & i_err=(/iplen,izero,izero,izero,izero/),a_err='complex(psb_spk_)') + goto 9999 + end if + if (len2 < 0) then + err=4025 + iplen = len2 + call psb_errpush(err,name, & + & i_err=(/iplen,izero,izero,izero,izero/),a_err='complex(psb_spk_)') + goto 9999 + end if + + + if (allocated(rrax)) then + dim = size(rrax,1) + lbi1 = lbound(rrax,1) + dim2 = size(rrax,2) + lbi2 = lbound(rrax,2) + If ((dim /= len1).or.(dim2 /= len2).or.(lbi1 /= lb1_)& + & .or.(lbi2 /= lb2_)) Then + Allocate(tmp(lb1_:ub1_,lb2_:ub2_),stat=info) + if (info /= psb_success_) then + err=4025 + iplen = len1*len2 + call psb_errpush(err,name, & + & i_err=(/iplen,izero,izero,izero,izero/),a_err='complex(psb_spk_)') + goto 9999 + end if + tmp(lb1_:lb1_-1+min(len1,dim),lb2_:lb2_-1+min(len2,dim2)) = & + & rrax(lbi1:lbi1-1+min(len1,dim),lbi2:lbi2-1+min(len2,dim2)) + call psb_move_alloc(tmp,rrax,info) + End If + else + dim = 0 + dim2 = 0 + Allocate(rrax(lb1_:ub1_,lb2_:ub2_),stat=info) + if (info /= psb_success_) then + err=4025 + iplen = len1*len2 + call psb_errpush(err,name, & + & i_err=(/iplen,izero,izero,izero,izero/),a_err='complex(psb_spk_)') + goto 9999 + end if + endif + if (present(pad)) then + rrax(lb1_-1+dim+1:lb1_-1+len1,:) = pad + rrax(lb1_:lb1_-1+dim,lb2_-1+dim2+1:lb2_-1+len2) = pad + endif + call psb_erractionrestore(err_act) + return + +9999 continue + info = err + call psb_error_handler(err_act) + return + + End Subroutine psb_r_e_c_rk2 + + Subroutine psb_r_me_c_rk2(len1,len2,rrax,info,pad,lb1,lb2) + use psb_error_mod + ! ...Subroutine Arguments + integer(psb_mpk_),Intent(in) :: len1 + integer(psb_epk_),Intent(in) :: len2 + complex(psb_spk_),allocatable :: rrax(:,:) + integer(psb_ipk_) :: info + complex(psb_spk_), optional, intent(in) :: pad + integer(psb_mpk_),Intent(in), optional :: lb1,lb2 + + ! ...Local Variables + + complex(psb_spk_),allocatable :: tmp(:,:) + integer(psb_ipk_) :: err_act,err, iplen + integer(psb_mpk_) :: dim,lb1_, lb2_, ub1_, ub2_,lbi1, lbi2 + integer(psb_epk_) :: dim2 + character(len=20) :: name + + name='psb_r_me_c_rk2' + call psb_erractionsave(err_act) + info=psb_success_ + if (present(lb1)) then + lb1_ = lb1 + else + lb1_ = 1 + endif + if (present(lb2)) then + lb2_ = lb2 + else + lb2_ = 1 + endif + ub1_ = lb1_ + len1 -1 + ub2_ = lb2_ + len2 -1 + + if (len1 < 0) then + err=4025 + iplen = len1 + call psb_errpush(err,name, & + & i_err=(/iplen,izero,izero,izero,izero/),a_err='complex(psb_spk_)') + goto 9999 + end if + if (len2 < 0) then + err=4025 + iplen = len2 + call psb_errpush(err,name, & + & i_err=(/iplen,izero,izero,izero,izero/),a_err='complex(psb_spk_)') + goto 9999 + end if + + + if (allocated(rrax)) then + dim = size(rrax,1) + lbi1 = lbound(rrax,1) + dim2 = size(rrax,2) + lbi2 = lbound(rrax,2) + If ((dim /= len1).or.(dim2 /= len2).or.(lbi1 /= lb1_)& + & .or.(lbi2 /= lb2_)) Then + Allocate(tmp(lb1_:ub1_,lb2_:ub2_),stat=info) + if (info /= psb_success_) then + err=4025 + iplen = len1*len2 + call psb_errpush(err,name, & + & i_err=(/iplen,izero,izero,izero,izero/),a_err='complex(psb_spk_)') + goto 9999 + end if + tmp(lb1_:lb1_-1+min(len1,dim),lb2_:lb2_-1+min(len2,dim2)) = & + & rrax(lbi1:lbi1-1+min(len1,dim),lbi2:lbi2-1+min(len2,dim2)) + call psb_move_alloc(tmp,rrax,info) + End If + else + dim = 0 + dim2 = 0 + Allocate(rrax(lb1_:ub1_,lb2_:ub2_),stat=info) + if (info /= psb_success_) then + err=4025 + iplen = len1*len2 + call psb_errpush(err,name, & + & i_err=(/iplen,izero,izero,izero,izero/),a_err='complex(psb_spk_)') + goto 9999 + end if + endif + if (present(pad)) then + rrax(lb1_-1+dim+1:lb1_-1+len1,:) = pad + rrax(lb1_:lb1_-1+dim,lb2_-1+dim2+1:lb2_-1+len2) = pad + endif + call psb_erractionrestore(err_act) + return + +9999 continue + info = err + call psb_error_handler(err_act) + return + + End Subroutine psb_r_me_c_rk2 + + Subroutine psb_r_em_c_rk2(len1,len2,rrax,info,pad,lb1,lb2) + use psb_error_mod + ! ...Subroutine Arguments + integer(psb_epk_),Intent(in) :: len1 + integer(psb_mpk_),Intent(in) :: len2 + complex(psb_spk_),allocatable :: rrax(:,:) + integer(psb_ipk_) :: info + complex(psb_spk_), optional, intent(in) :: pad + integer(psb_mpk_),Intent(in), optional :: lb1,lb2 + + ! ...Local Variables + + complex(psb_spk_),allocatable :: tmp(:,:) + integer(psb_ipk_) :: err_act,err, iplen + integer(psb_mpk_) :: dim2,lb1_, lb2_, ub1_, ub2_,lbi1, lbi2 + integer(psb_epk_) :: dim + character(len=20) :: name + + name='psb_r_me_c_rk2' + call psb_erractionsave(err_act) + info=psb_success_ + if (present(lb1)) then + lb1_ = lb1 + else + lb1_ = 1 + endif + if (present(lb2)) then + lb2_ = lb2 + else + lb2_ = 1 + endif + ub1_ = lb1_ + len1 -1 + ub2_ = lb2_ + len2 -1 + + if (len1 < 0) then + err=4025 + iplen = len1 + call psb_errpush(err,name, & + & i_err=(/iplen,izero,izero,izero,izero/),a_err='complex(psb_spk_)') + goto 9999 + end if + if (len2 < 0) then + err=4025 + iplen = len2 + call psb_errpush(err,name, & + & i_err=(/iplen,izero,izero,izero,izero/),a_err='complex(psb_spk_)') + goto 9999 + end if + + + if (allocated(rrax)) then + dim = size(rrax,1) + lbi1 = lbound(rrax,1) + dim2 = size(rrax,2) + lbi2 = lbound(rrax,2) + If ((dim /= len1).or.(dim2 /= len2).or.(lbi1 /= lb1_)& + & .or.(lbi2 /= lb2_)) Then + Allocate(tmp(lb1_:ub1_,lb2_:ub2_),stat=info) + if (info /= psb_success_) then + err=4025 + iplen = len1*len2 + call psb_errpush(err,name, & + & i_err=(/iplen,izero,izero,izero,izero/),a_err='complex(psb_spk_)') + goto 9999 + end if + tmp(lb1_:lb1_-1+min(len1,dim),lb2_:lb2_-1+min(len2,dim2)) = & + & rrax(lbi1:lbi1-1+min(len1,dim),lbi2:lbi2-1+min(len2,dim2)) + call psb_move_alloc(tmp,rrax,info) + End If + else + dim = 0 + dim2 = 0 + Allocate(rrax(lb1_:ub1_,lb2_:ub2_),stat=info) + if (info /= psb_success_) then + err=4025 + iplen = len1*len2 + call psb_errpush(err,name, & + & i_err=(/iplen,izero,izero,izero,izero/),a_err='complex(psb_spk_)') + goto 9999 + end if + endif + if (present(pad)) then + rrax(lb1_-1+dim+1:lb1_-1+len1,:) = pad + rrax(lb1_:lb1_-1+dim,lb2_-1+dim2+1:lb2_-1+len2) = pad + endif + call psb_erractionrestore(err_act) + return + +9999 continue + info = err + call psb_error_handler(err_act) + return + + End Subroutine psb_r_em_c_rk2 + + Subroutine psb_r_m_2_c_rk1(len,rrax,y,info,pad) + use psb_error_mod + ! ...Subroutine Arguments + + integer(psb_mpk_),Intent(in) :: len + complex(psb_spk_),allocatable, intent(inout) :: rrax(:),y(:) + integer(psb_ipk_) :: info + complex(psb_spk_), optional, intent(in) :: pad + character(len=20) :: name + integer(psb_ipk_) :: err_act, err + + name='psb_r_m_2_c_rk1' + call psb_erractionsave(err_act) + info=psb_success_ + + if(psb_get_errstatus() /= 0) then + info=psb_err_from_subroutine_ + goto 9999 + end if + + call psb_realloc(len,rrax,info,pad=pad) + if (info /= psb_success_) then + err=4000 + call psb_errpush(err,name) + goto 9999 + end if + call psb_realloc(len,y,info,pad=pad) + if (info /= psb_success_) then + err=4000 + call psb_errpush(err,name) + goto 9999 + end if + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + + End Subroutine psb_r_m_2_c_rk1 + + Subroutine psb_r_e_2_c_rk1(len,rrax,y,info,pad) + use psb_error_mod + ! ...Subroutine Arguments + + integer(psb_epk_),Intent(in) :: len + complex(psb_spk_),allocatable, intent(inout) :: rrax(:),y(:) + integer(psb_ipk_) :: info + complex(psb_spk_), optional, intent(in) :: pad + character(len=20) :: name + integer(psb_ipk_) :: err_act, err + + name='psb_r_m_2_c_rk1' + call psb_erractionsave(err_act) + info=psb_success_ + + if(psb_get_errstatus() /= 0) then + info=psb_err_from_subroutine_ + goto 9999 + end if + + call psb_realloc(len,rrax,info,pad=pad) + if (info /= psb_success_) then + err=4000 + call psb_errpush(err,name) + goto 9999 + end if + call psb_realloc(len,y,info,pad=pad) + if (info /= psb_success_) then + err=4000 + call psb_errpush(err,name) + goto 9999 + end if + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + + End Subroutine psb_r_e_2_c_rk1 + + + + subroutine psb_ab_cpy_c_rk1(vin,vout,info) + use psb_error_mod + + ! ...Subroutine Arguments + complex(psb_spk_), allocatable, intent(in) :: vin(:) + complex(psb_spk_), allocatable, intent(out) :: vout(:) + integer(psb_ipk_) :: info + ! ...Local Variables + + integer(psb_ipk_) :: isz,err_act,lb + character(len=20) :: name, char_err + logical, parameter :: debug=.false. + + name='psb_ab_cpy_c_rk1' + call psb_erractionsave(err_act) + info=psb_success_ + if(psb_get_errstatus() /= 0) then + info=psb_err_from_subroutine_ + goto 9999 + end if + + if (allocated(vin)) then + isz = size(vin) + lb = lbound(vin,1) + call psb_realloc(isz,vout,info,lb=lb) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + char_err='psb_realloc' + call psb_errpush(info,name,a_err=char_err) + goto 9999 + else + vout(:) = vin(:) + endif + endif + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + + end subroutine psb_ab_cpy_c_rk1 + + subroutine psb_ab_cpy_c_rk2(vin,vout,info) + use psb_error_mod + + ! ...Subroutine Arguments + complex(psb_spk_), allocatable, intent(in) :: vin(:,:) + complex(psb_spk_), allocatable, intent(out) :: vout(:,:) + integer(psb_ipk_) :: info + ! ...Local Variables + + integer(psb_ipk_) :: isz1, isz2,err_act, lb1, lb2 + character(len=20) :: name, char_err + logical, parameter :: debug=.false. + + name='psb_ab_cpy_c_rk2' + call psb_erractionsave(err_act) + info=psb_success_ + if(psb_get_errstatus() /= 0) then + info=psb_err_from_subroutine_ + goto 9999 + end if + + if (allocated(vin)) then + isz1 = size(vin,1) + isz2 = size(vin,2) + lb1 = lbound(vin,1) + lb2 = lbound(vin,2) + call psb_realloc(isz1,isz2,vout,info,lb1=lb1,lb2=lb2) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + char_err='psb_realloc' + call psb_errpush(info,name,a_err=char_err) + goto 9999 + else + vout(:,:) = vin(:,:) + endif + endif + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + + end subroutine psb_ab_cpy_c_rk2 + + + subroutine psb_cpy_c_rk1(vin,vout,info) + use psb_error_mod + + ! ...Subroutine Arguments + complex(psb_spk_), intent(in) :: vin(:) + complex(psb_spk_), allocatable, intent(out) :: vout(:) + integer(psb_ipk_) :: info + ! ...Local Variables + + integer(psb_ipk_) :: isz,err_act,lb + character(len=20) :: name, char_err + logical, parameter :: debug=.false. + + name='psb_cpy_c_rk1' + call psb_erractionsave(err_act) + info=psb_success_ + if(psb_get_errstatus() /= 0) then + info=psb_err_from_subroutine_ + goto 9999 + end if + isz = size(vin) + lb = lbound(vin,1) + call psb_realloc(isz,vout,info,lb=lb) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + char_err='psb_realloc' + call psb_errpush(info,name,a_err=char_err) + goto 9999 + else + vout(:) = vin(:) + endif + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + + end subroutine psb_cpy_c_rk1 + + subroutine psb_cpy_c_rk2(vin,vout,info) + use psb_error_mod + + ! ...Subroutine Arguments + complex(psb_spk_), intent(in) :: vin(:,:) + complex(psb_spk_), allocatable, intent(out) :: vout(:,:) + integer(psb_ipk_) :: info + ! ...Local Variables + + integer(psb_ipk_) :: isz1, isz2,err_act, lb1, lb2 + character(len=20) :: name, char_err + logical, parameter :: debug=.false. + + name='psb_safe_cpy' + call psb_erractionsave(err_act) + info=psb_success_ + if(psb_get_errstatus() /= 0) then + info=psb_err_from_subroutine_ + goto 9999 + end if + + isz1 = size(vin,1) + isz2 = size(vin,2) + lb1 = lbound(vin,1) + lb2 = lbound(vin,2) + call psb_realloc(isz1,isz2,vout,info,lb1=lb1,lb2=lb2) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + char_err='psb_realloc' + call psb_errpush(info,name,a_err=char_err) + goto 9999 + else + vout(:,:) = vin(:,:) + endif + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + + end subroutine psb_cpy_c_rk2 + + + function psb_size_c_rk1(vin) result(val) + integer(psb_epk_) :: val + complex(psb_spk_), allocatable, intent(in) :: vin(:) + + if (.not.allocated(vin)) then + val = 0 + else + val = size(vin) + end if + end function psb_size_c_rk1 + + + function psb_size_c_rk2(vin,dim) result(val) + integer(psb_epk_) :: val + complex(psb_spk_), allocatable, intent(in) :: vin(:,:) + integer(psb_ipk_), optional :: dim + integer(psb_ipk_) :: dim_ + + + if (.not.allocated(vin)) then + val = 0 + else + if (present(dim)) then + dim_= dim + val = size(vin,dim=dim_) + else + val = size(vin) + end if + end if + end function psb_size_c_rk2 + + Subroutine psb_ensure_m_sz_c_rk1(len,v,info,pad,addsz,newsz) + use psb_error_mod + + ! ...Subroutine Arguments + integer(psb_mpk_),Intent(in) :: len + complex(psb_spk_),allocatable, intent(inout) :: v(:) + integer(psb_ipk_) :: info + integer(psb_mpk_), optional, intent(in) :: addsz,newsz + complex(psb_spk_), optional, intent(in) :: pad + ! ...Local Variables + character(len=20) :: name + logical, parameter :: debug=.false. + integer(psb_ipk_) :: err_act + integer(psb_mpk_) :: isz + + name='psb_ensure_m_sz_c_rk1' + call psb_erractionsave(err_act) + info = psb_success_ + + if (psb_get_errstatus() /= 0) then + info=psb_err_from_subroutine_ + goto 9999 + end if + + If (len > psb_size(v)) Then + if (present(newsz)) then + isz = (max(len+1,newsz)) + else + if (present(addsz)) then + isz = len+max(1,addsz) + else + isz = max(len+10, int(1.25*len)) + endif + endif + + call psb_realloc(isz,v,info,pad=pad) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='psb_realloc') + goto 9999 + End If + end If + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + + + End Subroutine psb_ensure_m_sz_c_rk1 + + Subroutine psb_ensure_e_sz_c_rk1(len,v,info,pad,addsz,newsz) + use psb_error_mod + + ! ...Subroutine Arguments + integer(psb_epk_),Intent(in) :: len + complex(psb_spk_),allocatable, intent(inout) :: v(:) + integer(psb_ipk_) :: info + integer(psb_epk_), optional, intent(in) :: addsz,newsz + complex(psb_spk_), optional, intent(in) :: pad + ! ...Local Variables + character(len=20) :: name + logical, parameter :: debug=.false. + integer(psb_ipk_) :: err_act + integer(psb_epk_) :: isz + + name='psb_ensure_m_sz_c_rk1' + call psb_erractionsave(err_act) + info = psb_success_ + + if (psb_get_errstatus() /= 0) then + info=psb_err_from_subroutine_ + goto 9999 + end if + + If (len > psb_size(v)) Then + if (present(newsz)) then + isz = (max(len+1,newsz)) + else + if (present(addsz)) then + isz = len+max(1,addsz) + else + isz = max(len+10, int(1.25*len)) + endif + endif + + call psb_realloc(isz,v,info,pad=pad) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='psb_realloc') + goto 9999 + End If + end If + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + + + End Subroutine psb_ensure_e_sz_c_rk1 + + Subroutine psb_move_alloc_c_rk1(vin,vout,info) + use psb_error_mod + complex(psb_spk_), allocatable, intent(inout) :: vin(:),vout(:) + integer(psb_ipk_), intent(out) :: info + ! + ! + info=psb_success_ + call move_alloc(vin,vout) + + end Subroutine psb_move_alloc_c_rk1 + + Subroutine psb_move_alloc_c_rk2(vin,vout,info) + use psb_error_mod + complex(psb_spk_), allocatable, intent(inout) :: vin(:,:),vout(:,:) + integer(psb_ipk_), intent(out) :: info + ! + ! + info=psb_success_ + + call move_alloc(vin,vout) + + end Subroutine psb_move_alloc_c_rk2 + +end module psb_c_realloc_mod diff --git a/base/modules/basics/psb_d_realloc_mod.F90 b/base/modules/basics/psb_d_realloc_mod.F90 new file mode 100644 index 00000000..1ddadad1 --- /dev/null +++ b/base/modules/basics/psb_d_realloc_mod.F90 @@ -0,0 +1,1027 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! 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. +! +! +module psb_d_realloc_mod + use psb_const_mod + + implicit none + + ! + ! psb_realloc will reallocate the input array to have exactly + ! the size specified, possibly shortening it. + ! + Interface psb_realloc + module procedure psb_r_m_d_rk1 + module procedure psb_r_m_d_rk2 + module procedure psb_r_e_d_rk1 + module procedure psb_r_e_d_rk2 + module procedure psb_r_me_d_rk2 + module procedure psb_r_em_d_rk2 + + module procedure psb_r_m_2_d_rk1 + module procedure psb_r_e_2_d_rk1 + + end Interface psb_realloc + + interface psb_move_alloc + module procedure psb_move_alloc_d_rk1, psb_move_alloc_d_rk2 + end interface psb_move_alloc + + Interface psb_safe_ab_cpy + module procedure psb_ab_cpy_d_rk1, psb_ab_cpy_d_rk2 + end Interface psb_safe_ab_cpy + + Interface psb_safe_cpy + module procedure psb_cpy_d_rk1, psb_cpy_d_rk2 + end Interface psb_safe_cpy + + ! + ! psb_ensure_size will reallocate the input array if necessary + ! to guarantee that its size is at least as large as the + ! value required, usually with some room to spare. + ! + interface psb_ensure_size + module procedure psb_ensure_m_sz_d_rk1, psb_ensure_e_sz_d_rk1 + end Interface psb_ensure_size + + ! + ! psb_size returns 0 if argument is not allocated. + ! + interface psb_size + module procedure psb_size_d_rk1, psb_size_d_rk2 + end interface psb_size + + +Contains + + Subroutine psb_r_m_d_rk1(len,rrax,info,pad,lb) + use psb_error_mod + + ! ...Subroutine Arguments + integer(psb_mpk_),Intent(in) :: len + real(psb_dpk_), allocatable, intent(inout) :: rrax(:) + integer(psb_ipk_) :: info + real(psb_dpk_), optional, intent(in) :: pad + integer(psb_mpk_), optional, intent(in) :: lb + + ! ...Local Variables + real(psb_dpk_),allocatable :: tmp(:) + integer(psb_mpk_) :: dim, lb_, lbi,ub_ + integer(psb_ipk_) :: err_act,err + character(len=20) :: name + logical, parameter :: debug=.false. + + name='psb_r_m_d_rk1' + call psb_erractionsave(err_act) + info=psb_success_ + if (debug) write(psb_err_unit,*) 'reallocate D',len + + if (present(lb)) then + lb_ = lb + else + lb_ = 1 + endif + if ((len<0)) then + err=4025 + call psb_errpush(err,name, & + & i_err=(/len,izero,izero,izero,izero/),a_err='real(psb_dpk_)') + goto 9999 + end if + ub_ = lb_ + len-1 + + if (allocated(rrax)) then + dim = size(rrax) + lbi = lbound(rrax,1) + If ((dim /= len).or.(lbi /= lb_)) Then + Allocate(tmp(lb_:ub_),stat=info) + if (info /= psb_success_) then + err=4025 + call psb_errpush(err,name, & + & i_err=(/len,izero,izero,izero,izero/),a_err='real(psb_dpk_)') + goto 9999 + end if + tmp(lb_:lb_-1+min(len,dim))=rrax(lbi:lbi-1+min(len,dim)) + call psb_move_alloc(tmp,rrax,info) + End If + else + dim = 0 + Allocate(rrax(lb_:ub_),stat=info) + if (info /= psb_success_) then + err=4025 + call psb_errpush(err,name, & + & i_err=(/len,izero,izero,izero,izero/),a_err='real(psb_dpk_)') + goto 9999 + end if + endif + if (present(pad)) then + rrax(lb_-1+dim+1:lb_-1+len) = pad + endif + call psb_erractionrestore(err_act) + return + +9999 continue + info = err + call psb_error_handler(err_act) + return + + End Subroutine psb_r_m_d_rk1 + + Subroutine psb_r_m_d_rk2(len1,len2,rrax,info,pad,lb1,lb2) + use psb_error_mod + ! ...Subroutine Arguments + integer(psb_mpk_),Intent(in) :: len1,len2 + real(psb_dpk_),allocatable :: rrax(:,:) + integer(psb_ipk_) :: info + real(psb_dpk_), optional, intent(in) :: pad + integer(psb_mpk_),Intent(in), optional :: lb1,lb2 + + ! ...Local Variables + + real(psb_dpk_),allocatable :: tmp(:,:) + integer(psb_ipk_) :: err_act,err + integer(psb_mpk_) :: dim,dim2,lb1_, lb2_, ub1_, ub2_,lbi1, lbi2 + character(len=20) :: name + + name='psb_r_m_d_rk2' + call psb_erractionsave(err_act) + info=psb_success_ + if (present(lb1)) then + lb1_ = lb1 + else + lb1_ = 1 + endif + if (present(lb2)) then + lb2_ = lb2 + else + lb2_ = 1 + endif + ub1_ = lb1_ + len1 -1 + ub2_ = lb2_ + len2 -1 + + if (len1 < 0) then + err=4025 + call psb_errpush(err,name, & + & i_err=(/len1,izero,izero,izero,izero/),a_err='real(psb_dpk_)') + goto 9999 + end if + if (len2 < 0) then + err=4025 + call psb_errpush(err,name, & + & i_err=(/len2,izero,izero,izero,izero/),a_err='real(psb_dpk_)') + goto 9999 + end if + + + if (allocated(rrax)) then + dim = size(rrax,1) + lbi1 = lbound(rrax,1) + dim2 = size(rrax,2) + lbi2 = lbound(rrax,2) + If ((dim /= len1).or.(dim2 /= len2).or.(lbi1 /= lb1_)& + & .or.(lbi2 /= lb2_)) Then + Allocate(tmp(lb1_:ub1_,lb2_:ub2_),stat=info) + if (info /= psb_success_) then + err=4025 + call psb_errpush(err,name, & + & i_err=(/len1*len2,izero,izero,izero,izero/),a_err='real(psb_dpk_)') + goto 9999 + end if + tmp(lb1_:lb1_-1+min(len1,dim),lb2_:lb2_-1+min(len2,dim2)) = & + & rrax(lbi1:lbi1-1+min(len1,dim),lbi2:lbi2-1+min(len2,dim2)) + call psb_move_alloc(tmp,rrax,info) + End If + else + dim = 0 + dim2 = 0 + Allocate(rrax(lb1_:ub1_,lb2_:ub2_),stat=info) + if (info /= psb_success_) then + err=4025 + call psb_errpush(err,name, & + & i_err=(/len1*len2,izero,izero,izero,izero/),a_err='real(psb_dpk_)') + goto 9999 + end if + endif + if (present(pad)) then + rrax(lb1_-1+dim+1:lb1_-1+len1,:) = pad + rrax(lb1_:lb1_-1+dim,lb2_-1+dim2+1:lb2_-1+len2) = pad + endif + call psb_erractionrestore(err_act) + return + +9999 continue + info = err + call psb_error_handler(err_act) + return + + End Subroutine psb_r_m_d_rk2 + + + Subroutine psb_r_e_d_rk1(len,rrax,info,pad,lb) + use psb_error_mod + + ! ...Subroutine Arguments + integer(psb_epk_),Intent(in) :: len + real(psb_dpk_), allocatable, intent(inout) :: rrax(:) + integer(psb_ipk_) :: info + real(psb_dpk_), optional, intent(in) :: pad + integer(psb_epk_), optional, intent(in) :: lb + + ! ...Local Variables + real(psb_dpk_),allocatable :: tmp(:) + integer(psb_epk_) :: dim, lb_, lbi,ub_ + integer(psb_ipk_) :: iplen + integer(psb_ipk_) :: err_act,err + character(len=20) :: name + logical, parameter :: debug=.false. + + name='psb_r_m_d_rk1' + call psb_erractionsave(err_act) + info=psb_success_ + if (debug) write(psb_err_unit,*) 'reallocate D',len + + if (present(lb)) then + lb_ = lb + else + lb_ = 1 + endif + if ((len<0)) then + err=4025 + iplen = len + call psb_errpush(err,name, & + & i_err=(/iplen,izero,izero,izero,izero/),a_err='real(psb_dpk_)') + goto 9999 + end if + ub_ = lb_ + len-1 + + if (allocated(rrax)) then + dim = size(rrax) + lbi = lbound(rrax,1) + If ((dim /= len).or.(lbi /= lb_)) Then + Allocate(tmp(lb_:ub_),stat=info) + if (info /= psb_success_) then + err=4025 + iplen = len + call psb_errpush(err,name, & + & i_err=(/iplen,izero,izero,izero,izero/),a_err='real(psb_dpk_)') + goto 9999 + end if + tmp(lb_:lb_-1+min(len,dim))=rrax(lbi:lbi-1+min(len,dim)) + call psb_move_alloc(tmp,rrax,info) + End If + else + dim = 0 + Allocate(rrax(lb_:ub_),stat=info) + if (info /= psb_success_) then + err=4025 + iplen = len + call psb_errpush(err,name, & + & i_err=(/iplen,izero,izero,izero,izero/),a_err='real(psb_dpk_)') + goto 9999 + end if + endif + if (present(pad)) then + rrax(lb_-1+dim+1:lb_-1+len) = pad + endif + call psb_erractionrestore(err_act) + return + +9999 continue + info = err + call psb_error_handler(err_act) + return + + End Subroutine psb_r_e_d_rk1 + + Subroutine psb_r_e_d_rk2(len1,len2,rrax,info,pad,lb1,lb2) + use psb_error_mod + ! ...Subroutine Arguments + integer(psb_epk_),Intent(in) :: len1,len2 + real(psb_dpk_),allocatable :: rrax(:,:) + integer(psb_ipk_) :: info + real(psb_dpk_), optional, intent(in) :: pad + integer(psb_epk_),Intent(in), optional :: lb1,lb2 + + ! ...Local Variables + + real(psb_dpk_),allocatable :: tmp(:,:) + integer(psb_ipk_) :: err_act,err, iplen + integer(psb_epk_) :: dim,dim2,lb1_, lb2_, ub1_, ub2_,lbi1, lbi2 + character(len=20) :: name + + name='psb_r_e_d_rk2' + call psb_erractionsave(err_act) + info=psb_success_ + if (present(lb1)) then + lb1_ = lb1 + else + lb1_ = 1 + endif + if (present(lb2)) then + lb2_ = lb2 + else + lb2_ = 1 + endif + ub1_ = lb1_ + len1 -1 + ub2_ = lb2_ + len2 -1 + + if (len1 < 0) then + err=4025 + iplen = len1 + call psb_errpush(err,name, & + & i_err=(/iplen,izero,izero,izero,izero/),a_err='real(psb_dpk_)') + goto 9999 + end if + if (len2 < 0) then + err=4025 + iplen = len2 + call psb_errpush(err,name, & + & i_err=(/iplen,izero,izero,izero,izero/),a_err='real(psb_dpk_)') + goto 9999 + end if + + + if (allocated(rrax)) then + dim = size(rrax,1) + lbi1 = lbound(rrax,1) + dim2 = size(rrax,2) + lbi2 = lbound(rrax,2) + If ((dim /= len1).or.(dim2 /= len2).or.(lbi1 /= lb1_)& + & .or.(lbi2 /= lb2_)) Then + Allocate(tmp(lb1_:ub1_,lb2_:ub2_),stat=info) + if (info /= psb_success_) then + err=4025 + iplen = len1*len2 + call psb_errpush(err,name, & + & i_err=(/iplen,izero,izero,izero,izero/),a_err='real(psb_dpk_)') + goto 9999 + end if + tmp(lb1_:lb1_-1+min(len1,dim),lb2_:lb2_-1+min(len2,dim2)) = & + & rrax(lbi1:lbi1-1+min(len1,dim),lbi2:lbi2-1+min(len2,dim2)) + call psb_move_alloc(tmp,rrax,info) + End If + else + dim = 0 + dim2 = 0 + Allocate(rrax(lb1_:ub1_,lb2_:ub2_),stat=info) + if (info /= psb_success_) then + err=4025 + iplen = len1*len2 + call psb_errpush(err,name, & + & i_err=(/iplen,izero,izero,izero,izero/),a_err='real(psb_dpk_)') + goto 9999 + end if + endif + if (present(pad)) then + rrax(lb1_-1+dim+1:lb1_-1+len1,:) = pad + rrax(lb1_:lb1_-1+dim,lb2_-1+dim2+1:lb2_-1+len2) = pad + endif + call psb_erractionrestore(err_act) + return + +9999 continue + info = err + call psb_error_handler(err_act) + return + + End Subroutine psb_r_e_d_rk2 + + Subroutine psb_r_me_d_rk2(len1,len2,rrax,info,pad,lb1,lb2) + use psb_error_mod + ! ...Subroutine Arguments + integer(psb_mpk_),Intent(in) :: len1 + integer(psb_epk_),Intent(in) :: len2 + real(psb_dpk_),allocatable :: rrax(:,:) + integer(psb_ipk_) :: info + real(psb_dpk_), optional, intent(in) :: pad + integer(psb_mpk_),Intent(in), optional :: lb1,lb2 + + ! ...Local Variables + + real(psb_dpk_),allocatable :: tmp(:,:) + integer(psb_ipk_) :: err_act,err, iplen + integer(psb_mpk_) :: dim,lb1_, lb2_, ub1_, ub2_,lbi1, lbi2 + integer(psb_epk_) :: dim2 + character(len=20) :: name + + name='psb_r_me_d_rk2' + call psb_erractionsave(err_act) + info=psb_success_ + if (present(lb1)) then + lb1_ = lb1 + else + lb1_ = 1 + endif + if (present(lb2)) then + lb2_ = lb2 + else + lb2_ = 1 + endif + ub1_ = lb1_ + len1 -1 + ub2_ = lb2_ + len2 -1 + + if (len1 < 0) then + err=4025 + iplen = len1 + call psb_errpush(err,name, & + & i_err=(/iplen,izero,izero,izero,izero/),a_err='real(psb_dpk_)') + goto 9999 + end if + if (len2 < 0) then + err=4025 + iplen = len2 + call psb_errpush(err,name, & + & i_err=(/iplen,izero,izero,izero,izero/),a_err='real(psb_dpk_)') + goto 9999 + end if + + + if (allocated(rrax)) then + dim = size(rrax,1) + lbi1 = lbound(rrax,1) + dim2 = size(rrax,2) + lbi2 = lbound(rrax,2) + If ((dim /= len1).or.(dim2 /= len2).or.(lbi1 /= lb1_)& + & .or.(lbi2 /= lb2_)) Then + Allocate(tmp(lb1_:ub1_,lb2_:ub2_),stat=info) + if (info /= psb_success_) then + err=4025 + iplen = len1*len2 + call psb_errpush(err,name, & + & i_err=(/iplen,izero,izero,izero,izero/),a_err='real(psb_dpk_)') + goto 9999 + end if + tmp(lb1_:lb1_-1+min(len1,dim),lb2_:lb2_-1+min(len2,dim2)) = & + & rrax(lbi1:lbi1-1+min(len1,dim),lbi2:lbi2-1+min(len2,dim2)) + call psb_move_alloc(tmp,rrax,info) + End If + else + dim = 0 + dim2 = 0 + Allocate(rrax(lb1_:ub1_,lb2_:ub2_),stat=info) + if (info /= psb_success_) then + err=4025 + iplen = len1*len2 + call psb_errpush(err,name, & + & i_err=(/iplen,izero,izero,izero,izero/),a_err='real(psb_dpk_)') + goto 9999 + end if + endif + if (present(pad)) then + rrax(lb1_-1+dim+1:lb1_-1+len1,:) = pad + rrax(lb1_:lb1_-1+dim,lb2_-1+dim2+1:lb2_-1+len2) = pad + endif + call psb_erractionrestore(err_act) + return + +9999 continue + info = err + call psb_error_handler(err_act) + return + + End Subroutine psb_r_me_d_rk2 + + Subroutine psb_r_em_d_rk2(len1,len2,rrax,info,pad,lb1,lb2) + use psb_error_mod + ! ...Subroutine Arguments + integer(psb_epk_),Intent(in) :: len1 + integer(psb_mpk_),Intent(in) :: len2 + real(psb_dpk_),allocatable :: rrax(:,:) + integer(psb_ipk_) :: info + real(psb_dpk_), optional, intent(in) :: pad + integer(psb_mpk_),Intent(in), optional :: lb1,lb2 + + ! ...Local Variables + + real(psb_dpk_),allocatable :: tmp(:,:) + integer(psb_ipk_) :: err_act,err, iplen + integer(psb_mpk_) :: dim2,lb1_, lb2_, ub1_, ub2_,lbi1, lbi2 + integer(psb_epk_) :: dim + character(len=20) :: name + + name='psb_r_me_d_rk2' + call psb_erractionsave(err_act) + info=psb_success_ + if (present(lb1)) then + lb1_ = lb1 + else + lb1_ = 1 + endif + if (present(lb2)) then + lb2_ = lb2 + else + lb2_ = 1 + endif + ub1_ = lb1_ + len1 -1 + ub2_ = lb2_ + len2 -1 + + if (len1 < 0) then + err=4025 + iplen = len1 + call psb_errpush(err,name, & + & i_err=(/iplen,izero,izero,izero,izero/),a_err='real(psb_dpk_)') + goto 9999 + end if + if (len2 < 0) then + err=4025 + iplen = len2 + call psb_errpush(err,name, & + & i_err=(/iplen,izero,izero,izero,izero/),a_err='real(psb_dpk_)') + goto 9999 + end if + + + if (allocated(rrax)) then + dim = size(rrax,1) + lbi1 = lbound(rrax,1) + dim2 = size(rrax,2) + lbi2 = lbound(rrax,2) + If ((dim /= len1).or.(dim2 /= len2).or.(lbi1 /= lb1_)& + & .or.(lbi2 /= lb2_)) Then + Allocate(tmp(lb1_:ub1_,lb2_:ub2_),stat=info) + if (info /= psb_success_) then + err=4025 + iplen = len1*len2 + call psb_errpush(err,name, & + & i_err=(/iplen,izero,izero,izero,izero/),a_err='real(psb_dpk_)') + goto 9999 + end if + tmp(lb1_:lb1_-1+min(len1,dim),lb2_:lb2_-1+min(len2,dim2)) = & + & rrax(lbi1:lbi1-1+min(len1,dim),lbi2:lbi2-1+min(len2,dim2)) + call psb_move_alloc(tmp,rrax,info) + End If + else + dim = 0 + dim2 = 0 + Allocate(rrax(lb1_:ub1_,lb2_:ub2_),stat=info) + if (info /= psb_success_) then + err=4025 + iplen = len1*len2 + call psb_errpush(err,name, & + & i_err=(/iplen,izero,izero,izero,izero/),a_err='real(psb_dpk_)') + goto 9999 + end if + endif + if (present(pad)) then + rrax(lb1_-1+dim+1:lb1_-1+len1,:) = pad + rrax(lb1_:lb1_-1+dim,lb2_-1+dim2+1:lb2_-1+len2) = pad + endif + call psb_erractionrestore(err_act) + return + +9999 continue + info = err + call psb_error_handler(err_act) + return + + End Subroutine psb_r_em_d_rk2 + + Subroutine psb_r_m_2_d_rk1(len,rrax,y,info,pad) + use psb_error_mod + ! ...Subroutine Arguments + + integer(psb_mpk_),Intent(in) :: len + real(psb_dpk_),allocatable, intent(inout) :: rrax(:),y(:) + integer(psb_ipk_) :: info + real(psb_dpk_), optional, intent(in) :: pad + character(len=20) :: name + integer(psb_ipk_) :: err_act, err + + name='psb_r_m_2_d_rk1' + call psb_erractionsave(err_act) + info=psb_success_ + + if(psb_get_errstatus() /= 0) then + info=psb_err_from_subroutine_ + goto 9999 + end if + + call psb_realloc(len,rrax,info,pad=pad) + if (info /= psb_success_) then + err=4000 + call psb_errpush(err,name) + goto 9999 + end if + call psb_realloc(len,y,info,pad=pad) + if (info /= psb_success_) then + err=4000 + call psb_errpush(err,name) + goto 9999 + end if + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + + End Subroutine psb_r_m_2_d_rk1 + + Subroutine psb_r_e_2_d_rk1(len,rrax,y,info,pad) + use psb_error_mod + ! ...Subroutine Arguments + + integer(psb_epk_),Intent(in) :: len + real(psb_dpk_),allocatable, intent(inout) :: rrax(:),y(:) + integer(psb_ipk_) :: info + real(psb_dpk_), optional, intent(in) :: pad + character(len=20) :: name + integer(psb_ipk_) :: err_act, err + + name='psb_r_m_2_d_rk1' + call psb_erractionsave(err_act) + info=psb_success_ + + if(psb_get_errstatus() /= 0) then + info=psb_err_from_subroutine_ + goto 9999 + end if + + call psb_realloc(len,rrax,info,pad=pad) + if (info /= psb_success_) then + err=4000 + call psb_errpush(err,name) + goto 9999 + end if + call psb_realloc(len,y,info,pad=pad) + if (info /= psb_success_) then + err=4000 + call psb_errpush(err,name) + goto 9999 + end if + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + + End Subroutine psb_r_e_2_d_rk1 + + + + subroutine psb_ab_cpy_d_rk1(vin,vout,info) + use psb_error_mod + + ! ...Subroutine Arguments + real(psb_dpk_), allocatable, intent(in) :: vin(:) + real(psb_dpk_), allocatable, intent(out) :: vout(:) + integer(psb_ipk_) :: info + ! ...Local Variables + + integer(psb_ipk_) :: isz,err_act,lb + character(len=20) :: name, char_err + logical, parameter :: debug=.false. + + name='psb_ab_cpy_d_rk1' + call psb_erractionsave(err_act) + info=psb_success_ + if(psb_get_errstatus() /= 0) then + info=psb_err_from_subroutine_ + goto 9999 + end if + + if (allocated(vin)) then + isz = size(vin) + lb = lbound(vin,1) + call psb_realloc(isz,vout,info,lb=lb) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + char_err='psb_realloc' + call psb_errpush(info,name,a_err=char_err) + goto 9999 + else + vout(:) = vin(:) + endif + endif + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + + end subroutine psb_ab_cpy_d_rk1 + + subroutine psb_ab_cpy_d_rk2(vin,vout,info) + use psb_error_mod + + ! ...Subroutine Arguments + real(psb_dpk_), allocatable, intent(in) :: vin(:,:) + real(psb_dpk_), allocatable, intent(out) :: vout(:,:) + integer(psb_ipk_) :: info + ! ...Local Variables + + integer(psb_ipk_) :: isz1, isz2,err_act, lb1, lb2 + character(len=20) :: name, char_err + logical, parameter :: debug=.false. + + name='psb_ab_cpy_d_rk2' + call psb_erractionsave(err_act) + info=psb_success_ + if(psb_get_errstatus() /= 0) then + info=psb_err_from_subroutine_ + goto 9999 + end if + + if (allocated(vin)) then + isz1 = size(vin,1) + isz2 = size(vin,2) + lb1 = lbound(vin,1) + lb2 = lbound(vin,2) + call psb_realloc(isz1,isz2,vout,info,lb1=lb1,lb2=lb2) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + char_err='psb_realloc' + call psb_errpush(info,name,a_err=char_err) + goto 9999 + else + vout(:,:) = vin(:,:) + endif + endif + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + + end subroutine psb_ab_cpy_d_rk2 + + + subroutine psb_cpy_d_rk1(vin,vout,info) + use psb_error_mod + + ! ...Subroutine Arguments + real(psb_dpk_), intent(in) :: vin(:) + real(psb_dpk_), allocatable, intent(out) :: vout(:) + integer(psb_ipk_) :: info + ! ...Local Variables + + integer(psb_ipk_) :: isz,err_act,lb + character(len=20) :: name, char_err + logical, parameter :: debug=.false. + + name='psb_cpy_d_rk1' + call psb_erractionsave(err_act) + info=psb_success_ + if(psb_get_errstatus() /= 0) then + info=psb_err_from_subroutine_ + goto 9999 + end if + isz = size(vin) + lb = lbound(vin,1) + call psb_realloc(isz,vout,info,lb=lb) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + char_err='psb_realloc' + call psb_errpush(info,name,a_err=char_err) + goto 9999 + else + vout(:) = vin(:) + endif + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + + end subroutine psb_cpy_d_rk1 + + subroutine psb_cpy_d_rk2(vin,vout,info) + use psb_error_mod + + ! ...Subroutine Arguments + real(psb_dpk_), intent(in) :: vin(:,:) + real(psb_dpk_), allocatable, intent(out) :: vout(:,:) + integer(psb_ipk_) :: info + ! ...Local Variables + + integer(psb_ipk_) :: isz1, isz2,err_act, lb1, lb2 + character(len=20) :: name, char_err + logical, parameter :: debug=.false. + + name='psb_safe_cpy' + call psb_erractionsave(err_act) + info=psb_success_ + if(psb_get_errstatus() /= 0) then + info=psb_err_from_subroutine_ + goto 9999 + end if + + isz1 = size(vin,1) + isz2 = size(vin,2) + lb1 = lbound(vin,1) + lb2 = lbound(vin,2) + call psb_realloc(isz1,isz2,vout,info,lb1=lb1,lb2=lb2) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + char_err='psb_realloc' + call psb_errpush(info,name,a_err=char_err) + goto 9999 + else + vout(:,:) = vin(:,:) + endif + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + + end subroutine psb_cpy_d_rk2 + + + function psb_size_d_rk1(vin) result(val) + integer(psb_epk_) :: val + real(psb_dpk_), allocatable, intent(in) :: vin(:) + + if (.not.allocated(vin)) then + val = 0 + else + val = size(vin) + end if + end function psb_size_d_rk1 + + + function psb_size_d_rk2(vin,dim) result(val) + integer(psb_epk_) :: val + real(psb_dpk_), allocatable, intent(in) :: vin(:,:) + integer(psb_ipk_), optional :: dim + integer(psb_ipk_) :: dim_ + + + if (.not.allocated(vin)) then + val = 0 + else + if (present(dim)) then + dim_= dim + val = size(vin,dim=dim_) + else + val = size(vin) + end if + end if + end function psb_size_d_rk2 + + Subroutine psb_ensure_m_sz_d_rk1(len,v,info,pad,addsz,newsz) + use psb_error_mod + + ! ...Subroutine Arguments + integer(psb_mpk_),Intent(in) :: len + real(psb_dpk_),allocatable, intent(inout) :: v(:) + integer(psb_ipk_) :: info + integer(psb_mpk_), optional, intent(in) :: addsz,newsz + real(psb_dpk_), optional, intent(in) :: pad + ! ...Local Variables + character(len=20) :: name + logical, parameter :: debug=.false. + integer(psb_ipk_) :: err_act + integer(psb_mpk_) :: isz + + name='psb_ensure_m_sz_d_rk1' + call psb_erractionsave(err_act) + info = psb_success_ + + if (psb_get_errstatus() /= 0) then + info=psb_err_from_subroutine_ + goto 9999 + end if + + If (len > psb_size(v)) Then + if (present(newsz)) then + isz = (max(len+1,newsz)) + else + if (present(addsz)) then + isz = len+max(1,addsz) + else + isz = max(len+10, int(1.25*len)) + endif + endif + + call psb_realloc(isz,v,info,pad=pad) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='psb_realloc') + goto 9999 + End If + end If + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + + + End Subroutine psb_ensure_m_sz_d_rk1 + + Subroutine psb_ensure_e_sz_d_rk1(len,v,info,pad,addsz,newsz) + use psb_error_mod + + ! ...Subroutine Arguments + integer(psb_epk_),Intent(in) :: len + real(psb_dpk_),allocatable, intent(inout) :: v(:) + integer(psb_ipk_) :: info + integer(psb_epk_), optional, intent(in) :: addsz,newsz + real(psb_dpk_), optional, intent(in) :: pad + ! ...Local Variables + character(len=20) :: name + logical, parameter :: debug=.false. + integer(psb_ipk_) :: err_act + integer(psb_epk_) :: isz + + name='psb_ensure_m_sz_d_rk1' + call psb_erractionsave(err_act) + info = psb_success_ + + if (psb_get_errstatus() /= 0) then + info=psb_err_from_subroutine_ + goto 9999 + end if + + If (len > psb_size(v)) Then + if (present(newsz)) then + isz = (max(len+1,newsz)) + else + if (present(addsz)) then + isz = len+max(1,addsz) + else + isz = max(len+10, int(1.25*len)) + endif + endif + + call psb_realloc(isz,v,info,pad=pad) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='psb_realloc') + goto 9999 + End If + end If + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + + + End Subroutine psb_ensure_e_sz_d_rk1 + + Subroutine psb_move_alloc_d_rk1(vin,vout,info) + use psb_error_mod + real(psb_dpk_), allocatable, intent(inout) :: vin(:),vout(:) + integer(psb_ipk_), intent(out) :: info + ! + ! + info=psb_success_ + call move_alloc(vin,vout) + + end Subroutine psb_move_alloc_d_rk1 + + Subroutine psb_move_alloc_d_rk2(vin,vout,info) + use psb_error_mod + real(psb_dpk_), allocatable, intent(inout) :: vin(:,:),vout(:,:) + integer(psb_ipk_), intent(out) :: info + ! + ! + info=psb_success_ + + call move_alloc(vin,vout) + + end Subroutine psb_move_alloc_d_rk2 + +end module psb_d_realloc_mod diff --git a/base/modules/basics/psb_e_realloc_mod.F90 b/base/modules/basics/psb_e_realloc_mod.F90 new file mode 100644 index 00000000..7ef08064 --- /dev/null +++ b/base/modules/basics/psb_e_realloc_mod.F90 @@ -0,0 +1,1027 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! 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. +! +! +module psb_e_realloc_mod + use psb_const_mod + + implicit none + + ! + ! psb_realloc will reallocate the input array to have exactly + ! the size specified, possibly shortening it. + ! + Interface psb_realloc + module procedure psb_r_m_e_rk1 + module procedure psb_r_m_e_rk2 + module procedure psb_r_e_e_rk1 + module procedure psb_r_e_e_rk2 + module procedure psb_r_me_e_rk2 + module procedure psb_r_em_e_rk2 + + module procedure psb_r_m_2_e_rk1 + module procedure psb_r_e_2_e_rk1 + + end Interface psb_realloc + + interface psb_move_alloc + module procedure psb_move_alloc_e_rk1, psb_move_alloc_e_rk2 + end interface psb_move_alloc + + Interface psb_safe_ab_cpy + module procedure psb_ab_cpy_e_rk1, psb_ab_cpy_e_rk2 + end Interface psb_safe_ab_cpy + + Interface psb_safe_cpy + module procedure psb_cpy_e_rk1, psb_cpy_e_rk2 + end Interface psb_safe_cpy + + ! + ! psb_ensure_size will reallocate the input array if necessary + ! to guarantee that its size is at least as large as the + ! value required, usually with some room to spare. + ! + interface psb_ensure_size + module procedure psb_ensure_m_sz_e_rk1, psb_ensure_e_sz_e_rk1 + end Interface psb_ensure_size + + ! + ! psb_size returns 0 if argument is not allocated. + ! + interface psb_size + module procedure psb_size_e_rk1, psb_size_e_rk2 + end interface psb_size + + +Contains + + Subroutine psb_r_m_e_rk1(len,rrax,info,pad,lb) + use psb_error_mod + + ! ...Subroutine Arguments + integer(psb_mpk_),Intent(in) :: len + integer(psb_epk_), allocatable, intent(inout) :: rrax(:) + integer(psb_ipk_) :: info + integer(psb_epk_), optional, intent(in) :: pad + integer(psb_mpk_), optional, intent(in) :: lb + + ! ...Local Variables + integer(psb_epk_),allocatable :: tmp(:) + integer(psb_mpk_) :: dim, lb_, lbi,ub_ + integer(psb_ipk_) :: err_act,err + character(len=20) :: name + logical, parameter :: debug=.false. + + name='psb_r_m_e_rk1' + call psb_erractionsave(err_act) + info=psb_success_ + if (debug) write(psb_err_unit,*) 'reallocate D',len + + if (present(lb)) then + lb_ = lb + else + lb_ = 1 + endif + if ((len<0)) then + err=4025 + call psb_errpush(err,name, & + & i_err=(/len,izero,izero,izero,izero/),a_err='integer(psb_epk_)') + goto 9999 + end if + ub_ = lb_ + len-1 + + if (allocated(rrax)) then + dim = size(rrax) + lbi = lbound(rrax,1) + If ((dim /= len).or.(lbi /= lb_)) Then + Allocate(tmp(lb_:ub_),stat=info) + if (info /= psb_success_) then + err=4025 + call psb_errpush(err,name, & + & i_err=(/len,izero,izero,izero,izero/),a_err='integer(psb_epk_)') + goto 9999 + end if + tmp(lb_:lb_-1+min(len,dim))=rrax(lbi:lbi-1+min(len,dim)) + call psb_move_alloc(tmp,rrax,info) + End If + else + dim = 0 + Allocate(rrax(lb_:ub_),stat=info) + if (info /= psb_success_) then + err=4025 + call psb_errpush(err,name, & + & i_err=(/len,izero,izero,izero,izero/),a_err='integer(psb_epk_)') + goto 9999 + end if + endif + if (present(pad)) then + rrax(lb_-1+dim+1:lb_-1+len) = pad + endif + call psb_erractionrestore(err_act) + return + +9999 continue + info = err + call psb_error_handler(err_act) + return + + End Subroutine psb_r_m_e_rk1 + + Subroutine psb_r_m_e_rk2(len1,len2,rrax,info,pad,lb1,lb2) + use psb_error_mod + ! ...Subroutine Arguments + integer(psb_mpk_),Intent(in) :: len1,len2 + integer(psb_epk_),allocatable :: rrax(:,:) + integer(psb_ipk_) :: info + integer(psb_epk_), optional, intent(in) :: pad + integer(psb_mpk_),Intent(in), optional :: lb1,lb2 + + ! ...Local Variables + + integer(psb_epk_),allocatable :: tmp(:,:) + integer(psb_ipk_) :: err_act,err + integer(psb_mpk_) :: dim,dim2,lb1_, lb2_, ub1_, ub2_,lbi1, lbi2 + character(len=20) :: name + + name='psb_r_m_e_rk2' + call psb_erractionsave(err_act) + info=psb_success_ + if (present(lb1)) then + lb1_ = lb1 + else + lb1_ = 1 + endif + if (present(lb2)) then + lb2_ = lb2 + else + lb2_ = 1 + endif + ub1_ = lb1_ + len1 -1 + ub2_ = lb2_ + len2 -1 + + if (len1 < 0) then + err=4025 + call psb_errpush(err,name, & + & i_err=(/len1,izero,izero,izero,izero/),a_err='integer(psb_epk_)') + goto 9999 + end if + if (len2 < 0) then + err=4025 + call psb_errpush(err,name, & + & i_err=(/len2,izero,izero,izero,izero/),a_err='integer(psb_epk_)') + goto 9999 + end if + + + if (allocated(rrax)) then + dim = size(rrax,1) + lbi1 = lbound(rrax,1) + dim2 = size(rrax,2) + lbi2 = lbound(rrax,2) + If ((dim /= len1).or.(dim2 /= len2).or.(lbi1 /= lb1_)& + & .or.(lbi2 /= lb2_)) Then + Allocate(tmp(lb1_:ub1_,lb2_:ub2_),stat=info) + if (info /= psb_success_) then + err=4025 + call psb_errpush(err,name, & + & i_err=(/len1*len2,izero,izero,izero,izero/),a_err='integer(psb_epk_)') + goto 9999 + end if + tmp(lb1_:lb1_-1+min(len1,dim),lb2_:lb2_-1+min(len2,dim2)) = & + & rrax(lbi1:lbi1-1+min(len1,dim),lbi2:lbi2-1+min(len2,dim2)) + call psb_move_alloc(tmp,rrax,info) + End If + else + dim = 0 + dim2 = 0 + Allocate(rrax(lb1_:ub1_,lb2_:ub2_),stat=info) + if (info /= psb_success_) then + err=4025 + call psb_errpush(err,name, & + & i_err=(/len1*len2,izero,izero,izero,izero/),a_err='integer(psb_epk_)') + goto 9999 + end if + endif + if (present(pad)) then + rrax(lb1_-1+dim+1:lb1_-1+len1,:) = pad + rrax(lb1_:lb1_-1+dim,lb2_-1+dim2+1:lb2_-1+len2) = pad + endif + call psb_erractionrestore(err_act) + return + +9999 continue + info = err + call psb_error_handler(err_act) + return + + End Subroutine psb_r_m_e_rk2 + + + Subroutine psb_r_e_e_rk1(len,rrax,info,pad,lb) + use psb_error_mod + + ! ...Subroutine Arguments + integer(psb_epk_),Intent(in) :: len + integer(psb_epk_), allocatable, intent(inout) :: rrax(:) + integer(psb_ipk_) :: info + integer(psb_epk_), optional, intent(in) :: pad + integer(psb_epk_), optional, intent(in) :: lb + + ! ...Local Variables + integer(psb_epk_),allocatable :: tmp(:) + integer(psb_epk_) :: dim, lb_, lbi,ub_ + integer(psb_ipk_) :: iplen + integer(psb_ipk_) :: err_act,err + character(len=20) :: name + logical, parameter :: debug=.false. + + name='psb_r_m_e_rk1' + call psb_erractionsave(err_act) + info=psb_success_ + if (debug) write(psb_err_unit,*) 'reallocate D',len + + if (present(lb)) then + lb_ = lb + else + lb_ = 1 + endif + if ((len<0)) then + err=4025 + iplen = len + call psb_errpush(err,name, & + & i_err=(/iplen,izero,izero,izero,izero/),a_err='integer(psb_epk_)') + goto 9999 + end if + ub_ = lb_ + len-1 + + if (allocated(rrax)) then + dim = size(rrax) + lbi = lbound(rrax,1) + If ((dim /= len).or.(lbi /= lb_)) Then + Allocate(tmp(lb_:ub_),stat=info) + if (info /= psb_success_) then + err=4025 + iplen = len + call psb_errpush(err,name, & + & i_err=(/iplen,izero,izero,izero,izero/),a_err='integer(psb_epk_)') + goto 9999 + end if + tmp(lb_:lb_-1+min(len,dim))=rrax(lbi:lbi-1+min(len,dim)) + call psb_move_alloc(tmp,rrax,info) + End If + else + dim = 0 + Allocate(rrax(lb_:ub_),stat=info) + if (info /= psb_success_) then + err=4025 + iplen = len + call psb_errpush(err,name, & + & i_err=(/iplen,izero,izero,izero,izero/),a_err='integer(psb_epk_)') + goto 9999 + end if + endif + if (present(pad)) then + rrax(lb_-1+dim+1:lb_-1+len) = pad + endif + call psb_erractionrestore(err_act) + return + +9999 continue + info = err + call psb_error_handler(err_act) + return + + End Subroutine psb_r_e_e_rk1 + + Subroutine psb_r_e_e_rk2(len1,len2,rrax,info,pad,lb1,lb2) + use psb_error_mod + ! ...Subroutine Arguments + integer(psb_epk_),Intent(in) :: len1,len2 + integer(psb_epk_),allocatable :: rrax(:,:) + integer(psb_ipk_) :: info + integer(psb_epk_), optional, intent(in) :: pad + integer(psb_epk_),Intent(in), optional :: lb1,lb2 + + ! ...Local Variables + + integer(psb_epk_),allocatable :: tmp(:,:) + integer(psb_ipk_) :: err_act,err, iplen + integer(psb_epk_) :: dim,dim2,lb1_, lb2_, ub1_, ub2_,lbi1, lbi2 + character(len=20) :: name + + name='psb_r_e_e_rk2' + call psb_erractionsave(err_act) + info=psb_success_ + if (present(lb1)) then + lb1_ = lb1 + else + lb1_ = 1 + endif + if (present(lb2)) then + lb2_ = lb2 + else + lb2_ = 1 + endif + ub1_ = lb1_ + len1 -1 + ub2_ = lb2_ + len2 -1 + + if (len1 < 0) then + err=4025 + iplen = len1 + call psb_errpush(err,name, & + & i_err=(/iplen,izero,izero,izero,izero/),a_err='integer(psb_epk_)') + goto 9999 + end if + if (len2 < 0) then + err=4025 + iplen = len2 + call psb_errpush(err,name, & + & i_err=(/iplen,izero,izero,izero,izero/),a_err='integer(psb_epk_)') + goto 9999 + end if + + + if (allocated(rrax)) then + dim = size(rrax,1) + lbi1 = lbound(rrax,1) + dim2 = size(rrax,2) + lbi2 = lbound(rrax,2) + If ((dim /= len1).or.(dim2 /= len2).or.(lbi1 /= lb1_)& + & .or.(lbi2 /= lb2_)) Then + Allocate(tmp(lb1_:ub1_,lb2_:ub2_),stat=info) + if (info /= psb_success_) then + err=4025 + iplen = len1*len2 + call psb_errpush(err,name, & + & i_err=(/iplen,izero,izero,izero,izero/),a_err='integer(psb_epk_)') + goto 9999 + end if + tmp(lb1_:lb1_-1+min(len1,dim),lb2_:lb2_-1+min(len2,dim2)) = & + & rrax(lbi1:lbi1-1+min(len1,dim),lbi2:lbi2-1+min(len2,dim2)) + call psb_move_alloc(tmp,rrax,info) + End If + else + dim = 0 + dim2 = 0 + Allocate(rrax(lb1_:ub1_,lb2_:ub2_),stat=info) + if (info /= psb_success_) then + err=4025 + iplen = len1*len2 + call psb_errpush(err,name, & + & i_err=(/iplen,izero,izero,izero,izero/),a_err='integer(psb_epk_)') + goto 9999 + end if + endif + if (present(pad)) then + rrax(lb1_-1+dim+1:lb1_-1+len1,:) = pad + rrax(lb1_:lb1_-1+dim,lb2_-1+dim2+1:lb2_-1+len2) = pad + endif + call psb_erractionrestore(err_act) + return + +9999 continue + info = err + call psb_error_handler(err_act) + return + + End Subroutine psb_r_e_e_rk2 + + Subroutine psb_r_me_e_rk2(len1,len2,rrax,info,pad,lb1,lb2) + use psb_error_mod + ! ...Subroutine Arguments + integer(psb_mpk_),Intent(in) :: len1 + integer(psb_epk_),Intent(in) :: len2 + integer(psb_epk_),allocatable :: rrax(:,:) + integer(psb_ipk_) :: info + integer(psb_epk_), optional, intent(in) :: pad + integer(psb_mpk_),Intent(in), optional :: lb1,lb2 + + ! ...Local Variables + + integer(psb_epk_),allocatable :: tmp(:,:) + integer(psb_ipk_) :: err_act,err, iplen + integer(psb_mpk_) :: dim,lb1_, lb2_, ub1_, ub2_,lbi1, lbi2 + integer(psb_epk_) :: dim2 + character(len=20) :: name + + name='psb_r_me_e_rk2' + call psb_erractionsave(err_act) + info=psb_success_ + if (present(lb1)) then + lb1_ = lb1 + else + lb1_ = 1 + endif + if (present(lb2)) then + lb2_ = lb2 + else + lb2_ = 1 + endif + ub1_ = lb1_ + len1 -1 + ub2_ = lb2_ + len2 -1 + + if (len1 < 0) then + err=4025 + iplen = len1 + call psb_errpush(err,name, & + & i_err=(/iplen,izero,izero,izero,izero/),a_err='integer(psb_epk_)') + goto 9999 + end if + if (len2 < 0) then + err=4025 + iplen = len2 + call psb_errpush(err,name, & + & i_err=(/iplen,izero,izero,izero,izero/),a_err='integer(psb_epk_)') + goto 9999 + end if + + + if (allocated(rrax)) then + dim = size(rrax,1) + lbi1 = lbound(rrax,1) + dim2 = size(rrax,2) + lbi2 = lbound(rrax,2) + If ((dim /= len1).or.(dim2 /= len2).or.(lbi1 /= lb1_)& + & .or.(lbi2 /= lb2_)) Then + Allocate(tmp(lb1_:ub1_,lb2_:ub2_),stat=info) + if (info /= psb_success_) then + err=4025 + iplen = len1*len2 + call psb_errpush(err,name, & + & i_err=(/iplen,izero,izero,izero,izero/),a_err='integer(psb_epk_)') + goto 9999 + end if + tmp(lb1_:lb1_-1+min(len1,dim),lb2_:lb2_-1+min(len2,dim2)) = & + & rrax(lbi1:lbi1-1+min(len1,dim),lbi2:lbi2-1+min(len2,dim2)) + call psb_move_alloc(tmp,rrax,info) + End If + else + dim = 0 + dim2 = 0 + Allocate(rrax(lb1_:ub1_,lb2_:ub2_),stat=info) + if (info /= psb_success_) then + err=4025 + iplen = len1*len2 + call psb_errpush(err,name, & + & i_err=(/iplen,izero,izero,izero,izero/),a_err='integer(psb_epk_)') + goto 9999 + end if + endif + if (present(pad)) then + rrax(lb1_-1+dim+1:lb1_-1+len1,:) = pad + rrax(lb1_:lb1_-1+dim,lb2_-1+dim2+1:lb2_-1+len2) = pad + endif + call psb_erractionrestore(err_act) + return + +9999 continue + info = err + call psb_error_handler(err_act) + return + + End Subroutine psb_r_me_e_rk2 + + Subroutine psb_r_em_e_rk2(len1,len2,rrax,info,pad,lb1,lb2) + use psb_error_mod + ! ...Subroutine Arguments + integer(psb_epk_),Intent(in) :: len1 + integer(psb_mpk_),Intent(in) :: len2 + integer(psb_epk_),allocatable :: rrax(:,:) + integer(psb_ipk_) :: info + integer(psb_epk_), optional, intent(in) :: pad + integer(psb_mpk_),Intent(in), optional :: lb1,lb2 + + ! ...Local Variables + + integer(psb_epk_),allocatable :: tmp(:,:) + integer(psb_ipk_) :: err_act,err, iplen + integer(psb_mpk_) :: dim2,lb1_, lb2_, ub1_, ub2_,lbi1, lbi2 + integer(psb_epk_) :: dim + character(len=20) :: name + + name='psb_r_me_e_rk2' + call psb_erractionsave(err_act) + info=psb_success_ + if (present(lb1)) then + lb1_ = lb1 + else + lb1_ = 1 + endif + if (present(lb2)) then + lb2_ = lb2 + else + lb2_ = 1 + endif + ub1_ = lb1_ + len1 -1 + ub2_ = lb2_ + len2 -1 + + if (len1 < 0) then + err=4025 + iplen = len1 + call psb_errpush(err,name, & + & i_err=(/iplen,izero,izero,izero,izero/),a_err='integer(psb_epk_)') + goto 9999 + end if + if (len2 < 0) then + err=4025 + iplen = len2 + call psb_errpush(err,name, & + & i_err=(/iplen,izero,izero,izero,izero/),a_err='integer(psb_epk_)') + goto 9999 + end if + + + if (allocated(rrax)) then + dim = size(rrax,1) + lbi1 = lbound(rrax,1) + dim2 = size(rrax,2) + lbi2 = lbound(rrax,2) + If ((dim /= len1).or.(dim2 /= len2).or.(lbi1 /= lb1_)& + & .or.(lbi2 /= lb2_)) Then + Allocate(tmp(lb1_:ub1_,lb2_:ub2_),stat=info) + if (info /= psb_success_) then + err=4025 + iplen = len1*len2 + call psb_errpush(err,name, & + & i_err=(/iplen,izero,izero,izero,izero/),a_err='integer(psb_epk_)') + goto 9999 + end if + tmp(lb1_:lb1_-1+min(len1,dim),lb2_:lb2_-1+min(len2,dim2)) = & + & rrax(lbi1:lbi1-1+min(len1,dim),lbi2:lbi2-1+min(len2,dim2)) + call psb_move_alloc(tmp,rrax,info) + End If + else + dim = 0 + dim2 = 0 + Allocate(rrax(lb1_:ub1_,lb2_:ub2_),stat=info) + if (info /= psb_success_) then + err=4025 + iplen = len1*len2 + call psb_errpush(err,name, & + & i_err=(/iplen,izero,izero,izero,izero/),a_err='integer(psb_epk_)') + goto 9999 + end if + endif + if (present(pad)) then + rrax(lb1_-1+dim+1:lb1_-1+len1,:) = pad + rrax(lb1_:lb1_-1+dim,lb2_-1+dim2+1:lb2_-1+len2) = pad + endif + call psb_erractionrestore(err_act) + return + +9999 continue + info = err + call psb_error_handler(err_act) + return + + End Subroutine psb_r_em_e_rk2 + + Subroutine psb_r_m_2_e_rk1(len,rrax,y,info,pad) + use psb_error_mod + ! ...Subroutine Arguments + + integer(psb_mpk_),Intent(in) :: len + integer(psb_epk_),allocatable, intent(inout) :: rrax(:),y(:) + integer(psb_ipk_) :: info + integer(psb_epk_), optional, intent(in) :: pad + character(len=20) :: name + integer(psb_ipk_) :: err_act, err + + name='psb_r_m_2_e_rk1' + call psb_erractionsave(err_act) + info=psb_success_ + + if(psb_get_errstatus() /= 0) then + info=psb_err_from_subroutine_ + goto 9999 + end if + + call psb_realloc(len,rrax,info,pad=pad) + if (info /= psb_success_) then + err=4000 + call psb_errpush(err,name) + goto 9999 + end if + call psb_realloc(len,y,info,pad=pad) + if (info /= psb_success_) then + err=4000 + call psb_errpush(err,name) + goto 9999 + end if + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + + End Subroutine psb_r_m_2_e_rk1 + + Subroutine psb_r_e_2_e_rk1(len,rrax,y,info,pad) + use psb_error_mod + ! ...Subroutine Arguments + + integer(psb_epk_),Intent(in) :: len + integer(psb_epk_),allocatable, intent(inout) :: rrax(:),y(:) + integer(psb_ipk_) :: info + integer(psb_epk_), optional, intent(in) :: pad + character(len=20) :: name + integer(psb_ipk_) :: err_act, err + + name='psb_r_m_2_e_rk1' + call psb_erractionsave(err_act) + info=psb_success_ + + if(psb_get_errstatus() /= 0) then + info=psb_err_from_subroutine_ + goto 9999 + end if + + call psb_realloc(len,rrax,info,pad=pad) + if (info /= psb_success_) then + err=4000 + call psb_errpush(err,name) + goto 9999 + end if + call psb_realloc(len,y,info,pad=pad) + if (info /= psb_success_) then + err=4000 + call psb_errpush(err,name) + goto 9999 + end if + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + + End Subroutine psb_r_e_2_e_rk1 + + + + subroutine psb_ab_cpy_e_rk1(vin,vout,info) + use psb_error_mod + + ! ...Subroutine Arguments + integer(psb_epk_), allocatable, intent(in) :: vin(:) + integer(psb_epk_), allocatable, intent(out) :: vout(:) + integer(psb_ipk_) :: info + ! ...Local Variables + + integer(psb_ipk_) :: isz,err_act,lb + character(len=20) :: name, char_err + logical, parameter :: debug=.false. + + name='psb_ab_cpy_e_rk1' + call psb_erractionsave(err_act) + info=psb_success_ + if(psb_get_errstatus() /= 0) then + info=psb_err_from_subroutine_ + goto 9999 + end if + + if (allocated(vin)) then + isz = size(vin) + lb = lbound(vin,1) + call psb_realloc(isz,vout,info,lb=lb) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + char_err='psb_realloc' + call psb_errpush(info,name,a_err=char_err) + goto 9999 + else + vout(:) = vin(:) + endif + endif + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + + end subroutine psb_ab_cpy_e_rk1 + + subroutine psb_ab_cpy_e_rk2(vin,vout,info) + use psb_error_mod + + ! ...Subroutine Arguments + integer(psb_epk_), allocatable, intent(in) :: vin(:,:) + integer(psb_epk_), allocatable, intent(out) :: vout(:,:) + integer(psb_ipk_) :: info + ! ...Local Variables + + integer(psb_ipk_) :: isz1, isz2,err_act, lb1, lb2 + character(len=20) :: name, char_err + logical, parameter :: debug=.false. + + name='psb_ab_cpy_e_rk2' + call psb_erractionsave(err_act) + info=psb_success_ + if(psb_get_errstatus() /= 0) then + info=psb_err_from_subroutine_ + goto 9999 + end if + + if (allocated(vin)) then + isz1 = size(vin,1) + isz2 = size(vin,2) + lb1 = lbound(vin,1) + lb2 = lbound(vin,2) + call psb_realloc(isz1,isz2,vout,info,lb1=lb1,lb2=lb2) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + char_err='psb_realloc' + call psb_errpush(info,name,a_err=char_err) + goto 9999 + else + vout(:,:) = vin(:,:) + endif + endif + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + + end subroutine psb_ab_cpy_e_rk2 + + + subroutine psb_cpy_e_rk1(vin,vout,info) + use psb_error_mod + + ! ...Subroutine Arguments + integer(psb_epk_), intent(in) :: vin(:) + integer(psb_epk_), allocatable, intent(out) :: vout(:) + integer(psb_ipk_) :: info + ! ...Local Variables + + integer(psb_ipk_) :: isz,err_act,lb + character(len=20) :: name, char_err + logical, parameter :: debug=.false. + + name='psb_cpy_e_rk1' + call psb_erractionsave(err_act) + info=psb_success_ + if(psb_get_errstatus() /= 0) then + info=psb_err_from_subroutine_ + goto 9999 + end if + isz = size(vin) + lb = lbound(vin,1) + call psb_realloc(isz,vout,info,lb=lb) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + char_err='psb_realloc' + call psb_errpush(info,name,a_err=char_err) + goto 9999 + else + vout(:) = vin(:) + endif + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + + end subroutine psb_cpy_e_rk1 + + subroutine psb_cpy_e_rk2(vin,vout,info) + use psb_error_mod + + ! ...Subroutine Arguments + integer(psb_epk_), intent(in) :: vin(:,:) + integer(psb_epk_), allocatable, intent(out) :: vout(:,:) + integer(psb_ipk_) :: info + ! ...Local Variables + + integer(psb_ipk_) :: isz1, isz2,err_act, lb1, lb2 + character(len=20) :: name, char_err + logical, parameter :: debug=.false. + + name='psb_safe_cpy' + call psb_erractionsave(err_act) + info=psb_success_ + if(psb_get_errstatus() /= 0) then + info=psb_err_from_subroutine_ + goto 9999 + end if + + isz1 = size(vin,1) + isz2 = size(vin,2) + lb1 = lbound(vin,1) + lb2 = lbound(vin,2) + call psb_realloc(isz1,isz2,vout,info,lb1=lb1,lb2=lb2) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + char_err='psb_realloc' + call psb_errpush(info,name,a_err=char_err) + goto 9999 + else + vout(:,:) = vin(:,:) + endif + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + + end subroutine psb_cpy_e_rk2 + + + function psb_size_e_rk1(vin) result(val) + integer(psb_epk_) :: val + integer(psb_epk_), allocatable, intent(in) :: vin(:) + + if (.not.allocated(vin)) then + val = 0 + else + val = size(vin) + end if + end function psb_size_e_rk1 + + + function psb_size_e_rk2(vin,dim) result(val) + integer(psb_epk_) :: val + integer(psb_epk_), allocatable, intent(in) :: vin(:,:) + integer(psb_ipk_), optional :: dim + integer(psb_ipk_) :: dim_ + + + if (.not.allocated(vin)) then + val = 0 + else + if (present(dim)) then + dim_= dim + val = size(vin,dim=dim_) + else + val = size(vin) + end if + end if + end function psb_size_e_rk2 + + Subroutine psb_ensure_m_sz_e_rk1(len,v,info,pad,addsz,newsz) + use psb_error_mod + + ! ...Subroutine Arguments + integer(psb_mpk_),Intent(in) :: len + integer(psb_epk_),allocatable, intent(inout) :: v(:) + integer(psb_ipk_) :: info + integer(psb_mpk_), optional, intent(in) :: addsz,newsz + integer(psb_epk_), optional, intent(in) :: pad + ! ...Local Variables + character(len=20) :: name + logical, parameter :: debug=.false. + integer(psb_ipk_) :: err_act + integer(psb_mpk_) :: isz + + name='psb_ensure_m_sz_e_rk1' + call psb_erractionsave(err_act) + info = psb_success_ + + if (psb_get_errstatus() /= 0) then + info=psb_err_from_subroutine_ + goto 9999 + end if + + If (len > psb_size(v)) Then + if (present(newsz)) then + isz = (max(len+1,newsz)) + else + if (present(addsz)) then + isz = len+max(1,addsz) + else + isz = max(len+10, int(1.25*len)) + endif + endif + + call psb_realloc(isz,v,info,pad=pad) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='psb_realloc') + goto 9999 + End If + end If + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + + + End Subroutine psb_ensure_m_sz_e_rk1 + + Subroutine psb_ensure_e_sz_e_rk1(len,v,info,pad,addsz,newsz) + use psb_error_mod + + ! ...Subroutine Arguments + integer(psb_epk_),Intent(in) :: len + integer(psb_epk_),allocatable, intent(inout) :: v(:) + integer(psb_ipk_) :: info + integer(psb_epk_), optional, intent(in) :: addsz,newsz + integer(psb_epk_), optional, intent(in) :: pad + ! ...Local Variables + character(len=20) :: name + logical, parameter :: debug=.false. + integer(psb_ipk_) :: err_act + integer(psb_epk_) :: isz + + name='psb_ensure_m_sz_e_rk1' + call psb_erractionsave(err_act) + info = psb_success_ + + if (psb_get_errstatus() /= 0) then + info=psb_err_from_subroutine_ + goto 9999 + end if + + If (len > psb_size(v)) Then + if (present(newsz)) then + isz = (max(len+1,newsz)) + else + if (present(addsz)) then + isz = len+max(1,addsz) + else + isz = max(len+10, int(1.25*len)) + endif + endif + + call psb_realloc(isz,v,info,pad=pad) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='psb_realloc') + goto 9999 + End If + end If + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + + + End Subroutine psb_ensure_e_sz_e_rk1 + + Subroutine psb_move_alloc_e_rk1(vin,vout,info) + use psb_error_mod + integer(psb_epk_), allocatable, intent(inout) :: vin(:),vout(:) + integer(psb_ipk_), intent(out) :: info + ! + ! + info=psb_success_ + call move_alloc(vin,vout) + + end Subroutine psb_move_alloc_e_rk1 + + Subroutine psb_move_alloc_e_rk2(vin,vout,info) + use psb_error_mod + integer(psb_epk_), allocatable, intent(inout) :: vin(:,:),vout(:,:) + integer(psb_ipk_), intent(out) :: info + ! + ! + info=psb_success_ + + call move_alloc(vin,vout) + + end Subroutine psb_move_alloc_e_rk2 + +end module psb_e_realloc_mod diff --git a/base/modules/basics/psb_m_realloc_mod.F90 b/base/modules/basics/psb_m_realloc_mod.F90 new file mode 100644 index 00000000..b7e993e8 --- /dev/null +++ b/base/modules/basics/psb_m_realloc_mod.F90 @@ -0,0 +1,1027 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! 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. +! +! +module psb_m_realloc_mod + use psb_const_mod + + implicit none + + ! + ! psb_realloc will reallocate the input array to have exactly + ! the size specified, possibly shortening it. + ! + Interface psb_realloc + module procedure psb_r_m_m_rk1 + module procedure psb_r_m_m_rk2 + module procedure psb_r_e_m_rk1 + module procedure psb_r_e_m_rk2 + module procedure psb_r_me_m_rk2 + module procedure psb_r_em_m_rk2 + + module procedure psb_r_m_2_m_rk1 + module procedure psb_r_e_2_m_rk1 + + end Interface psb_realloc + + interface psb_move_alloc + module procedure psb_move_alloc_m_rk1, psb_move_alloc_m_rk2 + end interface psb_move_alloc + + Interface psb_safe_ab_cpy + module procedure psb_ab_cpy_m_rk1, psb_ab_cpy_m_rk2 + end Interface psb_safe_ab_cpy + + Interface psb_safe_cpy + module procedure psb_cpy_m_rk1, psb_cpy_m_rk2 + end Interface psb_safe_cpy + + ! + ! psb_ensure_size will reallocate the input array if necessary + ! to guarantee that its size is at least as large as the + ! value required, usually with some room to spare. + ! + interface psb_ensure_size + module procedure psb_ensure_m_sz_m_rk1, psb_ensure_e_sz_m_rk1 + end Interface psb_ensure_size + + ! + ! psb_size returns 0 if argument is not allocated. + ! + interface psb_size + module procedure psb_size_m_rk1, psb_size_m_rk2 + end interface psb_size + + +Contains + + Subroutine psb_r_m_m_rk1(len,rrax,info,pad,lb) + use psb_error_mod + + ! ...Subroutine Arguments + integer(psb_mpk_),Intent(in) :: len + integer(psb_mpk_), allocatable, intent(inout) :: rrax(:) + integer(psb_ipk_) :: info + integer(psb_mpk_), optional, intent(in) :: pad + integer(psb_mpk_), optional, intent(in) :: lb + + ! ...Local Variables + integer(psb_mpk_),allocatable :: tmp(:) + integer(psb_mpk_) :: dim, lb_, lbi,ub_ + integer(psb_ipk_) :: err_act,err + character(len=20) :: name + logical, parameter :: debug=.false. + + name='psb_r_m_m_rk1' + call psb_erractionsave(err_act) + info=psb_success_ + if (debug) write(psb_err_unit,*) 'reallocate D',len + + if (present(lb)) then + lb_ = lb + else + lb_ = 1 + endif + if ((len<0)) then + err=4025 + call psb_errpush(err,name, & + & i_err=(/len,izero,izero,izero,izero/),a_err='integer(psb_mpk_)') + goto 9999 + end if + ub_ = lb_ + len-1 + + if (allocated(rrax)) then + dim = size(rrax) + lbi = lbound(rrax,1) + If ((dim /= len).or.(lbi /= lb_)) Then + Allocate(tmp(lb_:ub_),stat=info) + if (info /= psb_success_) then + err=4025 + call psb_errpush(err,name, & + & i_err=(/len,izero,izero,izero,izero/),a_err='integer(psb_mpk_)') + goto 9999 + end if + tmp(lb_:lb_-1+min(len,dim))=rrax(lbi:lbi-1+min(len,dim)) + call psb_move_alloc(tmp,rrax,info) + End If + else + dim = 0 + Allocate(rrax(lb_:ub_),stat=info) + if (info /= psb_success_) then + err=4025 + call psb_errpush(err,name, & + & i_err=(/len,izero,izero,izero,izero/),a_err='integer(psb_mpk_)') + goto 9999 + end if + endif + if (present(pad)) then + rrax(lb_-1+dim+1:lb_-1+len) = pad + endif + call psb_erractionrestore(err_act) + return + +9999 continue + info = err + call psb_error_handler(err_act) + return + + End Subroutine psb_r_m_m_rk1 + + Subroutine psb_r_m_m_rk2(len1,len2,rrax,info,pad,lb1,lb2) + use psb_error_mod + ! ...Subroutine Arguments + integer(psb_mpk_),Intent(in) :: len1,len2 + integer(psb_mpk_),allocatable :: rrax(:,:) + integer(psb_ipk_) :: info + integer(psb_mpk_), optional, intent(in) :: pad + integer(psb_mpk_),Intent(in), optional :: lb1,lb2 + + ! ...Local Variables + + integer(psb_mpk_),allocatable :: tmp(:,:) + integer(psb_ipk_) :: err_act,err + integer(psb_mpk_) :: dim,dim2,lb1_, lb2_, ub1_, ub2_,lbi1, lbi2 + character(len=20) :: name + + name='psb_r_m_m_rk2' + call psb_erractionsave(err_act) + info=psb_success_ + if (present(lb1)) then + lb1_ = lb1 + else + lb1_ = 1 + endif + if (present(lb2)) then + lb2_ = lb2 + else + lb2_ = 1 + endif + ub1_ = lb1_ + len1 -1 + ub2_ = lb2_ + len2 -1 + + if (len1 < 0) then + err=4025 + call psb_errpush(err,name, & + & i_err=(/len1,izero,izero,izero,izero/),a_err='integer(psb_mpk_)') + goto 9999 + end if + if (len2 < 0) then + err=4025 + call psb_errpush(err,name, & + & i_err=(/len2,izero,izero,izero,izero/),a_err='integer(psb_mpk_)') + goto 9999 + end if + + + if (allocated(rrax)) then + dim = size(rrax,1) + lbi1 = lbound(rrax,1) + dim2 = size(rrax,2) + lbi2 = lbound(rrax,2) + If ((dim /= len1).or.(dim2 /= len2).or.(lbi1 /= lb1_)& + & .or.(lbi2 /= lb2_)) Then + Allocate(tmp(lb1_:ub1_,lb2_:ub2_),stat=info) + if (info /= psb_success_) then + err=4025 + call psb_errpush(err,name, & + & i_err=(/len1*len2,izero,izero,izero,izero/),a_err='integer(psb_mpk_)') + goto 9999 + end if + tmp(lb1_:lb1_-1+min(len1,dim),lb2_:lb2_-1+min(len2,dim2)) = & + & rrax(lbi1:lbi1-1+min(len1,dim),lbi2:lbi2-1+min(len2,dim2)) + call psb_move_alloc(tmp,rrax,info) + End If + else + dim = 0 + dim2 = 0 + Allocate(rrax(lb1_:ub1_,lb2_:ub2_),stat=info) + if (info /= psb_success_) then + err=4025 + call psb_errpush(err,name, & + & i_err=(/len1*len2,izero,izero,izero,izero/),a_err='integer(psb_mpk_)') + goto 9999 + end if + endif + if (present(pad)) then + rrax(lb1_-1+dim+1:lb1_-1+len1,:) = pad + rrax(lb1_:lb1_-1+dim,lb2_-1+dim2+1:lb2_-1+len2) = pad + endif + call psb_erractionrestore(err_act) + return + +9999 continue + info = err + call psb_error_handler(err_act) + return + + End Subroutine psb_r_m_m_rk2 + + + Subroutine psb_r_e_m_rk1(len,rrax,info,pad,lb) + use psb_error_mod + + ! ...Subroutine Arguments + integer(psb_epk_),Intent(in) :: len + integer(psb_mpk_), allocatable, intent(inout) :: rrax(:) + integer(psb_ipk_) :: info + integer(psb_mpk_), optional, intent(in) :: pad + integer(psb_epk_), optional, intent(in) :: lb + + ! ...Local Variables + integer(psb_mpk_),allocatable :: tmp(:) + integer(psb_epk_) :: dim, lb_, lbi,ub_ + integer(psb_ipk_) :: iplen + integer(psb_ipk_) :: err_act,err + character(len=20) :: name + logical, parameter :: debug=.false. + + name='psb_r_m_m_rk1' + call psb_erractionsave(err_act) + info=psb_success_ + if (debug) write(psb_err_unit,*) 'reallocate D',len + + if (present(lb)) then + lb_ = lb + else + lb_ = 1 + endif + if ((len<0)) then + err=4025 + iplen = len + call psb_errpush(err,name, & + & i_err=(/iplen,izero,izero,izero,izero/),a_err='integer(psb_mpk_)') + goto 9999 + end if + ub_ = lb_ + len-1 + + if (allocated(rrax)) then + dim = size(rrax) + lbi = lbound(rrax,1) + If ((dim /= len).or.(lbi /= lb_)) Then + Allocate(tmp(lb_:ub_),stat=info) + if (info /= psb_success_) then + err=4025 + iplen = len + call psb_errpush(err,name, & + & i_err=(/iplen,izero,izero,izero,izero/),a_err='integer(psb_mpk_)') + goto 9999 + end if + tmp(lb_:lb_-1+min(len,dim))=rrax(lbi:lbi-1+min(len,dim)) + call psb_move_alloc(tmp,rrax,info) + End If + else + dim = 0 + Allocate(rrax(lb_:ub_),stat=info) + if (info /= psb_success_) then + err=4025 + iplen = len + call psb_errpush(err,name, & + & i_err=(/iplen,izero,izero,izero,izero/),a_err='integer(psb_mpk_)') + goto 9999 + end if + endif + if (present(pad)) then + rrax(lb_-1+dim+1:lb_-1+len) = pad + endif + call psb_erractionrestore(err_act) + return + +9999 continue + info = err + call psb_error_handler(err_act) + return + + End Subroutine psb_r_e_m_rk1 + + Subroutine psb_r_e_m_rk2(len1,len2,rrax,info,pad,lb1,lb2) + use psb_error_mod + ! ...Subroutine Arguments + integer(psb_epk_),Intent(in) :: len1,len2 + integer(psb_mpk_),allocatable :: rrax(:,:) + integer(psb_ipk_) :: info + integer(psb_mpk_), optional, intent(in) :: pad + integer(psb_epk_),Intent(in), optional :: lb1,lb2 + + ! ...Local Variables + + integer(psb_mpk_),allocatable :: tmp(:,:) + integer(psb_ipk_) :: err_act,err, iplen + integer(psb_epk_) :: dim,dim2,lb1_, lb2_, ub1_, ub2_,lbi1, lbi2 + character(len=20) :: name + + name='psb_r_e_m_rk2' + call psb_erractionsave(err_act) + info=psb_success_ + if (present(lb1)) then + lb1_ = lb1 + else + lb1_ = 1 + endif + if (present(lb2)) then + lb2_ = lb2 + else + lb2_ = 1 + endif + ub1_ = lb1_ + len1 -1 + ub2_ = lb2_ + len2 -1 + + if (len1 < 0) then + err=4025 + iplen = len1 + call psb_errpush(err,name, & + & i_err=(/iplen,izero,izero,izero,izero/),a_err='integer(psb_mpk_)') + goto 9999 + end if + if (len2 < 0) then + err=4025 + iplen = len2 + call psb_errpush(err,name, & + & i_err=(/iplen,izero,izero,izero,izero/),a_err='integer(psb_mpk_)') + goto 9999 + end if + + + if (allocated(rrax)) then + dim = size(rrax,1) + lbi1 = lbound(rrax,1) + dim2 = size(rrax,2) + lbi2 = lbound(rrax,2) + If ((dim /= len1).or.(dim2 /= len2).or.(lbi1 /= lb1_)& + & .or.(lbi2 /= lb2_)) Then + Allocate(tmp(lb1_:ub1_,lb2_:ub2_),stat=info) + if (info /= psb_success_) then + err=4025 + iplen = len1*len2 + call psb_errpush(err,name, & + & i_err=(/iplen,izero,izero,izero,izero/),a_err='integer(psb_mpk_)') + goto 9999 + end if + tmp(lb1_:lb1_-1+min(len1,dim),lb2_:lb2_-1+min(len2,dim2)) = & + & rrax(lbi1:lbi1-1+min(len1,dim),lbi2:lbi2-1+min(len2,dim2)) + call psb_move_alloc(tmp,rrax,info) + End If + else + dim = 0 + dim2 = 0 + Allocate(rrax(lb1_:ub1_,lb2_:ub2_),stat=info) + if (info /= psb_success_) then + err=4025 + iplen = len1*len2 + call psb_errpush(err,name, & + & i_err=(/iplen,izero,izero,izero,izero/),a_err='integer(psb_mpk_)') + goto 9999 + end if + endif + if (present(pad)) then + rrax(lb1_-1+dim+1:lb1_-1+len1,:) = pad + rrax(lb1_:lb1_-1+dim,lb2_-1+dim2+1:lb2_-1+len2) = pad + endif + call psb_erractionrestore(err_act) + return + +9999 continue + info = err + call psb_error_handler(err_act) + return + + End Subroutine psb_r_e_m_rk2 + + Subroutine psb_r_me_m_rk2(len1,len2,rrax,info,pad,lb1,lb2) + use psb_error_mod + ! ...Subroutine Arguments + integer(psb_mpk_),Intent(in) :: len1 + integer(psb_epk_),Intent(in) :: len2 + integer(psb_mpk_),allocatable :: rrax(:,:) + integer(psb_ipk_) :: info + integer(psb_mpk_), optional, intent(in) :: pad + integer(psb_mpk_),Intent(in), optional :: lb1,lb2 + + ! ...Local Variables + + integer(psb_mpk_),allocatable :: tmp(:,:) + integer(psb_ipk_) :: err_act,err, iplen + integer(psb_mpk_) :: dim,lb1_, lb2_, ub1_, ub2_,lbi1, lbi2 + integer(psb_epk_) :: dim2 + character(len=20) :: name + + name='psb_r_me_m_rk2' + call psb_erractionsave(err_act) + info=psb_success_ + if (present(lb1)) then + lb1_ = lb1 + else + lb1_ = 1 + endif + if (present(lb2)) then + lb2_ = lb2 + else + lb2_ = 1 + endif + ub1_ = lb1_ + len1 -1 + ub2_ = lb2_ + len2 -1 + + if (len1 < 0) then + err=4025 + iplen = len1 + call psb_errpush(err,name, & + & i_err=(/iplen,izero,izero,izero,izero/),a_err='integer(psb_mpk_)') + goto 9999 + end if + if (len2 < 0) then + err=4025 + iplen = len2 + call psb_errpush(err,name, & + & i_err=(/iplen,izero,izero,izero,izero/),a_err='integer(psb_mpk_)') + goto 9999 + end if + + + if (allocated(rrax)) then + dim = size(rrax,1) + lbi1 = lbound(rrax,1) + dim2 = size(rrax,2) + lbi2 = lbound(rrax,2) + If ((dim /= len1).or.(dim2 /= len2).or.(lbi1 /= lb1_)& + & .or.(lbi2 /= lb2_)) Then + Allocate(tmp(lb1_:ub1_,lb2_:ub2_),stat=info) + if (info /= psb_success_) then + err=4025 + iplen = len1*len2 + call psb_errpush(err,name, & + & i_err=(/iplen,izero,izero,izero,izero/),a_err='integer(psb_mpk_)') + goto 9999 + end if + tmp(lb1_:lb1_-1+min(len1,dim),lb2_:lb2_-1+min(len2,dim2)) = & + & rrax(lbi1:lbi1-1+min(len1,dim),lbi2:lbi2-1+min(len2,dim2)) + call psb_move_alloc(tmp,rrax,info) + End If + else + dim = 0 + dim2 = 0 + Allocate(rrax(lb1_:ub1_,lb2_:ub2_),stat=info) + if (info /= psb_success_) then + err=4025 + iplen = len1*len2 + call psb_errpush(err,name, & + & i_err=(/iplen,izero,izero,izero,izero/),a_err='integer(psb_mpk_)') + goto 9999 + end if + endif + if (present(pad)) then + rrax(lb1_-1+dim+1:lb1_-1+len1,:) = pad + rrax(lb1_:lb1_-1+dim,lb2_-1+dim2+1:lb2_-1+len2) = pad + endif + call psb_erractionrestore(err_act) + return + +9999 continue + info = err + call psb_error_handler(err_act) + return + + End Subroutine psb_r_me_m_rk2 + + Subroutine psb_r_em_m_rk2(len1,len2,rrax,info,pad,lb1,lb2) + use psb_error_mod + ! ...Subroutine Arguments + integer(psb_epk_),Intent(in) :: len1 + integer(psb_mpk_),Intent(in) :: len2 + integer(psb_mpk_),allocatable :: rrax(:,:) + integer(psb_ipk_) :: info + integer(psb_mpk_), optional, intent(in) :: pad + integer(psb_mpk_),Intent(in), optional :: lb1,lb2 + + ! ...Local Variables + + integer(psb_mpk_),allocatable :: tmp(:,:) + integer(psb_ipk_) :: err_act,err, iplen + integer(psb_mpk_) :: dim2,lb1_, lb2_, ub1_, ub2_,lbi1, lbi2 + integer(psb_epk_) :: dim + character(len=20) :: name + + name='psb_r_me_m_rk2' + call psb_erractionsave(err_act) + info=psb_success_ + if (present(lb1)) then + lb1_ = lb1 + else + lb1_ = 1 + endif + if (present(lb2)) then + lb2_ = lb2 + else + lb2_ = 1 + endif + ub1_ = lb1_ + len1 -1 + ub2_ = lb2_ + len2 -1 + + if (len1 < 0) then + err=4025 + iplen = len1 + call psb_errpush(err,name, & + & i_err=(/iplen,izero,izero,izero,izero/),a_err='integer(psb_mpk_)') + goto 9999 + end if + if (len2 < 0) then + err=4025 + iplen = len2 + call psb_errpush(err,name, & + & i_err=(/iplen,izero,izero,izero,izero/),a_err='integer(psb_mpk_)') + goto 9999 + end if + + + if (allocated(rrax)) then + dim = size(rrax,1) + lbi1 = lbound(rrax,1) + dim2 = size(rrax,2) + lbi2 = lbound(rrax,2) + If ((dim /= len1).or.(dim2 /= len2).or.(lbi1 /= lb1_)& + & .or.(lbi2 /= lb2_)) Then + Allocate(tmp(lb1_:ub1_,lb2_:ub2_),stat=info) + if (info /= psb_success_) then + err=4025 + iplen = len1*len2 + call psb_errpush(err,name, & + & i_err=(/iplen,izero,izero,izero,izero/),a_err='integer(psb_mpk_)') + goto 9999 + end if + tmp(lb1_:lb1_-1+min(len1,dim),lb2_:lb2_-1+min(len2,dim2)) = & + & rrax(lbi1:lbi1-1+min(len1,dim),lbi2:lbi2-1+min(len2,dim2)) + call psb_move_alloc(tmp,rrax,info) + End If + else + dim = 0 + dim2 = 0 + Allocate(rrax(lb1_:ub1_,lb2_:ub2_),stat=info) + if (info /= psb_success_) then + err=4025 + iplen = len1*len2 + call psb_errpush(err,name, & + & i_err=(/iplen,izero,izero,izero,izero/),a_err='integer(psb_mpk_)') + goto 9999 + end if + endif + if (present(pad)) then + rrax(lb1_-1+dim+1:lb1_-1+len1,:) = pad + rrax(lb1_:lb1_-1+dim,lb2_-1+dim2+1:lb2_-1+len2) = pad + endif + call psb_erractionrestore(err_act) + return + +9999 continue + info = err + call psb_error_handler(err_act) + return + + End Subroutine psb_r_em_m_rk2 + + Subroutine psb_r_m_2_m_rk1(len,rrax,y,info,pad) + use psb_error_mod + ! ...Subroutine Arguments + + integer(psb_mpk_),Intent(in) :: len + integer(psb_mpk_),allocatable, intent(inout) :: rrax(:),y(:) + integer(psb_ipk_) :: info + integer(psb_mpk_), optional, intent(in) :: pad + character(len=20) :: name + integer(psb_ipk_) :: err_act, err + + name='psb_r_m_2_m_rk1' + call psb_erractionsave(err_act) + info=psb_success_ + + if(psb_get_errstatus() /= 0) then + info=psb_err_from_subroutine_ + goto 9999 + end if + + call psb_realloc(len,rrax,info,pad=pad) + if (info /= psb_success_) then + err=4000 + call psb_errpush(err,name) + goto 9999 + end if + call psb_realloc(len,y,info,pad=pad) + if (info /= psb_success_) then + err=4000 + call psb_errpush(err,name) + goto 9999 + end if + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + + End Subroutine psb_r_m_2_m_rk1 + + Subroutine psb_r_e_2_m_rk1(len,rrax,y,info,pad) + use psb_error_mod + ! ...Subroutine Arguments + + integer(psb_epk_),Intent(in) :: len + integer(psb_mpk_),allocatable, intent(inout) :: rrax(:),y(:) + integer(psb_ipk_) :: info + integer(psb_mpk_), optional, intent(in) :: pad + character(len=20) :: name + integer(psb_ipk_) :: err_act, err + + name='psb_r_m_2_m_rk1' + call psb_erractionsave(err_act) + info=psb_success_ + + if(psb_get_errstatus() /= 0) then + info=psb_err_from_subroutine_ + goto 9999 + end if + + call psb_realloc(len,rrax,info,pad=pad) + if (info /= psb_success_) then + err=4000 + call psb_errpush(err,name) + goto 9999 + end if + call psb_realloc(len,y,info,pad=pad) + if (info /= psb_success_) then + err=4000 + call psb_errpush(err,name) + goto 9999 + end if + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + + End Subroutine psb_r_e_2_m_rk1 + + + + subroutine psb_ab_cpy_m_rk1(vin,vout,info) + use psb_error_mod + + ! ...Subroutine Arguments + integer(psb_mpk_), allocatable, intent(in) :: vin(:) + integer(psb_mpk_), allocatable, intent(out) :: vout(:) + integer(psb_ipk_) :: info + ! ...Local Variables + + integer(psb_ipk_) :: isz,err_act,lb + character(len=20) :: name, char_err + logical, parameter :: debug=.false. + + name='psb_ab_cpy_m_rk1' + call psb_erractionsave(err_act) + info=psb_success_ + if(psb_get_errstatus() /= 0) then + info=psb_err_from_subroutine_ + goto 9999 + end if + + if (allocated(vin)) then + isz = size(vin) + lb = lbound(vin,1) + call psb_realloc(isz,vout,info,lb=lb) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + char_err='psb_realloc' + call psb_errpush(info,name,a_err=char_err) + goto 9999 + else + vout(:) = vin(:) + endif + endif + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + + end subroutine psb_ab_cpy_m_rk1 + + subroutine psb_ab_cpy_m_rk2(vin,vout,info) + use psb_error_mod + + ! ...Subroutine Arguments + integer(psb_mpk_), allocatable, intent(in) :: vin(:,:) + integer(psb_mpk_), allocatable, intent(out) :: vout(:,:) + integer(psb_ipk_) :: info + ! ...Local Variables + + integer(psb_ipk_) :: isz1, isz2,err_act, lb1, lb2 + character(len=20) :: name, char_err + logical, parameter :: debug=.false. + + name='psb_ab_cpy_m_rk2' + call psb_erractionsave(err_act) + info=psb_success_ + if(psb_get_errstatus() /= 0) then + info=psb_err_from_subroutine_ + goto 9999 + end if + + if (allocated(vin)) then + isz1 = size(vin,1) + isz2 = size(vin,2) + lb1 = lbound(vin,1) + lb2 = lbound(vin,2) + call psb_realloc(isz1,isz2,vout,info,lb1=lb1,lb2=lb2) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + char_err='psb_realloc' + call psb_errpush(info,name,a_err=char_err) + goto 9999 + else + vout(:,:) = vin(:,:) + endif + endif + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + + end subroutine psb_ab_cpy_m_rk2 + + + subroutine psb_cpy_m_rk1(vin,vout,info) + use psb_error_mod + + ! ...Subroutine Arguments + integer(psb_mpk_), intent(in) :: vin(:) + integer(psb_mpk_), allocatable, intent(out) :: vout(:) + integer(psb_ipk_) :: info + ! ...Local Variables + + integer(psb_ipk_) :: isz,err_act,lb + character(len=20) :: name, char_err + logical, parameter :: debug=.false. + + name='psb_cpy_m_rk1' + call psb_erractionsave(err_act) + info=psb_success_ + if(psb_get_errstatus() /= 0) then + info=psb_err_from_subroutine_ + goto 9999 + end if + isz = size(vin) + lb = lbound(vin,1) + call psb_realloc(isz,vout,info,lb=lb) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + char_err='psb_realloc' + call psb_errpush(info,name,a_err=char_err) + goto 9999 + else + vout(:) = vin(:) + endif + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + + end subroutine psb_cpy_m_rk1 + + subroutine psb_cpy_m_rk2(vin,vout,info) + use psb_error_mod + + ! ...Subroutine Arguments + integer(psb_mpk_), intent(in) :: vin(:,:) + integer(psb_mpk_), allocatable, intent(out) :: vout(:,:) + integer(psb_ipk_) :: info + ! ...Local Variables + + integer(psb_ipk_) :: isz1, isz2,err_act, lb1, lb2 + character(len=20) :: name, char_err + logical, parameter :: debug=.false. + + name='psb_safe_cpy' + call psb_erractionsave(err_act) + info=psb_success_ + if(psb_get_errstatus() /= 0) then + info=psb_err_from_subroutine_ + goto 9999 + end if + + isz1 = size(vin,1) + isz2 = size(vin,2) + lb1 = lbound(vin,1) + lb2 = lbound(vin,2) + call psb_realloc(isz1,isz2,vout,info,lb1=lb1,lb2=lb2) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + char_err='psb_realloc' + call psb_errpush(info,name,a_err=char_err) + goto 9999 + else + vout(:,:) = vin(:,:) + endif + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + + end subroutine psb_cpy_m_rk2 + + + function psb_size_m_rk1(vin) result(val) + integer(psb_epk_) :: val + integer(psb_mpk_), allocatable, intent(in) :: vin(:) + + if (.not.allocated(vin)) then + val = 0 + else + val = size(vin) + end if + end function psb_size_m_rk1 + + + function psb_size_m_rk2(vin,dim) result(val) + integer(psb_epk_) :: val + integer(psb_mpk_), allocatable, intent(in) :: vin(:,:) + integer(psb_ipk_), optional :: dim + integer(psb_ipk_) :: dim_ + + + if (.not.allocated(vin)) then + val = 0 + else + if (present(dim)) then + dim_= dim + val = size(vin,dim=dim_) + else + val = size(vin) + end if + end if + end function psb_size_m_rk2 + + Subroutine psb_ensure_m_sz_m_rk1(len,v,info,pad,addsz,newsz) + use psb_error_mod + + ! ...Subroutine Arguments + integer(psb_mpk_),Intent(in) :: len + integer(psb_mpk_),allocatable, intent(inout) :: v(:) + integer(psb_ipk_) :: info + integer(psb_mpk_), optional, intent(in) :: addsz,newsz + integer(psb_mpk_), optional, intent(in) :: pad + ! ...Local Variables + character(len=20) :: name + logical, parameter :: debug=.false. + integer(psb_ipk_) :: err_act + integer(psb_mpk_) :: isz + + name='psb_ensure_m_sz_m_rk1' + call psb_erractionsave(err_act) + info = psb_success_ + + if (psb_get_errstatus() /= 0) then + info=psb_err_from_subroutine_ + goto 9999 + end if + + If (len > psb_size(v)) Then + if (present(newsz)) then + isz = (max(len+1,newsz)) + else + if (present(addsz)) then + isz = len+max(1,addsz) + else + isz = max(len+10, int(1.25*len)) + endif + endif + + call psb_realloc(isz,v,info,pad=pad) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='psb_realloc') + goto 9999 + End If + end If + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + + + End Subroutine psb_ensure_m_sz_m_rk1 + + Subroutine psb_ensure_e_sz_m_rk1(len,v,info,pad,addsz,newsz) + use psb_error_mod + + ! ...Subroutine Arguments + integer(psb_epk_),Intent(in) :: len + integer(psb_mpk_),allocatable, intent(inout) :: v(:) + integer(psb_ipk_) :: info + integer(psb_epk_), optional, intent(in) :: addsz,newsz + integer(psb_mpk_), optional, intent(in) :: pad + ! ...Local Variables + character(len=20) :: name + logical, parameter :: debug=.false. + integer(psb_ipk_) :: err_act + integer(psb_epk_) :: isz + + name='psb_ensure_m_sz_m_rk1' + call psb_erractionsave(err_act) + info = psb_success_ + + if (psb_get_errstatus() /= 0) then + info=psb_err_from_subroutine_ + goto 9999 + end if + + If (len > psb_size(v)) Then + if (present(newsz)) then + isz = (max(len+1,newsz)) + else + if (present(addsz)) then + isz = len+max(1,addsz) + else + isz = max(len+10, int(1.25*len)) + endif + endif + + call psb_realloc(isz,v,info,pad=pad) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='psb_realloc') + goto 9999 + End If + end If + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + + + End Subroutine psb_ensure_e_sz_m_rk1 + + Subroutine psb_move_alloc_m_rk1(vin,vout,info) + use psb_error_mod + integer(psb_mpk_), allocatable, intent(inout) :: vin(:),vout(:) + integer(psb_ipk_), intent(out) :: info + ! + ! + info=psb_success_ + call move_alloc(vin,vout) + + end Subroutine psb_move_alloc_m_rk1 + + Subroutine psb_move_alloc_m_rk2(vin,vout,info) + use psb_error_mod + integer(psb_mpk_), allocatable, intent(inout) :: vin(:,:),vout(:,:) + integer(psb_ipk_), intent(out) :: info + ! + ! + info=psb_success_ + + call move_alloc(vin,vout) + + end Subroutine psb_move_alloc_m_rk2 + +end module psb_m_realloc_mod diff --git a/base/modules/basics/psb_s_realloc_mod.F90 b/base/modules/basics/psb_s_realloc_mod.F90 new file mode 100644 index 00000000..4a482d2d --- /dev/null +++ b/base/modules/basics/psb_s_realloc_mod.F90 @@ -0,0 +1,1027 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! 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. +! +! +module psb_s_realloc_mod + use psb_const_mod + + implicit none + + ! + ! psb_realloc will reallocate the input array to have exactly + ! the size specified, possibly shortening it. + ! + Interface psb_realloc + module procedure psb_r_m_s_rk1 + module procedure psb_r_m_s_rk2 + module procedure psb_r_e_s_rk1 + module procedure psb_r_e_s_rk2 + module procedure psb_r_me_s_rk2 + module procedure psb_r_em_s_rk2 + + module procedure psb_r_m_2_s_rk1 + module procedure psb_r_e_2_s_rk1 + + end Interface psb_realloc + + interface psb_move_alloc + module procedure psb_move_alloc_s_rk1, psb_move_alloc_s_rk2 + end interface psb_move_alloc + + Interface psb_safe_ab_cpy + module procedure psb_ab_cpy_s_rk1, psb_ab_cpy_s_rk2 + end Interface psb_safe_ab_cpy + + Interface psb_safe_cpy + module procedure psb_cpy_s_rk1, psb_cpy_s_rk2 + end Interface psb_safe_cpy + + ! + ! psb_ensure_size will reallocate the input array if necessary + ! to guarantee that its size is at least as large as the + ! value required, usually with some room to spare. + ! + interface psb_ensure_size + module procedure psb_ensure_m_sz_s_rk1, psb_ensure_e_sz_s_rk1 + end Interface psb_ensure_size + + ! + ! psb_size returns 0 if argument is not allocated. + ! + interface psb_size + module procedure psb_size_s_rk1, psb_size_s_rk2 + end interface psb_size + + +Contains + + Subroutine psb_r_m_s_rk1(len,rrax,info,pad,lb) + use psb_error_mod + + ! ...Subroutine Arguments + integer(psb_mpk_),Intent(in) :: len + real(psb_spk_), allocatable, intent(inout) :: rrax(:) + integer(psb_ipk_) :: info + real(psb_spk_), optional, intent(in) :: pad + integer(psb_mpk_), optional, intent(in) :: lb + + ! ...Local Variables + real(psb_spk_),allocatable :: tmp(:) + integer(psb_mpk_) :: dim, lb_, lbi,ub_ + integer(psb_ipk_) :: err_act,err + character(len=20) :: name + logical, parameter :: debug=.false. + + name='psb_r_m_s_rk1' + call psb_erractionsave(err_act) + info=psb_success_ + if (debug) write(psb_err_unit,*) 'reallocate D',len + + if (present(lb)) then + lb_ = lb + else + lb_ = 1 + endif + if ((len<0)) then + err=4025 + call psb_errpush(err,name, & + & i_err=(/len,izero,izero,izero,izero/),a_err='real(psb_spk_)') + goto 9999 + end if + ub_ = lb_ + len-1 + + if (allocated(rrax)) then + dim = size(rrax) + lbi = lbound(rrax,1) + If ((dim /= len).or.(lbi /= lb_)) Then + Allocate(tmp(lb_:ub_),stat=info) + if (info /= psb_success_) then + err=4025 + call psb_errpush(err,name, & + & i_err=(/len,izero,izero,izero,izero/),a_err='real(psb_spk_)') + goto 9999 + end if + tmp(lb_:lb_-1+min(len,dim))=rrax(lbi:lbi-1+min(len,dim)) + call psb_move_alloc(tmp,rrax,info) + End If + else + dim = 0 + Allocate(rrax(lb_:ub_),stat=info) + if (info /= psb_success_) then + err=4025 + call psb_errpush(err,name, & + & i_err=(/len,izero,izero,izero,izero/),a_err='real(psb_spk_)') + goto 9999 + end if + endif + if (present(pad)) then + rrax(lb_-1+dim+1:lb_-1+len) = pad + endif + call psb_erractionrestore(err_act) + return + +9999 continue + info = err + call psb_error_handler(err_act) + return + + End Subroutine psb_r_m_s_rk1 + + Subroutine psb_r_m_s_rk2(len1,len2,rrax,info,pad,lb1,lb2) + use psb_error_mod + ! ...Subroutine Arguments + integer(psb_mpk_),Intent(in) :: len1,len2 + real(psb_spk_),allocatable :: rrax(:,:) + integer(psb_ipk_) :: info + real(psb_spk_), optional, intent(in) :: pad + integer(psb_mpk_),Intent(in), optional :: lb1,lb2 + + ! ...Local Variables + + real(psb_spk_),allocatable :: tmp(:,:) + integer(psb_ipk_) :: err_act,err + integer(psb_mpk_) :: dim,dim2,lb1_, lb2_, ub1_, ub2_,lbi1, lbi2 + character(len=20) :: name + + name='psb_r_m_s_rk2' + call psb_erractionsave(err_act) + info=psb_success_ + if (present(lb1)) then + lb1_ = lb1 + else + lb1_ = 1 + endif + if (present(lb2)) then + lb2_ = lb2 + else + lb2_ = 1 + endif + ub1_ = lb1_ + len1 -1 + ub2_ = lb2_ + len2 -1 + + if (len1 < 0) then + err=4025 + call psb_errpush(err,name, & + & i_err=(/len1,izero,izero,izero,izero/),a_err='real(psb_spk_)') + goto 9999 + end if + if (len2 < 0) then + err=4025 + call psb_errpush(err,name, & + & i_err=(/len2,izero,izero,izero,izero/),a_err='real(psb_spk_)') + goto 9999 + end if + + + if (allocated(rrax)) then + dim = size(rrax,1) + lbi1 = lbound(rrax,1) + dim2 = size(rrax,2) + lbi2 = lbound(rrax,2) + If ((dim /= len1).or.(dim2 /= len2).or.(lbi1 /= lb1_)& + & .or.(lbi2 /= lb2_)) Then + Allocate(tmp(lb1_:ub1_,lb2_:ub2_),stat=info) + if (info /= psb_success_) then + err=4025 + call psb_errpush(err,name, & + & i_err=(/len1*len2,izero,izero,izero,izero/),a_err='real(psb_spk_)') + goto 9999 + end if + tmp(lb1_:lb1_-1+min(len1,dim),lb2_:lb2_-1+min(len2,dim2)) = & + & rrax(lbi1:lbi1-1+min(len1,dim),lbi2:lbi2-1+min(len2,dim2)) + call psb_move_alloc(tmp,rrax,info) + End If + else + dim = 0 + dim2 = 0 + Allocate(rrax(lb1_:ub1_,lb2_:ub2_),stat=info) + if (info /= psb_success_) then + err=4025 + call psb_errpush(err,name, & + & i_err=(/len1*len2,izero,izero,izero,izero/),a_err='real(psb_spk_)') + goto 9999 + end if + endif + if (present(pad)) then + rrax(lb1_-1+dim+1:lb1_-1+len1,:) = pad + rrax(lb1_:lb1_-1+dim,lb2_-1+dim2+1:lb2_-1+len2) = pad + endif + call psb_erractionrestore(err_act) + return + +9999 continue + info = err + call psb_error_handler(err_act) + return + + End Subroutine psb_r_m_s_rk2 + + + Subroutine psb_r_e_s_rk1(len,rrax,info,pad,lb) + use psb_error_mod + + ! ...Subroutine Arguments + integer(psb_epk_),Intent(in) :: len + real(psb_spk_), allocatable, intent(inout) :: rrax(:) + integer(psb_ipk_) :: info + real(psb_spk_), optional, intent(in) :: pad + integer(psb_epk_), optional, intent(in) :: lb + + ! ...Local Variables + real(psb_spk_),allocatable :: tmp(:) + integer(psb_epk_) :: dim, lb_, lbi,ub_ + integer(psb_ipk_) :: iplen + integer(psb_ipk_) :: err_act,err + character(len=20) :: name + logical, parameter :: debug=.false. + + name='psb_r_m_s_rk1' + call psb_erractionsave(err_act) + info=psb_success_ + if (debug) write(psb_err_unit,*) 'reallocate D',len + + if (present(lb)) then + lb_ = lb + else + lb_ = 1 + endif + if ((len<0)) then + err=4025 + iplen = len + call psb_errpush(err,name, & + & i_err=(/iplen,izero,izero,izero,izero/),a_err='real(psb_spk_)') + goto 9999 + end if + ub_ = lb_ + len-1 + + if (allocated(rrax)) then + dim = size(rrax) + lbi = lbound(rrax,1) + If ((dim /= len).or.(lbi /= lb_)) Then + Allocate(tmp(lb_:ub_),stat=info) + if (info /= psb_success_) then + err=4025 + iplen = len + call psb_errpush(err,name, & + & i_err=(/iplen,izero,izero,izero,izero/),a_err='real(psb_spk_)') + goto 9999 + end if + tmp(lb_:lb_-1+min(len,dim))=rrax(lbi:lbi-1+min(len,dim)) + call psb_move_alloc(tmp,rrax,info) + End If + else + dim = 0 + Allocate(rrax(lb_:ub_),stat=info) + if (info /= psb_success_) then + err=4025 + iplen = len + call psb_errpush(err,name, & + & i_err=(/iplen,izero,izero,izero,izero/),a_err='real(psb_spk_)') + goto 9999 + end if + endif + if (present(pad)) then + rrax(lb_-1+dim+1:lb_-1+len) = pad + endif + call psb_erractionrestore(err_act) + return + +9999 continue + info = err + call psb_error_handler(err_act) + return + + End Subroutine psb_r_e_s_rk1 + + Subroutine psb_r_e_s_rk2(len1,len2,rrax,info,pad,lb1,lb2) + use psb_error_mod + ! ...Subroutine Arguments + integer(psb_epk_),Intent(in) :: len1,len2 + real(psb_spk_),allocatable :: rrax(:,:) + integer(psb_ipk_) :: info + real(psb_spk_), optional, intent(in) :: pad + integer(psb_epk_),Intent(in), optional :: lb1,lb2 + + ! ...Local Variables + + real(psb_spk_),allocatable :: tmp(:,:) + integer(psb_ipk_) :: err_act,err, iplen + integer(psb_epk_) :: dim,dim2,lb1_, lb2_, ub1_, ub2_,lbi1, lbi2 + character(len=20) :: name + + name='psb_r_e_s_rk2' + call psb_erractionsave(err_act) + info=psb_success_ + if (present(lb1)) then + lb1_ = lb1 + else + lb1_ = 1 + endif + if (present(lb2)) then + lb2_ = lb2 + else + lb2_ = 1 + endif + ub1_ = lb1_ + len1 -1 + ub2_ = lb2_ + len2 -1 + + if (len1 < 0) then + err=4025 + iplen = len1 + call psb_errpush(err,name, & + & i_err=(/iplen,izero,izero,izero,izero/),a_err='real(psb_spk_)') + goto 9999 + end if + if (len2 < 0) then + err=4025 + iplen = len2 + call psb_errpush(err,name, & + & i_err=(/iplen,izero,izero,izero,izero/),a_err='real(psb_spk_)') + goto 9999 + end if + + + if (allocated(rrax)) then + dim = size(rrax,1) + lbi1 = lbound(rrax,1) + dim2 = size(rrax,2) + lbi2 = lbound(rrax,2) + If ((dim /= len1).or.(dim2 /= len2).or.(lbi1 /= lb1_)& + & .or.(lbi2 /= lb2_)) Then + Allocate(tmp(lb1_:ub1_,lb2_:ub2_),stat=info) + if (info /= psb_success_) then + err=4025 + iplen = len1*len2 + call psb_errpush(err,name, & + & i_err=(/iplen,izero,izero,izero,izero/),a_err='real(psb_spk_)') + goto 9999 + end if + tmp(lb1_:lb1_-1+min(len1,dim),lb2_:lb2_-1+min(len2,dim2)) = & + & rrax(lbi1:lbi1-1+min(len1,dim),lbi2:lbi2-1+min(len2,dim2)) + call psb_move_alloc(tmp,rrax,info) + End If + else + dim = 0 + dim2 = 0 + Allocate(rrax(lb1_:ub1_,lb2_:ub2_),stat=info) + if (info /= psb_success_) then + err=4025 + iplen = len1*len2 + call psb_errpush(err,name, & + & i_err=(/iplen,izero,izero,izero,izero/),a_err='real(psb_spk_)') + goto 9999 + end if + endif + if (present(pad)) then + rrax(lb1_-1+dim+1:lb1_-1+len1,:) = pad + rrax(lb1_:lb1_-1+dim,lb2_-1+dim2+1:lb2_-1+len2) = pad + endif + call psb_erractionrestore(err_act) + return + +9999 continue + info = err + call psb_error_handler(err_act) + return + + End Subroutine psb_r_e_s_rk2 + + Subroutine psb_r_me_s_rk2(len1,len2,rrax,info,pad,lb1,lb2) + use psb_error_mod + ! ...Subroutine Arguments + integer(psb_mpk_),Intent(in) :: len1 + integer(psb_epk_),Intent(in) :: len2 + real(psb_spk_),allocatable :: rrax(:,:) + integer(psb_ipk_) :: info + real(psb_spk_), optional, intent(in) :: pad + integer(psb_mpk_),Intent(in), optional :: lb1,lb2 + + ! ...Local Variables + + real(psb_spk_),allocatable :: tmp(:,:) + integer(psb_ipk_) :: err_act,err, iplen + integer(psb_mpk_) :: dim,lb1_, lb2_, ub1_, ub2_,lbi1, lbi2 + integer(psb_epk_) :: dim2 + character(len=20) :: name + + name='psb_r_me_s_rk2' + call psb_erractionsave(err_act) + info=psb_success_ + if (present(lb1)) then + lb1_ = lb1 + else + lb1_ = 1 + endif + if (present(lb2)) then + lb2_ = lb2 + else + lb2_ = 1 + endif + ub1_ = lb1_ + len1 -1 + ub2_ = lb2_ + len2 -1 + + if (len1 < 0) then + err=4025 + iplen = len1 + call psb_errpush(err,name, & + & i_err=(/iplen,izero,izero,izero,izero/),a_err='real(psb_spk_)') + goto 9999 + end if + if (len2 < 0) then + err=4025 + iplen = len2 + call psb_errpush(err,name, & + & i_err=(/iplen,izero,izero,izero,izero/),a_err='real(psb_spk_)') + goto 9999 + end if + + + if (allocated(rrax)) then + dim = size(rrax,1) + lbi1 = lbound(rrax,1) + dim2 = size(rrax,2) + lbi2 = lbound(rrax,2) + If ((dim /= len1).or.(dim2 /= len2).or.(lbi1 /= lb1_)& + & .or.(lbi2 /= lb2_)) Then + Allocate(tmp(lb1_:ub1_,lb2_:ub2_),stat=info) + if (info /= psb_success_) then + err=4025 + iplen = len1*len2 + call psb_errpush(err,name, & + & i_err=(/iplen,izero,izero,izero,izero/),a_err='real(psb_spk_)') + goto 9999 + end if + tmp(lb1_:lb1_-1+min(len1,dim),lb2_:lb2_-1+min(len2,dim2)) = & + & rrax(lbi1:lbi1-1+min(len1,dim),lbi2:lbi2-1+min(len2,dim2)) + call psb_move_alloc(tmp,rrax,info) + End If + else + dim = 0 + dim2 = 0 + Allocate(rrax(lb1_:ub1_,lb2_:ub2_),stat=info) + if (info /= psb_success_) then + err=4025 + iplen = len1*len2 + call psb_errpush(err,name, & + & i_err=(/iplen,izero,izero,izero,izero/),a_err='real(psb_spk_)') + goto 9999 + end if + endif + if (present(pad)) then + rrax(lb1_-1+dim+1:lb1_-1+len1,:) = pad + rrax(lb1_:lb1_-1+dim,lb2_-1+dim2+1:lb2_-1+len2) = pad + endif + call psb_erractionrestore(err_act) + return + +9999 continue + info = err + call psb_error_handler(err_act) + return + + End Subroutine psb_r_me_s_rk2 + + Subroutine psb_r_em_s_rk2(len1,len2,rrax,info,pad,lb1,lb2) + use psb_error_mod + ! ...Subroutine Arguments + integer(psb_epk_),Intent(in) :: len1 + integer(psb_mpk_),Intent(in) :: len2 + real(psb_spk_),allocatable :: rrax(:,:) + integer(psb_ipk_) :: info + real(psb_spk_), optional, intent(in) :: pad + integer(psb_mpk_),Intent(in), optional :: lb1,lb2 + + ! ...Local Variables + + real(psb_spk_),allocatable :: tmp(:,:) + integer(psb_ipk_) :: err_act,err, iplen + integer(psb_mpk_) :: dim2,lb1_, lb2_, ub1_, ub2_,lbi1, lbi2 + integer(psb_epk_) :: dim + character(len=20) :: name + + name='psb_r_me_s_rk2' + call psb_erractionsave(err_act) + info=psb_success_ + if (present(lb1)) then + lb1_ = lb1 + else + lb1_ = 1 + endif + if (present(lb2)) then + lb2_ = lb2 + else + lb2_ = 1 + endif + ub1_ = lb1_ + len1 -1 + ub2_ = lb2_ + len2 -1 + + if (len1 < 0) then + err=4025 + iplen = len1 + call psb_errpush(err,name, & + & i_err=(/iplen,izero,izero,izero,izero/),a_err='real(psb_spk_)') + goto 9999 + end if + if (len2 < 0) then + err=4025 + iplen = len2 + call psb_errpush(err,name, & + & i_err=(/iplen,izero,izero,izero,izero/),a_err='real(psb_spk_)') + goto 9999 + end if + + + if (allocated(rrax)) then + dim = size(rrax,1) + lbi1 = lbound(rrax,1) + dim2 = size(rrax,2) + lbi2 = lbound(rrax,2) + If ((dim /= len1).or.(dim2 /= len2).or.(lbi1 /= lb1_)& + & .or.(lbi2 /= lb2_)) Then + Allocate(tmp(lb1_:ub1_,lb2_:ub2_),stat=info) + if (info /= psb_success_) then + err=4025 + iplen = len1*len2 + call psb_errpush(err,name, & + & i_err=(/iplen,izero,izero,izero,izero/),a_err='real(psb_spk_)') + goto 9999 + end if + tmp(lb1_:lb1_-1+min(len1,dim),lb2_:lb2_-1+min(len2,dim2)) = & + & rrax(lbi1:lbi1-1+min(len1,dim),lbi2:lbi2-1+min(len2,dim2)) + call psb_move_alloc(tmp,rrax,info) + End If + else + dim = 0 + dim2 = 0 + Allocate(rrax(lb1_:ub1_,lb2_:ub2_),stat=info) + if (info /= psb_success_) then + err=4025 + iplen = len1*len2 + call psb_errpush(err,name, & + & i_err=(/iplen,izero,izero,izero,izero/),a_err='real(psb_spk_)') + goto 9999 + end if + endif + if (present(pad)) then + rrax(lb1_-1+dim+1:lb1_-1+len1,:) = pad + rrax(lb1_:lb1_-1+dim,lb2_-1+dim2+1:lb2_-1+len2) = pad + endif + call psb_erractionrestore(err_act) + return + +9999 continue + info = err + call psb_error_handler(err_act) + return + + End Subroutine psb_r_em_s_rk2 + + Subroutine psb_r_m_2_s_rk1(len,rrax,y,info,pad) + use psb_error_mod + ! ...Subroutine Arguments + + integer(psb_mpk_),Intent(in) :: len + real(psb_spk_),allocatable, intent(inout) :: rrax(:),y(:) + integer(psb_ipk_) :: info + real(psb_spk_), optional, intent(in) :: pad + character(len=20) :: name + integer(psb_ipk_) :: err_act, err + + name='psb_r_m_2_s_rk1' + call psb_erractionsave(err_act) + info=psb_success_ + + if(psb_get_errstatus() /= 0) then + info=psb_err_from_subroutine_ + goto 9999 + end if + + call psb_realloc(len,rrax,info,pad=pad) + if (info /= psb_success_) then + err=4000 + call psb_errpush(err,name) + goto 9999 + end if + call psb_realloc(len,y,info,pad=pad) + if (info /= psb_success_) then + err=4000 + call psb_errpush(err,name) + goto 9999 + end if + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + + End Subroutine psb_r_m_2_s_rk1 + + Subroutine psb_r_e_2_s_rk1(len,rrax,y,info,pad) + use psb_error_mod + ! ...Subroutine Arguments + + integer(psb_epk_),Intent(in) :: len + real(psb_spk_),allocatable, intent(inout) :: rrax(:),y(:) + integer(psb_ipk_) :: info + real(psb_spk_), optional, intent(in) :: pad + character(len=20) :: name + integer(psb_ipk_) :: err_act, err + + name='psb_r_m_2_s_rk1' + call psb_erractionsave(err_act) + info=psb_success_ + + if(psb_get_errstatus() /= 0) then + info=psb_err_from_subroutine_ + goto 9999 + end if + + call psb_realloc(len,rrax,info,pad=pad) + if (info /= psb_success_) then + err=4000 + call psb_errpush(err,name) + goto 9999 + end if + call psb_realloc(len,y,info,pad=pad) + if (info /= psb_success_) then + err=4000 + call psb_errpush(err,name) + goto 9999 + end if + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + + End Subroutine psb_r_e_2_s_rk1 + + + + subroutine psb_ab_cpy_s_rk1(vin,vout,info) + use psb_error_mod + + ! ...Subroutine Arguments + real(psb_spk_), allocatable, intent(in) :: vin(:) + real(psb_spk_), allocatable, intent(out) :: vout(:) + integer(psb_ipk_) :: info + ! ...Local Variables + + integer(psb_ipk_) :: isz,err_act,lb + character(len=20) :: name, char_err + logical, parameter :: debug=.false. + + name='psb_ab_cpy_s_rk1' + call psb_erractionsave(err_act) + info=psb_success_ + if(psb_get_errstatus() /= 0) then + info=psb_err_from_subroutine_ + goto 9999 + end if + + if (allocated(vin)) then + isz = size(vin) + lb = lbound(vin,1) + call psb_realloc(isz,vout,info,lb=lb) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + char_err='psb_realloc' + call psb_errpush(info,name,a_err=char_err) + goto 9999 + else + vout(:) = vin(:) + endif + endif + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + + end subroutine psb_ab_cpy_s_rk1 + + subroutine psb_ab_cpy_s_rk2(vin,vout,info) + use psb_error_mod + + ! ...Subroutine Arguments + real(psb_spk_), allocatable, intent(in) :: vin(:,:) + real(psb_spk_), allocatable, intent(out) :: vout(:,:) + integer(psb_ipk_) :: info + ! ...Local Variables + + integer(psb_ipk_) :: isz1, isz2,err_act, lb1, lb2 + character(len=20) :: name, char_err + logical, parameter :: debug=.false. + + name='psb_ab_cpy_s_rk2' + call psb_erractionsave(err_act) + info=psb_success_ + if(psb_get_errstatus() /= 0) then + info=psb_err_from_subroutine_ + goto 9999 + end if + + if (allocated(vin)) then + isz1 = size(vin,1) + isz2 = size(vin,2) + lb1 = lbound(vin,1) + lb2 = lbound(vin,2) + call psb_realloc(isz1,isz2,vout,info,lb1=lb1,lb2=lb2) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + char_err='psb_realloc' + call psb_errpush(info,name,a_err=char_err) + goto 9999 + else + vout(:,:) = vin(:,:) + endif + endif + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + + end subroutine psb_ab_cpy_s_rk2 + + + subroutine psb_cpy_s_rk1(vin,vout,info) + use psb_error_mod + + ! ...Subroutine Arguments + real(psb_spk_), intent(in) :: vin(:) + real(psb_spk_), allocatable, intent(out) :: vout(:) + integer(psb_ipk_) :: info + ! ...Local Variables + + integer(psb_ipk_) :: isz,err_act,lb + character(len=20) :: name, char_err + logical, parameter :: debug=.false. + + name='psb_cpy_s_rk1' + call psb_erractionsave(err_act) + info=psb_success_ + if(psb_get_errstatus() /= 0) then + info=psb_err_from_subroutine_ + goto 9999 + end if + isz = size(vin) + lb = lbound(vin,1) + call psb_realloc(isz,vout,info,lb=lb) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + char_err='psb_realloc' + call psb_errpush(info,name,a_err=char_err) + goto 9999 + else + vout(:) = vin(:) + endif + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + + end subroutine psb_cpy_s_rk1 + + subroutine psb_cpy_s_rk2(vin,vout,info) + use psb_error_mod + + ! ...Subroutine Arguments + real(psb_spk_), intent(in) :: vin(:,:) + real(psb_spk_), allocatable, intent(out) :: vout(:,:) + integer(psb_ipk_) :: info + ! ...Local Variables + + integer(psb_ipk_) :: isz1, isz2,err_act, lb1, lb2 + character(len=20) :: name, char_err + logical, parameter :: debug=.false. + + name='psb_safe_cpy' + call psb_erractionsave(err_act) + info=psb_success_ + if(psb_get_errstatus() /= 0) then + info=psb_err_from_subroutine_ + goto 9999 + end if + + isz1 = size(vin,1) + isz2 = size(vin,2) + lb1 = lbound(vin,1) + lb2 = lbound(vin,2) + call psb_realloc(isz1,isz2,vout,info,lb1=lb1,lb2=lb2) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + char_err='psb_realloc' + call psb_errpush(info,name,a_err=char_err) + goto 9999 + else + vout(:,:) = vin(:,:) + endif + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + + end subroutine psb_cpy_s_rk2 + + + function psb_size_s_rk1(vin) result(val) + integer(psb_epk_) :: val + real(psb_spk_), allocatable, intent(in) :: vin(:) + + if (.not.allocated(vin)) then + val = 0 + else + val = size(vin) + end if + end function psb_size_s_rk1 + + + function psb_size_s_rk2(vin,dim) result(val) + integer(psb_epk_) :: val + real(psb_spk_), allocatable, intent(in) :: vin(:,:) + integer(psb_ipk_), optional :: dim + integer(psb_ipk_) :: dim_ + + + if (.not.allocated(vin)) then + val = 0 + else + if (present(dim)) then + dim_= dim + val = size(vin,dim=dim_) + else + val = size(vin) + end if + end if + end function psb_size_s_rk2 + + Subroutine psb_ensure_m_sz_s_rk1(len,v,info,pad,addsz,newsz) + use psb_error_mod + + ! ...Subroutine Arguments + integer(psb_mpk_),Intent(in) :: len + real(psb_spk_),allocatable, intent(inout) :: v(:) + integer(psb_ipk_) :: info + integer(psb_mpk_), optional, intent(in) :: addsz,newsz + real(psb_spk_), optional, intent(in) :: pad + ! ...Local Variables + character(len=20) :: name + logical, parameter :: debug=.false. + integer(psb_ipk_) :: err_act + integer(psb_mpk_) :: isz + + name='psb_ensure_m_sz_s_rk1' + call psb_erractionsave(err_act) + info = psb_success_ + + if (psb_get_errstatus() /= 0) then + info=psb_err_from_subroutine_ + goto 9999 + end if + + If (len > psb_size(v)) Then + if (present(newsz)) then + isz = (max(len+1,newsz)) + else + if (present(addsz)) then + isz = len+max(1,addsz) + else + isz = max(len+10, int(1.25*len)) + endif + endif + + call psb_realloc(isz,v,info,pad=pad) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='psb_realloc') + goto 9999 + End If + end If + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + + + End Subroutine psb_ensure_m_sz_s_rk1 + + Subroutine psb_ensure_e_sz_s_rk1(len,v,info,pad,addsz,newsz) + use psb_error_mod + + ! ...Subroutine Arguments + integer(psb_epk_),Intent(in) :: len + real(psb_spk_),allocatable, intent(inout) :: v(:) + integer(psb_ipk_) :: info + integer(psb_epk_), optional, intent(in) :: addsz,newsz + real(psb_spk_), optional, intent(in) :: pad + ! ...Local Variables + character(len=20) :: name + logical, parameter :: debug=.false. + integer(psb_ipk_) :: err_act + integer(psb_epk_) :: isz + + name='psb_ensure_m_sz_s_rk1' + call psb_erractionsave(err_act) + info = psb_success_ + + if (psb_get_errstatus() /= 0) then + info=psb_err_from_subroutine_ + goto 9999 + end if + + If (len > psb_size(v)) Then + if (present(newsz)) then + isz = (max(len+1,newsz)) + else + if (present(addsz)) then + isz = len+max(1,addsz) + else + isz = max(len+10, int(1.25*len)) + endif + endif + + call psb_realloc(isz,v,info,pad=pad) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='psb_realloc') + goto 9999 + End If + end If + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + + + End Subroutine psb_ensure_e_sz_s_rk1 + + Subroutine psb_move_alloc_s_rk1(vin,vout,info) + use psb_error_mod + real(psb_spk_), allocatable, intent(inout) :: vin(:),vout(:) + integer(psb_ipk_), intent(out) :: info + ! + ! + info=psb_success_ + call move_alloc(vin,vout) + + end Subroutine psb_move_alloc_s_rk1 + + Subroutine psb_move_alloc_s_rk2(vin,vout,info) + use psb_error_mod + real(psb_spk_), allocatable, intent(inout) :: vin(:,:),vout(:,:) + integer(psb_ipk_), intent(out) :: info + ! + ! + info=psb_success_ + + call move_alloc(vin,vout) + + end Subroutine psb_move_alloc_s_rk2 + +end module psb_s_realloc_mod diff --git a/base/modules/basics/psb_z_realloc_mod.F90 b/base/modules/basics/psb_z_realloc_mod.F90 new file mode 100644 index 00000000..cdc401d4 --- /dev/null +++ b/base/modules/basics/psb_z_realloc_mod.F90 @@ -0,0 +1,1027 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! 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. +! +! +module psb_z_realloc_mod + use psb_const_mod + + implicit none + + ! + ! psb_realloc will reallocate the input array to have exactly + ! the size specified, possibly shortening it. + ! + Interface psb_realloc + module procedure psb_r_m_z_rk1 + module procedure psb_r_m_z_rk2 + module procedure psb_r_e_z_rk1 + module procedure psb_r_e_z_rk2 + module procedure psb_r_me_z_rk2 + module procedure psb_r_em_z_rk2 + + module procedure psb_r_m_2_z_rk1 + module procedure psb_r_e_2_z_rk1 + + end Interface psb_realloc + + interface psb_move_alloc + module procedure psb_move_alloc_z_rk1, psb_move_alloc_z_rk2 + end interface psb_move_alloc + + Interface psb_safe_ab_cpy + module procedure psb_ab_cpy_z_rk1, psb_ab_cpy_z_rk2 + end Interface psb_safe_ab_cpy + + Interface psb_safe_cpy + module procedure psb_cpy_z_rk1, psb_cpy_z_rk2 + end Interface psb_safe_cpy + + ! + ! psb_ensure_size will reallocate the input array if necessary + ! to guarantee that its size is at least as large as the + ! value required, usually with some room to spare. + ! + interface psb_ensure_size + module procedure psb_ensure_m_sz_z_rk1, psb_ensure_e_sz_z_rk1 + end Interface psb_ensure_size + + ! + ! psb_size returns 0 if argument is not allocated. + ! + interface psb_size + module procedure psb_size_z_rk1, psb_size_z_rk2 + end interface psb_size + + +Contains + + Subroutine psb_r_m_z_rk1(len,rrax,info,pad,lb) + use psb_error_mod + + ! ...Subroutine Arguments + integer(psb_mpk_),Intent(in) :: len + complex(psb_dpk_), allocatable, intent(inout) :: rrax(:) + integer(psb_ipk_) :: info + complex(psb_dpk_), optional, intent(in) :: pad + integer(psb_mpk_), optional, intent(in) :: lb + + ! ...Local Variables + complex(psb_dpk_),allocatable :: tmp(:) + integer(psb_mpk_) :: dim, lb_, lbi,ub_ + integer(psb_ipk_) :: err_act,err + character(len=20) :: name + logical, parameter :: debug=.false. + + name='psb_r_m_z_rk1' + call psb_erractionsave(err_act) + info=psb_success_ + if (debug) write(psb_err_unit,*) 'reallocate D',len + + if (present(lb)) then + lb_ = lb + else + lb_ = 1 + endif + if ((len<0)) then + err=4025 + call psb_errpush(err,name, & + & i_err=(/len,izero,izero,izero,izero/),a_err='complex(psb_dpk_)') + goto 9999 + end if + ub_ = lb_ + len-1 + + if (allocated(rrax)) then + dim = size(rrax) + lbi = lbound(rrax,1) + If ((dim /= len).or.(lbi /= lb_)) Then + Allocate(tmp(lb_:ub_),stat=info) + if (info /= psb_success_) then + err=4025 + call psb_errpush(err,name, & + & i_err=(/len,izero,izero,izero,izero/),a_err='complex(psb_dpk_)') + goto 9999 + end if + tmp(lb_:lb_-1+min(len,dim))=rrax(lbi:lbi-1+min(len,dim)) + call psb_move_alloc(tmp,rrax,info) + End If + else + dim = 0 + Allocate(rrax(lb_:ub_),stat=info) + if (info /= psb_success_) then + err=4025 + call psb_errpush(err,name, & + & i_err=(/len,izero,izero,izero,izero/),a_err='complex(psb_dpk_)') + goto 9999 + end if + endif + if (present(pad)) then + rrax(lb_-1+dim+1:lb_-1+len) = pad + endif + call psb_erractionrestore(err_act) + return + +9999 continue + info = err + call psb_error_handler(err_act) + return + + End Subroutine psb_r_m_z_rk1 + + Subroutine psb_r_m_z_rk2(len1,len2,rrax,info,pad,lb1,lb2) + use psb_error_mod + ! ...Subroutine Arguments + integer(psb_mpk_),Intent(in) :: len1,len2 + complex(psb_dpk_),allocatable :: rrax(:,:) + integer(psb_ipk_) :: info + complex(psb_dpk_), optional, intent(in) :: pad + integer(psb_mpk_),Intent(in), optional :: lb1,lb2 + + ! ...Local Variables + + complex(psb_dpk_),allocatable :: tmp(:,:) + integer(psb_ipk_) :: err_act,err + integer(psb_mpk_) :: dim,dim2,lb1_, lb2_, ub1_, ub2_,lbi1, lbi2 + character(len=20) :: name + + name='psb_r_m_z_rk2' + call psb_erractionsave(err_act) + info=psb_success_ + if (present(lb1)) then + lb1_ = lb1 + else + lb1_ = 1 + endif + if (present(lb2)) then + lb2_ = lb2 + else + lb2_ = 1 + endif + ub1_ = lb1_ + len1 -1 + ub2_ = lb2_ + len2 -1 + + if (len1 < 0) then + err=4025 + call psb_errpush(err,name, & + & i_err=(/len1,izero,izero,izero,izero/),a_err='complex(psb_dpk_)') + goto 9999 + end if + if (len2 < 0) then + err=4025 + call psb_errpush(err,name, & + & i_err=(/len2,izero,izero,izero,izero/),a_err='complex(psb_dpk_)') + goto 9999 + end if + + + if (allocated(rrax)) then + dim = size(rrax,1) + lbi1 = lbound(rrax,1) + dim2 = size(rrax,2) + lbi2 = lbound(rrax,2) + If ((dim /= len1).or.(dim2 /= len2).or.(lbi1 /= lb1_)& + & .or.(lbi2 /= lb2_)) Then + Allocate(tmp(lb1_:ub1_,lb2_:ub2_),stat=info) + if (info /= psb_success_) then + err=4025 + call psb_errpush(err,name, & + & i_err=(/len1*len2,izero,izero,izero,izero/),a_err='complex(psb_dpk_)') + goto 9999 + end if + tmp(lb1_:lb1_-1+min(len1,dim),lb2_:lb2_-1+min(len2,dim2)) = & + & rrax(lbi1:lbi1-1+min(len1,dim),lbi2:lbi2-1+min(len2,dim2)) + call psb_move_alloc(tmp,rrax,info) + End If + else + dim = 0 + dim2 = 0 + Allocate(rrax(lb1_:ub1_,lb2_:ub2_),stat=info) + if (info /= psb_success_) then + err=4025 + call psb_errpush(err,name, & + & i_err=(/len1*len2,izero,izero,izero,izero/),a_err='complex(psb_dpk_)') + goto 9999 + end if + endif + if (present(pad)) then + rrax(lb1_-1+dim+1:lb1_-1+len1,:) = pad + rrax(lb1_:lb1_-1+dim,lb2_-1+dim2+1:lb2_-1+len2) = pad + endif + call psb_erractionrestore(err_act) + return + +9999 continue + info = err + call psb_error_handler(err_act) + return + + End Subroutine psb_r_m_z_rk2 + + + Subroutine psb_r_e_z_rk1(len,rrax,info,pad,lb) + use psb_error_mod + + ! ...Subroutine Arguments + integer(psb_epk_),Intent(in) :: len + complex(psb_dpk_), allocatable, intent(inout) :: rrax(:) + integer(psb_ipk_) :: info + complex(psb_dpk_), optional, intent(in) :: pad + integer(psb_epk_), optional, intent(in) :: lb + + ! ...Local Variables + complex(psb_dpk_),allocatable :: tmp(:) + integer(psb_epk_) :: dim, lb_, lbi,ub_ + integer(psb_ipk_) :: iplen + integer(psb_ipk_) :: err_act,err + character(len=20) :: name + logical, parameter :: debug=.false. + + name='psb_r_m_z_rk1' + call psb_erractionsave(err_act) + info=psb_success_ + if (debug) write(psb_err_unit,*) 'reallocate D',len + + if (present(lb)) then + lb_ = lb + else + lb_ = 1 + endif + if ((len<0)) then + err=4025 + iplen = len + call psb_errpush(err,name, & + & i_err=(/iplen,izero,izero,izero,izero/),a_err='complex(psb_dpk_)') + goto 9999 + end if + ub_ = lb_ + len-1 + + if (allocated(rrax)) then + dim = size(rrax) + lbi = lbound(rrax,1) + If ((dim /= len).or.(lbi /= lb_)) Then + Allocate(tmp(lb_:ub_),stat=info) + if (info /= psb_success_) then + err=4025 + iplen = len + call psb_errpush(err,name, & + & i_err=(/iplen,izero,izero,izero,izero/),a_err='complex(psb_dpk_)') + goto 9999 + end if + tmp(lb_:lb_-1+min(len,dim))=rrax(lbi:lbi-1+min(len,dim)) + call psb_move_alloc(tmp,rrax,info) + End If + else + dim = 0 + Allocate(rrax(lb_:ub_),stat=info) + if (info /= psb_success_) then + err=4025 + iplen = len + call psb_errpush(err,name, & + & i_err=(/iplen,izero,izero,izero,izero/),a_err='complex(psb_dpk_)') + goto 9999 + end if + endif + if (present(pad)) then + rrax(lb_-1+dim+1:lb_-1+len) = pad + endif + call psb_erractionrestore(err_act) + return + +9999 continue + info = err + call psb_error_handler(err_act) + return + + End Subroutine psb_r_e_z_rk1 + + Subroutine psb_r_e_z_rk2(len1,len2,rrax,info,pad,lb1,lb2) + use psb_error_mod + ! ...Subroutine Arguments + integer(psb_epk_),Intent(in) :: len1,len2 + complex(psb_dpk_),allocatable :: rrax(:,:) + integer(psb_ipk_) :: info + complex(psb_dpk_), optional, intent(in) :: pad + integer(psb_epk_),Intent(in), optional :: lb1,lb2 + + ! ...Local Variables + + complex(psb_dpk_),allocatable :: tmp(:,:) + integer(psb_ipk_) :: err_act,err, iplen + integer(psb_epk_) :: dim,dim2,lb1_, lb2_, ub1_, ub2_,lbi1, lbi2 + character(len=20) :: name + + name='psb_r_e_z_rk2' + call psb_erractionsave(err_act) + info=psb_success_ + if (present(lb1)) then + lb1_ = lb1 + else + lb1_ = 1 + endif + if (present(lb2)) then + lb2_ = lb2 + else + lb2_ = 1 + endif + ub1_ = lb1_ + len1 -1 + ub2_ = lb2_ + len2 -1 + + if (len1 < 0) then + err=4025 + iplen = len1 + call psb_errpush(err,name, & + & i_err=(/iplen,izero,izero,izero,izero/),a_err='complex(psb_dpk_)') + goto 9999 + end if + if (len2 < 0) then + err=4025 + iplen = len2 + call psb_errpush(err,name, & + & i_err=(/iplen,izero,izero,izero,izero/),a_err='complex(psb_dpk_)') + goto 9999 + end if + + + if (allocated(rrax)) then + dim = size(rrax,1) + lbi1 = lbound(rrax,1) + dim2 = size(rrax,2) + lbi2 = lbound(rrax,2) + If ((dim /= len1).or.(dim2 /= len2).or.(lbi1 /= lb1_)& + & .or.(lbi2 /= lb2_)) Then + Allocate(tmp(lb1_:ub1_,lb2_:ub2_),stat=info) + if (info /= psb_success_) then + err=4025 + iplen = len1*len2 + call psb_errpush(err,name, & + & i_err=(/iplen,izero,izero,izero,izero/),a_err='complex(psb_dpk_)') + goto 9999 + end if + tmp(lb1_:lb1_-1+min(len1,dim),lb2_:lb2_-1+min(len2,dim2)) = & + & rrax(lbi1:lbi1-1+min(len1,dim),lbi2:lbi2-1+min(len2,dim2)) + call psb_move_alloc(tmp,rrax,info) + End If + else + dim = 0 + dim2 = 0 + Allocate(rrax(lb1_:ub1_,lb2_:ub2_),stat=info) + if (info /= psb_success_) then + err=4025 + iplen = len1*len2 + call psb_errpush(err,name, & + & i_err=(/iplen,izero,izero,izero,izero/),a_err='complex(psb_dpk_)') + goto 9999 + end if + endif + if (present(pad)) then + rrax(lb1_-1+dim+1:lb1_-1+len1,:) = pad + rrax(lb1_:lb1_-1+dim,lb2_-1+dim2+1:lb2_-1+len2) = pad + endif + call psb_erractionrestore(err_act) + return + +9999 continue + info = err + call psb_error_handler(err_act) + return + + End Subroutine psb_r_e_z_rk2 + + Subroutine psb_r_me_z_rk2(len1,len2,rrax,info,pad,lb1,lb2) + use psb_error_mod + ! ...Subroutine Arguments + integer(psb_mpk_),Intent(in) :: len1 + integer(psb_epk_),Intent(in) :: len2 + complex(psb_dpk_),allocatable :: rrax(:,:) + integer(psb_ipk_) :: info + complex(psb_dpk_), optional, intent(in) :: pad + integer(psb_mpk_),Intent(in), optional :: lb1,lb2 + + ! ...Local Variables + + complex(psb_dpk_),allocatable :: tmp(:,:) + integer(psb_ipk_) :: err_act,err, iplen + integer(psb_mpk_) :: dim,lb1_, lb2_, ub1_, ub2_,lbi1, lbi2 + integer(psb_epk_) :: dim2 + character(len=20) :: name + + name='psb_r_me_z_rk2' + call psb_erractionsave(err_act) + info=psb_success_ + if (present(lb1)) then + lb1_ = lb1 + else + lb1_ = 1 + endif + if (present(lb2)) then + lb2_ = lb2 + else + lb2_ = 1 + endif + ub1_ = lb1_ + len1 -1 + ub2_ = lb2_ + len2 -1 + + if (len1 < 0) then + err=4025 + iplen = len1 + call psb_errpush(err,name, & + & i_err=(/iplen,izero,izero,izero,izero/),a_err='complex(psb_dpk_)') + goto 9999 + end if + if (len2 < 0) then + err=4025 + iplen = len2 + call psb_errpush(err,name, & + & i_err=(/iplen,izero,izero,izero,izero/),a_err='complex(psb_dpk_)') + goto 9999 + end if + + + if (allocated(rrax)) then + dim = size(rrax,1) + lbi1 = lbound(rrax,1) + dim2 = size(rrax,2) + lbi2 = lbound(rrax,2) + If ((dim /= len1).or.(dim2 /= len2).or.(lbi1 /= lb1_)& + & .or.(lbi2 /= lb2_)) Then + Allocate(tmp(lb1_:ub1_,lb2_:ub2_),stat=info) + if (info /= psb_success_) then + err=4025 + iplen = len1*len2 + call psb_errpush(err,name, & + & i_err=(/iplen,izero,izero,izero,izero/),a_err='complex(psb_dpk_)') + goto 9999 + end if + tmp(lb1_:lb1_-1+min(len1,dim),lb2_:lb2_-1+min(len2,dim2)) = & + & rrax(lbi1:lbi1-1+min(len1,dim),lbi2:lbi2-1+min(len2,dim2)) + call psb_move_alloc(tmp,rrax,info) + End If + else + dim = 0 + dim2 = 0 + Allocate(rrax(lb1_:ub1_,lb2_:ub2_),stat=info) + if (info /= psb_success_) then + err=4025 + iplen = len1*len2 + call psb_errpush(err,name, & + & i_err=(/iplen,izero,izero,izero,izero/),a_err='complex(psb_dpk_)') + goto 9999 + end if + endif + if (present(pad)) then + rrax(lb1_-1+dim+1:lb1_-1+len1,:) = pad + rrax(lb1_:lb1_-1+dim,lb2_-1+dim2+1:lb2_-1+len2) = pad + endif + call psb_erractionrestore(err_act) + return + +9999 continue + info = err + call psb_error_handler(err_act) + return + + End Subroutine psb_r_me_z_rk2 + + Subroutine psb_r_em_z_rk2(len1,len2,rrax,info,pad,lb1,lb2) + use psb_error_mod + ! ...Subroutine Arguments + integer(psb_epk_),Intent(in) :: len1 + integer(psb_mpk_),Intent(in) :: len2 + complex(psb_dpk_),allocatable :: rrax(:,:) + integer(psb_ipk_) :: info + complex(psb_dpk_), optional, intent(in) :: pad + integer(psb_mpk_),Intent(in), optional :: lb1,lb2 + + ! ...Local Variables + + complex(psb_dpk_),allocatable :: tmp(:,:) + integer(psb_ipk_) :: err_act,err, iplen + integer(psb_mpk_) :: dim2,lb1_, lb2_, ub1_, ub2_,lbi1, lbi2 + integer(psb_epk_) :: dim + character(len=20) :: name + + name='psb_r_me_z_rk2' + call psb_erractionsave(err_act) + info=psb_success_ + if (present(lb1)) then + lb1_ = lb1 + else + lb1_ = 1 + endif + if (present(lb2)) then + lb2_ = lb2 + else + lb2_ = 1 + endif + ub1_ = lb1_ + len1 -1 + ub2_ = lb2_ + len2 -1 + + if (len1 < 0) then + err=4025 + iplen = len1 + call psb_errpush(err,name, & + & i_err=(/iplen,izero,izero,izero,izero/),a_err='complex(psb_dpk_)') + goto 9999 + end if + if (len2 < 0) then + err=4025 + iplen = len2 + call psb_errpush(err,name, & + & i_err=(/iplen,izero,izero,izero,izero/),a_err='complex(psb_dpk_)') + goto 9999 + end if + + + if (allocated(rrax)) then + dim = size(rrax,1) + lbi1 = lbound(rrax,1) + dim2 = size(rrax,2) + lbi2 = lbound(rrax,2) + If ((dim /= len1).or.(dim2 /= len2).or.(lbi1 /= lb1_)& + & .or.(lbi2 /= lb2_)) Then + Allocate(tmp(lb1_:ub1_,lb2_:ub2_),stat=info) + if (info /= psb_success_) then + err=4025 + iplen = len1*len2 + call psb_errpush(err,name, & + & i_err=(/iplen,izero,izero,izero,izero/),a_err='complex(psb_dpk_)') + goto 9999 + end if + tmp(lb1_:lb1_-1+min(len1,dim),lb2_:lb2_-1+min(len2,dim2)) = & + & rrax(lbi1:lbi1-1+min(len1,dim),lbi2:lbi2-1+min(len2,dim2)) + call psb_move_alloc(tmp,rrax,info) + End If + else + dim = 0 + dim2 = 0 + Allocate(rrax(lb1_:ub1_,lb2_:ub2_),stat=info) + if (info /= psb_success_) then + err=4025 + iplen = len1*len2 + call psb_errpush(err,name, & + & i_err=(/iplen,izero,izero,izero,izero/),a_err='complex(psb_dpk_)') + goto 9999 + end if + endif + if (present(pad)) then + rrax(lb1_-1+dim+1:lb1_-1+len1,:) = pad + rrax(lb1_:lb1_-1+dim,lb2_-1+dim2+1:lb2_-1+len2) = pad + endif + call psb_erractionrestore(err_act) + return + +9999 continue + info = err + call psb_error_handler(err_act) + return + + End Subroutine psb_r_em_z_rk2 + + Subroutine psb_r_m_2_z_rk1(len,rrax,y,info,pad) + use psb_error_mod + ! ...Subroutine Arguments + + integer(psb_mpk_),Intent(in) :: len + complex(psb_dpk_),allocatable, intent(inout) :: rrax(:),y(:) + integer(psb_ipk_) :: info + complex(psb_dpk_), optional, intent(in) :: pad + character(len=20) :: name + integer(psb_ipk_) :: err_act, err + + name='psb_r_m_2_z_rk1' + call psb_erractionsave(err_act) + info=psb_success_ + + if(psb_get_errstatus() /= 0) then + info=psb_err_from_subroutine_ + goto 9999 + end if + + call psb_realloc(len,rrax,info,pad=pad) + if (info /= psb_success_) then + err=4000 + call psb_errpush(err,name) + goto 9999 + end if + call psb_realloc(len,y,info,pad=pad) + if (info /= psb_success_) then + err=4000 + call psb_errpush(err,name) + goto 9999 + end if + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + + End Subroutine psb_r_m_2_z_rk1 + + Subroutine psb_r_e_2_z_rk1(len,rrax,y,info,pad) + use psb_error_mod + ! ...Subroutine Arguments + + integer(psb_epk_),Intent(in) :: len + complex(psb_dpk_),allocatable, intent(inout) :: rrax(:),y(:) + integer(psb_ipk_) :: info + complex(psb_dpk_), optional, intent(in) :: pad + character(len=20) :: name + integer(psb_ipk_) :: err_act, err + + name='psb_r_m_2_z_rk1' + call psb_erractionsave(err_act) + info=psb_success_ + + if(psb_get_errstatus() /= 0) then + info=psb_err_from_subroutine_ + goto 9999 + end if + + call psb_realloc(len,rrax,info,pad=pad) + if (info /= psb_success_) then + err=4000 + call psb_errpush(err,name) + goto 9999 + end if + call psb_realloc(len,y,info,pad=pad) + if (info /= psb_success_) then + err=4000 + call psb_errpush(err,name) + goto 9999 + end if + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + + End Subroutine psb_r_e_2_z_rk1 + + + + subroutine psb_ab_cpy_z_rk1(vin,vout,info) + use psb_error_mod + + ! ...Subroutine Arguments + complex(psb_dpk_), allocatable, intent(in) :: vin(:) + complex(psb_dpk_), allocatable, intent(out) :: vout(:) + integer(psb_ipk_) :: info + ! ...Local Variables + + integer(psb_ipk_) :: isz,err_act,lb + character(len=20) :: name, char_err + logical, parameter :: debug=.false. + + name='psb_ab_cpy_z_rk1' + call psb_erractionsave(err_act) + info=psb_success_ + if(psb_get_errstatus() /= 0) then + info=psb_err_from_subroutine_ + goto 9999 + end if + + if (allocated(vin)) then + isz = size(vin) + lb = lbound(vin,1) + call psb_realloc(isz,vout,info,lb=lb) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + char_err='psb_realloc' + call psb_errpush(info,name,a_err=char_err) + goto 9999 + else + vout(:) = vin(:) + endif + endif + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + + end subroutine psb_ab_cpy_z_rk1 + + subroutine psb_ab_cpy_z_rk2(vin,vout,info) + use psb_error_mod + + ! ...Subroutine Arguments + complex(psb_dpk_), allocatable, intent(in) :: vin(:,:) + complex(psb_dpk_), allocatable, intent(out) :: vout(:,:) + integer(psb_ipk_) :: info + ! ...Local Variables + + integer(psb_ipk_) :: isz1, isz2,err_act, lb1, lb2 + character(len=20) :: name, char_err + logical, parameter :: debug=.false. + + name='psb_ab_cpy_z_rk2' + call psb_erractionsave(err_act) + info=psb_success_ + if(psb_get_errstatus() /= 0) then + info=psb_err_from_subroutine_ + goto 9999 + end if + + if (allocated(vin)) then + isz1 = size(vin,1) + isz2 = size(vin,2) + lb1 = lbound(vin,1) + lb2 = lbound(vin,2) + call psb_realloc(isz1,isz2,vout,info,lb1=lb1,lb2=lb2) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + char_err='psb_realloc' + call psb_errpush(info,name,a_err=char_err) + goto 9999 + else + vout(:,:) = vin(:,:) + endif + endif + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + + end subroutine psb_ab_cpy_z_rk2 + + + subroutine psb_cpy_z_rk1(vin,vout,info) + use psb_error_mod + + ! ...Subroutine Arguments + complex(psb_dpk_), intent(in) :: vin(:) + complex(psb_dpk_), allocatable, intent(out) :: vout(:) + integer(psb_ipk_) :: info + ! ...Local Variables + + integer(psb_ipk_) :: isz,err_act,lb + character(len=20) :: name, char_err + logical, parameter :: debug=.false. + + name='psb_cpy_z_rk1' + call psb_erractionsave(err_act) + info=psb_success_ + if(psb_get_errstatus() /= 0) then + info=psb_err_from_subroutine_ + goto 9999 + end if + isz = size(vin) + lb = lbound(vin,1) + call psb_realloc(isz,vout,info,lb=lb) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + char_err='psb_realloc' + call psb_errpush(info,name,a_err=char_err) + goto 9999 + else + vout(:) = vin(:) + endif + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + + end subroutine psb_cpy_z_rk1 + + subroutine psb_cpy_z_rk2(vin,vout,info) + use psb_error_mod + + ! ...Subroutine Arguments + complex(psb_dpk_), intent(in) :: vin(:,:) + complex(psb_dpk_), allocatable, intent(out) :: vout(:,:) + integer(psb_ipk_) :: info + ! ...Local Variables + + integer(psb_ipk_) :: isz1, isz2,err_act, lb1, lb2 + character(len=20) :: name, char_err + logical, parameter :: debug=.false. + + name='psb_safe_cpy' + call psb_erractionsave(err_act) + info=psb_success_ + if(psb_get_errstatus() /= 0) then + info=psb_err_from_subroutine_ + goto 9999 + end if + + isz1 = size(vin,1) + isz2 = size(vin,2) + lb1 = lbound(vin,1) + lb2 = lbound(vin,2) + call psb_realloc(isz1,isz2,vout,info,lb1=lb1,lb2=lb2) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + char_err='psb_realloc' + call psb_errpush(info,name,a_err=char_err) + goto 9999 + else + vout(:,:) = vin(:,:) + endif + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + + end subroutine psb_cpy_z_rk2 + + + function psb_size_z_rk1(vin) result(val) + integer(psb_epk_) :: val + complex(psb_dpk_), allocatable, intent(in) :: vin(:) + + if (.not.allocated(vin)) then + val = 0 + else + val = size(vin) + end if + end function psb_size_z_rk1 + + + function psb_size_z_rk2(vin,dim) result(val) + integer(psb_epk_) :: val + complex(psb_dpk_), allocatable, intent(in) :: vin(:,:) + integer(psb_ipk_), optional :: dim + integer(psb_ipk_) :: dim_ + + + if (.not.allocated(vin)) then + val = 0 + else + if (present(dim)) then + dim_= dim + val = size(vin,dim=dim_) + else + val = size(vin) + end if + end if + end function psb_size_z_rk2 + + Subroutine psb_ensure_m_sz_z_rk1(len,v,info,pad,addsz,newsz) + use psb_error_mod + + ! ...Subroutine Arguments + integer(psb_mpk_),Intent(in) :: len + complex(psb_dpk_),allocatable, intent(inout) :: v(:) + integer(psb_ipk_) :: info + integer(psb_mpk_), optional, intent(in) :: addsz,newsz + complex(psb_dpk_), optional, intent(in) :: pad + ! ...Local Variables + character(len=20) :: name + logical, parameter :: debug=.false. + integer(psb_ipk_) :: err_act + integer(psb_mpk_) :: isz + + name='psb_ensure_m_sz_z_rk1' + call psb_erractionsave(err_act) + info = psb_success_ + + if (psb_get_errstatus() /= 0) then + info=psb_err_from_subroutine_ + goto 9999 + end if + + If (len > psb_size(v)) Then + if (present(newsz)) then + isz = (max(len+1,newsz)) + else + if (present(addsz)) then + isz = len+max(1,addsz) + else + isz = max(len+10, int(1.25*len)) + endif + endif + + call psb_realloc(isz,v,info,pad=pad) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='psb_realloc') + goto 9999 + End If + end If + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + + + End Subroutine psb_ensure_m_sz_z_rk1 + + Subroutine psb_ensure_e_sz_z_rk1(len,v,info,pad,addsz,newsz) + use psb_error_mod + + ! ...Subroutine Arguments + integer(psb_epk_),Intent(in) :: len + complex(psb_dpk_),allocatable, intent(inout) :: v(:) + integer(psb_ipk_) :: info + integer(psb_epk_), optional, intent(in) :: addsz,newsz + complex(psb_dpk_), optional, intent(in) :: pad + ! ...Local Variables + character(len=20) :: name + logical, parameter :: debug=.false. + integer(psb_ipk_) :: err_act + integer(psb_epk_) :: isz + + name='psb_ensure_m_sz_z_rk1' + call psb_erractionsave(err_act) + info = psb_success_ + + if (psb_get_errstatus() /= 0) then + info=psb_err_from_subroutine_ + goto 9999 + end if + + If (len > psb_size(v)) Then + if (present(newsz)) then + isz = (max(len+1,newsz)) + else + if (present(addsz)) then + isz = len+max(1,addsz) + else + isz = max(len+10, int(1.25*len)) + endif + endif + + call psb_realloc(isz,v,info,pad=pad) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='psb_realloc') + goto 9999 + End If + end If + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + + + End Subroutine psb_ensure_e_sz_z_rk1 + + Subroutine psb_move_alloc_z_rk1(vin,vout,info) + use psb_error_mod + complex(psb_dpk_), allocatable, intent(inout) :: vin(:),vout(:) + integer(psb_ipk_), intent(out) :: info + ! + ! + info=psb_success_ + call move_alloc(vin,vout) + + end Subroutine psb_move_alloc_z_rk1 + + Subroutine psb_move_alloc_z_rk2(vin,vout,info) + use psb_error_mod + complex(psb_dpk_), allocatable, intent(inout) :: vin(:,:),vout(:,:) + integer(psb_ipk_), intent(out) :: info + ! + ! + info=psb_success_ + + call move_alloc(vin,vout) + + end Subroutine psb_move_alloc_z_rk2 + +end module psb_z_realloc_mod diff --git a/base/modules/psb_const_mod.F90 b/base/modules/psb_const_mod.F90 index c3071987..238aef5d 100644 --- a/base/modules/psb_const_mod.F90 +++ b/base/modules/psb_const_mod.F90 @@ -33,6 +33,8 @@ module psb_const_mod #if defined(HAVE_ISO_FORTRAN_ENV) use iso_fortran_env + ! This is a 2-byte integer, just in case + integer, parameter :: psb_i2pk_ = int16 ! This is always a 4-byte integer, for MPI-related stuff integer, parameter :: psb_mpk_ = int32 ! This is always an 8-byte integer. @@ -45,12 +47,15 @@ module psb_const_mod integer, parameter :: psb_dpk_ = real64 #else - - integer, parameter :: indig=8 - integer, parameter :: lndig=12 + + ! This is a 2-byte integer, just in case + integer, parameter :: i2ndig=4 + integer, parameter :: psb_i2pk_ = selected_int_kind(i2ndig) ! This is always a 4-byte integer, for MPI-related stuff + integer, parameter :: indig=8 integer, parameter :: psb_mpk_ = selected_int_kind(indig) ! This is always an 8-byte integer. + integer, parameter :: lndig=12 integer, parameter :: psb_epk_ = selected_int_kind(lndig) ! ! These must be the kind parameter corresponding to psb_mpi_r_dpk_ @@ -98,6 +103,7 @@ module psb_const_mod integer(psb_ipk_), save :: psb_sizeof_sp integer(psb_ipk_), save :: psb_sizeof_dp + integer(psb_ipk_), save :: psb_sizeof_i2p integer(psb_ipk_), save :: psb_sizeof_mp integer(psb_ipk_), save :: psb_sizeof_ep integer(psb_ipk_), save :: psb_sizeof_ip @@ -105,6 +111,7 @@ module psb_const_mod ! ! Integer type identifiers for MPI operations. ! + integer(psb_mpk_), save :: psb_mpi_i2pk_int integer(psb_mpk_), save :: psb_mpi_epk_int integer(psb_mpk_), save :: psb_mpi_mpk_int integer(psb_mpk_), save :: psb_mpi_ipk_int @@ -124,10 +131,15 @@ module psb_const_mod ! ! Handy & miscellaneous constants ! + integer(psb_epk_), parameter :: ezero=0, eone=1 + integer(psb_epk_), parameter :: etwo=2, ethree=3,emone=-1 + integer(psb_mpk_), parameter :: mzero=0, mone=1 + integer(psb_mpk_), parameter :: mtwo=2, mthree=3,mmone=-1 integer(psb_lpk_), parameter :: lzero=0, lone=1 integer(psb_lpk_), parameter :: ltwo=2, lthree=3,lmone=-1 integer(psb_ipk_), parameter :: izero=0, ione=1 - integer(psb_ipk_), parameter :: itwo=2, ithree=3,mone=-1 + integer(psb_ipk_), parameter :: itwo=2, ithree=3,imone=-1 + integer(psb_ipk_), parameter :: psb_root_=0 real(psb_spk_), parameter :: szero=0.0_psb_spk_, sone=1.0_psb_spk_ real(psb_dpk_), parameter :: dzero=0.0_psb_dpk_, done=1.0_psb_dpk_ @@ -138,6 +150,8 @@ module psb_const_mod real(psb_dpk_), parameter :: d_epstol=1.1e-16_psb_dpk_ ! Unit roundoff. real(psb_spk_), parameter :: s_epstol=5.e-8_psb_spk_ ! Is this right? character, parameter :: psb_all_='A', psb_topdef_=' ' + logical, parameter :: psb_m_is_complex_ = .false. + logical, parameter :: psb_e_is_complex_ = .false. logical, parameter :: psb_i_is_complex_ = .false. logical, parameter :: psb_l_is_complex_ = .false. logical, parameter :: psb_s_is_complex_ = .false. diff --git a/base/modules/psb_realloc_mod.F90 b/base/modules/psb_realloc_mod.F90 index 93d6854e..7aa5c177 100644 --- a/base/modules/psb_realloc_mod.F90 +++ b/base/modules/psb_realloc_mod.F90 @@ -31,131 +31,26 @@ ! module psb_realloc_mod use psb_const_mod + use psb_m_realloc_mod + use psb_e_realloc_mod + use psb_s_realloc_mod + use psb_d_realloc_mod + use psb_c_realloc_mod + use psb_z_realloc_mod + implicit none - + ! ! psb_realloc will reallocate the input array to have exactly ! the size specified, possibly shortening it. ! Interface psb_realloc - module procedure psb_reallocate1i - module procedure psb_reallocate2i module procedure psb_reallocate2i1d module procedure psb_reallocate2i1s - module procedure psb_reallocate1d - module procedure psb_reallocate1s - module procedure psb_reallocated2 - module procedure psb_reallocates2 - module procedure psb_reallocatei2 -#if ! defined(LONG_INTEGERS) - module procedure psb_reallocate1i8 - module procedure psb_reallocate1i8l - module procedure psb_reallocatei8_2 -#endif module procedure psb_reallocate2i1z module procedure psb_reallocate2i1c - module procedure psb_reallocate1z - module procedure psb_reallocate1c - module procedure psb_reallocatez2 - module procedure psb_reallocatec2 -#if defined(LONG_INTEGERS) - module procedure psb_reallocate1i4 - module procedure psb_reallocate1i4_i8 - module procedure psb_reallocate2i4 - module procedure psb_reallocate2i4_i8 - module procedure psb_rp1i1 - module procedure psb_rp1i2i2 - module procedure psb_ri1p2i2 - module procedure psb_rp1p2i2 - - module procedure psb_rp1s1 - module procedure psb_rp1i2s2 - module procedure psb_ri1p2s2 - module procedure psb_rp1p2s2 - - module procedure psb_rp1d1 - module procedure psb_rp1i2d2 - module procedure psb_ri1p2d2 - module procedure psb_rp1p2d2 - - module procedure psb_rp1c1 - module procedure psb_rp1i2c2 - module procedure psb_ri1p2c2 - module procedure psb_rp1p2c2 - - module procedure psb_rp1z1 - module procedure psb_rp1i2z2 - module procedure psb_ri1p2z2 - module procedure psb_rp1p2z2 - -#endif end Interface psb_realloc - interface psb_move_alloc - module procedure psb_smove_alloc1d - module procedure psb_smove_alloc2d - module procedure psb_dmove_alloc1d - module procedure psb_dmove_alloc2d - module procedure psb_imove_alloc1d - module procedure psb_imove_alloc2d -#if !defined(LONG_INTEGERS) - module procedure psb_i8move_alloc1d - module procedure psb_i8move_alloc2d -#else - module procedure psb_i4move_alloc1d - module procedure psb_i4move_alloc2d - module procedure psb_i4move_alloc1d_i8 - module procedure psb_i4move_alloc2d_i8 -#endif - module procedure psb_cmove_alloc1d - module procedure psb_cmove_alloc2d - module procedure psb_zmove_alloc1d - module procedure psb_zmove_alloc2d - end interface psb_move_alloc - - Interface psb_safe_ab_cpy - module procedure psb_i_ab_cpy1d,psb_i_ab_cpy2d, & -#if !defined(LONG_INTEGERS) - & psb_i8_ab_cpy1d, psb_i8_ab_cpy2d, & -#endif - & psb_s_ab_cpy1d, psb_s_ab_cpy2d,& - & psb_c_ab_cpy1d, psb_c_ab_cpy2d,& - & psb_d_ab_cpy1d, psb_d_ab_cpy2d,& - & psb_z_ab_cpy1d, psb_z_ab_cpy2d - end Interface psb_safe_ab_cpy - - Interface psb_safe_cpy - module procedure psb_i_cpy1d,psb_i_cpy2d, & - & psb_s_cpy1d, psb_s_cpy2d,& - & psb_c_cpy1d, psb_c_cpy2d,& - & psb_d_cpy1d, psb_d_cpy2d,& - & psb_z_cpy1d, psb_z_cpy2d - end Interface psb_safe_cpy - - ! - ! psb_ensure_size will reallocate the input array if necessary - ! to guarantee that its size is at least as large as the - ! value required, usually with some room to spare. - ! - interface psb_ensure_size - module procedure psb_icksz1d,& -#if !defined(LONG_INTEGERS) - & psb_i8cksz1d, & -#endif - & psb_scksz1d, psb_ccksz1d, & - & psb_dcksz1d, psb_zcksz1d - end Interface psb_ensure_size - - interface psb_size - module procedure psb_isize1d, psb_isize2d,& -#if !defined(LONG_INTEGERS) - & psb_i8size1d, psb_i8size2d,& -#endif - & psb_ssize1d, psb_ssize2d,& - & psb_csize1d, psb_csize2d,& - & psb_dsize1d, psb_dsize2d,& - & psb_zsize1d, psb_zsize2d - end interface psb_size logical, private :: do_maybe_free_buffer = .true. @@ -171,3644 +66,173 @@ Contains do_maybe_free_buffer = val end subroutine psb_set_maybe_free_buffer - subroutine psb_i_ab_cpy1d(vin,vout,info) - use psb_error_mod - - ! ...Subroutine Arguments - integer(psb_ipk_),allocatable, intent(in) :: vin(:) - integer(psb_ipk_),allocatable, intent(out) :: vout(:) - integer(psb_ipk_) :: info - ! ...Local Variables - - integer(psb_ipk_) :: isz,err_act,lb - character(len=20) :: name, char_err - logical, parameter :: debug=.false. - - name='psb_safe_ab_cpy' - call psb_erractionsave(err_act) - info=psb_success_ - - if (psb_get_errstatus() /= 0) then - info=psb_err_from_subroutine_ - goto 9999 - end if - - if (allocated(vin)) then - isz = size(vin) - lb = lbound(vin,1) - call psb_realloc(isz,vout,info,lb=lb) - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - char_err='psb_realloc' - call psb_errpush(info,name,a_err=char_err) - goto 9999 - else - vout(:) = vin(:) - endif - endif - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - return - - end subroutine psb_i_ab_cpy1d - subroutine psb_i_ab_cpy2d(vin,vout,info) + Subroutine psb_reallocate2i1s(len,rrax,y,z,info) use psb_error_mod - ! ...Subroutine Arguments - integer(psb_ipk_), allocatable, intent(in) :: vin(:,:) - integer(psb_ipk_), allocatable, intent(out) :: vout(:,:) + integer(psb_ipk_),Intent(in) :: len + integer(psb_ipk_),allocatable, intent(inout) :: rrax(:),y(:) + Real(psb_spk_),allocatable, intent(inout) :: z(:) integer(psb_ipk_) :: info - ! ...Local Variables - - integer(psb_ipk_) :: isz1, isz2,err_act, lb1, lb2 - character(len=20) :: name, char_err + character(len=20) :: name + integer(psb_ipk_) :: err_act, err logical, parameter :: debug=.false. - name='psb_safe_ab_cpy' + name='psb_reallocate2i1s' call psb_erractionsave(err_act) - info=psb_success_ - - if(psb_get_errstatus() /= 0) then - info=psb_err_from_subroutine_ - goto 9999 - end if - if (allocated(vin)) then - isz1 = size(vin,1) - isz2 = size(vin,2) - lb1 = lbound(vin,1) - lb2 = lbound(vin,2) - call psb_realloc(isz1,isz2,vout,info,lb1=lb1,lb2=lb2) - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - char_err='psb_realloc' - call psb_errpush(info,name,a_err=char_err) - goto 9999 - else - vout(:,:) = vin(:,:) - endif - endif - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - - return - - end subroutine psb_i_ab_cpy2d -#if !defined(LONG_INTEGERS) - - subroutine psb_i8_ab_cpy1d(vin,vout,info) - use psb_error_mod - ! ...Subroutine Arguments - integer(psb_lpk_),allocatable, intent(in) :: vin(:) - integer(psb_lpk_),allocatable, intent(out) :: vout(:) - integer(psb_ipk_) :: info - ! ...Local Variables - - integer(psb_ipk_) :: err_act - integer(psb_lpk_) :: isz,lb - character(len=20) :: name, char_err - logical, parameter :: debug=.false. - name='psb_safe_ab_cpy' - call psb_erractionsave(err_act) info=psb_success_ - - if (psb_get_errstatus() /= 0) then - info=psb_err_from_subroutine_ + call psb_realloc(len,rrax,info) + if (info /= psb_success_) then + err=4000 + call psb_errpush(err,name) + goto 9999 + end if + call psb_realloc(len,y,info) + if (info /= psb_success_) then + err=4000 + call psb_errpush(err,name) + goto 9999 + end if + call psb_realloc(len,z,info) + if (info /= psb_success_) then + err=4000 + call psb_errpush(err,name) goto 9999 end if - - if (allocated(vin)) then - isz = size(vin) - lb = lbound(vin,1) - call psb_realloc(isz,vout,info,lb=lb) - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - char_err='psb_realloc' - call psb_errpush(info,name,a_err=char_err) - goto 9999 - else - vout(:) = vin(:) - endif - endif - call psb_erractionrestore(err_act) return 9999 call psb_error_handler(err_act) return + End Subroutine psb_reallocate2i1s - end subroutine psb_i8_ab_cpy1d - subroutine psb_i8_ab_cpy2d(vin,vout,info) + Subroutine psb_reallocate2i1d(len,rrax,y,z,info) use psb_error_mod - ! ...Subroutine Arguments - integer(psb_lpk_), allocatable, intent(in) :: vin(:,:) - integer(psb_lpk_), allocatable, intent(out) :: vout(:,:) + integer(psb_ipk_),Intent(in) :: len + integer(psb_ipk_),allocatable, intent(inout) :: rrax(:),y(:) + Real(psb_dpk_),allocatable, intent(inout) :: z(:) integer(psb_ipk_) :: info - ! ...Local Variables - - integer(psb_ipk_) :: isz1, isz2,err_act, lb1, lb2 - character(len=20) :: name, char_err - logical, parameter :: debug=.false. + character(len=20) :: name + integer(psb_ipk_) :: err_act, err - name='psb_safe_ab_cpy' + name='psb_reallocate2i1d' call psb_erractionsave(err_act) + info=psb_success_ - if(psb_get_errstatus() /= 0) then - info=psb_err_from_subroutine_ + call psb_realloc(len,rrax,info) + if (info /= psb_success_) then + err=4000 + call psb_errpush(err,name) goto 9999 end if - if (allocated(vin)) then - isz1 = size(vin,1) - isz2 = size(vin,2) - lb1 = lbound(vin,1) - lb2 = lbound(vin,2) - call psb_realloc(isz1,isz2,vout,info,lb1=lb1,lb2=lb2) - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - char_err='psb_realloc' - call psb_errpush(info,name,a_err=char_err) - goto 9999 - else - vout(:,:) = vin(:,:) - endif - endif - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - - return - - end subroutine psb_i8_ab_cpy2d -#endif - - subroutine psb_s_ab_cpy1d(vin,vout,info) - use psb_error_mod - - ! ...Subroutine Arguments - real(psb_spk_), allocatable, intent(in) :: vin(:) - real(psb_spk_), allocatable, intent(out) :: vout(:) - integer(psb_ipk_) :: info - ! ...Local Variables - - integer(psb_ipk_) :: isz,err_act,lb - character(len=20) :: name, char_err - logical, parameter :: debug=.false. - - name='psb_safe_ab_cpy' - call psb_erractionsave(err_act) - info=psb_success_ - if(psb_get_errstatus() /= 0) then - info=psb_err_from_subroutine_ + call psb_realloc(len,y,info) + if (info /= psb_success_) then + err=4000 + call psb_errpush(err,name) goto 9999 end if - - if (allocated(vin)) then - isz = size(vin) - lb = lbound(vin,1) - call psb_realloc(isz,vout,info,lb=lb) - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - char_err='psb_realloc' - call psb_errpush(info,name,a_err=char_err) - goto 9999 - else - vout(:) = vin(:) - endif - endif - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - - return - - end subroutine psb_s_ab_cpy1d - - subroutine psb_s_ab_cpy2d(vin,vout,info) - use psb_error_mod - - ! ...Subroutine Arguments - real(psb_spk_), allocatable, intent(in) :: vin(:,:) - real(psb_spk_), allocatable, intent(out) :: vout(:,:) - integer(psb_ipk_) :: info - ! ...Local Variables - - integer(psb_ipk_) :: isz1, isz2,err_act, lb1, lb2 - character(len=20) :: name, char_err - logical, parameter :: debug=.false. - - name='psb_safe_ab_cpy' - call psb_erractionsave(err_act) - info=psb_success_ - if(psb_get_errstatus() /= 0) then - info=psb_err_from_subroutine_ + call psb_realloc(len,z,info) + if (info /= psb_success_) then + err=4000 + call psb_errpush(err,name) goto 9999 end if - - if (allocated(vin)) then - isz1 = size(vin,1) - isz2 = size(vin,2) - lb1 = lbound(vin,1) - lb2 = lbound(vin,2) - call psb_realloc(isz1,isz2,vout,info,lb1=lb1,lb2=lb2) - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - char_err='psb_realloc' - call psb_errpush(info,name,a_err=char_err) - goto 9999 - else - vout(:,:) = vin(:,:) - endif - endif - call psb_erractionrestore(err_act) return 9999 call psb_error_handler(err_act) return + End Subroutine psb_reallocate2i1d - end subroutine psb_s_ab_cpy2d - subroutine psb_d_ab_cpy1d(vin,vout,info) - use psb_error_mod + Subroutine psb_reallocate2i1c(len,rrax,y,z,info) + use psb_error_mod ! ...Subroutine Arguments - real(psb_dpk_), allocatable, intent(in) :: vin(:) - real(psb_dpk_), allocatable, intent(out) :: vout(:) + integer(psb_ipk_),Intent(in) :: len + integer(psb_ipk_),allocatable, intent(inout) :: rrax(:),y(:) + complex(psb_spk_),allocatable, intent(inout) :: z(:) integer(psb_ipk_) :: info - ! ...Local Variables - - integer(psb_ipk_) :: isz,err_act,lb - character(len=20) :: name, char_err - logical, parameter :: debug=.false. + character(len=20) :: name + integer(psb_ipk_) :: err_act, err - name='psb_safe_ab_cpy' + name='psb_reallocate2i1c' call psb_erractionsave(err_act) - info=psb_success_ - if(psb_get_errstatus() /= 0) then - info=psb_err_from_subroutine_ - goto 9999 - end if - - if (allocated(vin)) then - isz = size(vin) - lb = lbound(vin,1) - call psb_realloc(isz,vout,info,lb=lb) - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - char_err='psb_realloc' - call psb_errpush(info,name,a_err=char_err) - goto 9999 - else - vout(:) = vin(:) - endif - endif - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - - return - - end subroutine psb_d_ab_cpy1d - - subroutine psb_d_ab_cpy2d(vin,vout,info) - use psb_error_mod - - ! ...Subroutine Arguments - real(psb_dpk_), allocatable, intent(in) :: vin(:,:) - real(psb_dpk_), allocatable, intent(out) :: vout(:,:) - integer(psb_ipk_) :: info - ! ...Local Variables - integer(psb_ipk_) :: isz1, isz2,err_act, lb1, lb2 - character(len=20) :: name, char_err - logical, parameter :: debug=.false. - name='psb_safe_ab_cpy' - call psb_erractionsave(err_act) info=psb_success_ - if(psb_get_errstatus() /= 0) then - info=psb_err_from_subroutine_ + call psb_realloc(len,rrax,info) + if (info /= psb_success_) then + err=4000 + call psb_errpush(err,name) goto 9999 end if - - if (allocated(vin)) then - isz1 = size(vin,1) - isz2 = size(vin,2) - lb1 = lbound(vin,1) - lb2 = lbound(vin,2) - call psb_realloc(isz1,isz2,vout,info,lb1=lb1,lb2=lb2) - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - char_err='psb_realloc' - call psb_errpush(info,name,a_err=char_err) - goto 9999 - else - vout(:,:) = vin(:,:) - endif - endif - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - - return - - end subroutine psb_d_ab_cpy2d - - subroutine psb_c_ab_cpy1d(vin,vout,info) - use psb_error_mod - - ! ...Subroutine Arguments - complex(psb_spk_), allocatable, intent(in) :: vin(:) - complex(psb_spk_), allocatable, intent(out) :: vout(:) - integer(psb_ipk_) :: info - ! ...Local Variables - - integer(psb_ipk_) :: isz,err_act,lb - character(len=20) :: name, char_err - logical, parameter :: debug=.false. - - name='psb_safe_ab_cpy' - call psb_erractionsave(err_act) - info=psb_success_ - if(psb_get_errstatus() /= 0) then - info=psb_err_from_subroutine_ + call psb_realloc(len,y,info) + if (info /= psb_success_) then + err=4000 + call psb_errpush(err,name) goto 9999 end if - - if (allocated(vin)) then - isz = size(vin) - lb = lbound(vin,1) - call psb_realloc(isz,vout,info,lb=lb) - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - char_err='psb_realloc' - call psb_errpush(info,name,a_err=char_err) - goto 9999 - else - vout(:) = vin(:) - endif - endif - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - - return - - end subroutine psb_c_ab_cpy1d - - subroutine psb_c_ab_cpy2d(vin,vout,info) - use psb_error_mod - - ! ...Subroutine Arguments - complex(psb_spk_), allocatable, intent(in) :: vin(:,:) - complex(psb_spk_), allocatable, intent(out) :: vout(:,:) - integer(psb_ipk_) :: info - ! ...Local Variables - - integer(psb_ipk_) :: isz1, isz2,err_act, lb1, lb2 - character(len=20) :: name, char_err - logical, parameter :: debug=.false. - - name='psb_safe_ab_cpy' - call psb_erractionsave(err_act) - info=psb_success_ - if(psb_get_errstatus() /= 0) then - info=psb_err_from_subroutine_ + call psb_realloc(len,z,info) + if (info /= psb_success_) then + err=4000 + call psb_errpush(err,name) goto 9999 end if - - if (allocated(vin)) then - isz1 = size(vin,1) - isz2 = size(vin,2) - lb1 = lbound(vin,1) - lb2 = lbound(vin,2) - call psb_realloc(isz1,isz2,vout,info,lb1=lb1,lb2=lb2) - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - char_err='psb_realloc' - call psb_errpush(info,name,a_err=char_err) - goto 9999 - else - vout(:,:) = vin(:,:) - endif - endif - call psb_erractionrestore(err_act) return 9999 call psb_error_handler(err_act) return + End Subroutine psb_reallocate2i1c - end subroutine psb_c_ab_cpy2d - - subroutine psb_z_ab_cpy1d(vin,vout,info) + Subroutine psb_reallocate2i1z(len,rrax,y,z,info) use psb_error_mod - ! ...Subroutine Arguments - complex(psb_dpk_), allocatable, intent(in) :: vin(:) - complex(psb_dpk_), allocatable, intent(out) :: vout(:) + integer(psb_ipk_),Intent(in) :: len + integer(psb_ipk_),allocatable, intent(inout) :: rrax(:),y(:) + complex(psb_dpk_),allocatable, intent(inout) :: z(:) integer(psb_ipk_) :: info - ! ...Local Variables - - integer(psb_ipk_) :: isz,err_act,lb - character(len=20) :: name, char_err - logical, parameter :: debug=.false. + character(len=20) :: name + integer(psb_ipk_) :: err_act, err - name='psb_safe_ab_cpy' + name='psb_reallocate2i1z' call psb_erractionsave(err_act) + info=psb_success_ - if(psb_get_errstatus() /= 0) then - info=psb_err_from_subroutine_ + call psb_realloc(len,rrax,info) + if (info /= psb_success_) then + err=4000 + call psb_errpush(err,name) + goto 9999 + end if + call psb_realloc(len,y,info) + if (info /= psb_success_) then + err=4000 + call psb_errpush(err,name) + goto 9999 + end if + call psb_realloc(len,z,info) + if (info /= psb_success_) then + err=4000 + call psb_errpush(err,name) goto 9999 end if - if (allocated(vin)) then - isz = size(vin) - lb = lbound(vin,1) - call psb_realloc(isz,vout,info,lb=lb) - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - char_err='psb_realloc' - call psb_errpush(info,name,a_err=char_err) - goto 9999 - else - vout(:) = vin(:) - endif - endif - call psb_erractionrestore(err_act) return 9999 call psb_error_handler(err_act) return - - end subroutine psb_z_ab_cpy1d - - subroutine psb_z_ab_cpy2d(vin,vout,info) - use psb_error_mod - - ! ...Subroutine Arguments - complex(psb_dpk_), allocatable, intent(in) :: vin(:,:) - complex(psb_dpk_), allocatable, intent(out) :: vout(:,:) - integer(psb_ipk_) :: info - ! ...Local Variables - - integer(psb_ipk_) :: isz1, isz2,err_act, lb1, lb2 - character(len=20) :: name, char_err - logical, parameter :: debug=.false. - - name='psb_safe_ab_cpy' - call psb_erractionsave(err_act) - info=psb_success_ - if(psb_get_errstatus() /= 0) then - info=psb_err_from_subroutine_ - goto 9999 - end if - if (allocated(vin)) then - isz1 = size(vin,1) - isz2 = size(vin,2) - lb1 = lbound(vin,1) - lb2 = lbound(vin,2) - call psb_realloc(isz1,isz2,vout,info,lb1=lb1,lb2=lb2) - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - char_err='psb_realloc' - call psb_errpush(info,name,a_err=char_err) - goto 9999 - else - vout(:,:) = vin(:,:) - endif - endif - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - - return - - end subroutine psb_z_ab_cpy2d - - - subroutine psb_i_cpy1d(vin,vout,info) - use psb_error_mod - - ! ...Subroutine Arguments - integer(psb_ipk_), intent(in) :: vin(:) - integer(psb_ipk_), allocatable, intent(out) :: vout(:) - integer(psb_ipk_) :: info - ! ...Local Variables - - integer(psb_ipk_) :: isz,err_act,lb - character(len=20) :: name, char_err - logical, parameter :: debug=.false. - - name='psb_safe_cpy' - call psb_erractionsave(err_act) - info=psb_success_ - if(psb_get_errstatus() /= 0) then - info=psb_err_from_subroutine_ - goto 9999 - end if - isz = size(vin) - lb = lbound(vin,1) - call psb_realloc(isz,vout,info,lb=lb) - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - char_err='psb_realloc' - call psb_errpush(info,name,a_err=char_err) - goto 9999 - else - vout(:) = vin(:) - endif - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - - return - - end subroutine psb_i_cpy1d - - subroutine psb_i_cpy2d(vin,vout,info) - use psb_error_mod - - ! ...Subroutine Arguments - integer(psb_ipk_), intent(in) :: vin(:,:) - integer(psb_ipk_), allocatable, intent(out) :: vout(:,:) - integer(psb_ipk_) :: info - ! ...Local Variables - - integer(psb_ipk_) :: isz1, isz2,err_act, lb1, lb2 - character(len=20) :: name, char_err - logical, parameter :: debug=.false. - - name='psb_safe_cpy' - call psb_erractionsave(err_act) - info=psb_success_ - if(psb_get_errstatus() /= 0) then - info=psb_err_from_subroutine_ - goto 9999 - end if - - isz1 = size(vin,1) - isz2 = size(vin,2) - lb1 = lbound(vin,1) - lb2 = lbound(vin,2) - call psb_realloc(isz1,isz2,vout,info,lb1=lb1,lb2=lb2) - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - char_err='psb_realloc' - call psb_errpush(info,name,a_err=char_err) - goto 9999 - else - vout(:,:) = vin(:,:) - endif - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - - return - - end subroutine psb_i_cpy2d - - subroutine psb_s_cpy1d(vin,vout,info) - use psb_error_mod - - ! ...Subroutine Arguments - real(psb_spk_), intent(in) :: vin(:) - real(psb_spk_), allocatable, intent(out) :: vout(:) - integer(psb_ipk_) :: info - ! ...Local Variables - - integer(psb_ipk_) :: isz,err_act,lb - character(len=20) :: name, char_err - logical, parameter :: debug=.false. - - name='psb_safe_cpy' - call psb_erractionsave(err_act) - info=psb_success_ - if(psb_get_errstatus() /= 0) then - info=psb_err_from_subroutine_ - goto 9999 - end if - - isz = size(vin) - lb = lbound(vin,1) - call psb_realloc(isz,vout,info,lb=lb) - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - char_err='psb_realloc' - call psb_errpush(info,name,a_err=char_err) - goto 9999 - else - vout(:) = vin(:) - endif - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - - return - - end subroutine psb_s_cpy1d - - subroutine psb_s_cpy2d(vin,vout,info) - use psb_error_mod - - ! ...Subroutine Arguments - real(psb_spk_), intent(in) :: vin(:,:) - real(psb_spk_), allocatable, intent(out) :: vout(:,:) - integer(psb_ipk_) :: info - ! ...Local Variables - - integer(psb_ipk_) :: isz1, isz2,err_act, lb1, lb2 - character(len=20) :: name, char_err - logical, parameter :: debug=.false. - - name='psb_safe_cpy' - call psb_erractionsave(err_act) - info=psb_success_ - if(psb_get_errstatus() /= 0) then - info=psb_err_from_subroutine_ - goto 9999 - end if - - isz1 = size(vin,1) - isz2 = size(vin,2) - lb1 = lbound(vin,1) - lb2 = lbound(vin,2) - call psb_realloc(isz1,isz2,vout,info,lb1=lb1,lb2=lb2) - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - char_err='psb_realloc' - call psb_errpush(info,name,a_err=char_err) - goto 9999 - else - vout(:,:) = vin(:,:) - endif - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - - return - - end subroutine psb_s_cpy2d - - subroutine psb_d_cpy1d(vin,vout,info) - use psb_error_mod - - ! ...Subroutine Arguments - real(psb_dpk_), intent(in) :: vin(:) - real(psb_dpk_), allocatable, intent(out) :: vout(:) - integer(psb_ipk_) :: info - ! ...Local Variables - - integer(psb_ipk_) :: isz,err_act,lb - character(len=20) :: name, char_err - logical, parameter :: debug=.false. - - name='psb_safe_cpy' - call psb_erractionsave(err_act) - info=psb_success_ - if(psb_get_errstatus() /= 0) then - info=psb_err_from_subroutine_ - goto 9999 - end if - isz = size(vin) - lb = lbound(vin,1) - call psb_realloc(isz,vout,info,lb=lb) - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - char_err='psb_realloc' - call psb_errpush(info,name,a_err=char_err) - goto 9999 - else - vout(:) = vin(:) - endif - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - - return - - end subroutine psb_d_cpy1d - - subroutine psb_d_cpy2d(vin,vout,info) - use psb_error_mod - - ! ...Subroutine Arguments - real(psb_dpk_), intent(in) :: vin(:,:) - real(psb_dpk_), allocatable, intent(out) :: vout(:,:) - integer(psb_ipk_) :: info - ! ...Local Variables - - integer(psb_ipk_) :: isz1, isz2,err_act, lb1, lb2 - character(len=20) :: name, char_err - logical, parameter :: debug=.false. - - name='psb_safe_cpy' - call psb_erractionsave(err_act) - info=psb_success_ - if(psb_get_errstatus() /= 0) then - info=psb_err_from_subroutine_ - goto 9999 - end if - - isz1 = size(vin,1) - isz2 = size(vin,2) - lb1 = lbound(vin,1) - lb2 = lbound(vin,2) - call psb_realloc(isz1,isz2,vout,info,lb1=lb1,lb2=lb2) - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - char_err='psb_realloc' - call psb_errpush(info,name,a_err=char_err) - goto 9999 - else - vout(:,:) = vin(:,:) - endif - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - - return - - end subroutine psb_d_cpy2d - - subroutine psb_c_cpy1d(vin,vout,info) - use psb_error_mod - - ! ...Subroutine Arguments - complex(psb_spk_), intent(in) :: vin(:) - complex(psb_spk_), allocatable, intent(out) :: vout(:) - integer(psb_ipk_) :: info - ! ...Local Variables - - integer(psb_ipk_) :: isz,err_act,lb - character(len=20) :: name, char_err - logical, parameter :: debug=.false. - - name='psb_safe_cpy' - call psb_erractionsave(err_act) - info=psb_success_ - if(psb_get_errstatus() /= 0) then - info=psb_err_from_subroutine_ - goto 9999 - end if - - isz = size(vin) - lb = lbound(vin,1) - call psb_realloc(isz,vout,info,lb=lb) - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - char_err='psb_realloc' - call psb_errpush(info,name,a_err=char_err) - goto 9999 - else - vout(:) = vin(:) - endif - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - - return - - end subroutine psb_c_cpy1d - - subroutine psb_c_cpy2d(vin,vout,info) - use psb_error_mod - - ! ...Subroutine Arguments - complex(psb_spk_), intent(in) :: vin(:,:) - complex(psb_spk_), allocatable, intent(out) :: vout(:,:) - integer(psb_ipk_) :: info - ! ...Local Variables - - integer(psb_ipk_) :: isz1, isz2,err_act, lb1, lb2 - character(len=20) :: name, char_err - logical, parameter :: debug=.false. - - name='psb_safe_cpy' - call psb_erractionsave(err_act) - info=psb_success_ - if(psb_get_errstatus() /= 0) then - info=psb_err_from_subroutine_ - goto 9999 - end if - - isz1 = size(vin,1) - isz2 = size(vin,2) - lb1 = lbound(vin,1) - lb2 = lbound(vin,2) - call psb_realloc(isz1,isz2,vout,info,lb1=lb1,lb2=lb2) - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - char_err='psb_realloc' - call psb_errpush(info,name,a_err=char_err) - goto 9999 - else - vout(:,:) = vin(:,:) - endif - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - - return - - end subroutine psb_c_cpy2d - - subroutine psb_z_cpy1d(vin,vout,info) - use psb_error_mod - - ! ...Subroutine Arguments - complex(psb_dpk_), intent(in) :: vin(:) - complex(psb_dpk_), allocatable, intent(out) :: vout(:) - integer(psb_ipk_) :: info - ! ...Local Variables - - integer(psb_ipk_) :: isz,err_act,lb - character(len=20) :: name, char_err - logical, parameter :: debug=.false. - - name='psb_safe_cpy' - call psb_erractionsave(err_act) - info=psb_success_ - if(psb_get_errstatus() /= 0) then - info=psb_err_from_subroutine_ - goto 9999 - end if - isz = size(vin) - lb = lbound(vin,1) - call psb_realloc(isz,vout,info,lb=lb) - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - char_err='psb_realloc' - call psb_errpush(info,name,a_err=char_err) - goto 9999 - else - vout(:) = vin(:) - endif - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - - return - - end subroutine psb_z_cpy1d - - subroutine psb_z_cpy2d(vin,vout,info) - use psb_error_mod - - ! ...Subroutine Arguments - complex(psb_dpk_), intent(in) :: vin(:,:) - complex(psb_dpk_), allocatable, intent(out) :: vout(:,:) - integer(psb_ipk_) :: info - ! ...Local Variables - - integer(psb_ipk_) :: isz1, isz2,err_act, lb1, lb2 - character(len=20) :: name, char_err - logical, parameter :: debug=.false. - - name='psb_safe_cpy' - call psb_erractionsave(err_act) - - info=psb_success_ - if(psb_get_errstatus() /= 0) then - info=psb_err_from_subroutine_ - goto 9999 - end if - isz1 = size(vin,1) - isz2 = size(vin,2) - lb1 = lbound(vin,1) - lb2 = lbound(vin,2) - call psb_realloc(isz1,isz2,vout,info,lb1=lb1,lb2=lb2) - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - char_err='psb_realloc' - call psb_errpush(info,name,a_err=char_err) - goto 9999 - else - vout(:,:) = vin(:,:) - endif - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - - return - - end subroutine psb_z_cpy2d - - - function psb_isize1d(vin) - integer(psb_ipk_) :: psb_isize1d - integer(psb_ipk_), allocatable, intent(in) :: vin(:) - - if (.not.allocated(vin)) then - psb_isize1d = 0 - else - psb_isize1d = size(vin) - end if - end function psb_isize1d - - function psb_isize2d(vin,dim) - integer(psb_ipk_) :: psb_isize2d - integer(psb_ipk_), allocatable, intent(in) :: vin(:,:) - integer(psb_ipk_), optional :: dim - integer(psb_ipk_) :: dim_ - - if (.not.allocated(vin)) then - psb_isize2d = 0 - else - if (present(dim)) then - dim_= dim - psb_isize2d = size(vin,dim=dim_) - else - psb_isize2d = size(vin) - end if - end if - end function psb_isize2d - -#if !defined(LONG_INTEGERS) - function psb_i8size1d(vin) - integer(psb_ipk_) :: psb_i8size1d - integer(psb_epk_), allocatable, intent(in) :: vin(:) - - if (.not.allocated(vin)) then - psb_i8size1d = 0 - else - psb_i8size1d = size(vin) - end if - end function psb_i8size1d - - function psb_i8size2d(vin,dim) - integer(psb_ipk_) :: psb_i8size2d - integer(psb_epk_), allocatable, intent(in) :: vin(:,:) - integer(psb_ipk_), optional :: dim - integer(psb_ipk_) :: dim_ - - if (.not.allocated(vin)) then - psb_i8size2d = 0 - else - if (present(dim)) then - dim_= dim - psb_i8size2d = size(vin,dim=dim_) - else - psb_i8size2d = size(vin) - end if - end if - end function psb_i8size2d -#endif - - function psb_ssize1d(vin) - integer(psb_ipk_) :: psb_ssize1d - real(psb_spk_), allocatable, intent(in) :: vin(:) - - if (.not.allocated(vin)) then - psb_ssize1d = 0 - else - psb_ssize1d = size(vin) - end if - end function psb_ssize1d - - function psb_ssize2d(vin,dim) - integer(psb_ipk_) :: psb_ssize2d - real(psb_spk_), allocatable, intent(in) :: vin(:,:) - integer(psb_ipk_), optional :: dim - integer(psb_ipk_) :: dim_ - - - if (.not.allocated(vin)) then - psb_ssize2d = 0 - else - if (present(dim)) then - dim_= dim - psb_ssize2d = size(vin,dim=dim_) - else - psb_ssize2d = size(vin) - end if - end if - end function psb_ssize2d - - function psb_dsize1d(vin) - integer(psb_ipk_) :: psb_dsize1d - real(psb_dpk_), allocatable, intent(in) :: vin(:) - - if (.not.allocated(vin)) then - psb_dsize1d = 0 - else - psb_dsize1d = size(vin) - end if - end function psb_dsize1d - - function psb_dsize2d(vin,dim) - integer(psb_ipk_) :: psb_dsize2d - real(psb_dpk_), allocatable, intent(in) :: vin(:,:) - integer(psb_ipk_), optional :: dim - integer(psb_ipk_) :: dim_ - - - if (.not.allocated(vin)) then - psb_dsize2d = 0 - else - if (present(dim)) then - dim_= dim - psb_dsize2d = size(vin,dim=dim_) - else - psb_dsize2d = size(vin) - end if - end if - end function psb_dsize2d - - - function psb_csize1d(vin) - integer(psb_ipk_) :: psb_csize1d - complex(psb_spk_), allocatable, intent(in) :: vin(:) - - if (.not.allocated(vin)) then - psb_csize1d = 0 - else - psb_csize1d = size(vin) - end if - end function psb_csize1d - - function psb_csize2d(vin,dim) - integer(psb_ipk_) :: psb_csize2d - complex(psb_spk_), allocatable, intent(in) :: vin(:,:) - integer(psb_ipk_), optional :: dim - integer(psb_ipk_) :: dim_ - - if (.not.allocated(vin)) then - psb_csize2d = 0 - else - if (present(dim)) then - dim_= dim - psb_csize2d = size(vin,dim=dim_) - else - psb_csize2d = size(vin) - end if - end if - end function psb_csize2d - - function psb_zsize1d(vin) - integer(psb_ipk_) :: psb_zsize1d - complex(psb_dpk_), allocatable, intent(in) :: vin(:) - - if (.not.allocated(vin)) then - psb_zsize1d = 0 - else - psb_zsize1d = size(vin) - end if - end function psb_zsize1d - - function psb_zsize2d(vin,dim) - integer(psb_ipk_) :: psb_zsize2d - complex(psb_dpk_), allocatable, intent(in) :: vin(:,:) - integer(psb_ipk_), optional :: dim - integer(psb_ipk_) :: dim_ - - if (.not.allocated(vin)) then - psb_zsize2d = 0 - else - if (present(dim)) then - dim_= dim - psb_zsize2d = size(vin,dim=dim_) - else - psb_zsize2d = size(vin) - end if - end if - end function psb_zsize2d - - - Subroutine psb_icksz1d(len,v,info,pad,addsz,newsz) - use psb_error_mod - - ! ...Subroutine Arguments - integer(psb_ipk_),Intent(in) :: len - integer(psb_ipk_),allocatable, intent(inout) :: v(:) - integer(psb_ipk_) :: info - integer(psb_ipk_), optional, intent(in) :: pad - integer(psb_ipk_), optional, intent(in) :: addsz,newsz - ! ...Local Variables - character(len=20) :: name - logical, parameter :: debug=.false. - integer(psb_ipk_) :: isz, err_act - - name='psb_ensure_size' - call psb_erractionsave(err_act) - info=psb_success_ - - if(psb_get_errstatus() /= 0) then - info=psb_err_from_subroutine_ - goto 9999 - end if - - If (len > psb_size(v)) Then - if (present(newsz)) then - isz = (max(len+1,newsz)) - else - if (present(addsz)) then - isz = len+max(1,addsz) - else - isz = max(len+10, int(1.25*len)) - endif - endif - call psb_realloc(isz,v,info,pad=pad) - - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - call psb_errpush(info,name,a_err='psb_realloc') - goto 9999 - end if - end If - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - - return - - - End Subroutine psb_icksz1d - -#if !defined(LONG_INTEGERS) - Subroutine psb_i8cksz1d(len,v,info,pad,addsz,newsz) - use psb_error_mod - - ! ...Subroutine Arguments - integer(psb_ipk_),Intent(in) :: len - Integer(psb_epk_),allocatable, intent(inout) :: v(:) - integer(psb_ipk_) :: info - integer(psb_epk_), optional, intent(in) :: pad - integer(psb_ipk_), optional, intent(in) :: addsz,newsz - ! ...Local Variables - character(len=20) :: name - logical, parameter :: debug=.false. - integer(psb_ipk_) :: isz, err_act - - name='psb_ensure_size' - call psb_erractionsave(err_act) - info=psb_success_ - - if(psb_get_errstatus() /= 0) then - info=psb_err_from_subroutine_ - goto 9999 - end if - - If (len > psb_size(v)) Then - if (present(newsz)) then - isz = (max(len+1,newsz)) - else - if (present(addsz)) then - isz = len+max(1,addsz) - else - isz = max(len+10, int(1.25*len)) - endif - endif - call psb_realloc(isz,v,info,pad=pad) - - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - call psb_errpush(info,name,a_err='psb_realloc') - goto 9999 - end if - end If - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - - return - - End Subroutine psb_i8cksz1d -#endif - - Subroutine psb_scksz1d(len,v,info,pad,addsz,newsz) - use psb_error_mod - - ! ...Subroutine Arguments - integer(psb_ipk_),Intent(in) :: len - real(psb_spk_),allocatable, intent(inout) :: v(:) - integer(psb_ipk_) :: info - integer(psb_ipk_), optional, intent(in) :: addsz,newsz - real(psb_spk_), optional, intent(in) :: pad - ! ...Local Variables - character(len=20) :: name - logical, parameter :: debug=.false. - integer(psb_ipk_) :: isz, err_act - - name='psb_ensure_size' - call psb_erractionsave(err_act) - info=psb_success_ - - if(psb_get_errstatus() /= 0) then - info=psb_err_from_subroutine_ - goto 9999 - end if - - If (len > psb_size(v)) Then - if (present(newsz)) then - isz = (max(len+1,newsz)) - else - if (present(addsz)) then - isz = len+max(1,addsz) - else - isz = max(len+10, int(1.25*len)) - endif - endif - - call psb_realloc(isz,v,info,pad=pad) - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - call psb_errpush(info,name,a_err='psb_realloc') - goto 9999 - End If - end If - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - - return - - - End Subroutine psb_scksz1d - - Subroutine psb_dcksz1d(len,v,info,pad,addsz,newsz) - use psb_error_mod - - ! ...Subroutine Arguments - integer(psb_ipk_),Intent(in) :: len - real(psb_dpk_),allocatable, intent(inout) :: v(:) - integer(psb_ipk_) :: info - integer(psb_ipk_), optional, intent(in) :: addsz,newsz - real(psb_dpk_), optional, intent(in) :: pad - ! ...Local Variables - character(len=20) :: name - logical, parameter :: debug=.false. - integer(psb_ipk_) :: isz, err_act - - name='psb_ensure_size' - call psb_erractionsave(err_act) - info=psb_success_ - - if(psb_get_errstatus() /= 0) then - info=psb_err_from_subroutine_ - goto 9999 - end if - - If (len > psb_size(v)) Then - if (present(newsz)) then - isz = (max(len+1,newsz)) - else - if (present(addsz)) then - isz = len+max(1,addsz) - else - isz = max(len+10, int(1.25*len)) - endif - endif - - call psb_realloc(isz,v,info,pad=pad) - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - call psb_errpush(info,name,a_err='psb_realloc') - goto 9999 - End If - end If - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - - return - - - End Subroutine psb_dcksz1d - - - Subroutine psb_ccksz1d(len,v,info,pad,addsz,newsz) - use psb_error_mod - - ! ...Subroutine Arguments - integer(psb_ipk_),Intent(in) :: len - complex(psb_spk_),allocatable, intent(inout) :: v(:) - integer(psb_ipk_) :: info - integer(psb_ipk_), optional, intent(in) :: addsz,newsz - complex(psb_spk_), optional, intent(in) :: pad - ! ...Local Variables - character(len=20) :: name - logical, parameter :: debug=.false. - integer(psb_ipk_) :: isz, err_act - - name='psb_ensure_size' - call psb_erractionsave(err_act) - info=psb_success_ - - if(psb_get_errstatus() /= 0) then - info=psb_err_from_subroutine_ - goto 9999 - end if - - If (len > psb_size(v)) Then - if (present(newsz)) then - isz = (max(len+1,newsz)) - else - if (present(addsz)) then - isz = len+max(1,addsz) - else - isz = max(len+10, int(1.25*len)) - endif - endif - call psb_realloc(isz,v,info,pad=pad) - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - call psb_errpush(info,name,a_err='psb_realloc') - goto 9999 - end if - end If - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - - return - - - End Subroutine psb_ccksz1d - - - Subroutine psb_zcksz1d(len,v,info,pad,addsz,newsz) - use psb_error_mod - - ! ...Subroutine Arguments - integer(psb_ipk_),Intent(in) :: len - complex(psb_dpk_),allocatable, intent(inout) :: v(:) - integer(psb_ipk_) :: info - integer(psb_ipk_), optional, intent(in) :: addsz,newsz - complex(psb_dpk_), optional, intent(in) :: pad - ! ...Local Variables - character(len=20) :: name - logical, parameter :: debug=.false. - integer(psb_ipk_) :: isz, err_act - - name='psb_ensure_size' - call psb_erractionsave(err_act) - info=psb_success_ - - if(psb_get_errstatus() /= 0) then - info=psb_err_from_subroutine_ - goto 9999 - end if - - If (len > psb_size(v)) Then - if (present(newsz)) then - isz = (max(len+1,newsz)) - else - if (present(addsz)) then - isz = len+max(1,addsz) - else - isz = max(len+10, int(1.25*len)) - endif - endif - call psb_realloc(isz,v,info,pad=pad) - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - call psb_errpush(info,name,a_err='psb_realloc') - goto 9999 - end if - end If - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - - return - - - End Subroutine psb_zcksz1d - - - Subroutine psb_reallocate1i(len,rrax,info,pad,lb) - use psb_error_mod - - ! ...Subroutine Arguments - integer(psb_ipk_),Intent(in) :: len - integer(psb_ipk_),allocatable, intent(inout) :: rrax(:) - integer(psb_ipk_) :: info - integer(psb_ipk_), optional, intent(in) :: pad - integer(psb_ipk_), optional, intent(in) :: lb - ! ...Local Variables - integer(psb_ipk_),allocatable :: tmp(:) - integer(psb_ipk_) :: dim, err_act, err,lb_, lbi, ub_ - character(len=20) :: name - logical, parameter :: debug=.false. - - name='psb_reallocate1i' - call psb_erractionsave(err_act) - info=psb_success_ - - if (debug) write(psb_err_unit,*) 'reallocate I',len - if (psb_get_errstatus() /= 0) then - if (debug) write(psb_err_unit,*) 'reallocate errstatus /= 0' - info=psb_err_from_subroutine_ - goto 9999 - end if - - if (present(lb)) then - lb_ = lb - else - lb_ = 1 - endif - if ((len<0)) then - err=4025 - call psb_errpush(err,name,& - & i_err=(/len,izero,izero,izero,izero/),a_err='integer') - goto 9999 - end if - ub_ = lb_+len-1 - if (debug) write(psb_err_unit,*) 'reallocate : lb ub ',lb_, ub_ - if (allocated(rrax)) then - dim = size(rrax) - lbi = lbound(rrax,1) - If ((dim /= len).or.(lbi /= lb_)) Then - Allocate(tmp(lb_:ub_),stat=info) - if (info /= psb_success_) then - err=4025 - call psb_errpush(err,name, & - & i_err=(/len,izero,izero,izero,izero/),a_err='integer') - goto 9999 - end if - tmp(lb_:lb_-1+min(len,dim))=rrax(lbi:lbi-1+min(len,dim)) - if (debug) write(psb_err_unit,*) 'reallocate : calling move_alloc ' - call psb_move_alloc(tmp,rrax,info) - if (debug) write(psb_err_unit,*) 'reallocate : from move_alloc ',info - end if - else - dim = 0 - allocate(rrax(lb_:ub_),stat=info) - if (info /= psb_success_) then - err=4025 - call psb_errpush(err,name, & - & i_err=(/len,izero,izero,izero,izero/),a_err='integer') - goto 9999 - end if - endif - if (present(pad)) then - rrax(lb_-1+dim+1:lb_-1+len) = pad - endif - if (debug) write(psb_err_unit,*) 'end reallocate : ',info - call psb_erractionrestore(err_act) - return - -9999 continue - info = err - - call psb_error_handler(err_act) - - return - - End Subroutine psb_reallocate1i - - Subroutine psb_reallocate1s(len,rrax,info,pad,lb) - use psb_error_mod - - ! ...Subroutine Arguments - integer(psb_ipk_),Intent(in) :: len - Real(psb_spk_),allocatable, intent(inout) :: rrax(:) - integer(psb_ipk_) :: info - real(psb_spk_), optional, intent(in) :: pad - integer(psb_ipk_), optional, intent(in) :: lb - - ! ...Local Variables - Real(psb_spk_),allocatable :: tmp(:) - integer(psb_ipk_) :: dim,err_act,err, lb_, lbi,ub_ - character(len=20) :: name - logical, parameter :: debug=.false. - - name='psb_reallocate1s' - call psb_erractionsave(err_act) - info=psb_success_ - if (debug) write(psb_err_unit,*) 'reallocate S',len - - if (present(lb)) then - lb_ = lb - else - lb_ = 1 - endif - if ((len<0)) then - err=4025 - call psb_errpush(err,name, & - & i_err=(/len,izero,izero,izero,izero/),a_err='real(psb_spk_)') - goto 9999 - end if - ub_ = lb_ + len-1 - - if (allocated(rrax)) then - dim = size(rrax) - lbi = lbound(rrax,1) - If ((dim /= len).or.(lbi /= lb_)) Then - Allocate(tmp(lb_:ub_),stat=info) - if (info /= psb_success_) then - err=4025 - call psb_errpush(err,name, & - & i_err=(/len,izero,izero,izero,izero/),a_err='real(psb_spk_)') - goto 9999 - end if - tmp(lb_:lb_-1+min(len,dim))=rrax(lbi:lbi-1+min(len,dim)) - call psb_move_alloc(tmp,rrax,info) - End If - else - dim = 0 - Allocate(rrax(lb_:ub_),stat=info) - if (info /= psb_success_) then - err=4025 - call psb_errpush(err,name, & - & i_err=(/len,izero,izero,izero,izero/),a_err='real(psb_spk_)') - goto 9999 - end if - endif - if (present(pad)) then - rrax(lb_-1+dim+1:lb_-1+len) = pad - endif - call psb_erractionrestore(err_act) - return - -9999 continue - info = err - call psb_error_handler(err_act) - return - - End Subroutine psb_reallocate1s - - Subroutine psb_reallocate1d(len,rrax,info,pad,lb) - use psb_error_mod - - ! ...Subroutine Arguments - integer(psb_ipk_),Intent(in) :: len - Real(psb_dpk_),allocatable, intent(inout) :: rrax(:) - integer(psb_ipk_) :: info - real(psb_dpk_), optional, intent(in) :: pad - integer(psb_ipk_), optional, intent(in) :: lb - - ! ...Local Variables - Real(psb_dpk_),allocatable :: tmp(:) - integer(psb_ipk_) :: dim,err_act,err, lb_, lbi,ub_ - character(len=20) :: name - logical, parameter :: debug=.false. - - name='psb_reallocate1d' - call psb_erractionsave(err_act) - info=psb_success_ - if (debug) write(psb_err_unit,*) 'reallocate D',len - - if (present(lb)) then - lb_ = lb - else - lb_ = 1 - endif - if ((len<0)) then - err=4025 - call psb_errpush(err,name, & - & i_err=(/len,izero,izero,izero,izero/),a_err='real(psb_dpk_)') - goto 9999 - end if - ub_ = lb_ + len-1 - - if (allocated(rrax)) then - dim = size(rrax) - lbi = lbound(rrax,1) - If ((dim /= len).or.(lbi /= lb_)) Then - Allocate(tmp(lb_:ub_),stat=info) - if (info /= psb_success_) then - err=4025 - call psb_errpush(err,name, & - & i_err=(/len,izero,izero,izero,izero/),a_err='real(psb_dpk_)') - goto 9999 - end if - tmp(lb_:lb_-1+min(len,dim))=rrax(lbi:lbi-1+min(len,dim)) - call psb_move_alloc(tmp,rrax,info) - End If - else - dim = 0 - Allocate(rrax(lb_:ub_),stat=info) - if (info /= psb_success_) then - err=4025 - call psb_errpush(err,name, & - & i_err=(/len,izero,izero,izero,izero/),a_err='real(psb_dpk_)') - goto 9999 - end if - endif - if (present(pad)) then - rrax(lb_-1+dim+1:lb_-1+len) = pad - endif - call psb_erractionrestore(err_act) - return - -9999 continue - info = err - call psb_error_handler(err_act) - return - - End Subroutine psb_reallocate1d - - - Subroutine psb_reallocate1c(len,rrax,info,pad,lb) - use psb_error_mod - - ! ...Subroutine Arguments - integer(psb_ipk_),Intent(in) :: len - complex(psb_spk_),allocatable, intent(inout):: rrax(:) - integer(psb_ipk_) :: info - complex(psb_spk_), optional, intent(in) :: pad - integer(psb_ipk_), optional, intent(in) :: lb - - ! ...Local Variables - complex(psb_spk_),allocatable :: tmp(:) - integer(psb_ipk_) :: dim,err_act,err,lb_,ub_,lbi - character(len=20) :: name - logical, parameter :: debug=.false. - - name='psb_reallocate1c' - call psb_erractionsave(err_act) - info=psb_success_ - if (debug) write(psb_err_unit,*) 'reallocate C',len - if (present(lb)) then - lb_ = lb - else - lb_ = 1 - endif - if ((len<0)) then - err=4025 - call psb_errpush(err,name, & - & i_err=(/len,izero,izero,izero,izero/),a_err='complex(psb_spk_)') - goto 9999 - end if - ub_ = lb_+len-1 - - if (allocated(rrax)) then - dim = size(rrax) - lbi = lbound(rrax,1) - If ((dim /= len).or.(lbi /= lb_)) Then - Allocate(tmp(lb_:ub_),stat=info) - if (info /= psb_success_) then - err=4025 - call psb_errpush(err,name, & - & i_err=(/len,izero,izero,izero,izero/),a_err='complex(psb_spk_)') - goto 9999 - end if - tmp(lb_:lb_-1+min(len,dim))=rrax(lbi:lbi-1+min(len,dim)) - call psb_move_alloc(tmp,rrax,info) - end if - else - dim = 0 - Allocate(rrax(lb_:ub_),stat=info) - if (info /= psb_success_) then - err=4025 - call psb_errpush(err,name, & - & i_err=(/len,izero,izero,izero,izero/),a_err='complex(psb_spk_)') - goto 9999 - end if - endif - if (present(pad)) then - rrax(lb_-1+dim+1:lb_-1+len) = pad - endif - call psb_erractionrestore(err_act) - return - -9999 continue - info = err - call psb_error_handler(err_act) - return - - End Subroutine psb_reallocate1c - - Subroutine psb_reallocate1z(len,rrax,info,pad,lb) - use psb_error_mod - - ! ...Subroutine Arguments - integer(psb_ipk_),Intent(in) :: len - complex(psb_dpk_),allocatable, intent(inout):: rrax(:) - integer(psb_ipk_) :: info - complex(psb_dpk_), optional, intent(in) :: pad - integer(psb_ipk_), optional, intent(in) :: lb - - ! ...Local Variables - complex(psb_dpk_),allocatable :: tmp(:) - integer(psb_ipk_) :: dim,err_act,err,lb_,ub_,lbi - character(len=20) :: name - logical, parameter :: debug=.false. - - name='psb_reallocate1z' - call psb_erractionsave(err_act) - info=psb_success_ - if (debug) write(psb_err_unit,*) 'reallocate Z',len - if (present(lb)) then - lb_ = lb - else - lb_ = 1 - endif - if ((len<0)) then - err=4025 - call psb_errpush(err,name, & - & i_err=(/len,izero,izero,izero,izero/),a_err='complex(psb_dpk_)') - goto 9999 - end if - ub_ = lb_+len-1 - - if (allocated(rrax)) then - dim = size(rrax) - lbi = lbound(rrax,1) - If ((dim /= len).or.(lbi /= lb_)) Then - Allocate(tmp(lb_:ub_),stat=info) - if (info /= psb_success_) then - err=4025 - call psb_errpush(err,name, & - & i_err=(/len,izero,izero,izero,izero/),a_err='complex(psb_dpk_)') - goto 9999 - end if - tmp(lb_:lb_-1+min(len,dim))=rrax(lbi:lbi-1+min(len,dim)) - call psb_move_alloc(tmp,rrax,info) - end if - else - dim = 0 - Allocate(rrax(lb_:ub_),stat=info) - if (info /= psb_success_) then - err=4025 - call psb_errpush(err,name, & - & i_err=(/len,izero,izero,izero,izero/),a_err='complex(psb_dpk_)') - goto 9999 - end if - endif - if (present(pad)) then - rrax(lb_-1+dim+1:lb_-1+len) = pad - endif - call psb_erractionrestore(err_act) - return - -9999 continue - info = err - call psb_error_handler(err_act) - return - - End Subroutine psb_reallocate1z - - - - Subroutine psb_reallocates2(len1,len2,rrax,info,pad,lb1,lb2) - use psb_error_mod - ! ...Subroutine Arguments - integer(psb_ipk_),Intent(in) :: len1,len2 - Real(psb_spk_),allocatable :: rrax(:,:) - integer(psb_ipk_) :: info - real(psb_spk_), optional, intent(in) :: pad - integer(psb_ipk_),Intent(in), optional :: lb1,lb2 - - ! ...Local Variables - - Real(psb_spk_),allocatable :: tmp(:,:) - integer(psb_ipk_) :: dim,err_act,err, dim2,lb1_, lb2_, ub1_, ub2_,& - & lbi1, lbi2 - character(len=20) :: name - - name='psb_reallocates2' - call psb_erractionsave(err_act) - info=psb_success_ - if (present(lb1)) then - lb1_ = lb1 - else - lb1_ = 1 - endif - if (present(lb2)) then - lb2_ = lb2 - else - lb2_ = 1 - endif - ub1_ = lb1_ + len1 -1 - ub2_ = lb2_ + len2 -1 - - if (len1 < 0) then - err=4025 - call psb_errpush(err,name, & - & i_err=(/len1,izero,izero,izero,izero/),a_err='real(psb_spk_)') - goto 9999 - end if - if (len2 < 0) then - err=4025 - call psb_errpush(err,name, & - & i_err=(/len2,izero,izero,izero,izero/),a_err='real(psb_spk_)') - goto 9999 - end if - - - if (allocated(rrax)) then - dim = size(rrax,1) - lbi1 = lbound(rrax,1) - dim2 = size(rrax,2) - lbi2 = lbound(rrax,2) - If ((dim /= len1).or.(dim2 /= len2).or.(lbi1 /= lb1_)& - & .or.(lbi2 /= lb2_)) Then - Allocate(tmp(lb1_:ub1_,lb2_:ub2_),stat=info) - if (info /= psb_success_) then - err=4025 - call psb_errpush(err,name, & - & i_err=(/len1*len2,izero,izero,izero,izero/),a_err='real(psb_spk_)') - goto 9999 - end if - tmp(lb1_:lb1_-1+min(len1,dim),lb2_:lb2_-1+min(len2,dim2)) = & - & rrax(lbi1:lbi1-1+min(len1,dim),lbi2:lbi2-1+min(len2,dim2)) - call psb_move_alloc(tmp,rrax,info) - End If - else - dim = 0 - dim2 = 0 - Allocate(rrax(lb1_:ub1_,lb2_:ub2_),stat=info) - if (info /= psb_success_) then - err=4025 - call psb_errpush(err,name, & - & i_err=(/len1*len2,izero,izero,izero,izero/),a_err='real(psb_spk_)') - goto 9999 - end if - endif - if (present(pad)) then - rrax(lb1_-1+dim+1:lb1_-1+len1,:) = pad - rrax(lb1_:lb1_-1+dim,lb2_-1+dim2+1:lb2_-1+len2) = pad - endif - call psb_erractionrestore(err_act) - return - -9999 continue - info = err - call psb_error_handler(err_act) - return - - End Subroutine psb_reallocates2 - - - Subroutine psb_reallocated2(len1,len2,rrax,info,pad,lb1,lb2) - use psb_error_mod - ! ...Subroutine Arguments - integer(psb_ipk_),Intent(in) :: len1,len2 - Real(psb_dpk_),allocatable :: rrax(:,:) - integer(psb_ipk_) :: info - real(psb_dpk_), optional, intent(in) :: pad - integer(psb_ipk_),Intent(in), optional :: lb1,lb2 - - ! ...Local Variables - - Real(psb_dpk_),allocatable :: tmp(:,:) - integer(psb_ipk_) :: dim,err_act,err, dim2,lb1_, lb2_, ub1_, ub2_,& - & lbi1, lbi2 - character(len=20) :: name - - name='psb_reallocated2' - call psb_erractionsave(err_act) - info=psb_success_ - if (present(lb1)) then - lb1_ = lb1 - else - lb1_ = 1 - endif - if (present(lb2)) then - lb2_ = lb2 - else - lb2_ = 1 - endif - ub1_ = lb1_ + len1 -1 - ub2_ = lb2_ + len2 -1 - - if (len1 < 0) then - err=4025 - call psb_errpush(err,name, & - & i_err=(/len1,izero,izero,izero,izero/),a_err='real(psb_dpk_)') - goto 9999 - end if - if (len2 < 0) then - err=4025 - call psb_errpush(err,name, & - & i_err=(/len2,izero,izero,izero,izero/),a_err='real(psb_dpk_)') - goto 9999 - end if - - - if (allocated(rrax)) then - dim = size(rrax,1) - lbi1 = lbound(rrax,1) - dim2 = size(rrax,2) - lbi2 = lbound(rrax,2) - If ((dim /= len1).or.(dim2 /= len2).or.(lbi1 /= lb1_)& - & .or.(lbi2 /= lb2_)) Then - Allocate(tmp(lb1_:ub1_,lb2_:ub2_),stat=info) - if (info /= psb_success_) then - err=4025 - call psb_errpush(err,name, & - & i_err=(/len1*len2,izero,izero,izero,izero/),a_err='real(psb_dpk_)') - goto 9999 - end if - tmp(lb1_:lb1_-1+min(len1,dim),lb2_:lb2_-1+min(len2,dim2)) = & - & rrax(lbi1:lbi1-1+min(len1,dim),lbi2:lbi2-1+min(len2,dim2)) - call psb_move_alloc(tmp,rrax,info) - End If - else - dim = 0 - dim2 = 0 - Allocate(rrax(lb1_:ub1_,lb2_:ub2_),stat=info) - if (info /= psb_success_) then - err=4025 - call psb_errpush(err,name, & - & i_err=(/len1*len2,izero,izero,izero,izero/),a_err='real(psb_dpk_)') - goto 9999 - end if - endif - if (present(pad)) then - rrax(lb1_-1+dim+1:lb1_-1+len1,:) = pad - rrax(lb1_:lb1_-1+dim,lb2_-1+dim2+1:lb2_-1+len2) = pad - endif - call psb_erractionrestore(err_act) - return - -9999 continue - info = err - call psb_error_handler(err_act) - return - - End Subroutine psb_reallocated2 - - - Subroutine psb_reallocatec2(len1,len2,rrax,info,pad,lb1,lb2) - use psb_error_mod - ! ...Subroutine Arguments - integer(psb_ipk_),Intent(in) :: len1,len2 - complex(psb_spk_),allocatable :: rrax(:,:) - integer(psb_ipk_) :: info - complex(psb_spk_), optional, intent(in) :: pad - integer(psb_ipk_),Intent(in), optional :: lb1,lb2 - - ! ...Local Variables - - complex(psb_spk_),allocatable :: tmp(:,:) - integer(psb_ipk_) :: dim,err_act,err,dim2,lb1_, lb2_, ub1_, ub2_,& - & lbi1, lbi2 - character(len=20) :: name - - name='psb_reallocatec2' - call psb_erractionsave(err_act) - info=psb_success_ - if (present(lb1)) then - lb1_ = lb1 - else - lb1_ = 1 - endif - if (present(lb2)) then - lb2_ = lb2 - else - lb2_ = 1 - endif - ub1_ = lb1_ + len1 -1 - ub2_ = lb2_ + len2 -1 - - if (len1 < 0) then - err=4025 - call psb_errpush(err,name, & - & i_err=(/len1,izero,izero,izero,izero/),a_err='complex(psb_spk_)') - goto 9999 - end if - if (len2 < 0) then - err=4025 - call psb_errpush(err,name, & - & i_err=(/len2,izero,izero,izero,izero/),a_err='complex(psb_spk_)') - goto 9999 - end if - - - if (allocated(rrax)) then - dim = size(rrax,1) - lbi1 = lbound(rrax,1) - dim2 = size(rrax,2) - lbi2 = lbound(rrax,2) - If ((dim /= len1).or.(dim2 /= len2).or.(lbi1 /= lb1_)& - & .or.(lbi2 /= lb2_)) Then - Allocate(tmp(lb1_:ub1_,lb2_:ub2_),stat=info) - if (info /= psb_success_) then - err=4025 - call psb_errpush(err,name, & - & i_err=(/len1*len2,izero,izero,izero,izero/),a_err='complex(psb_spk_)') - goto 9999 - end if - tmp(lb1_:lb1_-1+min(len1,dim),lb2_:lb2_-1+min(len2,dim2)) = & - & rrax(lbi1:lbi1-1+min(len1,dim),lbi2:lbi2-1+min(len2,dim2)) - call psb_move_alloc(tmp,rrax,info) - End If - else - dim = 0 - dim2 = 0 - Allocate(rrax(lb1_:ub1_,lb2_:ub2_),stat=info) - if (info /= psb_success_) then - err=4025 - call psb_errpush(err,name, & - & i_err=(/len1*len2,izero,izero,izero,izero/),a_err='complex(psb_spk_)') - goto 9999 - end if - endif - if (present(pad)) then - rrax(lb1_-1+dim+1:lb1_-1+len1,:) = pad - rrax(lb1_:lb1_-1+dim,lb2_-1+dim2+1:lb2_-1+len2) = pad - endif - - call psb_erractionrestore(err_act) - return - -9999 continue - info = err - call psb_error_handler(err_act) - return - - End Subroutine psb_reallocatec2 - - Subroutine psb_reallocatez2(len1,len2,rrax,info,pad,lb1,lb2) - use psb_error_mod - ! ...Subroutine Arguments - integer(psb_ipk_),Intent(in) :: len1,len2 - complex(psb_dpk_),allocatable :: rrax(:,:) - integer(psb_ipk_) :: info - complex(psb_dpk_), optional, intent(in) :: pad - integer(psb_ipk_),Intent(in), optional :: lb1,lb2 - - ! ...Local Variables - - complex(psb_dpk_),allocatable :: tmp(:,:) - integer(psb_ipk_) :: dim,err_act,err,dim2,lb1_, lb2_, ub1_, ub2_,& - & lbi1, lbi2 - character(len=20) :: name - - name='psb_reallocatez2' - call psb_erractionsave(err_act) - info=psb_success_ - if (present(lb1)) then - lb1_ = lb1 - else - lb1_ = 1 - endif - if (present(lb2)) then - lb2_ = lb2 - else - lb2_ = 1 - endif - ub1_ = lb1_ + len1 -1 - ub2_ = lb2_ + len2 -1 - - if (len1 < 0) then - err=4025 - call psb_errpush(err,name, & - & i_err=(/len1,izero,izero,izero,izero/),a_err='complex(psb_dpk_)') - goto 9999 - end if - if (len2 < 0) then - err=4025 - call psb_errpush(err,name, & - & i_err=(/len2,izero,izero,izero,izero/),a_err='complex(psb_dpk_)') - goto 9999 - end if - - - if (allocated(rrax)) then - dim = size(rrax,1) - lbi1 = lbound(rrax,1) - dim2 = size(rrax,2) - lbi2 = lbound(rrax,2) - If ((dim /= len1).or.(dim2 /= len2).or.(lbi1 /= lb1_)& - & .or.(lbi2 /= lb2_)) Then - Allocate(tmp(lb1_:ub1_,lb2_:ub2_),stat=info) - if (info /= psb_success_) then - err=4025 - call psb_errpush(err,name, & - & i_err=(/len1*len2,izero,izero,izero,izero/),a_err='complex(psb_dpk_)') - goto 9999 - end if - tmp(lb1_:lb1_-1+min(len1,dim),lb2_:lb2_-1+min(len2,dim2)) = & - & rrax(lbi1:lbi1-1+min(len1,dim),lbi2:lbi2-1+min(len2,dim2)) - call psb_move_alloc(tmp,rrax,info) - End If - else - dim = 0 - dim2 = 0 - Allocate(rrax(lb1_:ub1_,lb2_:ub2_),stat=info) - if (info /= psb_success_) then - err=4025 - call psb_errpush(err,name, & - & i_err=(/len1*len2,izero,izero,izero,izero/),a_err='complex(psb_dpk_)') - goto 9999 - end if - endif - if (present(pad)) then - rrax(lb1_-1+dim+1:lb1_-1+len1,:) = pad - rrax(lb1_:lb1_-1+dim,lb2_-1+dim2+1:lb2_-1+len2) = pad - endif - - call psb_erractionrestore(err_act) - return - -9999 continue - info = err - call psb_error_handler(err_act) - return - - End Subroutine psb_reallocatez2 - - - Subroutine psb_reallocatei2(len1,len2,rrax,info,pad,lb1,lb2) - use psb_error_mod - ! ...Subroutine Arguments - integer(psb_ipk_),Intent(in) :: len1,len2 - integer(psb_ipk_),allocatable :: rrax(:,:) - integer(psb_ipk_) :: info - integer(psb_ipk_), optional, intent(in) :: pad - integer(psb_ipk_),Intent(in), optional :: lb1,lb2 - - ! ...Local Variables - integer(psb_ipk_),allocatable :: tmp(:,:) - integer(psb_ipk_) :: dim,err_act,err, dim2,lb1_, lb2_, ub1_, ub2_,& - & lbi1, lbi2 - character(len=20) :: name - - name='psb_reallocatei2' - call psb_erractionsave(err_act) - info=psb_success_ - if (present(lb1)) then - lb1_ = lb1 - else - lb1_ = 1 - endif - if (present(lb2)) then - lb2_ = lb2 - else - lb2_ = 1 - endif - ub1_ = lb1_ + len1 -1 - ub2_ = lb2_ + len2 -1 - - if (len1 < 0) then - err=4025 - call psb_errpush(err,name, & - & i_err=(/len1,izero,izero,izero,izero/),a_err='integer') - goto 9999 - end if - if (len2 < 0) then - err=4025 - call psb_errpush(err,name, & - & i_err=(/len2,izero,izero,izero,izero/),a_err='integer') - goto 9999 - end if - - if (allocated(rrax)) then - dim = size(rrax,1) - lbi1 = lbound(rrax,1) - dim2 = size(rrax,2) - lbi2 = lbound(rrax,2) - If ((dim /= len1).or.(dim2 /= len2).or.(lbi1 /= lb1_)& - & .or.(lbi2 /= lb2_)) Then - Allocate(tmp(lb1_:ub1_,lb2_:ub2_),stat=info) - if (info /= psb_success_) then - err=4025 - call psb_errpush(err,name, & - & i_err=(/len1*len2,izero,izero,izero,izero/),a_err='integer') - goto 9999 - end if - tmp(lb1_:lb1_-1+min(len1,dim),lb2_:lb2_-1+min(len2,dim2)) = & - & rrax(lbi1:lbi1-1+min(len1,dim),lbi2:lbi2-1+min(len2,dim2)) - call psb_move_alloc(tmp,rrax,info) - End If - else - dim = 0 - dim2 = 0 - Allocate(rrax(lb1_:ub1_,lb2_:ub2_),stat=info) - if (info /= psb_success_) then - err=4025 - call psb_errpush(err,name, & - & i_err=(/len1*len2,izero,izero,izero,izero/),a_err='integer') - goto 9999 - end if - endif - if (present(pad)) then - rrax(lb1_-1+dim+1:lb1_-1+len1,:) = pad - rrax(lb1_:lb1_-1+dim,lb2_-1+dim2+1:lb2_-1+len2) = pad - endif - - call psb_erractionrestore(err_act) - return - -9999 continue - info = err - call psb_error_handler(err_act) - return - - End Subroutine psb_reallocatei2 - -#if !defined(LONG_INTEGERS) - - Subroutine psb_reallocate1i8(len,rrax,info,pad,lb) - use psb_error_mod - - ! ...Subroutine Arguments - integer(psb_ipk_),Intent(in) :: len - Integer(psb_epk_),allocatable, intent(inout) :: rrax(:) - integer(psb_ipk_) :: info - integer(psb_epk_), optional, intent(in) :: pad - integer(psb_ipk_), optional, intent(in) :: lb - ! ...Local Variables - Integer(psb_epk_),allocatable :: tmp(:) - integer(psb_ipk_) :: dim, err_act, err,lb_, lbi, ub_ - character(len=20) :: name - logical, parameter :: debug=.false. - - name='psb_reallocate1i' - call psb_erractionsave(err_act) - info=psb_success_ - - if (debug) write(psb_err_unit,*) 'reallocate I',len - if (psb_get_errstatus() /= 0) then - if (debug) write(psb_err_unit,*) 'reallocate errstatus /= 0' - info=psb_err_from_subroutine_ - goto 9999 - end if - - if (present(lb)) then - lb_ = lb - else - lb_ = 1 - endif - if ((len<0)) then - err=4025 - call psb_errpush(err,name, & - & i_err=(/len,izero,izero,izero,izero/),a_err='integer') - goto 9999 - end if - ub_ = lb_+len-1 - if (debug) write(psb_err_unit,*) 'reallocate : lb ub ',lb_, ub_ - if (allocated(rrax)) then - dim = size(rrax) - lbi = lbound(rrax,1) - If ((dim /= len).or.(lbi /= lb_)) Then - Allocate(tmp(lb_:ub_),stat=info) - if (info /= psb_success_) then - err=4025 - call psb_errpush(err,name, & - & i_err=(/len,izero,izero,izero,izero/),a_err='integer') - goto 9999 - end if - tmp(lb_:lb_-1+min(len,dim))=rrax(lbi:lbi-1+min(len,dim)) - if (debug) write(psb_err_unit,*) 'reallocate : calling move_alloc ' - call psb_move_alloc(tmp,rrax,info) - if (debug) write(psb_err_unit,*) 'reallocate : from move_alloc ',info - end if - else - dim = 0 - allocate(rrax(lb_:ub_),stat=info) - if (info /= psb_success_) then - err=4025 - call psb_errpush(err,name, & - & i_err=(/len,izero,izero,izero,izero/),a_err='integer') - goto 9999 - end if - endif - if (present(pad)) then - rrax(lb_-1+dim+1:lb_-1+len) = pad - endif - if (debug) write(psb_err_unit,*) 'end reallocate : ',info - call psb_erractionrestore(err_act) - return - -9999 continue - info = err - call psb_error_handler(err_act) - return - - - End Subroutine psb_reallocate1i8 - - - Subroutine psb_reallocate1i8l(len,rrax,info,pad,lb) - use psb_error_mod - - ! ...Subroutine Arguments - integer(psb_lpk_),Intent(in) :: len - Integer(psb_lpk_),allocatable, intent(inout) :: rrax(:) - integer(psb_ipk_) :: info - integer(psb_lpk_), optional, intent(in) :: pad - integer(psb_lpk_), optional, intent(in) :: lb - ! ...Local Variables - Integer(psb_lpk_),allocatable :: tmp(:) - integer(psb_lpk_) :: dim, lb_, lbi, ub_ - integer(psb_ipk_) :: err_act, ilen, err - character(len=20) :: name - logical, parameter :: debug=.false. - - name='psb_reallocate1i' - call psb_erractionsave(err_act) - info=psb_success_ - - if (debug) write(psb_err_unit,*) 'reallocate I',len - if (psb_get_errstatus() /= 0) then - if (debug) write(psb_err_unit,*) 'reallocate errstatus /= 0' - info=psb_err_from_subroutine_ - goto 9999 - end if - - if (present(lb)) then - lb_ = lb - else - lb_ = 1 - endif - if ((len<0)) then - err=4025 - ilen = len - call psb_errpush(err,name, & - & i_err=(/ilen,izero,izero,izero,izero/),a_err='integer') - goto 9999 - end if - ub_ = lb_+len-1 - if (debug) write(psb_err_unit,*) 'reallocate : lb ub ',lb_, ub_ - if (allocated(rrax)) then - dim = size(rrax) - lbi = lbound(rrax,1) - If ((dim /= len).or.(lbi /= lb_)) Then - Allocate(tmp(lb_:ub_),stat=info) - if (info /= psb_success_) then - err=4025 - ilen = len - call psb_errpush(err,name, & - & i_err=(/ilen,izero,izero,izero,izero/),a_err='integer') - goto 9999 - end if - tmp(lb_:lb_-1+min(len,dim))=rrax(lbi:lbi-1+min(len,dim)) - if (debug) write(psb_err_unit,*) 'reallocate : calling move_alloc ' - call psb_move_alloc(tmp,rrax,info) - if (debug) write(psb_err_unit,*) 'reallocate : from move_alloc ',info - end if - else - dim = 0 - allocate(rrax(lb_:ub_),stat=info) - if (info /= psb_success_) then - err=4025 - ilen = len - call psb_errpush(err,name, & - & i_err=(/ilen,izero,izero,izero,izero/),a_err='integer') - goto 9999 - end if - endif - if (present(pad)) then - rrax(lb_-1+dim+1:lb_-1+len) = pad - endif - if (debug) write(psb_err_unit,*) 'end reallocate : ',info - call psb_erractionrestore(err_act) - return - -9999 continue - info = err - call psb_error_handler(err_act) - return - - - End Subroutine psb_reallocate1i8l - - Subroutine psb_reallocatei8_2(len1,len2,rrax,info,pad,lb1,lb2) - use psb_error_mod - ! ...Subroutine Arguments - integer(psb_ipk_),Intent(in) :: len1,len2 - integer(psb_epk_),allocatable :: rrax(:,:) - integer(psb_ipk_) :: info - integer(psb_epk_), optional, intent(in) :: pad - integer(psb_ipk_),Intent(in), optional :: lb1,lb2 - - ! ...Local Variables - integer(psb_epk_),allocatable :: tmp(:,:) - integer(psb_ipk_) :: dim,err_act,err, dim2,lb1_, lb2_, ub1_, ub2_,& - & lbi1, lbi2 - character(len=20) :: name - - name='psb_reallocatei2' - call psb_erractionsave(err_act) - info=psb_success_ - if (present(lb1)) then - lb1_ = lb1 - else - lb1_ = 1 - endif - if (present(lb2)) then - lb2_ = lb2 - else - lb2_ = 1 - endif - ub1_ = lb1_ + len1 -1 - ub2_ = lb2_ + len2 -1 - - if (len1 < 0) then - err=4025 - call psb_errpush(err,name, & - & i_err=(/len1,izero,izero,izero,izero/),a_err='integer') - goto 9999 - end if - if (len2 < 0) then - err=4025 - call psb_errpush(err,name, & - & i_err=(/len2,izero,izero,izero,izero/),a_err='integer') - goto 9999 - end if - - if (allocated(rrax)) then - dim = size(rrax,1) - lbi1 = lbound(rrax,1) - dim2 = size(rrax,2) - lbi2 = lbound(rrax,2) - If ((dim /= len1).or.(dim2 /= len2).or.(lbi1 /= lb1_)& - & .or.(lbi2 /= lb2_)) Then - Allocate(tmp(lb1_:ub1_,lb2_:ub2_),stat=info) - if (info /= psb_success_) then - err=4025 - call psb_errpush(err,name, & - & i_err=(/len1*len2,izero,izero,izero,izero/),a_err='integer') - goto 9999 - end if - tmp(lb1_:lb1_-1+min(len1,dim),lb2_:lb2_-1+min(len2,dim2)) = & - & rrax(lbi1:lbi1-1+min(len1,dim),lbi2:lbi2-1+min(len2,dim2)) - call psb_move_alloc(tmp,rrax,info) - End If - else - dim = 0 - dim2 = 0 - Allocate(rrax(lb1_:ub1_,lb2_:ub2_),stat=info) - if (info /= psb_success_) then - err=4025 - call psb_errpush(err,name, & - & i_err=(/len1*len2,izero,izero,izero,izero/),a_err='integer') - goto 9999 - end if - endif - if (present(pad)) then - rrax(lb1_-1+dim+1:lb1_-1+len1,:) = pad - rrax(lb1_:lb1_-1+dim,lb2_-1+dim2+1:lb2_-1+len2) = pad - endif - - call psb_erractionrestore(err_act) - return - -9999 continue - info = err - call psb_error_handler(err_act) - return - - End Subroutine psb_reallocatei8_2 -#endif - - Subroutine psb_reallocate2i(len,rrax,y,info,pad) - use psb_error_mod - ! ...Subroutine Arguments - - integer(psb_ipk_),Intent(in) :: len - integer(psb_ipk_),allocatable, intent(inout) :: rrax(:),y(:) - integer(psb_ipk_) :: info - integer(psb_ipk_), optional, intent(in) :: pad - character(len=20) :: name - integer(psb_ipk_) :: err_act, err - - name='psb_reallocate2i' - call psb_erractionsave(err_act) - info=psb_success_ - - if(psb_get_errstatus() /= 0) then - info=psb_err_from_subroutine_ - goto 9999 - end if - - call psb_reallocate1i(len,rrax,info,pad=pad) - if (info /= psb_success_) then - err=4000 - call psb_errpush(err,name) - goto 9999 - end if - call psb_reallocate1i(len,y,info,pad=pad) - if (info /= psb_success_) then - err=4000 - call psb_errpush(err,name) - goto 9999 - end if - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - - return - - End Subroutine psb_reallocate2i - - - - - Subroutine psb_reallocate2i1s(len,rrax,y,z,info) - use psb_error_mod - ! ...Subroutine Arguments - integer(psb_ipk_),Intent(in) :: len - integer(psb_ipk_),allocatable, intent(inout) :: rrax(:),y(:) - Real(psb_spk_),allocatable, intent(inout) :: z(:) - integer(psb_ipk_) :: info - character(len=20) :: name - integer(psb_ipk_) :: err_act, err - logical, parameter :: debug=.false. - - name='psb_reallocate2i1s' - call psb_erractionsave(err_act) - - - info=psb_success_ - call psb_realloc(len,rrax,info) - if (info /= psb_success_) then - err=4000 - call psb_errpush(err,name) - goto 9999 - end if - call psb_realloc(len,y,info) - if (info /= psb_success_) then - err=4000 - call psb_errpush(err,name) - goto 9999 - end if - call psb_realloc(len,z,info) - if (info /= psb_success_) then - err=4000 - call psb_errpush(err,name) - goto 9999 - end if - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - - return - End Subroutine psb_reallocate2i1s - - - Subroutine psb_reallocate2i1d(len,rrax,y,z,info) - use psb_error_mod - ! ...Subroutine Arguments - integer(psb_ipk_),Intent(in) :: len - integer(psb_ipk_),allocatable, intent(inout) :: rrax(:),y(:) - Real(psb_dpk_),allocatable, intent(inout) :: z(:) - integer(psb_ipk_) :: info - character(len=20) :: name - integer(psb_ipk_) :: err_act, err - - name='psb_reallocate2i1d' - call psb_erractionsave(err_act) - - info=psb_success_ - - call psb_realloc(len,rrax,info) - if (info /= psb_success_) then - err=4000 - call psb_errpush(err,name) - goto 9999 - end if - call psb_realloc(len,y,info) - if (info /= psb_success_) then - err=4000 - call psb_errpush(err,name) - goto 9999 - end if - call psb_realloc(len,z,info) - if (info /= psb_success_) then - err=4000 - call psb_errpush(err,name) - goto 9999 - end if - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - - return - End Subroutine psb_reallocate2i1d - - - - Subroutine psb_reallocate2i1c(len,rrax,y,z,info) - use psb_error_mod - ! ...Subroutine Arguments - integer(psb_ipk_),Intent(in) :: len - integer(psb_ipk_),allocatable, intent(inout) :: rrax(:),y(:) - complex(psb_spk_),allocatable, intent(inout) :: z(:) - integer(psb_ipk_) :: info - character(len=20) :: name - integer(psb_ipk_) :: err_act, err - - name='psb_reallocate2i1c' - call psb_erractionsave(err_act) - - - info=psb_success_ - call psb_realloc(len,rrax,info) - if (info /= psb_success_) then - err=4000 - call psb_errpush(err,name) - goto 9999 - end if - call psb_realloc(len,y,info) - if (info /= psb_success_) then - err=4000 - call psb_errpush(err,name) - goto 9999 - end if - call psb_realloc(len,z,info) - if (info /= psb_success_) then - err=4000 - call psb_errpush(err,name) - goto 9999 - end if - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - - return - End Subroutine psb_reallocate2i1c - - Subroutine psb_reallocate2i1z(len,rrax,y,z,info) - use psb_error_mod - ! ...Subroutine Arguments - integer(psb_ipk_),Intent(in) :: len - integer(psb_ipk_),allocatable, intent(inout) :: rrax(:),y(:) - complex(psb_dpk_),allocatable, intent(inout) :: z(:) - integer(psb_ipk_) :: info - character(len=20) :: name - integer(psb_ipk_) :: err_act, err - - name='psb_reallocate2i1z' - call psb_erractionsave(err_act) - - info=psb_success_ - call psb_realloc(len,rrax,info) - if (info /= psb_success_) then - err=4000 - call psb_errpush(err,name) - goto 9999 - end if - call psb_realloc(len,y,info) - if (info /= psb_success_) then - err=4000 - call psb_errpush(err,name) - goto 9999 - end if - call psb_realloc(len,z,info) - if (info /= psb_success_) then - err=4000 - call psb_errpush(err,name) - goto 9999 - end if - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - - return - End Subroutine psb_reallocate2i1z - - Subroutine psb_smove_alloc1d(vin,vout,info) - use psb_error_mod - real(psb_spk_), allocatable, intent(inout) :: vin(:),vout(:) - integer(psb_ipk_), intent(out) :: info - ! - ! - info=psb_success_ - - call move_alloc(vin,vout) - - end Subroutine psb_smove_alloc1d - - Subroutine psb_smove_alloc2d(vin,vout,info) - use psb_error_mod - real(psb_spk_), allocatable, intent(inout) :: vin(:,:),vout(:,:) - integer(psb_ipk_), intent(out) :: info - ! - ! - info=psb_success_ - - call move_alloc(vin,vout) - - end Subroutine psb_smove_alloc2d - - Subroutine psb_dmove_alloc1d(vin,vout,info) - use psb_error_mod - real(psb_dpk_), allocatable, intent(inout) :: vin(:),vout(:) - integer(psb_ipk_), intent(out) :: info - ! - ! - info=psb_success_ - - call move_alloc(vin,vout) - - end Subroutine psb_dmove_alloc1d - - Subroutine psb_dmove_alloc2d(vin,vout,info) - use psb_error_mod - real(psb_dpk_), allocatable, intent(inout) :: vin(:,:),vout(:,:) - integer(psb_ipk_), intent(out) :: info - ! - ! - info=psb_success_ - - call move_alloc(vin,vout) - - end Subroutine psb_dmove_alloc2d - - Subroutine psb_cmove_alloc1d(vin,vout,info) - use psb_error_mod - complex(psb_spk_), allocatable, intent(inout) :: vin(:),vout(:) - integer(psb_ipk_), intent(out) :: info - ! - ! - info=psb_success_ - - call move_alloc(vin,vout) - - end Subroutine psb_cmove_alloc1d - - Subroutine psb_cmove_alloc2d(vin,vout,info) - use psb_error_mod - complex(psb_spk_), allocatable, intent(inout) :: vin(:,:),vout(:,:) - integer(psb_ipk_), intent(out) :: info - ! - ! - info=psb_success_ - - call move_alloc(vin,vout) - - end Subroutine psb_cmove_alloc2d - - Subroutine psb_zmove_alloc1d(vin,vout,info) - use psb_error_mod - complex(psb_dpk_), allocatable, intent(inout) :: vin(:),vout(:) - integer(psb_ipk_), intent(out) :: info - ! - ! - info=psb_success_ - - call move_alloc(vin,vout) - - end Subroutine psb_zmove_alloc1d - - Subroutine psb_zmove_alloc2d(vin,vout,info) - use psb_error_mod - complex(psb_dpk_), allocatable, intent(inout) :: vin(:,:),vout(:,:) - integer(psb_ipk_), intent(out) :: info - ! - ! - info=psb_success_ - - call move_alloc(vin,vout) - - end Subroutine psb_zmove_alloc2d - - Subroutine psb_imove_alloc1d(vin,vout,info) - use psb_error_mod - integer(psb_ipk_), allocatable, intent(inout) :: vin(:),vout(:) - integer(psb_ipk_), intent(out) :: info - ! - ! - info=psb_success_ - - call move_alloc(vin,vout) - - end Subroutine psb_imove_alloc1d - - Subroutine psb_imove_alloc2d(vin,vout,info) - use psb_error_mod - integer(psb_ipk_), allocatable, intent(inout) :: vin(:,:),vout(:,:) - integer(psb_ipk_), intent(out) :: info - ! - ! - info=psb_success_ - - call move_alloc(vin,vout) - - end Subroutine psb_imove_alloc2d - -#if !defined(LONG_INTEGERS) - Subroutine psb_i8move_alloc1d(vin,vout,info) - use psb_error_mod - integer(psb_epk_), allocatable, intent(inout) :: vin(:),vout(:) - integer(psb_ipk_), intent(out) :: info - ! - ! - info=psb_success_ - - call move_alloc(vin,vout) - - end Subroutine psb_i8move_alloc1d - - Subroutine psb_i8move_alloc2d(vin,vout,info) - use psb_error_mod - integer(psb_epk_), allocatable, intent(inout) :: vin(:,:),vout(:,:) - integer(psb_ipk_), intent(out) :: info - ! - ! - info=psb_success_ - - call move_alloc(vin,vout) - - end Subroutine psb_i8move_alloc2d - -#else - - Subroutine psb_i4move_alloc1d(vin,vout,info) - use psb_error_mod - integer(psb_mpk_), allocatable, intent(inout) :: vin(:),vout(:) - integer(psb_mpk_), intent(out) :: info - ! - ! - info=psb_success_ - - call move_alloc(vin,vout) - - end Subroutine psb_i4move_alloc1d - - Subroutine psb_i4move_alloc1d_i8(vin,vout,info) - use psb_error_mod - integer(psb_mpk_), allocatable, intent(inout) :: vin(:),vout(:) - integer(psb_ipk_), intent(out) :: info - ! - ! - info=psb_success_ - - call move_alloc(vin,vout) - - end Subroutine psb_i4move_alloc1d_i8 - - Subroutine psb_i4move_alloc2d(vin,vout,info) - use psb_error_mod - integer(psb_mpk_), allocatable, intent(inout) :: vin(:,:),vout(:,:) - integer(psb_mpk_), intent(out) :: info - ! - ! - info=psb_success_ - - call move_alloc(vin,vout) - - end Subroutine psb_i4move_alloc2d - - Subroutine psb_i4move_alloc2d_i8(vin,vout,info) - use psb_error_mod - integer(psb_mpk_), allocatable, intent(inout) :: vin(:,:),vout(:,:) - integer(psb_ipk_), intent(out) :: info - ! - ! - info=psb_success_ - - call move_alloc(vin,vout) - - end Subroutine psb_i4move_alloc2d_i8 - -#endif - -#if defined(LONG_INTEGERS) - Subroutine psb_reallocate1i4(len,rrax,info,pad,lb) - use psb_error_mod - - ! ...Subroutine Arguments - integer(psb_mpk_),Intent(in) :: len - Integer(psb_mpk_),allocatable, intent(inout) :: rrax(:) - integer(psb_mpk_) :: info - integer(psb_mpk_), optional, intent(in) :: pad - integer(psb_mpk_), optional, intent(in) :: lb - ! ...Local Variables - Integer(psb_mpk_),allocatable :: tmp(:) - integer(psb_mpk_) :: dim, lb_, lbi, ub_ - integer(psb_ipk_) :: err, err_act, ierr(5) - character(len=20) :: name - logical, parameter :: debug=.false. - - name='psb_reallocate1i4' - call psb_erractionsave(err_act) - info=psb_success_ - - if (debug) write(psb_err_unit,*) 'reallocate I',len - if (psb_get_errstatus() /= 0) then - if (debug) write(psb_err_unit,*) 'reallocate errstatus /= 0' - info=psb_err_from_subroutine_ - goto 9999 - end if - - if (present(lb)) then - lb_ = lb - else - lb_ = 1 - endif - if ((len<0)) then - err=4025; ierr(1) = len - call psb_errpush(err,name,i_err=ierr,a_err='integer') - goto 9999 - end if - ub_ = lb_+len-1 - if (debug) write(psb_err_unit,*) 'reallocate : lb ub ',lb_, ub_ - if (allocated(rrax)) then - dim = size(rrax) - lbi = lbound(rrax,1) - If ((dim /= len).or.(lbi /= lb_)) Then - Allocate(tmp(lb_:ub_),stat=info) - if (info /= psb_success_) then - err=4025; ierr(1) = len - call psb_errpush(err,name,i_err=ierr,a_err='integer') - goto 9999 - end if - tmp(lb_:lb_-1+min(len,dim))=rrax(lbi:lbi-1+min(len,dim)) - if (debug) write(psb_err_unit,*) 'reallocate : calling move_alloc ' - call psb_move_alloc(tmp,rrax,info) - if (debug) write(psb_err_unit,*) 'reallocate : from move_alloc ',info - end if - else - dim = 0 - allocate(rrax(lb_:ub_),stat=info) - if (info /= psb_success_) then - err=4025; ierr(1) = len - call psb_errpush(err,name,i_err=ierr,a_err='integer') - goto 9999 - end if - endif - if (present(pad)) then - rrax(lb_-1+dim+1:lb_-1+len) = pad - endif - if (debug) write(psb_err_unit,*) 'end reallocate : ',info - call psb_erractionrestore(err_act) - return - -9999 continue - info = err - call psb_error_handler(err_act) - return - - - End Subroutine psb_reallocate1i4 - - Subroutine psb_reallocate1i4_i8(len,rrax,info,pad,lb) - use psb_error_mod - - ! ...Subroutine Arguments - integer(psb_ipk_),Intent(in) :: len - Integer(psb_mpk_),allocatable, intent(inout) :: rrax(:) - integer(psb_ipk_) :: info - integer(psb_mpk_), optional, intent(in) :: pad - integer(psb_ipk_), optional, intent(in) :: lb - ! ...Local Variables - Integer(psb_mpk_),allocatable :: tmp(:) - integer(psb_mpk_) :: dim, lb_, lbi, ub_, iinfo - integer(psb_ipk_) :: err, err_act, ierr(5) - character(len=20) :: name - logical, parameter :: debug=.false. - - name='psb_reallocate1i4' - call psb_erractionsave(err_act) - info=psb_success_ - - if (debug) write(psb_err_unit,*) 'reallocate I',len - if (psb_get_errstatus() /= 0) then - if (debug) write(psb_err_unit,*) 'reallocate errstatus /= 0' - info=psb_err_from_subroutine_ - goto 9999 - end if - - if (present(lb)) then - lb_ = lb - else - lb_ = 1 - endif - if ((len<0)) then - err=4025; ierr(1) = len - call psb_errpush(err,name,i_err=ierr,a_err='integer') - goto 9999 - end if - ub_ = lb_+len-1 - if (debug) write(psb_err_unit,*) 'reallocate : lb ub ',lb_, ub_ - if (allocated(rrax)) then - dim = size(rrax) - lbi = lbound(rrax,1) - If ((dim /= len).or.(lbi /= lb_)) Then - Allocate(tmp(lb_:ub_),stat=info) - if (info /= psb_success_) then - err=4025; ierr(1) = len - call psb_errpush(err,name,i_err=ierr,a_err='integer') - goto 9999 - end if - tmp(lb_:lb_-1+min(len,dim))=rrax(lbi:lbi-1+min(len,dim)) - if (debug) write(psb_err_unit,*) 'reallocate : calling move_alloc ' - call psb_move_alloc(tmp,rrax,iinfo) - if (debug) write(psb_err_unit,*) 'reallocate : from move_alloc ',iinfo - end if - else - dim = 0 - allocate(rrax(lb_:ub_),stat=info) - if (info /= psb_success_) then - err=4025; ierr(1) = len - call psb_errpush(err,name,i_err=ierr,a_err='integer') - goto 9999 - end if - endif - if (present(pad)) then - rrax(lb_-1+dim+1:lb_-1+len) = pad - endif - if (debug) write(psb_err_unit,*) 'end reallocate : ',info - call psb_erractionrestore(err_act) - return - -9999 continue - info = err - call psb_error_handler(err_act) - return - - - End Subroutine psb_reallocate1i4_i8 - - Subroutine psb_reallocate2i4(len1,len2,rrax,info,pad,lb1,lb2) - use psb_error_mod - ! ...Subroutine Arguments - integer(psb_mpk_),Intent(in) :: len1,len2 - integer(psb_mpk_),allocatable :: rrax(:,:) - integer(psb_mpk_) :: info - integer(psb_mpk_), optional, intent(in) :: pad - integer(psb_mpk_),Intent(in), optional :: lb1,lb2 - - ! ...Local Variables - integer(psb_mpk_),allocatable :: tmp(:,:) - integer(psb_mpk_) :: dim, dim2,lb1_, lb2_, ub1_, ub2_,& - & lbi1, lbi2 - integer(psb_ipk_) :: err,err_act, ierr(5) - character(len=20) :: name - - name='psb_reallocatei2' - call psb_erractionsave(err_act) - info=psb_success_ - if (present(lb1)) then - lb1_ = lb1 - else - lb1_ = 1 - endif - if (present(lb2)) then - lb2_ = lb2 - else - lb2_ = 1 - endif - ub1_ = lb1_ + len1 -1 - ub2_ = lb2_ + len2 -1 - - if (len1 < 0) then - err=4025; ierr(1) = len1 - call psb_errpush(err,name,i_err=ierr,a_err='integer') - goto 9999 - end if - if (len2 < 0) then - err=4025; ierr(1) = len2 - call psb_errpush(err,name,i_err=ierr,a_err='integer') - goto 9999 - end if - - if (allocated(rrax)) then - dim = size(rrax,1) - lbi1 = lbound(rrax,1) - dim2 = size(rrax,2) - lbi2 = lbound(rrax,2) - If ((dim /= len1).or.(dim2 /= len2).or.(lbi1 /= lb1_)& - & .or.(lbi2 /= lb2_)) Then - Allocate(tmp(lb1_:ub1_,lb2_:ub2_),stat=info) - if (info /= psb_success_) then - err=4025; ierr(1) = len1*len2 - call psb_errpush(err,name,i_err=ierr,a_err='integer') - goto 9999 - end if - tmp(lb1_:lb1_-1+min(len1,dim),lb2_:lb2_-1+min(len2,dim2)) = & - & rrax(lbi1:lbi1-1+min(len1,dim),lbi2:lbi2-1+min(len2,dim2)) - call psb_move_alloc(tmp,rrax,info) - End If - else - dim = 0 - dim2 = 0 - Allocate(rrax(lb1_:ub1_,lb2_:ub2_),stat=info) - if (info /= psb_success_) then - err=4025; ierr(1) = len1*len2 - call psb_errpush(err,name,i_err=ierr,a_err='integer') - goto 9999 - end if - endif - if (present(pad)) then - rrax(lb1_-1+dim+1:lb1_-1+len1,:) = pad - rrax(lb1_:lb1_-1+dim,lb2_-1+dim2+1:lb2_-1+len2) = pad - endif - - call psb_erractionrestore(err_act) - return - -9999 continue - info = err - call psb_error_handler(err_act) - return - - End Subroutine psb_reallocate2i4 - - Subroutine psb_reallocate2i4_i8(len1,len2,rrax,info,pad,lb1,lb2) - use psb_error_mod - ! ...Subroutine Arguments - integer(psb_ipk_),Intent(in) :: len1,len2 - integer(psb_mpk_),allocatable :: rrax(:,:) - integer(psb_ipk_) :: info - integer(psb_mpk_), optional, intent(in) :: pad - integer(psb_ipk_),Intent(in), optional :: lb1,lb2 - - ! ...Local Variables - integer(psb_mpk_),allocatable :: tmp(:,:) - integer(psb_mpk_) :: dim, dim2,lb1_, lb2_, ub1_, ub2_,& - & lbi1, lbi2 - integer(psb_ipk_) :: err,err_act, ierr(5) - character(len=20) :: name - - name='psb_reallocatei2' - call psb_erractionsave(err_act) - info=psb_success_ - if (present(lb1)) then - lb1_ = lb1 - else - lb1_ = 1 - endif - if (present(lb2)) then - lb2_ = lb2 - else - lb2_ = 1 - endif - ub1_ = lb1_ + len1 -1 - ub2_ = lb2_ + len2 -1 - - if (len1 < 0) then - err=4025; ierr(1) = len1 - call psb_errpush(err,name,i_err=ierr,a_err='integer') - goto 9999 - end if - if (len2 < 0) then - err=4025; ierr(1) = len2 - call psb_errpush(err,name,i_err=ierr,a_err='integer') - goto 9999 - end if - - if (allocated(rrax)) then - dim = size(rrax,1) - lbi1 = lbound(rrax,1) - dim2 = size(rrax,2) - lbi2 = lbound(rrax,2) - If ((dim /= len1).or.(dim2 /= len2).or.(lbi1 /= lb1_)& - & .or.(lbi2 /= lb2_)) Then - Allocate(tmp(lb1_:ub1_,lb2_:ub2_),stat=info) - if (info /= psb_success_) then - err=4025; ierr(1) = len1*len2 - call psb_errpush(err,name,i_err=ierr,a_err='integer') - goto 9999 - end if - tmp(lb1_:lb1_-1+min(len1,dim),lb2_:lb2_-1+min(len2,dim2)) = & - & rrax(lbi1:lbi1-1+min(len1,dim),lbi2:lbi2-1+min(len2,dim2)) - call psb_move_alloc(tmp,rrax,info) - End If - else - dim = 0 - dim2 = 0 - Allocate(rrax(lb1_:ub1_,lb2_:ub2_),stat=info) - if (info /= psb_success_) then - err=4025; ierr(1) = len1*len2 - call psb_errpush(err,name,i_err=ierr,a_err='integer') - goto 9999 - end if - endif - if (present(pad)) then - rrax(lb1_-1+dim+1:lb1_-1+len1,:) = pad - rrax(lb1_:lb1_-1+dim,lb2_-1+dim2+1:lb2_-1+len2) = pad - endif - - call psb_erractionrestore(err_act) - return - -9999 continue - info = err - call psb_error_handler(err_act) - return - - End Subroutine psb_reallocate2i4_i8 - - - Subroutine psb_rp1i1(len,rrax,info,pad,lb) - ! ...Subroutine Arguments - integer(psb_mpk_),Intent(in) :: len - integer(psb_ipk_),allocatable, intent(inout) :: rrax(:) - integer(psb_ipk_) :: info - integer(psb_ipk_), optional, intent(in) :: pad - integer(psb_mpk_), optional, intent(in) :: lb - - integer(psb_ipk_) :: ilen, ilb - - ilen=len - if (present(lb)) then - ilb=lb - else - ilb = 1 - end if - call psb_realloc(ilen,rrax,info,lb=ilb,pad=pad) - - end Subroutine psb_rp1i1 - - - subroutine psb_rp1i2i2(len1,len2,rrax,info,pad,lb1,lb2) - ! ...Subroutine Arguments - integer(psb_mpk_),Intent(in) :: len1 - integer(psb_ipk_),Intent(in) :: len2 - integer(psb_ipk_),allocatable :: rrax(:,:) - integer(psb_ipk_) :: info - integer(psb_ipk_), optional, intent(in) :: pad - integer(psb_ipk_),Intent(in), optional :: lb1,lb2 - - integer(psb_ipk_) :: len1_, len2_ - len1_ = len1 - call psb_realloc(len1_,len2,rrax,info,pad,lb1,lb2) - end subroutine psb_rp1i2i2 - - subroutine psb_ri1p2i2(len1,len2,rrax,info,pad,lb1,lb2) - ! ...Subroutine Arguments - integer(psb_mpk_),Intent(in) :: len2 - integer(psb_ipk_),Intent(in) :: len1 - integer(psb_ipk_),allocatable :: rrax(:,:) - integer(psb_ipk_) :: info - integer(psb_ipk_), optional, intent(in) :: pad - integer(psb_ipk_),Intent(in), optional :: lb1,lb2 - - integer(psb_ipk_) :: len1_, len2_ - len2_ = len2 - call psb_realloc(len1,len2_,rrax,info,pad,lb1,lb2) - end subroutine psb_ri1p2i2 - - subroutine psb_rp1p2i2(len1,len2,rrax,info,pad,lb1,lb2) - ! ...Subroutine Arguments - integer(psb_mpk_),Intent(in) :: len1 - integer(psb_mpk_),Intent(in) :: len2 - integer(psb_ipk_),allocatable :: rrax(:,:) - integer(psb_ipk_) :: info - integer(psb_ipk_), optional, intent(in) :: pad - integer(psb_ipk_),Intent(in), optional :: lb1,lb2 - - integer(psb_ipk_) :: len1_, len2_ - len1_ = len1 - len2_ = len2 - call psb_realloc(len1_,len2_,rrax,info,pad,lb1,lb2) - end subroutine psb_rp1p2i2 - - Subroutine psb_rp1s1(len,rrax,info,pad,lb) - ! ...Subroutine Arguments - integer(psb_mpk_),Intent(in) :: len - real(psb_spk_),allocatable, intent(inout) :: rrax(:) - integer(psb_ipk_) :: info - real(psb_spk_), optional, intent(in) :: pad - integer(psb_mpk_), optional, intent(in) :: lb - - integer(psb_ipk_) :: ilen, ilb - - ilen=len - if (present(lb)) then - ilb=lb - else - ilb = 1 - end if - call psb_realloc(ilen,rrax,info,lb=ilb,pad=pad) - - end Subroutine psb_rp1s1 - - subroutine psb_rp1i2s2(len1,len2,rrax,info,pad,lb1,lb2) - ! ...Subroutine Arguments - integer(psb_mpk_),Intent(in) :: len1 - integer(psb_ipk_),Intent(in) :: len2 - real(psb_spk_),allocatable :: rrax(:,:) - integer(psb_ipk_) :: info - real(psb_spk_), optional, intent(in) :: pad - integer(psb_ipk_),Intent(in), optional :: lb1,lb2 - - integer(psb_ipk_) :: len1_, len2_ - len1_ = len1 - call psb_realloc(len1_,len2,rrax,info,pad,lb1,lb2) - end subroutine psb_rp1i2s2 - - subroutine psb_ri1p2s2(len1,len2,rrax,info,pad,lb1,lb2) - ! ...Subroutine Arguments - integer(psb_mpk_),Intent(in) :: len2 - integer(psb_ipk_),Intent(in) :: len1 - real(psb_spk_),allocatable :: rrax(:,:) - integer(psb_ipk_) :: info - real(psb_spk_), optional, intent(in) :: pad - integer(psb_ipk_),Intent(in), optional :: lb1,lb2 - - integer(psb_ipk_) :: len1_, len2_ - len2_ = len2 - call psb_realloc(len1,len2_,rrax,info,pad,lb1,lb2) - end subroutine psb_ri1p2s2 - - subroutine psb_rp1p2s2(len1,len2,rrax,info,pad,lb1,lb2) - ! ...Subroutine Arguments - integer(psb_mpk_),Intent(in) :: len1 - integer(psb_mpk_),Intent(in) :: len2 - real(psb_spk_),allocatable :: rrax(:,:) - integer(psb_ipk_) :: info - real(psb_spk_), optional, intent(in) :: pad - integer(psb_ipk_),Intent(in), optional :: lb1,lb2 - - integer(psb_ipk_) :: len1_, len2_ - len1_ = len1 - len2_ = len2 - call psb_realloc(len1_,len2_,rrax,info,pad,lb1,lb2) - end subroutine psb_rp1p2s2 - - - - Subroutine psb_rp1d1(len,rrax,info,pad,lb) - ! ...Subroutine Arguments - integer(psb_mpk_),Intent(in) :: len - Real(psb_dpk_),allocatable, intent(inout) :: rrax(:) - integer(psb_ipk_) :: info - real(psb_dpk_), optional, intent(in) :: pad - integer(psb_mpk_), optional, intent(in) :: lb - - integer(psb_ipk_) :: ilen, ilb - - ilen=len - if (present(lb)) then - ilb=lb - else - ilb = 1 - end if - call psb_realloc(ilen,rrax,info,lb=ilb,pad=pad) - - end Subroutine psb_rp1d1 - - - subroutine psb_rp1i2d2(len1,len2,rrax,info,pad,lb1,lb2) - ! ...Subroutine Arguments - integer(psb_mpk_),Intent(in) :: len1 - integer(psb_ipk_),Intent(in) :: len2 - Real(psb_dpk_),allocatable :: rrax(:,:) - integer(psb_ipk_) :: info - real(psb_dpk_), optional, intent(in) :: pad - integer(psb_ipk_),Intent(in), optional :: lb1,lb2 - - integer(psb_ipk_) :: len1_, len2_ - len1_ = len1 - call psb_realloc(len1_,len2,rrax,info,pad,lb1,lb2) - end subroutine psb_rp1i2d2 - - subroutine psb_ri1p2d2(len1,len2,rrax,info,pad,lb1,lb2) - ! ...Subroutine Arguments - integer(psb_mpk_),Intent(in) :: len2 - integer(psb_ipk_),Intent(in) :: len1 - Real(psb_dpk_),allocatable :: rrax(:,:) - integer(psb_ipk_) :: info - real(psb_dpk_), optional, intent(in) :: pad - integer(psb_ipk_),Intent(in), optional :: lb1,lb2 - - integer(psb_ipk_) :: len1_, len2_ - len2_ = len2 - call psb_realloc(len1,len2_,rrax,info,pad,lb1,lb2) - end subroutine psb_ri1p2d2 - - subroutine psb_rp1p2d2(len1,len2,rrax,info,pad,lb1,lb2) - ! ...Subroutine Arguments - integer(psb_mpk_),Intent(in) :: len1 - integer(psb_mpk_),Intent(in) :: len2 - Real(psb_dpk_),allocatable :: rrax(:,:) - integer(psb_ipk_) :: info - real(psb_dpk_), optional, intent(in) :: pad - integer(psb_ipk_),Intent(in), optional :: lb1,lb2 - - integer(psb_ipk_) :: len1_, len2_ - len1_ = len1 - len2_ = len2 - call psb_realloc(len1_,len2_,rrax,info,pad,lb1,lb2) - end subroutine psb_rp1p2d2 - - - - Subroutine psb_rp1c1(len,rrax,info,pad,lb) - ! ...Subroutine Arguments - integer(psb_mpk_),Intent(in) :: len - complex(psb_spk_),allocatable, intent(inout) :: rrax(:) - integer(psb_ipk_) :: info - complex(psb_spk_), optional, intent(in) :: pad - integer(psb_mpk_), optional, intent(in) :: lb - - integer(psb_ipk_) :: ilen, ilb - - ilen=len - if (present(lb)) then - ilb=lb - else - ilb = 1 - end if - call psb_realloc(ilen,rrax,info,lb=ilb,pad=pad) - - end Subroutine psb_rp1c1 - - subroutine psb_rp1i2c2(len1,len2,rrax,info,pad,lb1,lb2) - ! ...Subroutine Arguments - integer(psb_mpk_),Intent(in) :: len1 - integer(psb_ipk_),Intent(in) :: len2 - complex(psb_spk_),allocatable :: rrax(:,:) - integer(psb_ipk_) :: info - complex(psb_spk_), optional, intent(in) :: pad - integer(psb_ipk_),Intent(in), optional :: lb1,lb2 - - integer(psb_ipk_) :: len1_, len2_ - len1_ = len1 - call psb_realloc(len1_,len2,rrax,info,pad,lb1,lb2) - end subroutine psb_rp1i2c2 - - subroutine psb_ri1p2c2(len1,len2,rrax,info,pad,lb1,lb2) - ! ...Subroutine Arguments - integer(psb_mpk_),Intent(in) :: len2 - integer(psb_ipk_),Intent(in) :: len1 - complex(psb_spk_),allocatable :: rrax(:,:) - integer(psb_ipk_) :: info - complex(psb_spk_), optional, intent(in) :: pad - integer(psb_ipk_),Intent(in), optional :: lb1,lb2 - - integer(psb_ipk_) :: len1_, len2_ - len2_ = len2 - call psb_realloc(len1,len2_,rrax,info,pad,lb1,lb2) - end subroutine psb_ri1p2c2 - - subroutine psb_rp1p2c2(len1,len2,rrax,info,pad,lb1,lb2) - ! ...Subroutine Arguments - integer(psb_mpk_),Intent(in) :: len1 - integer(psb_mpk_),Intent(in) :: len2 - complex(psb_spk_),allocatable :: rrax(:,:) - integer(psb_ipk_) :: info - complex(psb_spk_), optional, intent(in) :: pad - integer(psb_ipk_),Intent(in), optional :: lb1,lb2 - - integer(psb_ipk_) :: len1_, len2_ - len1_ = len1 - len2_ = len2 - call psb_realloc(len1_,len2_,rrax,info,pad,lb1,lb2) - end subroutine psb_rp1p2c2 - - - Subroutine psb_rp1z1(len,rrax,info,pad,lb) - ! ...Subroutine Arguments - integer(psb_mpk_),Intent(in) :: len - Complex(psb_dpk_),allocatable, intent(inout) :: rrax(:) - integer(psb_ipk_) :: info - complex(psb_dpk_), optional, intent(in) :: pad - integer(psb_mpk_), optional, intent(in) :: lb - - integer(psb_ipk_) :: ilen, ilb - - ilen=len - if (present(lb)) then - ilb=lb - else - ilb = 1 - end if - call psb_realloc(ilen,rrax,info,lb=ilb,pad=pad) - - end Subroutine psb_rp1z1 - - subroutine psb_rp1i2z2(len1,len2,rrax,info,pad,lb1,lb2) - ! ...Subroutine Arguments - integer(psb_mpk_),Intent(in) :: len1 - integer(psb_ipk_),Intent(in) :: len2 - Complex(psb_dpk_),allocatable :: rrax(:,:) - integer(psb_ipk_) :: info - complex(psb_dpk_), optional, intent(in) :: pad - integer(psb_ipk_),Intent(in), optional :: lb1,lb2 - - integer(psb_ipk_) :: len1_, len2_ - len1_ = len1 - call psb_realloc(len1_,len2,rrax,info,pad,lb1,lb2) - end subroutine psb_rp1i2z2 - - subroutine psb_ri1p2z2(len1,len2,rrax,info,pad,lb1,lb2) - ! ...Subroutine Arguments - integer(psb_mpk_),Intent(in) :: len2 - integer(psb_ipk_),Intent(in) :: len1 - Complex(psb_dpk_),allocatable :: rrax(:,:) - integer(psb_ipk_) :: info - complex(psb_dpk_), optional, intent(in) :: pad - integer(psb_ipk_),Intent(in), optional :: lb1,lb2 - - integer(psb_ipk_) :: len1_, len2_ - len2_ = len2 - call psb_realloc(len1,len2_,rrax,info,pad,lb1,lb2) - end subroutine psb_ri1p2z2 - - subroutine psb_rp1p2z2(len1,len2,rrax,info,pad,lb1,lb2) - ! ...Subroutine Arguments - integer(psb_mpk_),Intent(in) :: len1 - integer(psb_mpk_),Intent(in) :: len2 - Complex(psb_dpk_),allocatable :: rrax(:,:) - integer(psb_ipk_) :: info - complex(psb_dpk_), optional, intent(in) :: pad - integer(psb_ipk_),Intent(in), optional :: lb1,lb2 - - integer(psb_ipk_) :: len1_, len2_ - len1_ = len1 - len2_ = len2 - call psb_realloc(len1_,len2_,rrax,info,pad,lb1,lb2) - end subroutine psb_rp1p2z2 - -#endif - - - subroutine i_trans(a,at) - implicit none - integer(psb_ipk_) :: nr,nc - integer(psb_ipk_) :: a(:,:) - integer(psb_ipk_), allocatable, intent(out) :: at(:,:) - integer(psb_ipk_) :: i,j,ib, ii - integer(psb_ipk_), parameter :: nb=32 - - nr = size(a,1) - nc = size(a,2) - allocate(at(nc,nr)) - do i=1,nr,nb - ib=min(nb,nr-i+1) - do ii=i,i+ib-1 - do j=1,nc - at(j,ii) = a(ii,j) - end do - end do - end do - end subroutine i_trans - - subroutine d_trans(a,at) - implicit none - integer(psb_ipk_) :: nr,nc - real(psb_dpk_) :: a(:,:) - real(psb_dpk_), allocatable, intent(out) :: at(:,:) - integer(psb_ipk_) :: i,j,ib, ii - integer(psb_ipk_), parameter :: nb=32 - - nr = size(a,1) - nc = size(a,2) - allocate(at(nc,nr)) - do i=1,nr,nb - ib=min(nb,nr-i+1) - do ii=i,i+ib-1 - do j=1,nc - at(j,ii) = a(ii,j) - end do - end do - end do - end subroutine d_trans + End Subroutine psb_reallocate2i1z end module psb_realloc_mod diff --git a/base/modules/psi_comm_buffers_mod.F90 b/base/modules/psi_comm_buffers_mod.F90 index 980c4a5a..2d44dc72 100644 --- a/base/modules/psi_comm_buffers_mod.F90 +++ b/base/modules/psi_comm_buffers_mod.F90 @@ -65,6 +65,7 @@ module psi_comm_buffers_mod integer(psb_mpk_), parameter:: psb_int8_tag = psb_char_tag + 1 integer(psb_mpk_), parameter:: psb_int2_tag = psb_int8_tag + 1 integer(psb_mpk_), parameter:: psb_int4_tag = psb_int2_tag + 1 + integer(psb_mpk_), parameter:: psb_long_tag = psb_int4_tag + 1 integer(psb_mpk_), parameter:: psb_int_swap_tag = psb_int_tag + psb_int_tag integer(psb_mpk_), parameter:: psb_real_swap_tag = psb_real_tag + psb_int_tag @@ -76,6 +77,7 @@ module psi_comm_buffers_mod integer(psb_mpk_), parameter:: psb_int8_swap_tag = psb_int8_tag + psb_int_tag integer(psb_mpk_), parameter:: psb_int2_swap_tag = psb_int2_tag + psb_int_tag integer(psb_mpk_), parameter:: psb_int4_swap_tag = psb_int4_tag + psb_int_tag + integer(psb_mpk_), parameter:: psb_long_swap_tag = psb_long_tag + psb_int_tag @@ -89,22 +91,23 @@ module psi_comm_buffers_mod integer(psb_mpk_), private, parameter:: psb_int8_type = psb_char_type + 1 integer(psb_mpk_), private, parameter:: psb_int2_type = psb_int8_type + 1 integer(psb_mpk_), private, parameter:: psb_int4_type = psb_int2_type + 1 + integer(psb_mpk_), private, parameter:: psb_long_type = psb_int4_type + 1 type psb_buffer_node integer(psb_mpk_) :: request integer(psb_mpk_) :: icontxt integer(psb_mpk_) :: buffer_type - integer(psb_ipk_), allocatable :: intbuf(:) - integer(psb_epk_), allocatable :: int8buf(:) - integer(2), allocatable :: int2buf(:) - integer(psb_mpk_), allocatable :: int4buf(:) - real(psb_spk_), allocatable :: realbuf(:) - real(psb_dpk_), allocatable :: doublebuf(:) - complex(psb_spk_), allocatable :: complexbuf(:) - complex(psb_dpk_), allocatable :: dcomplbuf(:) - logical, allocatable :: logbuf(:) - character(len=1), allocatable :: charbuf(:) + integer(psb_ipk_), allocatable :: intbuf(:) + integer(psb_epk_), allocatable :: int8buf(:) + integer(psb_i2pk_), allocatable :: int2buf(:) + integer(psb_mpk_), allocatable :: int4buf(:) + real(psb_spk_), allocatable :: realbuf(:) + real(psb_dpk_), allocatable :: doublebuf(:) + complex(psb_spk_), allocatable :: complexbuf(:) + complex(psb_dpk_), allocatable :: dcomplbuf(:) + logical, allocatable :: logbuf(:) + character(len=1), allocatable :: charbuf(:) type(psb_buffer_node), pointer :: prev=>null(), next=>null() end type psb_buffer_node @@ -114,29 +117,14 @@ module psi_comm_buffers_mod interface psi_snd - module procedure psi_isnd,& + module procedure& + & psi_msnd, psi_esnd,& & psi_ssnd, psi_dsnd,& & psi_csnd, psi_zsnd,& - & psi_lsnd, psi_hsnd + & psi_logsnd, psi_hsnd,& + & psi_i2snd end interface -#if defined(LONG_INTEGERS) - interface psi_snd - module procedure psi_i4snd - end interface -#endif -#if !defined(LONG_INTEGERS) - interface psi_snd - module procedure psi_i8snd - end interface -#endif - -#if defined(SHORT_INTEGERS) - interface psi_snd - module procedure psi_i2snd - end interface -#endif - contains subroutine psb_init_queue(mesg_queue,info) @@ -297,7 +285,7 @@ contains ! has already been copied. ! ! !!!!!!!!!!!!!!!!! - subroutine psi_isnd(icontxt,tag,dest,buffer,mesg_queue) + subroutine psi_msnd(icontxt,tag,dest,buffer,mesg_queue) #ifdef MPI_MOD use mpi #endif @@ -306,7 +294,7 @@ contains include 'mpif.h' #endif integer(psb_mpk_) :: icontxt, tag, dest - integer(psb_ipk_), allocatable, intent(inout) :: buffer(:) + integer(psb_mpk_), allocatable, intent(inout) :: buffer(:) type(psb_buffer_queue) :: mesg_queue type(psb_buffer_node), pointer :: node integer(psb_ipk_) :: info @@ -324,55 +312,17 @@ contains write(psb_err_unit,*) 'Fatal memory error inside communication subsystem' return end if - call mpi_isend(node%intbuf,size(node%intbuf),psb_mpi_ipk_int,& + call mpi_isend(node%intbuf,size(node%intbuf),psb_mpi_mpk_int,& & dest,tag,icontxt,node%request,minfo) info = minfo call psb_insert_node(mesg_queue,node) call psb_test_nodes(mesg_queue) - end subroutine psi_isnd - -#if defined(LONG_INTEGERS) - subroutine psi_i4snd(icontxt,tag,dest,buffer,mesg_queue) -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - integer(psb_mpk_) :: icontxt, tag, dest - integer(psb_mpk_), allocatable, intent(inout) :: buffer(:) - type(psb_buffer_queue) :: mesg_queue - type(psb_buffer_node), pointer :: node - integer(psb_mpk_) :: info - integer(psb_mpk_) :: minfo - - allocate(node, stat=info) - if (info /= 0) then - write(psb_err_unit,*) 'Fatal memory error inside communication subsystem' - return - end if - node%icontxt = icontxt - node%buffer_type = psb_int4_type - call move_alloc(buffer,node%int4buf) - if (info /= 0) then - write(psb_err_unit,*) 'Fatal memory error inside communication subsystem' - return - end if - call mpi_isend(node%int4buf,size(node%int4buf),psb_mpi_mpk_int,& - & dest,tag,icontxt,node%request,minfo) - info = minfo - call psb_insert_node(mesg_queue,node) - - call psb_test_nodes(mesg_queue) + end subroutine psi_msnd - end subroutine psi_i4snd -#endif -#if !defined(LONG_INTEGERS) - subroutine psi_i8snd(icontxt,tag,dest,buffer,mesg_queue) + subroutine psi_esnd(icontxt,tag,dest,buffer,mesg_queue) #ifdef MPI_MOD use mpi #endif @@ -399,17 +349,15 @@ contains write(psb_err_unit,*) 'Fatal memory error inside communication subsystem' return end if - call mpi_isend(node%int8buf,size(node%int8buf),psb_mpi_lpk_int,& + call mpi_isend(node%int8buf,size(node%int8buf),psb_mpi_epk_int,& & dest,tag,icontxt,node%request,minfo) info = minfo call psb_insert_node(mesg_queue,node) call psb_test_nodes(mesg_queue) - end subroutine psi_i8snd -#endif + end subroutine psi_esnd -#if defined(SHORT_INTEGERS) subroutine psi_i2snd(icontxt,tag,dest,buffer,mesg_queue) #ifdef MPI_MOD use mpi @@ -419,7 +367,7 @@ contains include 'mpif.h' #endif integer(psb_mpk_) :: icontxt, tag, dest - integer(2), allocatable, intent(inout) :: buffer(:) + integer(psb_i2pk_), allocatable, intent(inout) :: buffer(:) type(psb_buffer_queue) :: mesg_queue type(psb_buffer_node), pointer :: node integer(psb_ipk_) :: info @@ -437,7 +385,7 @@ contains write(psb_err_unit,*) 'Fatal memory error inside communication subsystem' return end if - call mpi_isend(node%int2buf,size(node%int2buf),psb_mpi_mpk_int2,& + call mpi_isend(node%int2buf,size(node%int2buf),psb_mpi_i2pk_int,& & dest,tag,icontxt,node%request,minfo) info = minfo call psb_insert_node(mesg_queue,node) @@ -445,7 +393,6 @@ contains call psb_test_nodes(mesg_queue) end subroutine psi_i2snd -#endif subroutine psi_ssnd(icontxt,tag,dest,buffer,mesg_queue) #ifdef MPI_MOD @@ -592,7 +539,7 @@ contains end subroutine psi_zsnd - subroutine psi_lsnd(icontxt,tag,dest,buffer,mesg_queue) + subroutine psi_logsnd(icontxt,tag,dest,buffer,mesg_queue) #ifdef MPI_MOD use mpi #endif @@ -626,7 +573,7 @@ contains call psb_test_nodes(mesg_queue) - end subroutine psi_lsnd + end subroutine psi_logsnd subroutine psi_hsnd(icontxt,tag,dest,buffer,mesg_queue) diff --git a/base/modules/psi_p2p_mod.F90 b/base/modules/psi_p2p_mod.F90 index e4bb0a45..2d95fc13 100644 --- a/base/modules/psi_p2p_mod.F90 +++ b/base/modules/psi_p2p_mod.F90 @@ -108,7 +108,7 @@ module psi_p2p_mod end interface #endif -w + contains diff --git a/base/modules/psi_penv_mod.F90 b/base/modules/psi_penv_mod.F90 index 21137ac0..911a2d52 100644 --- a/base/modules/psi_penv_mod.F90 +++ b/base/modules/psi_penv_mod.F90 @@ -158,14 +158,16 @@ contains #if defined(INT_I4_L4) psb_mpi_ipk_int = mpi_integer psb_mpi_lpk_int = mpi_integer -#elsif defined(INT_I4_L8) +#elif defined(INT_I4_L8) psb_mpi_ipk_int = mpi_integer psb_mpi_lpk_int = mpi_integer8 -#elsif defined(INT_I8_L8) +#elif defined(INT_I8_L8) psb_mpi_ipk_int = mpi_integer8 psb_mpi_lpk_int = mpi_integer8 #else ! This should never happen + write(psb_err_unit,*) 'Warning: an impossible IPK/LPK combination.' + write(psb_err_unit,*) 'Something went wrong at configuration time.' psb_mpi_ipk_int = -1 psb_mpi_lpk_int = -1 #endif diff --git a/base/modules/serial/psb_c_base_vect_mod.f90 b/base/modules/serial/psb_c_base_vect_mod.f90 index 1cd250a0..1176376c 100644 --- a/base/modules/serial/psb_c_base_vect_mod.f90 +++ b/base/modules/serial/psb_c_base_vect_mod.f90 @@ -69,8 +69,9 @@ module psb_c_base_vect_mod ! Constructors/allocators ! procedure, pass(x) :: bld_x => c_base_bld_x - procedure, pass(x) :: bld_n => c_base_bld_n - generic, public :: bld => bld_x, bld_n + procedure, pass(x) :: bld_mn => c_base_bld_mn + procedure, pass(x) :: bld_en => c_base_bld_en + generic, public :: bld => bld_x, bld_mn, bld_en procedure, pass(x) :: all => c_base_all procedure, pass(x) :: mold => c_base_mold ! @@ -82,7 +83,9 @@ module psb_c_base_vect_mod procedure, pass(x) :: ins_v => c_base_ins_v generic, public :: ins => ins_a, ins_v procedure, pass(x) :: zero => c_base_zero - procedure, pass(x) :: asb => c_base_asb + procedure, pass(x) :: asb_m => c_base_asb_m + procedure, pass(x) :: asb_e => c_base_asb_e + generic, public :: asb => asb_m, asb_e procedure, pass(x) :: free => c_base_free ! ! Sync: centerpiece of handling of external storage. @@ -239,21 +242,37 @@ contains ! Create with size, but no initialization ! - !> Function bld_n: + !> Function bld_mn: !! \memberof psb_c_base_vect_type !! \brief Build method with size (uninitialized data) !! \param n size to be allocated. !! - subroutine c_base_bld_n(x,n) + subroutine c_base_bld_mn(x,n) use psb_realloc_mod - integer(psb_ipk_), intent(in) :: n + integer(psb_mpk_), intent(in) :: n + class(psb_c_base_vect_type), intent(inout) :: x + integer(psb_ipk_) :: info + + call psb_realloc(n,x%v,info) + call x%asb(n,info) + + end subroutine c_base_bld_mn + + !> Function bld_en: + !! \memberof psb_c_base_vect_type + !! \brief Build method with size (uninitialized data) + !! \param n size to be allocated. + !! + subroutine c_base_bld_en(x,n) + use psb_realloc_mod + integer(psb_epk_), intent(in) :: n class(psb_c_base_vect_type), intent(inout) :: x integer(psb_ipk_) :: info call psb_realloc(n,x%v,info) call x%asb(n,info) - end subroutine c_base_bld_n + end subroutine c_base_bld_en !> Function base_all: !! \memberof psb_c_base_vect_type @@ -435,11 +454,41 @@ contains !! ! - subroutine c_base_asb(n, x, info) + subroutine c_base_asb_m(n, x, info) use psi_serial_mod use psb_realloc_mod implicit none - integer(psb_ipk_), intent(in) :: n + integer(psb_mpk_), intent(in) :: n + class(psb_c_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + + info = 0 + if (x%get_nrows() < n) & + & call psb_realloc(n,x%v,info) + if (info /= 0) & + & call psb_errpush(psb_err_alloc_dealloc_,'vect_asb') + call x%sync() + end subroutine c_base_asb_m + + ! + ! Assembly. + ! For derived classes: after this the vector + ! storage is supposed to be in sync. + ! + !> Function base_asb: + !! \memberof psb_c_base_vect_type + !! \brief Assemble vector: reallocate as necessary. + !! + !! \param n final size + !! \param info return code + !! + ! + + subroutine c_base_asb_e(n, x, info) + use psi_serial_mod + use psb_realloc_mod + implicit none + integer(psb_epk_), intent(in) :: n class(psb_c_base_vect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info @@ -449,7 +498,7 @@ contains if (info /= 0) & & call psb_errpush(psb_err_alloc_dealloc_,'vect_asb') call x%sync() - end subroutine c_base_asb + end subroutine c_base_asb_e ! !> Function base_free: diff --git a/base/modules/serial/psb_c_vect_mod.F90 b/base/modules/serial/psb_c_vect_mod.F90 index fc0dd56d..8b587bd8 100644 --- a/base/modules/serial/psb_c_vect_mod.F90 +++ b/base/modules/serial/psb_c_vect_mod.F90 @@ -62,8 +62,9 @@ module psb_c_vect_mod procedure, pass(x) :: ins_v => c_vect_ins_v generic, public :: ins => ins_v, ins_a procedure, pass(x) :: bld_x => c_vect_bld_x - procedure, pass(x) :: bld_n => c_vect_bld_n - generic, public :: bld => bld_x, bld_n + procedure, pass(x) :: bld_mn => c_vect_bld_mn + procedure, pass(x) :: bld_en => c_vect_bld_en + generic, public :: bld => bld_x, bld_mn, bld_en procedure, pass(x) :: get_vect => c_vect_get_vect procedure, pass(x) :: cnv => c_vect_cnv procedure, pass(x) :: set_scal => c_vect_set_scal @@ -112,7 +113,8 @@ module psb_c_vect_mod & c_vect_all, c_vect_reall, c_vect_zero, c_vect_asb, & & c_vect_gthab, c_vect_gthzv, c_vect_sctb, & & c_vect_free, c_vect_ins_a, c_vect_ins_v, c_vect_bld_x, & - & c_vect_bld_n, c_vect_get_vect, c_vect_cnv, c_vect_set_scal, & + & c_vect_bld_mn, c_vect_bld_en, c_vect_get_vect, & + & c_vect_cnv, c_vect_set_scal, & & c_vect_set_vect, c_vect_clone, c_vect_sync, c_vect_is_host, & & c_vect_is_dev, c_vect_is_sync, c_vect_set_host, & & c_vect_set_dev, c_vect_set_sync @@ -216,8 +218,8 @@ contains end subroutine c_vect_bld_x - subroutine c_vect_bld_n(x,n,mold) - integer(psb_ipk_), intent(in) :: n + subroutine c_vect_bld_mn(x,n,mold) + integer(psb_mpk_), intent(in) :: n class(psb_c_vect_type), intent(inout) :: x class(psb_c_base_vect_type), intent(in), optional :: mold integer(psb_ipk_) :: info @@ -243,7 +245,37 @@ contains endif if (info == psb_success_) call x%v%bld(n) - end subroutine c_vect_bld_n + end subroutine c_vect_bld_mn + + + subroutine c_vect_bld_en(x,n,mold) + integer(psb_epk_), intent(in) :: n + class(psb_c_vect_type), intent(inout) :: x + class(psb_c_base_vect_type), intent(in), optional :: mold + integer(psb_ipk_) :: info + class(psb_c_base_vect_type), pointer :: mld + + + if (allocated(x%v)) & + & call x%free(info) + + if (present(mold)) then +#ifdef HAVE_MOLD + allocate(x%v,stat=info,mold=mold) +#else + call mold%mold(x%v,info) +#endif + else +#ifdef HAVE_MOLD + allocate(x%v,stat=info, mold=psb_c_get_base_vect_default()) +#else + mld = psb_c_get_base_vect_default() + call mld%mold(x%v,info) +#endif + endif + if (info == psb_success_) call x%v%bld(n) + + end subroutine c_vect_bld_en function c_vect_get_vect(x) result(res) class(psb_c_vect_type), intent(inout) :: x diff --git a/base/modules/serial/psb_d_base_vect_mod.f90 b/base/modules/serial/psb_d_base_vect_mod.f90 index adb32b95..61b38c8d 100644 --- a/base/modules/serial/psb_d_base_vect_mod.f90 +++ b/base/modules/serial/psb_d_base_vect_mod.f90 @@ -69,8 +69,9 @@ module psb_d_base_vect_mod ! Constructors/allocators ! procedure, pass(x) :: bld_x => d_base_bld_x - procedure, pass(x) :: bld_n => d_base_bld_n - generic, public :: bld => bld_x, bld_n + procedure, pass(x) :: bld_mn => d_base_bld_mn + procedure, pass(x) :: bld_en => d_base_bld_en + generic, public :: bld => bld_x, bld_mn, bld_en procedure, pass(x) :: all => d_base_all procedure, pass(x) :: mold => d_base_mold ! @@ -82,7 +83,9 @@ module psb_d_base_vect_mod procedure, pass(x) :: ins_v => d_base_ins_v generic, public :: ins => ins_a, ins_v procedure, pass(x) :: zero => d_base_zero - procedure, pass(x) :: asb => d_base_asb + procedure, pass(x) :: asb_m => d_base_asb_m + procedure, pass(x) :: asb_e => d_base_asb_e + generic, public :: asb => asb_m, asb_e procedure, pass(x) :: free => d_base_free ! ! Sync: centerpiece of handling of external storage. @@ -239,21 +242,37 @@ contains ! Create with size, but no initialization ! - !> Function bld_n: + !> Function bld_mn: !! \memberof psb_d_base_vect_type !! \brief Build method with size (uninitialized data) !! \param n size to be allocated. !! - subroutine d_base_bld_n(x,n) + subroutine d_base_bld_mn(x,n) use psb_realloc_mod - integer(psb_ipk_), intent(in) :: n + integer(psb_mpk_), intent(in) :: n + class(psb_d_base_vect_type), intent(inout) :: x + integer(psb_ipk_) :: info + + call psb_realloc(n,x%v,info) + call x%asb(n,info) + + end subroutine d_base_bld_mn + + !> Function bld_en: + !! \memberof psb_d_base_vect_type + !! \brief Build method with size (uninitialized data) + !! \param n size to be allocated. + !! + subroutine d_base_bld_en(x,n) + use psb_realloc_mod + integer(psb_epk_), intent(in) :: n class(psb_d_base_vect_type), intent(inout) :: x integer(psb_ipk_) :: info call psb_realloc(n,x%v,info) call x%asb(n,info) - end subroutine d_base_bld_n + end subroutine d_base_bld_en !> Function base_all: !! \memberof psb_d_base_vect_type @@ -435,11 +454,41 @@ contains !! ! - subroutine d_base_asb(n, x, info) + subroutine d_base_asb_m(n, x, info) use psi_serial_mod use psb_realloc_mod implicit none - integer(psb_ipk_), intent(in) :: n + integer(psb_mpk_), intent(in) :: n + class(psb_d_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + + info = 0 + if (x%get_nrows() < n) & + & call psb_realloc(n,x%v,info) + if (info /= 0) & + & call psb_errpush(psb_err_alloc_dealloc_,'vect_asb') + call x%sync() + end subroutine d_base_asb_m + + ! + ! Assembly. + ! For derived classes: after this the vector + ! storage is supposed to be in sync. + ! + !> Function base_asb: + !! \memberof psb_d_base_vect_type + !! \brief Assemble vector: reallocate as necessary. + !! + !! \param n final size + !! \param info return code + !! + ! + + subroutine d_base_asb_e(n, x, info) + use psi_serial_mod + use psb_realloc_mod + implicit none + integer(psb_epk_), intent(in) :: n class(psb_d_base_vect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info @@ -449,7 +498,7 @@ contains if (info /= 0) & & call psb_errpush(psb_err_alloc_dealloc_,'vect_asb') call x%sync() - end subroutine d_base_asb + end subroutine d_base_asb_e ! !> Function base_free: diff --git a/base/modules/serial/psb_d_vect_mod.F90 b/base/modules/serial/psb_d_vect_mod.F90 index 12023c4f..dfa3acaf 100644 --- a/base/modules/serial/psb_d_vect_mod.F90 +++ b/base/modules/serial/psb_d_vect_mod.F90 @@ -62,8 +62,9 @@ module psb_d_vect_mod procedure, pass(x) :: ins_v => d_vect_ins_v generic, public :: ins => ins_v, ins_a procedure, pass(x) :: bld_x => d_vect_bld_x - procedure, pass(x) :: bld_n => d_vect_bld_n - generic, public :: bld => bld_x, bld_n + procedure, pass(x) :: bld_mn => d_vect_bld_mn + procedure, pass(x) :: bld_en => d_vect_bld_en + generic, public :: bld => bld_x, bld_mn, bld_en procedure, pass(x) :: get_vect => d_vect_get_vect procedure, pass(x) :: cnv => d_vect_cnv procedure, pass(x) :: set_scal => d_vect_set_scal @@ -112,7 +113,8 @@ module psb_d_vect_mod & d_vect_all, d_vect_reall, d_vect_zero, d_vect_asb, & & d_vect_gthab, d_vect_gthzv, d_vect_sctb, & & d_vect_free, d_vect_ins_a, d_vect_ins_v, d_vect_bld_x, & - & d_vect_bld_n, d_vect_get_vect, d_vect_cnv, d_vect_set_scal, & + & d_vect_bld_mn, d_vect_bld_en, d_vect_get_vect, & + & d_vect_cnv, d_vect_set_scal, & & d_vect_set_vect, d_vect_clone, d_vect_sync, d_vect_is_host, & & d_vect_is_dev, d_vect_is_sync, d_vect_set_host, & & d_vect_set_dev, d_vect_set_sync @@ -216,8 +218,8 @@ contains end subroutine d_vect_bld_x - subroutine d_vect_bld_n(x,n,mold) - integer(psb_ipk_), intent(in) :: n + subroutine d_vect_bld_mn(x,n,mold) + integer(psb_mpk_), intent(in) :: n class(psb_d_vect_type), intent(inout) :: x class(psb_d_base_vect_type), intent(in), optional :: mold integer(psb_ipk_) :: info @@ -243,7 +245,37 @@ contains endif if (info == psb_success_) call x%v%bld(n) - end subroutine d_vect_bld_n + end subroutine d_vect_bld_mn + + + subroutine d_vect_bld_en(x,n,mold) + integer(psb_epk_), intent(in) :: n + class(psb_d_vect_type), intent(inout) :: x + class(psb_d_base_vect_type), intent(in), optional :: mold + integer(psb_ipk_) :: info + class(psb_d_base_vect_type), pointer :: mld + + + if (allocated(x%v)) & + & call x%free(info) + + if (present(mold)) then +#ifdef HAVE_MOLD + allocate(x%v,stat=info,mold=mold) +#else + call mold%mold(x%v,info) +#endif + else +#ifdef HAVE_MOLD + allocate(x%v,stat=info, mold=psb_d_get_base_vect_default()) +#else + mld = psb_d_get_base_vect_default() + call mld%mold(x%v,info) +#endif + endif + if (info == psb_success_) call x%v%bld(n) + + end subroutine d_vect_bld_en function d_vect_get_vect(x) result(res) class(psb_d_vect_type), intent(inout) :: x diff --git a/base/modules/serial/psb_i_base_vect_mod.f90 b/base/modules/serial/psb_i_base_vect_mod.f90 index ed1b8c1c..8d6f2cc5 100644 --- a/base/modules/serial/psb_i_base_vect_mod.f90 +++ b/base/modules/serial/psb_i_base_vect_mod.f90 @@ -68,8 +68,9 @@ module psb_i_base_vect_mod ! Constructors/allocators ! procedure, pass(x) :: bld_x => i_base_bld_x - procedure, pass(x) :: bld_n => i_base_bld_n - generic, public :: bld => bld_x, bld_n + procedure, pass(x) :: bld_mn => i_base_bld_mn + procedure, pass(x) :: bld_en => i_base_bld_en + generic, public :: bld => bld_x, bld_mn, bld_en procedure, pass(x) :: all => i_base_all procedure, pass(x) :: mold => i_base_mold ! @@ -81,7 +82,9 @@ module psb_i_base_vect_mod procedure, pass(x) :: ins_v => i_base_ins_v generic, public :: ins => ins_a, ins_v procedure, pass(x) :: zero => i_base_zero - procedure, pass(x) :: asb => i_base_asb + procedure, pass(x) :: asb_m => i_base_asb_m + procedure, pass(x) :: asb_e => i_base_asb_e + generic, public :: asb => asb_m, asb_e procedure, pass(x) :: free => i_base_free ! ! Sync: centerpiece of handling of external storage. @@ -208,21 +211,37 @@ contains ! Create with size, but no initialization ! - !> Function bld_n: + !> Function bld_mn: !! \memberof psb_i_base_vect_type !! \brief Build method with size (uninitialized data) !! \param n size to be allocated. !! - subroutine i_base_bld_n(x,n) + subroutine i_base_bld_mn(x,n) use psb_realloc_mod - integer(psb_ipk_), intent(in) :: n + integer(psb_mpk_), intent(in) :: n + class(psb_i_base_vect_type), intent(inout) :: x + integer(psb_ipk_) :: info + + call psb_realloc(n,x%v,info) + call x%asb(n,info) + + end subroutine i_base_bld_mn + + !> Function bld_en: + !! \memberof psb_i_base_vect_type + !! \brief Build method with size (uninitialized data) + !! \param n size to be allocated. + !! + subroutine i_base_bld_en(x,n) + use psb_realloc_mod + integer(psb_epk_), intent(in) :: n class(psb_i_base_vect_type), intent(inout) :: x integer(psb_ipk_) :: info call psb_realloc(n,x%v,info) call x%asb(n,info) - end subroutine i_base_bld_n + end subroutine i_base_bld_en !> Function base_all: !! \memberof psb_i_base_vect_type @@ -404,11 +423,41 @@ contains !! ! - subroutine i_base_asb(n, x, info) + subroutine i_base_asb_m(n, x, info) use psi_serial_mod use psb_realloc_mod implicit none - integer(psb_ipk_), intent(in) :: n + integer(psb_mpk_), intent(in) :: n + class(psb_i_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + + info = 0 + if (x%get_nrows() < n) & + & call psb_realloc(n,x%v,info) + if (info /= 0) & + & call psb_errpush(psb_err_alloc_dealloc_,'vect_asb') + call x%sync() + end subroutine i_base_asb_m + + ! + ! Assembly. + ! For derived classes: after this the vector + ! storage is supposed to be in sync. + ! + !> Function base_asb: + !! \memberof psb_i_base_vect_type + !! \brief Assemble vector: reallocate as necessary. + !! + !! \param n final size + !! \param info return code + !! + ! + + subroutine i_base_asb_e(n, x, info) + use psi_serial_mod + use psb_realloc_mod + implicit none + integer(psb_epk_), intent(in) :: n class(psb_i_base_vect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info @@ -418,7 +467,7 @@ contains if (info /= 0) & & call psb_errpush(psb_err_alloc_dealloc_,'vect_asb') call x%sync() - end subroutine i_base_asb + end subroutine i_base_asb_e ! !> Function base_free: diff --git a/base/modules/serial/psb_i_vect_mod.F90 b/base/modules/serial/psb_i_vect_mod.F90 index 568e78cf..891d0ced 100644 --- a/base/modules/serial/psb_i_vect_mod.F90 +++ b/base/modules/serial/psb_i_vect_mod.F90 @@ -61,8 +61,9 @@ module psb_i_vect_mod procedure, pass(x) :: ins_v => i_vect_ins_v generic, public :: ins => ins_v, ins_a procedure, pass(x) :: bld_x => i_vect_bld_x - procedure, pass(x) :: bld_n => i_vect_bld_n - generic, public :: bld => bld_x, bld_n + procedure, pass(x) :: bld_mn => i_vect_bld_mn + procedure, pass(x) :: bld_en => i_vect_bld_en + generic, public :: bld => bld_x, bld_mn, bld_en procedure, pass(x) :: get_vect => i_vect_get_vect procedure, pass(x) :: cnv => i_vect_cnv procedure, pass(x) :: set_scal => i_vect_set_scal @@ -90,7 +91,8 @@ module psb_i_vect_mod & i_vect_all, i_vect_reall, i_vect_zero, i_vect_asb, & & i_vect_gthab, i_vect_gthzv, i_vect_sctb, & & i_vect_free, i_vect_ins_a, i_vect_ins_v, i_vect_bld_x, & - & i_vect_bld_n, i_vect_get_vect, i_vect_cnv, i_vect_set_scal, & + & i_vect_bld_mn, i_vect_bld_en, i_vect_get_vect, & + & i_vect_cnv, i_vect_set_scal, & & i_vect_set_vect, i_vect_clone, i_vect_sync, i_vect_is_host, & & i_vect_is_dev, i_vect_is_sync, i_vect_set_host, & & i_vect_set_dev, i_vect_set_sync @@ -189,8 +191,8 @@ contains end subroutine i_vect_bld_x - subroutine i_vect_bld_n(x,n,mold) - integer(psb_ipk_), intent(in) :: n + subroutine i_vect_bld_mn(x,n,mold) + integer(psb_mpk_), intent(in) :: n class(psb_i_vect_type), intent(inout) :: x class(psb_i_base_vect_type), intent(in), optional :: mold integer(psb_ipk_) :: info @@ -216,7 +218,37 @@ contains endif if (info == psb_success_) call x%v%bld(n) - end subroutine i_vect_bld_n + end subroutine i_vect_bld_mn + + + subroutine i_vect_bld_en(x,n,mold) + integer(psb_epk_), intent(in) :: n + class(psb_i_vect_type), intent(inout) :: x + class(psb_i_base_vect_type), intent(in), optional :: mold + integer(psb_ipk_) :: info + class(psb_i_base_vect_type), pointer :: mld + + + if (allocated(x%v)) & + & call x%free(info) + + if (present(mold)) then +#ifdef HAVE_MOLD + allocate(x%v,stat=info,mold=mold) +#else + call mold%mold(x%v,info) +#endif + else +#ifdef HAVE_MOLD + allocate(x%v,stat=info, mold=psb_i_get_base_vect_default()) +#else + mld = psb_i_get_base_vect_default() + call mld%mold(x%v,info) +#endif + endif + if (info == psb_success_) call x%v%bld(n) + + end subroutine i_vect_bld_en function i_vect_get_vect(x) result(res) class(psb_i_vect_type), intent(inout) :: x diff --git a/base/modules/serial/psb_s_base_vect_mod.f90 b/base/modules/serial/psb_s_base_vect_mod.f90 index 22353f88..0e9ee727 100644 --- a/base/modules/serial/psb_s_base_vect_mod.f90 +++ b/base/modules/serial/psb_s_base_vect_mod.f90 @@ -69,8 +69,9 @@ module psb_s_base_vect_mod ! Constructors/allocators ! procedure, pass(x) :: bld_x => s_base_bld_x - procedure, pass(x) :: bld_n => s_base_bld_n - generic, public :: bld => bld_x, bld_n + procedure, pass(x) :: bld_mn => s_base_bld_mn + procedure, pass(x) :: bld_en => s_base_bld_en + generic, public :: bld => bld_x, bld_mn, bld_en procedure, pass(x) :: all => s_base_all procedure, pass(x) :: mold => s_base_mold ! @@ -82,7 +83,9 @@ module psb_s_base_vect_mod procedure, pass(x) :: ins_v => s_base_ins_v generic, public :: ins => ins_a, ins_v procedure, pass(x) :: zero => s_base_zero - procedure, pass(x) :: asb => s_base_asb + procedure, pass(x) :: asb_m => s_base_asb_m + procedure, pass(x) :: asb_e => s_base_asb_e + generic, public :: asb => asb_m, asb_e procedure, pass(x) :: free => s_base_free ! ! Sync: centerpiece of handling of external storage. @@ -239,21 +242,37 @@ contains ! Create with size, but no initialization ! - !> Function bld_n: + !> Function bld_mn: !! \memberof psb_s_base_vect_type !! \brief Build method with size (uninitialized data) !! \param n size to be allocated. !! - subroutine s_base_bld_n(x,n) + subroutine s_base_bld_mn(x,n) use psb_realloc_mod - integer(psb_ipk_), intent(in) :: n + integer(psb_mpk_), intent(in) :: n + class(psb_s_base_vect_type), intent(inout) :: x + integer(psb_ipk_) :: info + + call psb_realloc(n,x%v,info) + call x%asb(n,info) + + end subroutine s_base_bld_mn + + !> Function bld_en: + !! \memberof psb_s_base_vect_type + !! \brief Build method with size (uninitialized data) + !! \param n size to be allocated. + !! + subroutine s_base_bld_en(x,n) + use psb_realloc_mod + integer(psb_epk_), intent(in) :: n class(psb_s_base_vect_type), intent(inout) :: x integer(psb_ipk_) :: info call psb_realloc(n,x%v,info) call x%asb(n,info) - end subroutine s_base_bld_n + end subroutine s_base_bld_en !> Function base_all: !! \memberof psb_s_base_vect_type @@ -435,11 +454,41 @@ contains !! ! - subroutine s_base_asb(n, x, info) + subroutine s_base_asb_m(n, x, info) use psi_serial_mod use psb_realloc_mod implicit none - integer(psb_ipk_), intent(in) :: n + integer(psb_mpk_), intent(in) :: n + class(psb_s_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + + info = 0 + if (x%get_nrows() < n) & + & call psb_realloc(n,x%v,info) + if (info /= 0) & + & call psb_errpush(psb_err_alloc_dealloc_,'vect_asb') + call x%sync() + end subroutine s_base_asb_m + + ! + ! Assembly. + ! For derived classes: after this the vector + ! storage is supposed to be in sync. + ! + !> Function base_asb: + !! \memberof psb_s_base_vect_type + !! \brief Assemble vector: reallocate as necessary. + !! + !! \param n final size + !! \param info return code + !! + ! + + subroutine s_base_asb_e(n, x, info) + use psi_serial_mod + use psb_realloc_mod + implicit none + integer(psb_epk_), intent(in) :: n class(psb_s_base_vect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info @@ -449,7 +498,7 @@ contains if (info /= 0) & & call psb_errpush(psb_err_alloc_dealloc_,'vect_asb') call x%sync() - end subroutine s_base_asb + end subroutine s_base_asb_e ! !> Function base_free: diff --git a/base/modules/serial/psb_s_vect_mod.F90 b/base/modules/serial/psb_s_vect_mod.F90 index eb9febb6..6175017a 100644 --- a/base/modules/serial/psb_s_vect_mod.F90 +++ b/base/modules/serial/psb_s_vect_mod.F90 @@ -62,8 +62,9 @@ module psb_s_vect_mod procedure, pass(x) :: ins_v => s_vect_ins_v generic, public :: ins => ins_v, ins_a procedure, pass(x) :: bld_x => s_vect_bld_x - procedure, pass(x) :: bld_n => s_vect_bld_n - generic, public :: bld => bld_x, bld_n + procedure, pass(x) :: bld_mn => s_vect_bld_mn + procedure, pass(x) :: bld_en => s_vect_bld_en + generic, public :: bld => bld_x, bld_mn, bld_en procedure, pass(x) :: get_vect => s_vect_get_vect procedure, pass(x) :: cnv => s_vect_cnv procedure, pass(x) :: set_scal => s_vect_set_scal @@ -112,7 +113,8 @@ module psb_s_vect_mod & s_vect_all, s_vect_reall, s_vect_zero, s_vect_asb, & & s_vect_gthab, s_vect_gthzv, s_vect_sctb, & & s_vect_free, s_vect_ins_a, s_vect_ins_v, s_vect_bld_x, & - & s_vect_bld_n, s_vect_get_vect, s_vect_cnv, s_vect_set_scal, & + & s_vect_bld_mn, s_vect_bld_en, s_vect_get_vect, & + & s_vect_cnv, s_vect_set_scal, & & s_vect_set_vect, s_vect_clone, s_vect_sync, s_vect_is_host, & & s_vect_is_dev, s_vect_is_sync, s_vect_set_host, & & s_vect_set_dev, s_vect_set_sync @@ -216,8 +218,8 @@ contains end subroutine s_vect_bld_x - subroutine s_vect_bld_n(x,n,mold) - integer(psb_ipk_), intent(in) :: n + subroutine s_vect_bld_mn(x,n,mold) + integer(psb_mpk_), intent(in) :: n class(psb_s_vect_type), intent(inout) :: x class(psb_s_base_vect_type), intent(in), optional :: mold integer(psb_ipk_) :: info @@ -243,7 +245,37 @@ contains endif if (info == psb_success_) call x%v%bld(n) - end subroutine s_vect_bld_n + end subroutine s_vect_bld_mn + + + subroutine s_vect_bld_en(x,n,mold) + integer(psb_epk_), intent(in) :: n + class(psb_s_vect_type), intent(inout) :: x + class(psb_s_base_vect_type), intent(in), optional :: mold + integer(psb_ipk_) :: info + class(psb_s_base_vect_type), pointer :: mld + + + if (allocated(x%v)) & + & call x%free(info) + + if (present(mold)) then +#ifdef HAVE_MOLD + allocate(x%v,stat=info,mold=mold) +#else + call mold%mold(x%v,info) +#endif + else +#ifdef HAVE_MOLD + allocate(x%v,stat=info, mold=psb_s_get_base_vect_default()) +#else + mld = psb_s_get_base_vect_default() + call mld%mold(x%v,info) +#endif + endif + if (info == psb_success_) call x%v%bld(n) + + end subroutine s_vect_bld_en function s_vect_get_vect(x) result(res) class(psb_s_vect_type), intent(inout) :: x diff --git a/base/modules/serial/psb_z_base_vect_mod.f90 b/base/modules/serial/psb_z_base_vect_mod.f90 index e2a4a89f..737cdc8c 100644 --- a/base/modules/serial/psb_z_base_vect_mod.f90 +++ b/base/modules/serial/psb_z_base_vect_mod.f90 @@ -69,8 +69,9 @@ module psb_z_base_vect_mod ! Constructors/allocators ! procedure, pass(x) :: bld_x => z_base_bld_x - procedure, pass(x) :: bld_n => z_base_bld_n - generic, public :: bld => bld_x, bld_n + procedure, pass(x) :: bld_mn => z_base_bld_mn + procedure, pass(x) :: bld_en => z_base_bld_en + generic, public :: bld => bld_x, bld_mn, bld_en procedure, pass(x) :: all => z_base_all procedure, pass(x) :: mold => z_base_mold ! @@ -82,7 +83,9 @@ module psb_z_base_vect_mod procedure, pass(x) :: ins_v => z_base_ins_v generic, public :: ins => ins_a, ins_v procedure, pass(x) :: zero => z_base_zero - procedure, pass(x) :: asb => z_base_asb + procedure, pass(x) :: asb_m => z_base_asb_m + procedure, pass(x) :: asb_e => z_base_asb_e + generic, public :: asb => asb_m, asb_e procedure, pass(x) :: free => z_base_free ! ! Sync: centerpiece of handling of external storage. @@ -239,21 +242,37 @@ contains ! Create with size, but no initialization ! - !> Function bld_n: + !> Function bld_mn: !! \memberof psb_z_base_vect_type !! \brief Build method with size (uninitialized data) !! \param n size to be allocated. !! - subroutine z_base_bld_n(x,n) + subroutine z_base_bld_mn(x,n) use psb_realloc_mod - integer(psb_ipk_), intent(in) :: n + integer(psb_mpk_), intent(in) :: n + class(psb_z_base_vect_type), intent(inout) :: x + integer(psb_ipk_) :: info + + call psb_realloc(n,x%v,info) + call x%asb(n,info) + + end subroutine z_base_bld_mn + + !> Function bld_en: + !! \memberof psb_z_base_vect_type + !! \brief Build method with size (uninitialized data) + !! \param n size to be allocated. + !! + subroutine z_base_bld_en(x,n) + use psb_realloc_mod + integer(psb_epk_), intent(in) :: n class(psb_z_base_vect_type), intent(inout) :: x integer(psb_ipk_) :: info call psb_realloc(n,x%v,info) call x%asb(n,info) - end subroutine z_base_bld_n + end subroutine z_base_bld_en !> Function base_all: !! \memberof psb_z_base_vect_type @@ -435,11 +454,41 @@ contains !! ! - subroutine z_base_asb(n, x, info) + subroutine z_base_asb_m(n, x, info) use psi_serial_mod use psb_realloc_mod implicit none - integer(psb_ipk_), intent(in) :: n + integer(psb_mpk_), intent(in) :: n + class(psb_z_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + + info = 0 + if (x%get_nrows() < n) & + & call psb_realloc(n,x%v,info) + if (info /= 0) & + & call psb_errpush(psb_err_alloc_dealloc_,'vect_asb') + call x%sync() + end subroutine z_base_asb_m + + ! + ! Assembly. + ! For derived classes: after this the vector + ! storage is supposed to be in sync. + ! + !> Function base_asb: + !! \memberof psb_z_base_vect_type + !! \brief Assemble vector: reallocate as necessary. + !! + !! \param n final size + !! \param info return code + !! + ! + + subroutine z_base_asb_e(n, x, info) + use psi_serial_mod + use psb_realloc_mod + implicit none + integer(psb_epk_), intent(in) :: n class(psb_z_base_vect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info @@ -449,7 +498,7 @@ contains if (info /= 0) & & call psb_errpush(psb_err_alloc_dealloc_,'vect_asb') call x%sync() - end subroutine z_base_asb + end subroutine z_base_asb_e ! !> Function base_free: diff --git a/base/modules/serial/psb_z_vect_mod.F90 b/base/modules/serial/psb_z_vect_mod.F90 index 78cf99e6..5dd91c92 100644 --- a/base/modules/serial/psb_z_vect_mod.F90 +++ b/base/modules/serial/psb_z_vect_mod.F90 @@ -62,8 +62,9 @@ module psb_z_vect_mod procedure, pass(x) :: ins_v => z_vect_ins_v generic, public :: ins => ins_v, ins_a procedure, pass(x) :: bld_x => z_vect_bld_x - procedure, pass(x) :: bld_n => z_vect_bld_n - generic, public :: bld => bld_x, bld_n + procedure, pass(x) :: bld_mn => z_vect_bld_mn + procedure, pass(x) :: bld_en => z_vect_bld_en + generic, public :: bld => bld_x, bld_mn, bld_en procedure, pass(x) :: get_vect => z_vect_get_vect procedure, pass(x) :: cnv => z_vect_cnv procedure, pass(x) :: set_scal => z_vect_set_scal @@ -112,7 +113,8 @@ module psb_z_vect_mod & z_vect_all, z_vect_reall, z_vect_zero, z_vect_asb, & & z_vect_gthab, z_vect_gthzv, z_vect_sctb, & & z_vect_free, z_vect_ins_a, z_vect_ins_v, z_vect_bld_x, & - & z_vect_bld_n, z_vect_get_vect, z_vect_cnv, z_vect_set_scal, & + & z_vect_bld_mn, z_vect_bld_en, z_vect_get_vect, & + & z_vect_cnv, z_vect_set_scal, & & z_vect_set_vect, z_vect_clone, z_vect_sync, z_vect_is_host, & & z_vect_is_dev, z_vect_is_sync, z_vect_set_host, & & z_vect_set_dev, z_vect_set_sync @@ -216,8 +218,8 @@ contains end subroutine z_vect_bld_x - subroutine z_vect_bld_n(x,n,mold) - integer(psb_ipk_), intent(in) :: n + subroutine z_vect_bld_mn(x,n,mold) + integer(psb_mpk_), intent(in) :: n class(psb_z_vect_type), intent(inout) :: x class(psb_z_base_vect_type), intent(in), optional :: mold integer(psb_ipk_) :: info @@ -243,7 +245,37 @@ contains endif if (info == psb_success_) call x%v%bld(n) - end subroutine z_vect_bld_n + end subroutine z_vect_bld_mn + + + subroutine z_vect_bld_en(x,n,mold) + integer(psb_epk_), intent(in) :: n + class(psb_z_vect_type), intent(inout) :: x + class(psb_z_base_vect_type), intent(in), optional :: mold + integer(psb_ipk_) :: info + class(psb_z_base_vect_type), pointer :: mld + + + if (allocated(x%v)) & + & call x%free(info) + + if (present(mold)) then +#ifdef HAVE_MOLD + allocate(x%v,stat=info,mold=mold) +#else + call mold%mold(x%v,info) +#endif + else +#ifdef HAVE_MOLD + allocate(x%v,stat=info, mold=psb_z_get_base_vect_default()) +#else + mld = psb_z_get_base_vect_default() + call mld%mold(x%v,info) +#endif + endif + if (info == psb_success_) call x%v%bld(n) + + end subroutine z_vect_bld_en function z_vect_get_vect(x) result(res) class(psb_z_vect_type), intent(inout) :: x