fdurastante
/
psblas3
mirror of https://github.com/sfilippone/psblas3.git
1
0
Fork 0
Code Issues Packages Projects Releases Wiki Activity

Merged with development to fix

Browse Source
anderson
Cirdans-Home 3 years ago
parent 00df32c581
commit 301528e9d9
7 changed files with 707 additions and 791 deletions
Show Stats Download Patch File Download Diff File

214
base/modules/auxil/psb_c_realloc_mod.F90
Unescape Escape View File

@ -1,9 +1,9 @@
! !
! Parallel Sparse BLAS version 3.5 ! Parallel Sparse BLAS version 3.5
! (C) Copyright 2006-2018 ! (C) Copyright 2006-2018
! Salvatore Filippone ! Salvatore Filippone
! Alfredo Buttari ! Alfredo Buttari
! !
! Redistribution and use in source and binary forms, with or without ! Redistribution and use in source and binary forms, with or without
! modification, are permitted provided that the following conditions ! modification, are permitted provided that the following conditions
! are met: ! are met:
@ -15,7 +15,7 @@
! 3. The name of the PSBLAS group or the names of its contributors may ! 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 ! not be used to endorse or promote products derived from this
! software without specific written permission. ! software without specific written permission.
! !
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR ! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
@ -27,16 +27,16 @@
! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ! 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 ! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
! POSSIBILITY OF SUCH DAMAGE. ! POSSIBILITY OF SUCH DAMAGE.
! !
! !
module psb_c_realloc_mod module psb_c_realloc_mod
use psb_const_mod use psb_const_mod
implicit none implicit none
! !
! psb_realloc will reallocate the input array to have exactly ! psb_realloc will reallocate the input array to have exactly
! the size specified, possibly shortening it. ! the size specified, possibly shortening it.
! !
Interface psb_realloc Interface psb_realloc
module procedure psb_r_c_s module procedure psb_r_c_s
@ -49,7 +49,7 @@ module psb_c_realloc_mod
module procedure psb_r_m_2_c_rk1 module procedure psb_r_m_2_c_rk1
module procedure psb_r_e_2_c_rk1 module procedure psb_r_e_2_c_rk1
end Interface psb_realloc end Interface psb_realloc
interface psb_move_alloc interface psb_move_alloc
@ -66,7 +66,7 @@ module psb_c_realloc_mod
! !
! psb_ensure_size will reallocate the input array if necessary ! psb_ensure_size will reallocate the input array if necessary
! to guarantee that its size is at least as large as the ! to guarantee that its size is at least as large as the
! value required, usually with some room to spare. ! value required, usually with some room to spare.
! !
interface psb_ensure_size interface psb_ensure_size
@ -74,7 +74,7 @@ module psb_c_realloc_mod
end Interface psb_ensure_size end Interface psb_ensure_size
! !
! psb_size returns 0 if argument is not allocated. ! psb_size returns 0 if argument is not allocated.
! !
interface psb_size interface psb_size
module procedure psb_size_c_rk1, psb_size_c_rk2 module procedure psb_size_c_rk1, psb_size_c_rk2
@ -86,7 +86,7 @@ Contains
Subroutine psb_r_c_s(rrax,info) Subroutine psb_r_c_s(rrax,info)
use psb_error_mod use psb_error_mod
! ...Subroutine Arguments ! ...Subroutine Arguments
complex(psb_spk_), allocatable, intent(inout) :: rrax complex(psb_spk_), allocatable, intent(inout) :: rrax
integer(psb_ipk_) :: info integer(psb_ipk_) :: info
@ -97,9 +97,9 @@ Contains
name='psb_r_c_s' name='psb_r_c_s'
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
info=psb_success_ info=psb_success_
if (.not.allocated(rrax)) then if (.not.allocated(rrax)) then
Allocate(rrax,stat=info) Allocate(rrax,stat=info)
if (info /= psb_success_) then if (info /= psb_success_) then
err=4025 err=4025
@ -122,7 +122,7 @@ Contains
Subroutine psb_r_m_c_rk1(len,rrax,info,pad,lb) Subroutine psb_r_m_c_rk1(len,rrax,info,pad,lb)
use psb_error_mod use psb_error_mod
! ...Subroutine Arguments ! ...Subroutine Arguments
integer(psb_mpk_),Intent(in) :: len integer(psb_mpk_),Intent(in) :: len
complex(psb_spk_), allocatable, intent(inout) :: rrax(:) complex(psb_spk_), allocatable, intent(inout) :: rrax(:)
integer(psb_ipk_) :: info integer(psb_ipk_) :: info
@ -138,7 +138,7 @@ Contains
name='psb_r_m_c_rk1' name='psb_r_m_c_rk1'
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
info=psb_success_ info=psb_success_
if (debug) write(psb_err_unit,*) 'reallocate D',len if (debug) write(psb_err_unit,*) 'reallocate D',len
if (present(lb)) then if (present(lb)) then
@ -146,7 +146,7 @@ Contains
else else
lb_ = 1 lb_ = 1
endif endif
if ((len<0)) then if ((len<0)) then
err=4025 err=4025
call psb_errpush(err,name, l_err=(/len*1_psb_lpk_/), & call psb_errpush(err,name, l_err=(/len*1_psb_lpk_/), &
& a_err='complex(psb_spk_)') & a_err='complex(psb_spk_)')
@ -154,7 +154,7 @@ Contains
end if end if
ub_ = lb_ + len-1 ub_ = lb_ + len-1
if (allocated(rrax)) then if (allocated(rrax)) then
dim = size(rrax) dim = size(rrax)
lbi = lbound(rrax,1) lbi = lbound(rrax,1)
If ((dim /= len).or.(lbi /= lb_)) Then If ((dim /= len).or.(lbi /= lb_)) Then
@ -178,7 +178,7 @@ Contains
goto 9999 goto 9999
end if end if
endif endif
if (present(pad)) then if (present(pad)) then
!$omp parallel do private(i) shared(dim,len) !$omp parallel do private(i) shared(dim,len)
do i=lb_-1+dim+1,lb_-1+len do i=lb_-1+dim+1,lb_-1+len
rrax(i) = pad rrax(i) = pad
@ -196,7 +196,7 @@ Contains
Subroutine psb_r_m_c_rk2(len1,len2,rrax,info,pad,lb1,lb2) Subroutine psb_r_m_c_rk2(len1,len2,rrax,info,pad,lb1,lb2)
use psb_error_mod use psb_error_mod
! ...Subroutine Arguments ! ...Subroutine Arguments
integer(psb_mpk_),Intent(in) :: len1,len2 integer(psb_mpk_),Intent(in) :: len1,len2
complex(psb_spk_),allocatable :: rrax(:,:) complex(psb_spk_),allocatable :: rrax(:,:)
integer(psb_ipk_) :: info integer(psb_ipk_) :: info
@ -212,13 +212,13 @@ Contains
name='psb_r_m_c_rk2' name='psb_r_m_c_rk2'
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
info=psb_success_ info=psb_success_
if (present(lb1)) then if (present(lb1)) then
lb1_ = lb1 lb1_ = lb1
else else
lb1_ = 1 lb1_ = 1
endif endif
if (present(lb2)) then if (present(lb2)) then
lb2_ = lb2 lb2_ = lb2
else else
lb2_ = 1 lb2_ = 1
@ -227,7 +227,7 @@ Contains
ub2_ = lb2_ + len2 -1 ub2_ = lb2_ + len2 -1
if (len1 < 0) then if (len1 < 0) then
err=4025 err=4025
call psb_errpush(err,name, l_err=(/len1*1_psb_lpk_/), & call psb_errpush(err,name, l_err=(/len1*1_psb_lpk_/), &
& a_err='complex(psb_spk_)') & a_err='complex(psb_spk_)')
goto 9999 goto 9999
@ -240,7 +240,7 @@ Contains
end if end if
if (allocated(rrax)) then if (allocated(rrax)) then
dim = size(rrax,1) dim = size(rrax,1)
lbi1 = lbound(rrax,1) lbi1 = lbound(rrax,1)
dim2 = size(rrax,2) dim2 = size(rrax,2)
@ -269,7 +269,7 @@ Contains
goto 9999 goto 9999
end if end if
endif endif
if (present(pad)) then if (present(pad)) then
!$omp parallel do private(i) shared(lb1_,dim,len1) !$omp parallel do private(i) shared(lb1_,dim,len1)
do i=lb1_-1+dim+1,lb1_-1+len1 do i=lb1_-1+dim+1,lb1_-1+len1
rrax(i,:) = pad rrax(i,:) = pad
@ -293,7 +293,7 @@ Contains
Subroutine psb_r_e_c_rk1(len,rrax,info,pad,lb) Subroutine psb_r_e_c_rk1(len,rrax,info,pad,lb)
use psb_error_mod use psb_error_mod
! ...Subroutine Arguments ! ...Subroutine Arguments
integer(psb_epk_),Intent(in) :: len integer(psb_epk_),Intent(in) :: len
complex(psb_spk_), allocatable, intent(inout) :: rrax(:) complex(psb_spk_), allocatable, intent(inout) :: rrax(:)
integer(psb_ipk_) :: info integer(psb_ipk_) :: info
@ -309,7 +309,7 @@ Contains
name='psb_r_m_c_rk1' name='psb_r_m_c_rk1'
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
info=psb_success_ info=psb_success_
if (debug) write(psb_err_unit,*) 'reallocate D',len if (debug) write(psb_err_unit,*) 'reallocate D',len
if (present(lb)) then if (present(lb)) then
@ -317,7 +317,7 @@ Contains
else else
lb_ = 1 lb_ = 1
endif endif
if ((len<0)) then if ((len<0)) then
err=4025 err=4025
call psb_errpush(err,name, e_err=(/len/), & call psb_errpush(err,name, e_err=(/len/), &
& a_err='complex(psb_spk_)') & a_err='complex(psb_spk_)')
@ -325,7 +325,7 @@ Contains
end if end if
ub_ = lb_ + len-1 ub_ = lb_ + len-1
if (allocated(rrax)) then if (allocated(rrax)) then
dim = size(rrax) dim = size(rrax)
lbi = lbound(rrax,1) lbi = lbound(rrax,1)
If ((dim /= len).or.(lbi /= lb_)) Then If ((dim /= len).or.(lbi /= lb_)) Then
@ -349,7 +349,7 @@ Contains
goto 9999 goto 9999
end if end if
endif endif
if (present(pad)) then if (present(pad)) then
rrax(lb_-1+dim+1:lb_-1+len) = pad rrax(lb_-1+dim+1:lb_-1+len) = pad
endif endif
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
@ -364,7 +364,7 @@ Contains
Subroutine psb_r_e_c_rk2(len1,len2,rrax,info,pad,lb1,lb2) Subroutine psb_r_e_c_rk2(len1,len2,rrax,info,pad,lb1,lb2)
use psb_error_mod use psb_error_mod
! ...Subroutine Arguments ! ...Subroutine Arguments
integer(psb_epk_),Intent(in) :: len1,len2 integer(psb_epk_),Intent(in) :: len1,len2
complex(psb_spk_),allocatable :: rrax(:,:) complex(psb_spk_),allocatable :: rrax(:,:)
integer(psb_ipk_) :: info integer(psb_ipk_) :: info
@ -380,13 +380,13 @@ Contains
name='psb_r_e_c_rk2' name='psb_r_e_c_rk2'
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
info=psb_success_ info=psb_success_
if (present(lb1)) then if (present(lb1)) then
lb1_ = lb1 lb1_ = lb1
else else
lb1_ = 1 lb1_ = 1
endif endif
if (present(lb2)) then if (present(lb2)) then
lb2_ = lb2 lb2_ = lb2
else else
lb2_ = 1 lb2_ = 1
@ -408,7 +408,7 @@ Contains
end if end if
if (allocated(rrax)) then if (allocated(rrax)) then
dim = size(rrax,1) dim = size(rrax,1)
lbi1 = lbound(rrax,1) lbi1 = lbound(rrax,1)
dim2 = size(rrax,2) dim2 = size(rrax,2)
@ -437,7 +437,7 @@ Contains
goto 9999 goto 9999
end if end if
endif endif
if (present(pad)) then if (present(pad)) then
rrax(lb1_-1+dim+1:lb1_-1+len1,:) = pad rrax(lb1_-1+dim+1:lb1_-1+len1,:) = pad
rrax(lb1_:lb1_-1+dim,lb2_-1+dim2+1:lb2_-1+len2) = pad rrax(lb1_:lb1_-1+dim,lb2_-1+dim2+1:lb2_-1+len2) = pad
endif endif
@ -453,7 +453,7 @@ Contains
Subroutine psb_r_me_c_rk2(len1,len2,rrax,info,pad,lb1,lb2) Subroutine psb_r_me_c_rk2(len1,len2,rrax,info,pad,lb1,lb2)
use psb_error_mod use psb_error_mod
! ...Subroutine Arguments ! ...Subroutine Arguments
integer(psb_mpk_),Intent(in) :: len1 integer(psb_mpk_),Intent(in) :: len1
integer(psb_epk_),Intent(in) :: len2 integer(psb_epk_),Intent(in) :: len2
complex(psb_spk_),allocatable :: rrax(:,:) complex(psb_spk_),allocatable :: rrax(:,:)
@ -471,13 +471,13 @@ Contains
name='psb_r_me_c_rk2' name='psb_r_me_c_rk2'
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
info=psb_success_ info=psb_success_
if (present(lb1)) then if (present(lb1)) then
lb1_ = lb1 lb1_ = lb1
else else
lb1_ = 1 lb1_ = 1
endif endif
if (present(lb2)) then if (present(lb2)) then
lb2_ = lb2 lb2_ = lb2
else else
lb2_ = 1 lb2_ = 1
@ -486,7 +486,7 @@ Contains
ub2_ = lb2_ + len2 -1 ub2_ = lb2_ + len2 -1
if (len1 < 0) then if (len1 < 0) then
err=4025 err=4025
call psb_errpush(err,name, m_err=(/len1/), & call psb_errpush(err,name, m_err=(/len1/), &
& a_err='complex(psb_spk_)') & a_err='complex(psb_spk_)')
goto 9999 goto 9999
@ -499,7 +499,7 @@ Contains
end if end if
if (allocated(rrax)) then if (allocated(rrax)) then
dim = size(rrax,1) dim = size(rrax,1)
lbi1 = lbound(rrax,1) lbi1 = lbound(rrax,1)
dim2 = size(rrax,2) dim2 = size(rrax,2)
@ -528,7 +528,7 @@ Contains
goto 9999 goto 9999
end if end if
endif endif
if (present(pad)) then if (present(pad)) then
rrax(lb1_-1+dim+1:lb1_-1+len1,:) = pad rrax(lb1_-1+dim+1:lb1_-1+len1,:) = pad
rrax(lb1_:lb1_-1+dim,lb2_-1+dim2+1:lb2_-1+len2) = pad rrax(lb1_:lb1_-1+dim,lb2_-1+dim2+1:lb2_-1+len2) = pad
endif endif
@ -544,7 +544,7 @@ Contains
Subroutine psb_r_em_c_rk2(len1,len2,rrax,info,pad,lb1,lb2) Subroutine psb_r_em_c_rk2(len1,len2,rrax,info,pad,lb1,lb2)
use psb_error_mod use psb_error_mod
! ...Subroutine Arguments ! ...Subroutine Arguments
integer(psb_epk_),Intent(in) :: len1 integer(psb_epk_),Intent(in) :: len1
integer(psb_mpk_),Intent(in) :: len2 integer(psb_mpk_),Intent(in) :: len2
complex(psb_spk_),allocatable :: rrax(:,:) complex(psb_spk_),allocatable :: rrax(:,:)
@ -562,13 +562,13 @@ Contains
name='psb_r_me_c_rk2' name='psb_r_me_c_rk2'
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
info=psb_success_ info=psb_success_
if (present(lb1)) then if (present(lb1)) then
lb1_ = lb1 lb1_ = lb1
else else
lb1_ = 1 lb1_ = 1
endif endif
if (present(lb2)) then if (present(lb2)) then
lb2_ = lb2 lb2_ = lb2
else else
lb2_ = 1 lb2_ = 1
@ -577,7 +577,7 @@ Contains
ub2_ = lb2_ + len2 -1 ub2_ = lb2_ + len2 -1
if (len1 < 0) then if (len1 < 0) then
err=4025 err=4025
call psb_errpush(err,name, e_err=(/len1/), & call psb_errpush(err,name, e_err=(/len1/), &
& a_err='complex(psb_spk_)') & a_err='complex(psb_spk_)')
goto 9999 goto 9999
@ -590,7 +590,7 @@ Contains
end if end if
if (allocated(rrax)) then if (allocated(rrax)) then
dim = size(rrax,1) dim = size(rrax,1)
lbi1 = lbound(rrax,1) lbi1 = lbound(rrax,1)
dim2 = size(rrax,2) dim2 = size(rrax,2)
@ -619,7 +619,7 @@ Contains
goto 9999 goto 9999
end if end if
endif endif
if (present(pad)) then if (present(pad)) then
rrax(lb1_-1+dim+1:lb1_-1+len1,:) = pad rrax(lb1_-1+dim+1:lb1_-1+len1,:) = pad
rrax(lb1_:lb1_-1+dim,lb2_-1+dim2+1:lb2_-1+len2) = pad rrax(lb1_:lb1_-1+dim,lb2_-1+dim2+1:lb2_-1+len2) = pad
endif endif
@ -635,7 +635,7 @@ Contains
Subroutine psb_r_m_2_c_rk1(len,rrax,y,info,pad) Subroutine psb_r_m_2_c_rk1(len,rrax,y,info,pad)
use psb_error_mod use psb_error_mod
! ...Subroutine Arguments ! ...Subroutine Arguments
integer(psb_mpk_),Intent(in) :: len integer(psb_mpk_),Intent(in) :: len
complex(psb_spk_),allocatable, intent(inout) :: rrax(:),y(:) complex(psb_spk_),allocatable, intent(inout) :: rrax(:),y(:)
@ -648,7 +648,7 @@ Contains
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
info=psb_success_ info=psb_success_
if(psb_errstatus_fatal()) then if(psb_errstatus_fatal()) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
goto 9999 goto 9999
end if end if
@ -676,7 +676,7 @@ Contains
Subroutine psb_r_e_2_c_rk1(len,rrax,y,info,pad) Subroutine psb_r_e_2_c_rk1(len,rrax,y,info,pad)
use psb_error_mod use psb_error_mod
! ...Subroutine Arguments ! ...Subroutine Arguments
integer(psb_epk_),Intent(in) :: len integer(psb_epk_),Intent(in) :: len
complex(psb_spk_),allocatable, intent(inout) :: rrax(:),y(:) complex(psb_spk_),allocatable, intent(inout) :: rrax(:),y(:)
@ -689,7 +689,7 @@ Contains
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
info=psb_success_ info=psb_success_
if(psb_errstatus_fatal()) then if(psb_errstatus_fatal()) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
goto 9999 goto 9999
end if end if
@ -717,10 +717,10 @@ Contains
subroutine psb_ab_cpy_c_s(vin,vout,info) subroutine psb_ab_cpy_c_s(vin,vout,info)
use psb_error_mod use psb_error_mod
! ...Subroutine Arguments ! ...Subroutine Arguments
complex(psb_spk_), allocatable, intent(in) :: vin complex(psb_spk_), allocatable, intent(in) :: vin
complex(psb_spk_), allocatable, intent(out) :: vout complex(psb_spk_), allocatable, intent(out) :: vout
integer(psb_ipk_) :: info integer(psb_ipk_) :: info
@ -733,14 +733,14 @@ Contains
name='psb_ab_cpy_c_s' name='psb_ab_cpy_c_s'
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
info=psb_success_ info=psb_success_
if(psb_errstatus_fatal()) then if(psb_errstatus_fatal()) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
goto 9999 goto 9999
end if end if
if (allocated(vin)) then if (allocated(vin)) then
call psb_realloc(vout,info) call psb_realloc(vout,info)
if (info /= psb_success_) then if (info /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
char_err='psb_realloc' char_err='psb_realloc'
call psb_errpush(info,name,a_err=char_err) call psb_errpush(info,name,a_err=char_err)
@ -759,38 +759,42 @@ Contains
end subroutine psb_ab_cpy_c_s end subroutine psb_ab_cpy_c_s
subroutine psb_ab_cpy_c_rk1(vin,vout,info) subroutine psb_ab_cpy_c_rk1(vin,vout,info)
use psb_error_mod use psb_error_mod
! ...Subroutine Arguments ! ...Subroutine Arguments
complex(psb_spk_), allocatable, intent(in) :: vin(:) complex(psb_spk_), allocatable, intent(in) :: vin(:)
complex(psb_spk_), allocatable, intent(out) :: vout(:) complex(psb_spk_), allocatable, intent(out) :: vout(:)
integer(psb_ipk_) :: info integer(psb_ipk_) :: info
! ...Local Variables ! ...Local Variables
integer(psb_ipk_) :: isz,err_act,lb integer(psb_ipk_) :: isz,err_act,lb, i
character(len=30) :: name, char_err character(len=30) :: name, char_err
logical, parameter :: debug=.false. logical, parameter :: debug=.false.
name='psb_ab_cpy_c_rk1' name='psb_ab_cpy_c_rk1'
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
info=psb_success_ info=psb_success_
if(psb_errstatus_fatal()) then if(psb_errstatus_fatal()) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
goto 9999 goto 9999
end if end if
if (allocated(vin)) then if (allocated(vin)) then
isz = size(vin) isz = size(vin)
lb = lbound(vin,1) lb = lbound(vin,1)
call psb_realloc(isz,vout,info,lb=lb) call psb_realloc(isz,vout,info,lb=lb)
if (info /= psb_success_) then if (info /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
char_err='psb_realloc' char_err='psb_realloc'
call psb_errpush(info,name,a_err=char_err) call psb_errpush(info,name,a_err=char_err)
goto 9999 goto 9999
else else
vout(:) = vin(:) !$omp parallel do private(i)
do i=lb,lb+isz-1
vout(i) = vin(i)
end do
!$omp end parallel do
endif endif
endif endif
@ -803,40 +807,42 @@ Contains
end subroutine psb_ab_cpy_c_rk1 end subroutine psb_ab_cpy_c_rk1
subroutine psb_ab_cpy_c_rk2(vin,vout,info) subroutine psb_ab_cpy_c_rk2(vin,vout,info)
use psb_error_mod use psb_error_mod
! ...Subroutine Arguments ! ...Subroutine Arguments
complex(psb_spk_), allocatable, intent(in) :: vin(:,:) complex(psb_spk_), allocatable, intent(in) :: vin(:,:)
complex(psb_spk_), allocatable, intent(out) :: vout(:,:) complex(psb_spk_), allocatable, intent(out) :: vout(:,:)
integer(psb_ipk_) :: info integer(psb_ipk_) :: info
! ...Local Variables ! ...Local Variables
integer(psb_ipk_) :: isz1, isz2,err_act, lb1, lb2 integer(psb_ipk_) :: isz1, isz2,err_act, lb1, lb2
character(len=30) :: name, char_err character(len=30) :: name, char_err
logical, parameter :: debug=.false. logical, parameter :: debug=.false.
name='psb_ab_cpy_c_rk2' name='psb_ab_cpy_c_rk2'
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
info=psb_success_ info=psb_success_
if(psb_errstatus_fatal()) then if(psb_errstatus_fatal()) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
goto 9999 goto 9999
end if end if
if (allocated(vin)) then if (allocated(vin)) then
isz1 = size(vin,1) isz1 = size(vin,1)
isz2 = size(vin,2) isz2 = size(vin,2)
lb1 = lbound(vin,1) lb1 = lbound(vin,1)
lb2 = lbound(vin,2) lb2 = lbound(vin,2)
call psb_realloc(isz1,isz2,vout,info,lb1=lb1,lb2=lb2) call psb_realloc(isz1,isz2,vout,info,lb1=lb1,lb2=lb2)
if (info /= psb_success_) then if (info /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
char_err='psb_realloc' char_err='psb_realloc'
call psb_errpush(info,name,a_err=char_err) call psb_errpush(info,name,a_err=char_err)
goto 9999 goto 9999
else else
!$omp workshare
vout(:,:) = vin(:,:) vout(:,:) = vin(:,:)
!$omp end workshare
endif endif
endif endif
@ -850,10 +856,10 @@ Contains
end subroutine psb_ab_cpy_c_rk2 end subroutine psb_ab_cpy_c_rk2
subroutine psb_cpy_c_rk1(vin,vout,info) subroutine psb_cpy_c_rk1(vin,vout,info)
use psb_error_mod use psb_error_mod
! ...Subroutine Arguments ! ...Subroutine Arguments
complex(psb_spk_), intent(in) :: vin(:) complex(psb_spk_), intent(in) :: vin(:)
complex(psb_spk_), allocatable, intent(out) :: vout(:) complex(psb_spk_), allocatable, intent(out) :: vout(:)
integer(psb_ipk_) :: info integer(psb_ipk_) :: info
@ -866,14 +872,14 @@ Contains
name='psb_cpy_c_rk1' name='psb_cpy_c_rk1'
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
info=psb_success_ info=psb_success_
if(psb_errstatus_fatal()) then if(psb_errstatus_fatal()) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
goto 9999 goto 9999
end if end if
isz = size(vin) isz = size(vin)
lb = lbound(vin,1) lb = lbound(vin,1)
call psb_realloc(isz,vout,info,lb=lb) call psb_realloc(isz,vout,info,lb=lb)
if (info /= psb_success_) then if (info /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
char_err='psb_realloc' char_err='psb_realloc'
call psb_errpush(info,name,a_err=char_err) call psb_errpush(info,name,a_err=char_err)
@ -891,23 +897,23 @@ Contains
end subroutine psb_cpy_c_rk1 end subroutine psb_cpy_c_rk1
subroutine psb_cpy_c_rk2(vin,vout,info) subroutine psb_cpy_c_rk2(vin,vout,info)
use psb_error_mod use psb_error_mod
! ...Subroutine Arguments ! ...Subroutine Arguments
complex(psb_spk_), intent(in) :: vin(:,:) complex(psb_spk_), intent(in) :: vin(:,:)
complex(psb_spk_), allocatable, intent(out) :: vout(:,:) complex(psb_spk_), allocatable, intent(out) :: vout(:,:)
integer(psb_ipk_) :: info integer(psb_ipk_) :: info
! ...Local Variables ! ...Local Variables
integer(psb_ipk_) :: isz1, isz2,err_act, lb1, lb2 integer(psb_ipk_) :: isz1, isz2,err_act, lb1, lb2
character(len=30) :: name, char_err character(len=30) :: name, char_err
logical, parameter :: debug=.false. logical, parameter :: debug=.false.
name='psb_safe_cpy' name='psb_safe_cpy'
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
info=psb_success_ info=psb_success_
if(psb_errstatus_fatal()) then if(psb_errstatus_fatal()) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
goto 9999 goto 9999
end if end if
@ -917,7 +923,7 @@ Contains
lb1 = lbound(vin,1) lb1 = lbound(vin,1)
lb2 = lbound(vin,2) lb2 = lbound(vin,2)
call psb_realloc(isz1,isz2,vout,info,lb1=lb1,lb2=lb2) call psb_realloc(isz1,isz2,vout,info,lb1=lb1,lb2=lb2)
if (info /= psb_success_) then if (info /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
char_err='psb_realloc' char_err='psb_realloc'
call psb_errpush(info,name,a_err=char_err) call psb_errpush(info,name,a_err=char_err)
@ -940,7 +946,7 @@ Contains
integer(psb_epk_) :: val integer(psb_epk_) :: val
complex(psb_spk_), allocatable, intent(in) :: vin(:) complex(psb_spk_), allocatable, intent(in) :: vin(:)
if (.not.allocated(vin)) then if (.not.allocated(vin)) then
val = 0 val = 0
else else
val = size(vin) val = size(vin)
@ -955,10 +961,10 @@ Contains
integer(psb_ipk_) :: dim_ integer(psb_ipk_) :: dim_
if (.not.allocated(vin)) then if (.not.allocated(vin)) then
val = 0 val = 0
else else
if (present(dim)) then if (present(dim)) then
dim_= dim dim_= dim
val = size(vin,dim=dim_) val = size(vin,dim=dim_)
else else
@ -970,7 +976,7 @@ Contains
Subroutine psb_ensure_m_sz_c_rk1(len,v,info,pad,addsz,newsz) Subroutine psb_ensure_m_sz_c_rk1(len,v,info,pad,addsz,newsz)
use psb_error_mod use psb_error_mod
! ...Subroutine Arguments ! ...Subroutine Arguments
integer(psb_mpk_),Intent(in) :: len integer(psb_mpk_),Intent(in) :: len
complex(psb_spk_),allocatable, intent(inout) :: v(:) complex(psb_spk_),allocatable, intent(inout) :: v(:)
integer(psb_ipk_) :: info integer(psb_ipk_) :: info
@ -986,29 +992,11 @@ Contains
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
info = psb_success_ info = psb_success_
if (psb_errstatus_fatal()) then if (psb_errstatus_fatal()) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
goto 9999 goto 9999
end if 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
isz = psb_size(v) isz = psb_size(v)
If (len > isz) Then If (len > isz) Then
#if defined(OPENMP) #if defined(OPENMP)
@ -1017,7 +1005,7 @@ Contains
if (present(newsz)) then if (present(newsz)) then
isz = max(len+1,1,newsz) isz = max(len+1,1,newsz)
else if (present(addsz)) then else if (present(addsz)) then
isz = max(len,1,isz+addsz)) isz = max(len,1,isz+addsz)
else else
isz = max(len,1,int(1.25*isz)) isz = max(len,1,int(1.25*isz))
endif endif
@ -1065,7 +1053,7 @@ Contains
Subroutine psb_ensure_e_sz_c_rk1(len,v,info,pad,addsz,newsz) Subroutine psb_ensure_e_sz_c_rk1(len,v,info,pad,addsz,newsz)
use psb_error_mod use psb_error_mod
! ...Subroutine Arguments ! ...Subroutine Arguments
integer(psb_epk_),Intent(in) :: len integer(psb_epk_),Intent(in) :: len
complex(psb_spk_),allocatable, intent(inout) :: v(:) complex(psb_spk_),allocatable, intent(inout) :: v(:)
integer(psb_ipk_) :: info integer(psb_ipk_) :: info
@ -1081,7 +1069,7 @@ Contains
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
info = psb_success_ info = psb_success_
if (psb_errstatus_fatal()) then if (psb_errstatus_fatal()) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
goto 9999 goto 9999
end if end if
@ -1116,9 +1104,9 @@ Contains
Subroutine psb_move_alloc_c_rk1(vin,vout,info) Subroutine psb_move_alloc_c_rk1(vin,vout,info)
use psb_error_mod use psb_error_mod
complex(psb_spk_), allocatable, intent(inout) :: vin(:),vout(:) complex(psb_spk_), allocatable, intent(inout) :: vin(:),vout(:)
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
!
! !
!
info=psb_success_ info=psb_success_
call move_alloc(vin,vout) call move_alloc(vin,vout)
@ -1127,9 +1115,9 @@ Contains
Subroutine psb_move_alloc_c_rk2(vin,vout,info) Subroutine psb_move_alloc_c_rk2(vin,vout,info)
use psb_error_mod use psb_error_mod
complex(psb_spk_), allocatable, intent(inout) :: vin(:,:),vout(:,:) complex(psb_spk_), allocatable, intent(inout) :: vin(:,:),vout(:,:)
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
!
! !
!
info=psb_success_ info=psb_success_
call move_alloc(vin,vout) call move_alloc(vin,vout)

214
base/modules/auxil/psb_d_realloc_mod.F90
Unescape Escape View File

@ -1,9 +1,9 @@
! !
! Parallel Sparse BLAS version 3.5 ! Parallel Sparse BLAS version 3.5
! (C) Copyright 2006-2018 ! (C) Copyright 2006-2018
! Salvatore Filippone ! Salvatore Filippone
! Alfredo Buttari ! Alfredo Buttari
! !
! Redistribution and use in source and binary forms, with or without ! Redistribution and use in source and binary forms, with or without
! modification, are permitted provided that the following conditions ! modification, are permitted provided that the following conditions
! are met: ! are met:
@ -15,7 +15,7 @@
! 3. The name of the PSBLAS group or the names of its contributors may ! 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 ! not be used to endorse or promote products derived from this
! software without specific written permission. ! software without specific written permission.
! !
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR ! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
@ -27,16 +27,16 @@
! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ! 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 ! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
! POSSIBILITY OF SUCH DAMAGE. ! POSSIBILITY OF SUCH DAMAGE.
! !
! !
module psb_d_realloc_mod module psb_d_realloc_mod
use psb_const_mod use psb_const_mod
implicit none implicit none
! !
! psb_realloc will reallocate the input array to have exactly ! psb_realloc will reallocate the input array to have exactly
! the size specified, possibly shortening it. ! the size specified, possibly shortening it.
! !
Interface psb_realloc Interface psb_realloc
module procedure psb_r_d_s module procedure psb_r_d_s
@ -49,7 +49,7 @@ module psb_d_realloc_mod
module procedure psb_r_m_2_d_rk1 module procedure psb_r_m_2_d_rk1
module procedure psb_r_e_2_d_rk1 module procedure psb_r_e_2_d_rk1
end Interface psb_realloc end Interface psb_realloc
interface psb_move_alloc interface psb_move_alloc
@ -66,7 +66,7 @@ module psb_d_realloc_mod
! !
! psb_ensure_size will reallocate the input array if necessary ! psb_ensure_size will reallocate the input array if necessary
! to guarantee that its size is at least as large as the ! to guarantee that its size is at least as large as the
! value required, usually with some room to spare. ! value required, usually with some room to spare.
! !
interface psb_ensure_size interface psb_ensure_size
@ -74,7 +74,7 @@ module psb_d_realloc_mod
end Interface psb_ensure_size end Interface psb_ensure_size
! !
! psb_size returns 0 if argument is not allocated. ! psb_size returns 0 if argument is not allocated.
! !
interface psb_size interface psb_size
module procedure psb_size_d_rk1, psb_size_d_rk2 module procedure psb_size_d_rk1, psb_size_d_rk2
@ -86,7 +86,7 @@ Contains
Subroutine psb_r_d_s(rrax,info) Subroutine psb_r_d_s(rrax,info)
use psb_error_mod use psb_error_mod
! ...Subroutine Arguments ! ...Subroutine Arguments
real(psb_dpk_), allocatable, intent(inout) :: rrax real(psb_dpk_), allocatable, intent(inout) :: rrax
integer(psb_ipk_) :: info integer(psb_ipk_) :: info
@ -97,9 +97,9 @@ Contains
name='psb_r_d_s' name='psb_r_d_s'
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
info=psb_success_ info=psb_success_
if (.not.allocated(rrax)) then if (.not.allocated(rrax)) then
Allocate(rrax,stat=info) Allocate(rrax,stat=info)
if (info /= psb_success_) then if (info /= psb_success_) then
err=4025 err=4025
@ -122,7 +122,7 @@ Contains
Subroutine psb_r_m_d_rk1(len,rrax,info,pad,lb) Subroutine psb_r_m_d_rk1(len,rrax,info,pad,lb)
use psb_error_mod use psb_error_mod
! ...Subroutine Arguments ! ...Subroutine Arguments
integer(psb_mpk_),Intent(in) :: len integer(psb_mpk_),Intent(in) :: len
real(psb_dpk_), allocatable, intent(inout) :: rrax(:) real(psb_dpk_), allocatable, intent(inout) :: rrax(:)
integer(psb_ipk_) :: info integer(psb_ipk_) :: info
@ -138,7 +138,7 @@ Contains
name='psb_r_m_d_rk1' name='psb_r_m_d_rk1'
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
info=psb_success_ info=psb_success_
if (debug) write(psb_err_unit,*) 'reallocate D',len if (debug) write(psb_err_unit,*) 'reallocate D',len
if (present(lb)) then if (present(lb)) then
@ -146,7 +146,7 @@ Contains
else else
lb_ = 1 lb_ = 1
endif endif
if ((len<0)) then if ((len<0)) then
err=4025 err=4025
call psb_errpush(err,name, l_err=(/len*1_psb_lpk_/), & call psb_errpush(err,name, l_err=(/len*1_psb_lpk_/), &
& a_err='real(psb_dpk_)') & a_err='real(psb_dpk_)')
@ -154,7 +154,7 @@ Contains
end if end if
ub_ = lb_ + len-1 ub_ = lb_ + len-1
if (allocated(rrax)) then if (allocated(rrax)) then
dim = size(rrax) dim = size(rrax)
lbi = lbound(rrax,1) lbi = lbound(rrax,1)
If ((dim /= len).or.(lbi /= lb_)) Then If ((dim /= len).or.(lbi /= lb_)) Then
@ -178,7 +178,7 @@ Contains
goto 9999 goto 9999
end if end if
endif endif
if (present(pad)) then if (present(pad)) then
!$omp parallel do private(i) shared(dim,len) !$omp parallel do private(i) shared(dim,len)
do i=lb_-1+dim+1,lb_-1+len do i=lb_-1+dim+1,lb_-1+len
rrax(i) = pad rrax(i) = pad
@ -196,7 +196,7 @@ Contains
Subroutine psb_r_m_d_rk2(len1,len2,rrax,info,pad,lb1,lb2) Subroutine psb_r_m_d_rk2(len1,len2,rrax,info,pad,lb1,lb2)
use psb_error_mod use psb_error_mod
! ...Subroutine Arguments ! ...Subroutine Arguments
integer(psb_mpk_),Intent(in) :: len1,len2 integer(psb_mpk_),Intent(in) :: len1,len2
real(psb_dpk_),allocatable :: rrax(:,:) real(psb_dpk_),allocatable :: rrax(:,:)
integer(psb_ipk_) :: info integer(psb_ipk_) :: info
@ -212,13 +212,13 @@ Contains
name='psb_r_m_d_rk2' name='psb_r_m_d_rk2'
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
info=psb_success_ info=psb_success_
if (present(lb1)) then if (present(lb1)) then
lb1_ = lb1 lb1_ = lb1
else else
lb1_ = 1 lb1_ = 1
endif endif
if (present(lb2)) then if (present(lb2)) then
lb2_ = lb2 lb2_ = lb2
else else
lb2_ = 1 lb2_ = 1
@ -227,7 +227,7 @@ Contains
ub2_ = lb2_ + len2 -1 ub2_ = lb2_ + len2 -1
if (len1 < 0) then if (len1 < 0) then
err=4025 err=4025
call psb_errpush(err,name, l_err=(/len1*1_psb_lpk_/), & call psb_errpush(err,name, l_err=(/len1*1_psb_lpk_/), &
& a_err='real(psb_dpk_)') & a_err='real(psb_dpk_)')
goto 9999 goto 9999
@ -240,7 +240,7 @@ Contains
end if end if
if (allocated(rrax)) then if (allocated(rrax)) then
dim = size(rrax,1) dim = size(rrax,1)
lbi1 = lbound(rrax,1) lbi1 = lbound(rrax,1)
dim2 = size(rrax,2) dim2 = size(rrax,2)
@ -269,7 +269,7 @@ Contains
goto 9999 goto 9999
end if end if
endif endif
if (present(pad)) then if (present(pad)) then
!$omp parallel do private(i) shared(lb1_,dim,len1) !$omp parallel do private(i) shared(lb1_,dim,len1)
do i=lb1_-1+dim+1,lb1_-1+len1 do i=lb1_-1+dim+1,lb1_-1+len1
rrax(i,:) = pad rrax(i,:) = pad
@ -293,7 +293,7 @@ Contains
Subroutine psb_r_e_d_rk1(len,rrax,info,pad,lb) Subroutine psb_r_e_d_rk1(len,rrax,info,pad,lb)
use psb_error_mod use psb_error_mod
! ...Subroutine Arguments ! ...Subroutine Arguments
integer(psb_epk_),Intent(in) :: len integer(psb_epk_),Intent(in) :: len
real(psb_dpk_), allocatable, intent(inout) :: rrax(:) real(psb_dpk_), allocatable, intent(inout) :: rrax(:)
integer(psb_ipk_) :: info integer(psb_ipk_) :: info
@ -309,7 +309,7 @@ Contains
name='psb_r_m_d_rk1' name='psb_r_m_d_rk1'
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
info=psb_success_ info=psb_success_
if (debug) write(psb_err_unit,*) 'reallocate D',len if (debug) write(psb_err_unit,*) 'reallocate D',len
if (present(lb)) then if (present(lb)) then
@ -317,7 +317,7 @@ Contains
else else
lb_ = 1 lb_ = 1
endif endif
if ((len<0)) then if ((len<0)) then
err=4025 err=4025
call psb_errpush(err,name, e_err=(/len/), & call psb_errpush(err,name, e_err=(/len/), &
& a_err='real(psb_dpk_)') & a_err='real(psb_dpk_)')
@ -325,7 +325,7 @@ Contains
end if end if
ub_ = lb_ + len-1 ub_ = lb_ + len-1
if (allocated(rrax)) then if (allocated(rrax)) then
dim = size(rrax) dim = size(rrax)
lbi = lbound(rrax,1) lbi = lbound(rrax,1)
If ((dim /= len).or.(lbi /= lb_)) Then If ((dim /= len).or.(lbi /= lb_)) Then
@ -349,7 +349,7 @@ Contains
goto 9999 goto 9999
end if end if
endif endif
if (present(pad)) then if (present(pad)) then
rrax(lb_-1+dim+1:lb_-1+len) = pad rrax(lb_-1+dim+1:lb_-1+len) = pad
endif endif
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
@ -364,7 +364,7 @@ Contains
Subroutine psb_r_e_d_rk2(len1,len2,rrax,info,pad,lb1,lb2) Subroutine psb_r_e_d_rk2(len1,len2,rrax,info,pad,lb1,lb2)
use psb_error_mod use psb_error_mod
! ...Subroutine Arguments ! ...Subroutine Arguments
integer(psb_epk_),Intent(in) :: len1,len2 integer(psb_epk_),Intent(in) :: len1,len2
real(psb_dpk_),allocatable :: rrax(:,:) real(psb_dpk_),allocatable :: rrax(:,:)
integer(psb_ipk_) :: info integer(psb_ipk_) :: info
@ -380,13 +380,13 @@ Contains
name='psb_r_e_d_rk2' name='psb_r_e_d_rk2'
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
info=psb_success_ info=psb_success_
if (present(lb1)) then if (present(lb1)) then
lb1_ = lb1 lb1_ = lb1
else else
lb1_ = 1 lb1_ = 1
endif endif
if (present(lb2)) then if (present(lb2)) then
lb2_ = lb2 lb2_ = lb2
else else
lb2_ = 1 lb2_ = 1
@ -408,7 +408,7 @@ Contains
end if end if
if (allocated(rrax)) then if (allocated(rrax)) then
dim = size(rrax,1) dim = size(rrax,1)
lbi1 = lbound(rrax,1) lbi1 = lbound(rrax,1)
dim2 = size(rrax,2) dim2 = size(rrax,2)
@ -437,7 +437,7 @@ Contains
goto 9999 goto 9999
end if end if
endif endif
if (present(pad)) then if (present(pad)) then
rrax(lb1_-1+dim+1:lb1_-1+len1,:) = pad rrax(lb1_-1+dim+1:lb1_-1+len1,:) = pad
rrax(lb1_:lb1_-1+dim,lb2_-1+dim2+1:lb2_-1+len2) = pad rrax(lb1_:lb1_-1+dim,lb2_-1+dim2+1:lb2_-1+len2) = pad
endif endif
@ -453,7 +453,7 @@ Contains
Subroutine psb_r_me_d_rk2(len1,len2,rrax,info,pad,lb1,lb2) Subroutine psb_r_me_d_rk2(len1,len2,rrax,info,pad,lb1,lb2)
use psb_error_mod use psb_error_mod
! ...Subroutine Arguments ! ...Subroutine Arguments
integer(psb_mpk_),Intent(in) :: len1 integer(psb_mpk_),Intent(in) :: len1
integer(psb_epk_),Intent(in) :: len2 integer(psb_epk_),Intent(in) :: len2
real(psb_dpk_),allocatable :: rrax(:,:) real(psb_dpk_),allocatable :: rrax(:,:)
@ -471,13 +471,13 @@ Contains
name='psb_r_me_d_rk2' name='psb_r_me_d_rk2'
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
info=psb_success_ info=psb_success_
if (present(lb1)) then if (present(lb1)) then
lb1_ = lb1 lb1_ = lb1
else else
lb1_ = 1 lb1_ = 1
endif endif
if (present(lb2)) then if (present(lb2)) then
lb2_ = lb2 lb2_ = lb2
else else
lb2_ = 1 lb2_ = 1
@ -486,7 +486,7 @@ Contains
ub2_ = lb2_ + len2 -1 ub2_ = lb2_ + len2 -1
if (len1 < 0) then if (len1 < 0) then
err=4025 err=4025
call psb_errpush(err,name, m_err=(/len1/), & call psb_errpush(err,name, m_err=(/len1/), &
& a_err='real(psb_dpk_)') & a_err='real(psb_dpk_)')
goto 9999 goto 9999
@ -499,7 +499,7 @@ Contains
end if end if
if (allocated(rrax)) then if (allocated(rrax)) then
dim = size(rrax,1) dim = size(rrax,1)
lbi1 = lbound(rrax,1) lbi1 = lbound(rrax,1)
dim2 = size(rrax,2) dim2 = size(rrax,2)
@ -528,7 +528,7 @@ Contains
goto 9999 goto 9999
end if end if
endif endif
if (present(pad)) then if (present(pad)) then
rrax(lb1_-1+dim+1:lb1_-1+len1,:) = pad rrax(lb1_-1+dim+1:lb1_-1+len1,:) = pad
rrax(lb1_:lb1_-1+dim,lb2_-1+dim2+1:lb2_-1+len2) = pad rrax(lb1_:lb1_-1+dim,lb2_-1+dim2+1:lb2_-1+len2) = pad
endif endif
@ -544,7 +544,7 @@ Contains
Subroutine psb_r_em_d_rk2(len1,len2,rrax,info,pad,lb1,lb2) Subroutine psb_r_em_d_rk2(len1,len2,rrax,info,pad,lb1,lb2)
use psb_error_mod use psb_error_mod
! ...Subroutine Arguments ! ...Subroutine Arguments
integer(psb_epk_),Intent(in) :: len1 integer(psb_epk_),Intent(in) :: len1
integer(psb_mpk_),Intent(in) :: len2 integer(psb_mpk_),Intent(in) :: len2
real(psb_dpk_),allocatable :: rrax(:,:) real(psb_dpk_),allocatable :: rrax(:,:)
@ -562,13 +562,13 @@ Contains
name='psb_r_me_d_rk2' name='psb_r_me_d_rk2'
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
info=psb_success_ info=psb_success_
if (present(lb1)) then if (present(lb1)) then
lb1_ = lb1 lb1_ = lb1
else else
lb1_ = 1 lb1_ = 1
endif endif
if (present(lb2)) then if (present(lb2)) then
lb2_ = lb2 lb2_ = lb2
else else
lb2_ = 1 lb2_ = 1
@ -577,7 +577,7 @@ Contains
ub2_ = lb2_ + len2 -1 ub2_ = lb2_ + len2 -1
if (len1 < 0) then if (len1 < 0) then
err=4025 err=4025
call psb_errpush(err,name, e_err=(/len1/), & call psb_errpush(err,name, e_err=(/len1/), &
& a_err='real(psb_dpk_)') & a_err='real(psb_dpk_)')
goto 9999 goto 9999
@ -590,7 +590,7 @@ Contains
end if end if
if (allocated(rrax)) then if (allocated(rrax)) then
dim = size(rrax,1) dim = size(rrax,1)
lbi1 = lbound(rrax,1) lbi1 = lbound(rrax,1)
dim2 = size(rrax,2) dim2 = size(rrax,2)
@ -619,7 +619,7 @@ Contains
goto 9999 goto 9999
end if end if
endif endif
if (present(pad)) then if (present(pad)) then
rrax(lb1_-1+dim+1:lb1_-1+len1,:) = pad rrax(lb1_-1+dim+1:lb1_-1+len1,:) = pad
rrax(lb1_:lb1_-1+dim,lb2_-1+dim2+1:lb2_-1+len2) = pad rrax(lb1_:lb1_-1+dim,lb2_-1+dim2+1:lb2_-1+len2) = pad
endif endif
@ -635,7 +635,7 @@ Contains
Subroutine psb_r_m_2_d_rk1(len,rrax,y,info,pad) Subroutine psb_r_m_2_d_rk1(len,rrax,y,info,pad)
use psb_error_mod use psb_error_mod
! ...Subroutine Arguments ! ...Subroutine Arguments
integer(psb_mpk_),Intent(in) :: len integer(psb_mpk_),Intent(in) :: len
real(psb_dpk_),allocatable, intent(inout) :: rrax(:),y(:) real(psb_dpk_),allocatable, intent(inout) :: rrax(:),y(:)
@ -648,7 +648,7 @@ Contains
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
info=psb_success_ info=psb_success_
if(psb_errstatus_fatal()) then if(psb_errstatus_fatal()) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
goto 9999 goto 9999
end if end if
@ -676,7 +676,7 @@ Contains
Subroutine psb_r_e_2_d_rk1(len,rrax,y,info,pad) Subroutine psb_r_e_2_d_rk1(len,rrax,y,info,pad)
use psb_error_mod use psb_error_mod
! ...Subroutine Arguments ! ...Subroutine Arguments
integer(psb_epk_),Intent(in) :: len integer(psb_epk_),Intent(in) :: len
real(psb_dpk_),allocatable, intent(inout) :: rrax(:),y(:) real(psb_dpk_),allocatable, intent(inout) :: rrax(:),y(:)
@ -689,7 +689,7 @@ Contains
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
info=psb_success_ info=psb_success_
if(psb_errstatus_fatal()) then if(psb_errstatus_fatal()) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
goto 9999 goto 9999
end if end if
@ -717,10 +717,10 @@ Contains
subroutine psb_ab_cpy_d_s(vin,vout,info) subroutine psb_ab_cpy_d_s(vin,vout,info)
use psb_error_mod use psb_error_mod
! ...Subroutine Arguments ! ...Subroutine Arguments
real(psb_dpk_), allocatable, intent(in) :: vin real(psb_dpk_), allocatable, intent(in) :: vin
real(psb_dpk_), allocatable, intent(out) :: vout real(psb_dpk_), allocatable, intent(out) :: vout
integer(psb_ipk_) :: info integer(psb_ipk_) :: info
@ -733,14 +733,14 @@ Contains
name='psb_ab_cpy_d_s' name='psb_ab_cpy_d_s'
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
info=psb_success_ info=psb_success_
if(psb_errstatus_fatal()) then if(psb_errstatus_fatal()) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
goto 9999 goto 9999
end if end if
if (allocated(vin)) then if (allocated(vin)) then
call psb_realloc(vout,info) call psb_realloc(vout,info)
if (info /= psb_success_) then if (info /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
char_err='psb_realloc' char_err='psb_realloc'
call psb_errpush(info,name,a_err=char_err) call psb_errpush(info,name,a_err=char_err)
@ -759,38 +759,42 @@ Contains
end subroutine psb_ab_cpy_d_s end subroutine psb_ab_cpy_d_s
subroutine psb_ab_cpy_d_rk1(vin,vout,info) subroutine psb_ab_cpy_d_rk1(vin,vout,info)
use psb_error_mod use psb_error_mod
! ...Subroutine Arguments ! ...Subroutine Arguments
real(psb_dpk_), allocatable, intent(in) :: vin(:) real(psb_dpk_), allocatable, intent(in) :: vin(:)
real(psb_dpk_), allocatable, intent(out) :: vout(:) real(psb_dpk_), allocatable, intent(out) :: vout(:)
integer(psb_ipk_) :: info integer(psb_ipk_) :: info
! ...Local Variables ! ...Local Variables
integer(psb_ipk_) :: isz,err_act,lb integer(psb_ipk_) :: isz,err_act,lb, i
character(len=30) :: name, char_err character(len=30) :: name, char_err
logical, parameter :: debug=.false. logical, parameter :: debug=.false.
name='psb_ab_cpy_d_rk1' name='psb_ab_cpy_d_rk1'
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
info=psb_success_ info=psb_success_
if(psb_errstatus_fatal()) then if(psb_errstatus_fatal()) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
goto 9999 goto 9999
end if end if
if (allocated(vin)) then if (allocated(vin)) then
isz = size(vin) isz = size(vin)
lb = lbound(vin,1) lb = lbound(vin,1)
call psb_realloc(isz,vout,info,lb=lb) call psb_realloc(isz,vout,info,lb=lb)
if (info /= psb_success_) then if (info /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
char_err='psb_realloc' char_err='psb_realloc'
call psb_errpush(info,name,a_err=char_err) call psb_errpush(info,name,a_err=char_err)
goto 9999 goto 9999
else else
vout(:) = vin(:) !$omp parallel do private(i)
do i=lb,lb+isz-1
vout(i) = vin(i)
end do
!$omp end parallel do
endif endif
endif endif
@ -803,40 +807,42 @@ Contains
end subroutine psb_ab_cpy_d_rk1 end subroutine psb_ab_cpy_d_rk1
subroutine psb_ab_cpy_d_rk2(vin,vout,info) subroutine psb_ab_cpy_d_rk2(vin,vout,info)
use psb_error_mod use psb_error_mod
! ...Subroutine Arguments ! ...Subroutine Arguments
real(psb_dpk_), allocatable, intent(in) :: vin(:,:) real(psb_dpk_), allocatable, intent(in) :: vin(:,:)
real(psb_dpk_), allocatable, intent(out) :: vout(:,:) real(psb_dpk_), allocatable, intent(out) :: vout(:,:)
integer(psb_ipk_) :: info integer(psb_ipk_) :: info
! ...Local Variables ! ...Local Variables
integer(psb_ipk_) :: isz1, isz2,err_act, lb1, lb2 integer(psb_ipk_) :: isz1, isz2,err_act, lb1, lb2
character(len=30) :: name, char_err character(len=30) :: name, char_err
logical, parameter :: debug=.false. logical, parameter :: debug=.false.
name='psb_ab_cpy_d_rk2' name='psb_ab_cpy_d_rk2'
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
info=psb_success_ info=psb_success_
if(psb_errstatus_fatal()) then if(psb_errstatus_fatal()) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
goto 9999 goto 9999
end if end if
if (allocated(vin)) then if (allocated(vin)) then
isz1 = size(vin,1) isz1 = size(vin,1)
isz2 = size(vin,2) isz2 = size(vin,2)
lb1 = lbound(vin,1) lb1 = lbound(vin,1)
lb2 = lbound(vin,2) lb2 = lbound(vin,2)
call psb_realloc(isz1,isz2,vout,info,lb1=lb1,lb2=lb2) call psb_realloc(isz1,isz2,vout,info,lb1=lb1,lb2=lb2)
if (info /= psb_success_) then if (info /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
char_err='psb_realloc' char_err='psb_realloc'
call psb_errpush(info,name,a_err=char_err) call psb_errpush(info,name,a_err=char_err)
goto 9999 goto 9999
else else
!$omp workshare
vout(:,:) = vin(:,:) vout(:,:) = vin(:,:)
!$omp end workshare
endif endif
endif endif
@ -850,10 +856,10 @@ Contains
end subroutine psb_ab_cpy_d_rk2 end subroutine psb_ab_cpy_d_rk2
subroutine psb_cpy_d_rk1(vin,vout,info) subroutine psb_cpy_d_rk1(vin,vout,info)
use psb_error_mod use psb_error_mod
! ...Subroutine Arguments ! ...Subroutine Arguments
real(psb_dpk_), intent(in) :: vin(:) real(psb_dpk_), intent(in) :: vin(:)
real(psb_dpk_), allocatable, intent(out) :: vout(:) real(psb_dpk_), allocatable, intent(out) :: vout(:)
integer(psb_ipk_) :: info integer(psb_ipk_) :: info
@ -866,14 +872,14 @@ Contains
name='psb_cpy_d_rk1' name='psb_cpy_d_rk1'
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
info=psb_success_ info=psb_success_
if(psb_errstatus_fatal()) then if(psb_errstatus_fatal()) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
goto 9999 goto 9999
end if end if
isz = size(vin) isz = size(vin)
lb = lbound(vin,1) lb = lbound(vin,1)
call psb_realloc(isz,vout,info,lb=lb) call psb_realloc(isz,vout,info,lb=lb)
if (info /= psb_success_) then if (info /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
char_err='psb_realloc' char_err='psb_realloc'
call psb_errpush(info,name,a_err=char_err) call psb_errpush(info,name,a_err=char_err)
@ -891,23 +897,23 @@ Contains
end subroutine psb_cpy_d_rk1 end subroutine psb_cpy_d_rk1
subroutine psb_cpy_d_rk2(vin,vout,info) subroutine psb_cpy_d_rk2(vin,vout,info)
use psb_error_mod use psb_error_mod
! ...Subroutine Arguments ! ...Subroutine Arguments
real(psb_dpk_), intent(in) :: vin(:,:) real(psb_dpk_), intent(in) :: vin(:,:)
real(psb_dpk_), allocatable, intent(out) :: vout(:,:) real(psb_dpk_), allocatable, intent(out) :: vout(:,:)
integer(psb_ipk_) :: info integer(psb_ipk_) :: info
! ...Local Variables ! ...Local Variables
integer(psb_ipk_) :: isz1, isz2,err_act, lb1, lb2 integer(psb_ipk_) :: isz1, isz2,err_act, lb1, lb2
character(len=30) :: name, char_err character(len=30) :: name, char_err
logical, parameter :: debug=.false. logical, parameter :: debug=.false.
name='psb_safe_cpy' name='psb_safe_cpy'
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
info=psb_success_ info=psb_success_
if(psb_errstatus_fatal()) then if(psb_errstatus_fatal()) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
goto 9999 goto 9999
end if end if
@ -917,7 +923,7 @@ Contains
lb1 = lbound(vin,1) lb1 = lbound(vin,1)
lb2 = lbound(vin,2) lb2 = lbound(vin,2)
call psb_realloc(isz1,isz2,vout,info,lb1=lb1,lb2=lb2) call psb_realloc(isz1,isz2,vout,info,lb1=lb1,lb2=lb2)
if (info /= psb_success_) then if (info /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
char_err='psb_realloc' char_err='psb_realloc'
call psb_errpush(info,name,a_err=char_err) call psb_errpush(info,name,a_err=char_err)
@ -940,7 +946,7 @@ Contains
integer(psb_epk_) :: val integer(psb_epk_) :: val
real(psb_dpk_), allocatable, intent(in) :: vin(:) real(psb_dpk_), allocatable, intent(in) :: vin(:)
if (.not.allocated(vin)) then if (.not.allocated(vin)) then
val = 0 val = 0
else else
val = size(vin) val = size(vin)
@ -955,10 +961,10 @@ Contains
integer(psb_ipk_) :: dim_ integer(psb_ipk_) :: dim_
if (.not.allocated(vin)) then if (.not.allocated(vin)) then
val = 0 val = 0
else else
if (present(dim)) then if (present(dim)) then
dim_= dim dim_= dim
val = size(vin,dim=dim_) val = size(vin,dim=dim_)
else else
@ -970,7 +976,7 @@ Contains
Subroutine psb_ensure_m_sz_d_rk1(len,v,info,pad,addsz,newsz) Subroutine psb_ensure_m_sz_d_rk1(len,v,info,pad,addsz,newsz)
use psb_error_mod use psb_error_mod
! ...Subroutine Arguments ! ...Subroutine Arguments
integer(psb_mpk_),Intent(in) :: len integer(psb_mpk_),Intent(in) :: len
real(psb_dpk_),allocatable, intent(inout) :: v(:) real(psb_dpk_),allocatable, intent(inout) :: v(:)
integer(psb_ipk_) :: info integer(psb_ipk_) :: info
@ -986,29 +992,11 @@ Contains
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
info = psb_success_ info = psb_success_
if (psb_errstatus_fatal()) then if (psb_errstatus_fatal()) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
goto 9999 goto 9999
end if 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
isz = psb_size(v) isz = psb_size(v)
If (len > isz) Then If (len > isz) Then
#if defined(OPENMP) #if defined(OPENMP)
@ -1017,7 +1005,7 @@ Contains
if (present(newsz)) then if (present(newsz)) then
isz = max(len+1,1,newsz) isz = max(len+1,1,newsz)
else if (present(addsz)) then else if (present(addsz)) then
isz = max(len,1,isz+addsz)) isz = max(len,1,isz+addsz)
else else
isz = max(len,1,int(1.25*isz)) isz = max(len,1,int(1.25*isz))
endif endif
@ -1065,7 +1053,7 @@ Contains
Subroutine psb_ensure_e_sz_d_rk1(len,v,info,pad,addsz,newsz) Subroutine psb_ensure_e_sz_d_rk1(len,v,info,pad,addsz,newsz)
use psb_error_mod use psb_error_mod
! ...Subroutine Arguments ! ...Subroutine Arguments
integer(psb_epk_),Intent(in) :: len integer(psb_epk_),Intent(in) :: len
real(psb_dpk_),allocatable, intent(inout) :: v(:) real(psb_dpk_),allocatable, intent(inout) :: v(:)
integer(psb_ipk_) :: info integer(psb_ipk_) :: info
@ -1081,7 +1069,7 @@ Contains
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
info = psb_success_ info = psb_success_
if (psb_errstatus_fatal()) then if (psb_errstatus_fatal()) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
goto 9999 goto 9999
end if end if
@ -1116,9 +1104,9 @@ Contains
Subroutine psb_move_alloc_d_rk1(vin,vout,info) Subroutine psb_move_alloc_d_rk1(vin,vout,info)
use psb_error_mod use psb_error_mod
real(psb_dpk_), allocatable, intent(inout) :: vin(:),vout(:) real(psb_dpk_), allocatable, intent(inout) :: vin(:),vout(:)
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
!
! !
!
info=psb_success_ info=psb_success_
call move_alloc(vin,vout) call move_alloc(vin,vout)
@ -1127,9 +1115,9 @@ Contains
Subroutine psb_move_alloc_d_rk2(vin,vout,info) Subroutine psb_move_alloc_d_rk2(vin,vout,info)
use psb_error_mod use psb_error_mod
real(psb_dpk_), allocatable, intent(inout) :: vin(:,:),vout(:,:) real(psb_dpk_), allocatable, intent(inout) :: vin(:,:),vout(:,:)
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
!
! !
!
info=psb_success_ info=psb_success_
call move_alloc(vin,vout) call move_alloc(vin,vout)

214
base/modules/auxil/psb_e_realloc_mod.F90
Unescape Escape View File

@ -1,9 +1,9 @@
! !
! Parallel Sparse BLAS version 3.5 ! Parallel Sparse BLAS version 3.5
! (C) Copyright 2006-2018 ! (C) Copyright 2006-2018
! Salvatore Filippone ! Salvatore Filippone
! Alfredo Buttari ! Alfredo Buttari
! !
! Redistribution and use in source and binary forms, with or without ! Redistribution and use in source and binary forms, with or without
! modification, are permitted provided that the following conditions ! modification, are permitted provided that the following conditions
! are met: ! are met:
@ -15,7 +15,7 @@
! 3. The name of the PSBLAS group or the names of its contributors may ! 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 ! not be used to endorse or promote products derived from this
! software without specific written permission. ! software without specific written permission.
! !
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR ! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
@ -27,16 +27,16 @@
! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ! 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 ! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
! POSSIBILITY OF SUCH DAMAGE. ! POSSIBILITY OF SUCH DAMAGE.
! !
! !
module psb_e_realloc_mod module psb_e_realloc_mod
use psb_const_mod use psb_const_mod
implicit none implicit none
! !
! psb_realloc will reallocate the input array to have exactly ! psb_realloc will reallocate the input array to have exactly
! the size specified, possibly shortening it. ! the size specified, possibly shortening it.
! !
Interface psb_realloc Interface psb_realloc
module procedure psb_r_e_s module procedure psb_r_e_s
@ -49,7 +49,7 @@ module psb_e_realloc_mod
module procedure psb_r_m_2_e_rk1 module procedure psb_r_m_2_e_rk1
module procedure psb_r_e_2_e_rk1 module procedure psb_r_e_2_e_rk1
end Interface psb_realloc end Interface psb_realloc
interface psb_move_alloc interface psb_move_alloc
@ -66,7 +66,7 @@ module psb_e_realloc_mod
! !
! psb_ensure_size will reallocate the input array if necessary ! psb_ensure_size will reallocate the input array if necessary
! to guarantee that its size is at least as large as the ! to guarantee that its size is at least as large as the
! value required, usually with some room to spare. ! value required, usually with some room to spare.
! !
interface psb_ensure_size interface psb_ensure_size
@ -74,7 +74,7 @@ module psb_e_realloc_mod
end Interface psb_ensure_size end Interface psb_ensure_size
! !
! psb_size returns 0 if argument is not allocated. ! psb_size returns 0 if argument is not allocated.
! !
interface psb_size interface psb_size
module procedure psb_size_e_rk1, psb_size_e_rk2 module procedure psb_size_e_rk1, psb_size_e_rk2
@ -86,7 +86,7 @@ Contains
Subroutine psb_r_e_s(rrax,info) Subroutine psb_r_e_s(rrax,info)
use psb_error_mod use psb_error_mod
! ...Subroutine Arguments ! ...Subroutine Arguments
integer(psb_epk_), allocatable, intent(inout) :: rrax integer(psb_epk_), allocatable, intent(inout) :: rrax
integer(psb_ipk_) :: info integer(psb_ipk_) :: info
@ -97,9 +97,9 @@ Contains
name='psb_r_e_s' name='psb_r_e_s'
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
info=psb_success_ info=psb_success_
if (.not.allocated(rrax)) then if (.not.allocated(rrax)) then
Allocate(rrax,stat=info) Allocate(rrax,stat=info)
if (info /= psb_success_) then if (info /= psb_success_) then
err=4025 err=4025
@ -122,7 +122,7 @@ Contains
Subroutine psb_r_m_e_rk1(len,rrax,info,pad,lb) Subroutine psb_r_m_e_rk1(len,rrax,info,pad,lb)
use psb_error_mod use psb_error_mod
! ...Subroutine Arguments ! ...Subroutine Arguments
integer(psb_mpk_),Intent(in) :: len integer(psb_mpk_),Intent(in) :: len
integer(psb_epk_), allocatable, intent(inout) :: rrax(:) integer(psb_epk_), allocatable, intent(inout) :: rrax(:)
integer(psb_ipk_) :: info integer(psb_ipk_) :: info
@ -138,7 +138,7 @@ Contains
name='psb_r_m_e_rk1' name='psb_r_m_e_rk1'
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
info=psb_success_ info=psb_success_
if (debug) write(psb_err_unit,*) 'reallocate D',len if (debug) write(psb_err_unit,*) 'reallocate D',len
if (present(lb)) then if (present(lb)) then
@ -146,7 +146,7 @@ Contains
else else
lb_ = 1 lb_ = 1
endif endif
if ((len<0)) then if ((len<0)) then
err=4025 err=4025
call psb_errpush(err,name, l_err=(/len*1_psb_lpk_/), & call psb_errpush(err,name, l_err=(/len*1_psb_lpk_/), &
& a_err='integer(psb_epk_)') & a_err='integer(psb_epk_)')
@ -154,7 +154,7 @@ Contains
end if end if
ub_ = lb_ + len-1 ub_ = lb_ + len-1
if (allocated(rrax)) then if (allocated(rrax)) then
dim = size(rrax) dim = size(rrax)
lbi = lbound(rrax,1) lbi = lbound(rrax,1)
If ((dim /= len).or.(lbi /= lb_)) Then If ((dim /= len).or.(lbi /= lb_)) Then
@ -178,7 +178,7 @@ Contains
goto 9999 goto 9999
end if end if
endif endif
if (present(pad)) then if (present(pad)) then
!$omp parallel do private(i) shared(dim,len) !$omp parallel do private(i) shared(dim,len)
do i=lb_-1+dim+1,lb_-1+len do i=lb_-1+dim+1,lb_-1+len
rrax(i) = pad rrax(i) = pad
@ -196,7 +196,7 @@ Contains
Subroutine psb_r_m_e_rk2(len1,len2,rrax,info,pad,lb1,lb2) Subroutine psb_r_m_e_rk2(len1,len2,rrax,info,pad,lb1,lb2)
use psb_error_mod use psb_error_mod
! ...Subroutine Arguments ! ...Subroutine Arguments
integer(psb_mpk_),Intent(in) :: len1,len2 integer(psb_mpk_),Intent(in) :: len1,len2
integer(psb_epk_),allocatable :: rrax(:,:) integer(psb_epk_),allocatable :: rrax(:,:)
integer(psb_ipk_) :: info integer(psb_ipk_) :: info
@ -212,13 +212,13 @@ Contains
name='psb_r_m_e_rk2' name='psb_r_m_e_rk2'
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
info=psb_success_ info=psb_success_
if (present(lb1)) then if (present(lb1)) then
lb1_ = lb1 lb1_ = lb1
else else
lb1_ = 1 lb1_ = 1
endif endif
if (present(lb2)) then if (present(lb2)) then
lb2_ = lb2 lb2_ = lb2
else else
lb2_ = 1 lb2_ = 1
@ -227,7 +227,7 @@ Contains
ub2_ = lb2_ + len2 -1 ub2_ = lb2_ + len2 -1
if (len1 < 0) then if (len1 < 0) then
err=4025 err=4025
call psb_errpush(err,name, l_err=(/len1*1_psb_lpk_/), & call psb_errpush(err,name, l_err=(/len1*1_psb_lpk_/), &
& a_err='integer(psb_epk_)') & a_err='integer(psb_epk_)')
goto 9999 goto 9999
@ -240,7 +240,7 @@ Contains
end if end if
if (allocated(rrax)) then if (allocated(rrax)) then
dim = size(rrax,1) dim = size(rrax,1)
lbi1 = lbound(rrax,1) lbi1 = lbound(rrax,1)
dim2 = size(rrax,2) dim2 = size(rrax,2)
@ -269,7 +269,7 @@ Contains
goto 9999 goto 9999
end if end if
endif endif
if (present(pad)) then if (present(pad)) then
!$omp parallel do private(i) shared(lb1_,dim,len1) !$omp parallel do private(i) shared(lb1_,dim,len1)
do i=lb1_-1+dim+1,lb1_-1+len1 do i=lb1_-1+dim+1,lb1_-1+len1
rrax(i,:) = pad rrax(i,:) = pad
@ -293,7 +293,7 @@ Contains
Subroutine psb_r_e_e_rk1(len,rrax,info,pad,lb) Subroutine psb_r_e_e_rk1(len,rrax,info,pad,lb)
use psb_error_mod use psb_error_mod
! ...Subroutine Arguments ! ...Subroutine Arguments
integer(psb_epk_),Intent(in) :: len integer(psb_epk_),Intent(in) :: len
integer(psb_epk_), allocatable, intent(inout) :: rrax(:) integer(psb_epk_), allocatable, intent(inout) :: rrax(:)
integer(psb_ipk_) :: info integer(psb_ipk_) :: info
@ -309,7 +309,7 @@ Contains
name='psb_r_m_e_rk1' name='psb_r_m_e_rk1'
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
info=psb_success_ info=psb_success_
if (debug) write(psb_err_unit,*) 'reallocate D',len if (debug) write(psb_err_unit,*) 'reallocate D',len
if (present(lb)) then if (present(lb)) then
@ -317,7 +317,7 @@ Contains
else else
lb_ = 1 lb_ = 1
endif endif
if ((len<0)) then if ((len<0)) then
err=4025 err=4025
call psb_errpush(err,name, e_err=(/len/), & call psb_errpush(err,name, e_err=(/len/), &
& a_err='integer(psb_epk_)') & a_err='integer(psb_epk_)')
@ -325,7 +325,7 @@ Contains
end if end if
ub_ = lb_ + len-1 ub_ = lb_ + len-1
if (allocated(rrax)) then if (allocated(rrax)) then
dim = size(rrax) dim = size(rrax)
lbi = lbound(rrax,1) lbi = lbound(rrax,1)
If ((dim /= len).or.(lbi /= lb_)) Then If ((dim /= len).or.(lbi /= lb_)) Then
@ -349,7 +349,7 @@ Contains
goto 9999 goto 9999
end if end if
endif endif
if (present(pad)) then if (present(pad)) then
rrax(lb_-1+dim+1:lb_-1+len) = pad rrax(lb_-1+dim+1:lb_-1+len) = pad
endif endif
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
@ -364,7 +364,7 @@ Contains
Subroutine psb_r_e_e_rk2(len1,len2,rrax,info,pad,lb1,lb2) Subroutine psb_r_e_e_rk2(len1,len2,rrax,info,pad,lb1,lb2)
use psb_error_mod use psb_error_mod
! ...Subroutine Arguments ! ...Subroutine Arguments
integer(psb_epk_),Intent(in) :: len1,len2 integer(psb_epk_),Intent(in) :: len1,len2
integer(psb_epk_),allocatable :: rrax(:,:) integer(psb_epk_),allocatable :: rrax(:,:)
integer(psb_ipk_) :: info integer(psb_ipk_) :: info
@ -380,13 +380,13 @@ Contains
name='psb_r_e_e_rk2' name='psb_r_e_e_rk2'
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
info=psb_success_ info=psb_success_
if (present(lb1)) then if (present(lb1)) then
lb1_ = lb1 lb1_ = lb1
else else
lb1_ = 1 lb1_ = 1
endif endif
if (present(lb2)) then if (present(lb2)) then
lb2_ = lb2 lb2_ = lb2
else else
lb2_ = 1 lb2_ = 1
@ -408,7 +408,7 @@ Contains
end if end if
if (allocated(rrax)) then if (allocated(rrax)) then
dim = size(rrax,1) dim = size(rrax,1)
lbi1 = lbound(rrax,1) lbi1 = lbound(rrax,1)
dim2 = size(rrax,2) dim2 = size(rrax,2)
@ -437,7 +437,7 @@ Contains
goto 9999 goto 9999
end if end if
endif endif
if (present(pad)) then if (present(pad)) then
rrax(lb1_-1+dim+1:lb1_-1+len1,:) = pad rrax(lb1_-1+dim+1:lb1_-1+len1,:) = pad
rrax(lb1_:lb1_-1+dim,lb2_-1+dim2+1:lb2_-1+len2) = pad rrax(lb1_:lb1_-1+dim,lb2_-1+dim2+1:lb2_-1+len2) = pad
endif endif
@ -453,7 +453,7 @@ Contains
Subroutine psb_r_me_e_rk2(len1,len2,rrax,info,pad,lb1,lb2) Subroutine psb_r_me_e_rk2(len1,len2,rrax,info,pad,lb1,lb2)
use psb_error_mod use psb_error_mod
! ...Subroutine Arguments ! ...Subroutine Arguments
integer(psb_mpk_),Intent(in) :: len1 integer(psb_mpk_),Intent(in) :: len1
integer(psb_epk_),Intent(in) :: len2 integer(psb_epk_),Intent(in) :: len2
integer(psb_epk_),allocatable :: rrax(:,:) integer(psb_epk_),allocatable :: rrax(:,:)
@ -471,13 +471,13 @@ Contains
name='psb_r_me_e_rk2' name='psb_r_me_e_rk2'
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
info=psb_success_ info=psb_success_
if (present(lb1)) then if (present(lb1)) then
lb1_ = lb1 lb1_ = lb1
else else
lb1_ = 1 lb1_ = 1
endif endif
if (present(lb2)) then if (present(lb2)) then
lb2_ = lb2 lb2_ = lb2
else else
lb2_ = 1 lb2_ = 1
@ -486,7 +486,7 @@ Contains
ub2_ = lb2_ + len2 -1 ub2_ = lb2_ + len2 -1
if (len1 < 0) then if (len1 < 0) then
err=4025 err=4025
call psb_errpush(err,name, m_err=(/len1/), & call psb_errpush(err,name, m_err=(/len1/), &
& a_err='integer(psb_epk_)') & a_err='integer(psb_epk_)')
goto 9999 goto 9999
@ -499,7 +499,7 @@ Contains
end if end if
if (allocated(rrax)) then if (allocated(rrax)) then
dim = size(rrax,1) dim = size(rrax,1)
lbi1 = lbound(rrax,1) lbi1 = lbound(rrax,1)
dim2 = size(rrax,2) dim2 = size(rrax,2)
@ -528,7 +528,7 @@ Contains
goto 9999 goto 9999
end if end if
endif endif
if (present(pad)) then if (present(pad)) then
rrax(lb1_-1+dim+1:lb1_-1+len1,:) = pad rrax(lb1_-1+dim+1:lb1_-1+len1,:) = pad
rrax(lb1_:lb1_-1+dim,lb2_-1+dim2+1:lb2_-1+len2) = pad rrax(lb1_:lb1_-1+dim,lb2_-1+dim2+1:lb2_-1+len2) = pad
endif endif
@ -544,7 +544,7 @@ Contains
Subroutine psb_r_em_e_rk2(len1,len2,rrax,info,pad,lb1,lb2) Subroutine psb_r_em_e_rk2(len1,len2,rrax,info,pad,lb1,lb2)
use psb_error_mod use psb_error_mod
! ...Subroutine Arguments ! ...Subroutine Arguments
integer(psb_epk_),Intent(in) :: len1 integer(psb_epk_),Intent(in) :: len1
integer(psb_mpk_),Intent(in) :: len2 integer(psb_mpk_),Intent(in) :: len2
integer(psb_epk_),allocatable :: rrax(:,:) integer(psb_epk_),allocatable :: rrax(:,:)
@ -562,13 +562,13 @@ Contains
name='psb_r_me_e_rk2' name='psb_r_me_e_rk2'
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
info=psb_success_ info=psb_success_
if (present(lb1)) then if (present(lb1)) then
lb1_ = lb1 lb1_ = lb1
else else
lb1_ = 1 lb1_ = 1
endif endif
if (present(lb2)) then if (present(lb2)) then
lb2_ = lb2 lb2_ = lb2
else else
lb2_ = 1 lb2_ = 1
@ -577,7 +577,7 @@ Contains
ub2_ = lb2_ + len2 -1 ub2_ = lb2_ + len2 -1
if (len1 < 0) then if (len1 < 0) then
err=4025 err=4025
call psb_errpush(err,name, e_err=(/len1/), & call psb_errpush(err,name, e_err=(/len1/), &
& a_err='integer(psb_epk_)') & a_err='integer(psb_epk_)')
goto 9999 goto 9999
@ -590,7 +590,7 @@ Contains
end if end if
if (allocated(rrax)) then if (allocated(rrax)) then
dim = size(rrax,1) dim = size(rrax,1)
lbi1 = lbound(rrax,1) lbi1 = lbound(rrax,1)
dim2 = size(rrax,2) dim2 = size(rrax,2)
@ -619,7 +619,7 @@ Contains
goto 9999 goto 9999
end if end if
endif endif
if (present(pad)) then if (present(pad)) then
rrax(lb1_-1+dim+1:lb1_-1+len1,:) = pad rrax(lb1_-1+dim+1:lb1_-1+len1,:) = pad
rrax(lb1_:lb1_-1+dim,lb2_-1+dim2+1:lb2_-1+len2) = pad rrax(lb1_:lb1_-1+dim,lb2_-1+dim2+1:lb2_-1+len2) = pad
endif endif
@ -635,7 +635,7 @@ Contains
Subroutine psb_r_m_2_e_rk1(len,rrax,y,info,pad) Subroutine psb_r_m_2_e_rk1(len,rrax,y,info,pad)
use psb_error_mod use psb_error_mod
! ...Subroutine Arguments ! ...Subroutine Arguments
integer(psb_mpk_),Intent(in) :: len integer(psb_mpk_),Intent(in) :: len
integer(psb_epk_),allocatable, intent(inout) :: rrax(:),y(:) integer(psb_epk_),allocatable, intent(inout) :: rrax(:),y(:)
@ -648,7 +648,7 @@ Contains
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
info=psb_success_ info=psb_success_
if(psb_errstatus_fatal()) then if(psb_errstatus_fatal()) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
goto 9999 goto 9999
end if end if
@ -676,7 +676,7 @@ Contains
Subroutine psb_r_e_2_e_rk1(len,rrax,y,info,pad) Subroutine psb_r_e_2_e_rk1(len,rrax,y,info,pad)
use psb_error_mod use psb_error_mod
! ...Subroutine Arguments ! ...Subroutine Arguments
integer(psb_epk_),Intent(in) :: len integer(psb_epk_),Intent(in) :: len
integer(psb_epk_),allocatable, intent(inout) :: rrax(:),y(:) integer(psb_epk_),allocatable, intent(inout) :: rrax(:),y(:)
@ -689,7 +689,7 @@ Contains
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
info=psb_success_ info=psb_success_
if(psb_errstatus_fatal()) then if(psb_errstatus_fatal()) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
goto 9999 goto 9999
end if end if
@ -717,10 +717,10 @@ Contains
subroutine psb_ab_cpy_e_s(vin,vout,info) subroutine psb_ab_cpy_e_s(vin,vout,info)
use psb_error_mod use psb_error_mod
! ...Subroutine Arguments ! ...Subroutine Arguments
integer(psb_epk_), allocatable, intent(in) :: vin integer(psb_epk_), allocatable, intent(in) :: vin
integer(psb_epk_), allocatable, intent(out) :: vout integer(psb_epk_), allocatable, intent(out) :: vout
integer(psb_ipk_) :: info integer(psb_ipk_) :: info
@ -733,14 +733,14 @@ Contains
name='psb_ab_cpy_e_s' name='psb_ab_cpy_e_s'
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
info=psb_success_ info=psb_success_
if(psb_errstatus_fatal()) then if(psb_errstatus_fatal()) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
goto 9999 goto 9999
end if end if
if (allocated(vin)) then if (allocated(vin)) then
call psb_realloc(vout,info) call psb_realloc(vout,info)
if (info /= psb_success_) then if (info /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
char_err='psb_realloc' char_err='psb_realloc'
call psb_errpush(info,name,a_err=char_err) call psb_errpush(info,name,a_err=char_err)
@ -759,38 +759,42 @@ Contains
end subroutine psb_ab_cpy_e_s end subroutine psb_ab_cpy_e_s
subroutine psb_ab_cpy_e_rk1(vin,vout,info) subroutine psb_ab_cpy_e_rk1(vin,vout,info)
use psb_error_mod use psb_error_mod
! ...Subroutine Arguments ! ...Subroutine Arguments
integer(psb_epk_), allocatable, intent(in) :: vin(:) integer(psb_epk_), allocatable, intent(in) :: vin(:)
integer(psb_epk_), allocatable, intent(out) :: vout(:) integer(psb_epk_), allocatable, intent(out) :: vout(:)
integer(psb_ipk_) :: info integer(psb_ipk_) :: info
! ...Local Variables ! ...Local Variables
integer(psb_ipk_) :: isz,err_act,lb integer(psb_ipk_) :: isz,err_act,lb, i
character(len=30) :: name, char_err character(len=30) :: name, char_err
logical, parameter :: debug=.false. logical, parameter :: debug=.false.
name='psb_ab_cpy_e_rk1' name='psb_ab_cpy_e_rk1'
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
info=psb_success_ info=psb_success_
if(psb_errstatus_fatal()) then if(psb_errstatus_fatal()) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
goto 9999 goto 9999
end if end if
if (allocated(vin)) then if (allocated(vin)) then
isz = size(vin) isz = size(vin)
lb = lbound(vin,1) lb = lbound(vin,1)
call psb_realloc(isz,vout,info,lb=lb) call psb_realloc(isz,vout,info,lb=lb)
if (info /= psb_success_) then if (info /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
char_err='psb_realloc' char_err='psb_realloc'
call psb_errpush(info,name,a_err=char_err) call psb_errpush(info,name,a_err=char_err)
goto 9999 goto 9999
else else
vout(:) = vin(:) !$omp parallel do private(i)
do i=lb,lb+isz-1
vout(i) = vin(i)
end do
!$omp end parallel do
endif endif
endif endif
@ -803,40 +807,42 @@ Contains
end subroutine psb_ab_cpy_e_rk1 end subroutine psb_ab_cpy_e_rk1
subroutine psb_ab_cpy_e_rk2(vin,vout,info) subroutine psb_ab_cpy_e_rk2(vin,vout,info)
use psb_error_mod use psb_error_mod
! ...Subroutine Arguments ! ...Subroutine Arguments
integer(psb_epk_), allocatable, intent(in) :: vin(:,:) integer(psb_epk_), allocatable, intent(in) :: vin(:,:)
integer(psb_epk_), allocatable, intent(out) :: vout(:,:) integer(psb_epk_), allocatable, intent(out) :: vout(:,:)
integer(psb_ipk_) :: info integer(psb_ipk_) :: info
! ...Local Variables ! ...Local Variables
integer(psb_ipk_) :: isz1, isz2,err_act, lb1, lb2 integer(psb_ipk_) :: isz1, isz2,err_act, lb1, lb2
character(len=30) :: name, char_err character(len=30) :: name, char_err
logical, parameter :: debug=.false. logical, parameter :: debug=.false.
name='psb_ab_cpy_e_rk2' name='psb_ab_cpy_e_rk2'
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
info=psb_success_ info=psb_success_
if(psb_errstatus_fatal()) then if(psb_errstatus_fatal()) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
goto 9999 goto 9999
end if end if
if (allocated(vin)) then if (allocated(vin)) then
isz1 = size(vin,1) isz1 = size(vin,1)
isz2 = size(vin,2) isz2 = size(vin,2)
lb1 = lbound(vin,1) lb1 = lbound(vin,1)
lb2 = lbound(vin,2) lb2 = lbound(vin,2)
call psb_realloc(isz1,isz2,vout,info,lb1=lb1,lb2=lb2) call psb_realloc(isz1,isz2,vout,info,lb1=lb1,lb2=lb2)
if (info /= psb_success_) then if (info /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
char_err='psb_realloc' char_err='psb_realloc'
call psb_errpush(info,name,a_err=char_err) call psb_errpush(info,name,a_err=char_err)
goto 9999 goto 9999
else else
!$omp workshare
vout(:,:) = vin(:,:) vout(:,:) = vin(:,:)
!$omp end workshare
endif endif
endif endif
@ -850,10 +856,10 @@ Contains
end subroutine psb_ab_cpy_e_rk2 end subroutine psb_ab_cpy_e_rk2
subroutine psb_cpy_e_rk1(vin,vout,info) subroutine psb_cpy_e_rk1(vin,vout,info)
use psb_error_mod use psb_error_mod
! ...Subroutine Arguments ! ...Subroutine Arguments
integer(psb_epk_), intent(in) :: vin(:) integer(psb_epk_), intent(in) :: vin(:)
integer(psb_epk_), allocatable, intent(out) :: vout(:) integer(psb_epk_), allocatable, intent(out) :: vout(:)
integer(psb_ipk_) :: info integer(psb_ipk_) :: info
@ -866,14 +872,14 @@ Contains
name='psb_cpy_e_rk1' name='psb_cpy_e_rk1'
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
info=psb_success_ info=psb_success_
if(psb_errstatus_fatal()) then if(psb_errstatus_fatal()) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
goto 9999 goto 9999
end if end if
isz = size(vin) isz = size(vin)
lb = lbound(vin,1) lb = lbound(vin,1)
call psb_realloc(isz,vout,info,lb=lb) call psb_realloc(isz,vout,info,lb=lb)
if (info /= psb_success_) then if (info /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
char_err='psb_realloc' char_err='psb_realloc'
call psb_errpush(info,name,a_err=char_err) call psb_errpush(info,name,a_err=char_err)
@ -891,23 +897,23 @@ Contains
end subroutine psb_cpy_e_rk1 end subroutine psb_cpy_e_rk1
subroutine psb_cpy_e_rk2(vin,vout,info) subroutine psb_cpy_e_rk2(vin,vout,info)
use psb_error_mod use psb_error_mod
! ...Subroutine Arguments ! ...Subroutine Arguments
integer(psb_epk_), intent(in) :: vin(:,:) integer(psb_epk_), intent(in) :: vin(:,:)
integer(psb_epk_), allocatable, intent(out) :: vout(:,:) integer(psb_epk_), allocatable, intent(out) :: vout(:,:)
integer(psb_ipk_) :: info integer(psb_ipk_) :: info
! ...Local Variables ! ...Local Variables
integer(psb_ipk_) :: isz1, isz2,err_act, lb1, lb2 integer(psb_ipk_) :: isz1, isz2,err_act, lb1, lb2
character(len=30) :: name, char_err character(len=30) :: name, char_err
logical, parameter :: debug=.false. logical, parameter :: debug=.false.
name='psb_safe_cpy' name='psb_safe_cpy'
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
info=psb_success_ info=psb_success_
if(psb_errstatus_fatal()) then if(psb_errstatus_fatal()) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
goto 9999 goto 9999
end if end if
@ -917,7 +923,7 @@ Contains
lb1 = lbound(vin,1) lb1 = lbound(vin,1)
lb2 = lbound(vin,2) lb2 = lbound(vin,2)
call psb_realloc(isz1,isz2,vout,info,lb1=lb1,lb2=lb2) call psb_realloc(isz1,isz2,vout,info,lb1=lb1,lb2=lb2)
if (info /= psb_success_) then if (info /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
char_err='psb_realloc' char_err='psb_realloc'
call psb_errpush(info,name,a_err=char_err) call psb_errpush(info,name,a_err=char_err)
@ -940,7 +946,7 @@ Contains
integer(psb_epk_) :: val integer(psb_epk_) :: val
integer(psb_epk_), allocatable, intent(in) :: vin(:) integer(psb_epk_), allocatable, intent(in) :: vin(:)
if (.not.allocated(vin)) then if (.not.allocated(vin)) then
val = 0 val = 0
else else
val = size(vin) val = size(vin)
@ -955,10 +961,10 @@ Contains
integer(psb_ipk_) :: dim_ integer(psb_ipk_) :: dim_
if (.not.allocated(vin)) then if (.not.allocated(vin)) then
val = 0 val = 0
else else
if (present(dim)) then if (present(dim)) then
dim_= dim dim_= dim
val = size(vin,dim=dim_) val = size(vin,dim=dim_)
else else
@ -970,7 +976,7 @@ Contains
Subroutine psb_ensure_m_sz_e_rk1(len,v,info,pad,addsz,newsz) Subroutine psb_ensure_m_sz_e_rk1(len,v,info,pad,addsz,newsz)
use psb_error_mod use psb_error_mod
! ...Subroutine Arguments ! ...Subroutine Arguments
integer(psb_mpk_),Intent(in) :: len integer(psb_mpk_),Intent(in) :: len
integer(psb_epk_),allocatable, intent(inout) :: v(:) integer(psb_epk_),allocatable, intent(inout) :: v(:)
integer(psb_ipk_) :: info integer(psb_ipk_) :: info
@ -986,29 +992,11 @@ Contains
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
info = psb_success_ info = psb_success_
if (psb_errstatus_fatal()) then if (psb_errstatus_fatal()) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
goto 9999 goto 9999
end if 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
isz = psb_size(v) isz = psb_size(v)
If (len > isz) Then If (len > isz) Then
#if defined(OPENMP) #if defined(OPENMP)
@ -1017,7 +1005,7 @@ Contains
if (present(newsz)) then if (present(newsz)) then
isz = max(len+1,1,newsz) isz = max(len+1,1,newsz)
else if (present(addsz)) then else if (present(addsz)) then
isz = max(len,1,isz+addsz)) isz = max(len,1,isz+addsz)
else else
isz = max(len,1,int(1.25*isz)) isz = max(len,1,int(1.25*isz))
endif endif
@ -1065,7 +1053,7 @@ Contains
Subroutine psb_ensure_e_sz_e_rk1(len,v,info,pad,addsz,newsz) Subroutine psb_ensure_e_sz_e_rk1(len,v,info,pad,addsz,newsz)
use psb_error_mod use psb_error_mod
! ...Subroutine Arguments ! ...Subroutine Arguments
integer(psb_epk_),Intent(in) :: len integer(psb_epk_),Intent(in) :: len
integer(psb_epk_),allocatable, intent(inout) :: v(:) integer(psb_epk_),allocatable, intent(inout) :: v(:)
integer(psb_ipk_) :: info integer(psb_ipk_) :: info
@ -1081,7 +1069,7 @@ Contains
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
info = psb_success_ info = psb_success_
if (psb_errstatus_fatal()) then if (psb_errstatus_fatal()) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
goto 9999 goto 9999
end if end if
@ -1116,9 +1104,9 @@ Contains
Subroutine psb_move_alloc_e_rk1(vin,vout,info) Subroutine psb_move_alloc_e_rk1(vin,vout,info)
use psb_error_mod use psb_error_mod
integer(psb_epk_), allocatable, intent(inout) :: vin(:),vout(:) integer(psb_epk_), allocatable, intent(inout) :: vin(:),vout(:)
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
!
! !
!
info=psb_success_ info=psb_success_
call move_alloc(vin,vout) call move_alloc(vin,vout)
@ -1127,9 +1115,9 @@ Contains
Subroutine psb_move_alloc_e_rk2(vin,vout,info) Subroutine psb_move_alloc_e_rk2(vin,vout,info)
use psb_error_mod use psb_error_mod
integer(psb_epk_), allocatable, intent(inout) :: vin(:,:),vout(:,:) integer(psb_epk_), allocatable, intent(inout) :: vin(:,:),vout(:,:)
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
!
! !
!
info=psb_success_ info=psb_success_
call move_alloc(vin,vout) call move_alloc(vin,vout)

214
base/modules/auxil/psb_i2_realloc_mod.F90
Unescape Escape View File

@ -1,9 +1,9 @@
! !
! Parallel Sparse BLAS version 3.5 ! Parallel Sparse BLAS version 3.5
! (C) Copyright 2006-2018 ! (C) Copyright 2006-2018
! Salvatore Filippone ! Salvatore Filippone
! Alfredo Buttari ! Alfredo Buttari
! !
! Redistribution and use in source and binary forms, with or without ! Redistribution and use in source and binary forms, with or without
! modification, are permitted provided that the following conditions ! modification, are permitted provided that the following conditions
! are met: ! are met:
@ -15,7 +15,7 @@
! 3. The name of the PSBLAS group or the names of its contributors may ! 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 ! not be used to endorse or promote products derived from this
! software without specific written permission. ! software without specific written permission.
! !
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR ! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
@ -27,16 +27,16 @@
! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ! 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 ! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
! POSSIBILITY OF SUCH DAMAGE. ! POSSIBILITY OF SUCH DAMAGE.
! !
! !
module psb_i2_realloc_mod module psb_i2_realloc_mod
use psb_const_mod use psb_const_mod
implicit none implicit none
! !
! psb_realloc will reallocate the input array to have exactly ! psb_realloc will reallocate the input array to have exactly
! the size specified, possibly shortening it. ! the size specified, possibly shortening it.
! !
Interface psb_realloc Interface psb_realloc
module procedure psb_r_i2_s module procedure psb_r_i2_s
@ -49,7 +49,7 @@ module psb_i2_realloc_mod
module procedure psb_r_m_2_i2_rk1 module procedure psb_r_m_2_i2_rk1
module procedure psb_r_e_2_i2_rk1 module procedure psb_r_e_2_i2_rk1
end Interface psb_realloc end Interface psb_realloc
interface psb_move_alloc interface psb_move_alloc
@ -66,7 +66,7 @@ module psb_i2_realloc_mod
! !
! psb_ensure_size will reallocate the input array if necessary ! psb_ensure_size will reallocate the input array if necessary
! to guarantee that its size is at least as large as the ! to guarantee that its size is at least as large as the
! value required, usually with some room to spare. ! value required, usually with some room to spare.
! !
interface psb_ensure_size interface psb_ensure_size
@ -74,7 +74,7 @@ module psb_i2_realloc_mod
end Interface psb_ensure_size end Interface psb_ensure_size
! !
! psb_size returns 0 if argument is not allocated. ! psb_size returns 0 if argument is not allocated.
! !
interface psb_size interface psb_size
module procedure psb_size_i2_rk1, psb_size_i2_rk2 module procedure psb_size_i2_rk1, psb_size_i2_rk2
@ -86,7 +86,7 @@ Contains
Subroutine psb_r_i2_s(rrax,info) Subroutine psb_r_i2_s(rrax,info)
use psb_error_mod use psb_error_mod
! ...Subroutine Arguments ! ...Subroutine Arguments
integer(psb_i2pk_), allocatable, intent(inout) :: rrax integer(psb_i2pk_), allocatable, intent(inout) :: rrax
integer(psb_ipk_) :: info integer(psb_ipk_) :: info
@ -97,9 +97,9 @@ Contains
name='psb_r_i2_s' name='psb_r_i2_s'
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
info=psb_success_ info=psb_success_
if (.not.allocated(rrax)) then if (.not.allocated(rrax)) then
Allocate(rrax,stat=info) Allocate(rrax,stat=info)
if (info /= psb_success_) then if (info /= psb_success_) then
err=4025 err=4025
@ -122,7 +122,7 @@ Contains
Subroutine psb_r_m_i2_rk1(len,rrax,info,pad,lb) Subroutine psb_r_m_i2_rk1(len,rrax,info,pad,lb)
use psb_error_mod use psb_error_mod
! ...Subroutine Arguments ! ...Subroutine Arguments
integer(psb_mpk_),Intent(in) :: len integer(psb_mpk_),Intent(in) :: len
integer(psb_i2pk_), allocatable, intent(inout) :: rrax(:) integer(psb_i2pk_), allocatable, intent(inout) :: rrax(:)
integer(psb_ipk_) :: info integer(psb_ipk_) :: info
@ -138,7 +138,7 @@ Contains
name='psb_r_m_i2_rk1' name='psb_r_m_i2_rk1'
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
info=psb_success_ info=psb_success_
if (debug) write(psb_err_unit,*) 'reallocate D',len if (debug) write(psb_err_unit,*) 'reallocate D',len
if (present(lb)) then if (present(lb)) then
@ -146,7 +146,7 @@ Contains
else else
lb_ = 1 lb_ = 1
endif endif
if ((len<0)) then if ((len<0)) then
err=4025 err=4025
call psb_errpush(err,name, l_err=(/len*1_psb_lpk_/), & call psb_errpush(err,name, l_err=(/len*1_psb_lpk_/), &
& a_err='integer(psb_i2pk_)') & a_err='integer(psb_i2pk_)')
@ -154,7 +154,7 @@ Contains
end if end if
ub_ = lb_ + len-1 ub_ = lb_ + len-1
if (allocated(rrax)) then if (allocated(rrax)) then
dim = size(rrax) dim = size(rrax)
lbi = lbound(rrax,1) lbi = lbound(rrax,1)
If ((dim /= len).or.(lbi /= lb_)) Then If ((dim /= len).or.(lbi /= lb_)) Then
@ -178,7 +178,7 @@ Contains
goto 9999 goto 9999
end if end if
endif endif
if (present(pad)) then if (present(pad)) then
!$omp parallel do private(i) shared(dim,len) !$omp parallel do private(i) shared(dim,len)
do i=lb_-1+dim+1,lb_-1+len do i=lb_-1+dim+1,lb_-1+len
rrax(i) = pad rrax(i) = pad
@ -196,7 +196,7 @@ Contains
Subroutine psb_r_m_i2_rk2(len1,len2,rrax,info,pad,lb1,lb2) Subroutine psb_r_m_i2_rk2(len1,len2,rrax,info,pad,lb1,lb2)
use psb_error_mod use psb_error_mod
! ...Subroutine Arguments ! ...Subroutine Arguments
integer(psb_mpk_),Intent(in) :: len1,len2 integer(psb_mpk_),Intent(in) :: len1,len2
integer(psb_i2pk_),allocatable :: rrax(:,:) integer(psb_i2pk_),allocatable :: rrax(:,:)
integer(psb_ipk_) :: info integer(psb_ipk_) :: info
@ -212,13 +212,13 @@ Contains
name='psb_r_m_i2_rk2' name='psb_r_m_i2_rk2'
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
info=psb_success_ info=psb_success_
if (present(lb1)) then if (present(lb1)) then
lb1_ = lb1 lb1_ = lb1
else else
lb1_ = 1 lb1_ = 1
endif endif
if (present(lb2)) then if (present(lb2)) then
lb2_ = lb2 lb2_ = lb2
else else
lb2_ = 1 lb2_ = 1
@ -227,7 +227,7 @@ Contains
ub2_ = lb2_ + len2 -1 ub2_ = lb2_ + len2 -1
if (len1 < 0) then if (len1 < 0) then
err=4025 err=4025
call psb_errpush(err,name, l_err=(/len1*1_psb_lpk_/), & call psb_errpush(err,name, l_err=(/len1*1_psb_lpk_/), &
& a_err='integer(psb_i2pk_)') & a_err='integer(psb_i2pk_)')
goto 9999 goto 9999
@ -240,7 +240,7 @@ Contains
end if end if
if (allocated(rrax)) then if (allocated(rrax)) then
dim = size(rrax,1) dim = size(rrax,1)
lbi1 = lbound(rrax,1) lbi1 = lbound(rrax,1)
dim2 = size(rrax,2) dim2 = size(rrax,2)
@ -269,7 +269,7 @@ Contains
goto 9999 goto 9999
end if end if
endif endif
if (present(pad)) then if (present(pad)) then
!$omp parallel do private(i) shared(lb1_,dim,len1) !$omp parallel do private(i) shared(lb1_,dim,len1)
do i=lb1_-1+dim+1,lb1_-1+len1 do i=lb1_-1+dim+1,lb1_-1+len1
rrax(i,:) = pad rrax(i,:) = pad
@ -293,7 +293,7 @@ Contains
Subroutine psb_r_e_i2_rk1(len,rrax,info,pad,lb) Subroutine psb_r_e_i2_rk1(len,rrax,info,pad,lb)
use psb_error_mod use psb_error_mod
! ...Subroutine Arguments ! ...Subroutine Arguments
integer(psb_epk_),Intent(in) :: len integer(psb_epk_),Intent(in) :: len
integer(psb_i2pk_), allocatable, intent(inout) :: rrax(:) integer(psb_i2pk_), allocatable, intent(inout) :: rrax(:)
integer(psb_ipk_) :: info integer(psb_ipk_) :: info
@ -309,7 +309,7 @@ Contains
name='psb_r_m_i2_rk1' name='psb_r_m_i2_rk1'
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
info=psb_success_ info=psb_success_
if (debug) write(psb_err_unit,*) 'reallocate D',len if (debug) write(psb_err_unit,*) 'reallocate D',len
if (present(lb)) then if (present(lb)) then
@ -317,7 +317,7 @@ Contains
else else
lb_ = 1 lb_ = 1
endif endif
if ((len<0)) then if ((len<0)) then
err=4025 err=4025
call psb_errpush(err,name, e_err=(/len/), & call psb_errpush(err,name, e_err=(/len/), &
& a_err='integer(psb_i2pk_)') & a_err='integer(psb_i2pk_)')
@ -325,7 +325,7 @@ Contains
end if end if
ub_ = lb_ + len-1 ub_ = lb_ + len-1
if (allocated(rrax)) then if (allocated(rrax)) then
dim = size(rrax) dim = size(rrax)
lbi = lbound(rrax,1) lbi = lbound(rrax,1)
If ((dim /= len).or.(lbi /= lb_)) Then If ((dim /= len).or.(lbi /= lb_)) Then
@ -349,7 +349,7 @@ Contains
goto 9999 goto 9999
end if end if
endif endif
if (present(pad)) then if (present(pad)) then
rrax(lb_-1+dim+1:lb_-1+len) = pad rrax(lb_-1+dim+1:lb_-1+len) = pad
endif endif
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
@ -364,7 +364,7 @@ Contains
Subroutine psb_r_e_i2_rk2(len1,len2,rrax,info,pad,lb1,lb2) Subroutine psb_r_e_i2_rk2(len1,len2,rrax,info,pad,lb1,lb2)
use psb_error_mod use psb_error_mod
! ...Subroutine Arguments ! ...Subroutine Arguments
integer(psb_epk_),Intent(in) :: len1,len2 integer(psb_epk_),Intent(in) :: len1,len2
integer(psb_i2pk_),allocatable :: rrax(:,:) integer(psb_i2pk_),allocatable :: rrax(:,:)
integer(psb_ipk_) :: info integer(psb_ipk_) :: info
@ -380,13 +380,13 @@ Contains
name='psb_r_e_i2_rk2' name='psb_r_e_i2_rk2'
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
info=psb_success_ info=psb_success_
if (present(lb1)) then if (present(lb1)) then
lb1_ = lb1 lb1_ = lb1
else else
lb1_ = 1 lb1_ = 1
endif endif
if (present(lb2)) then if (present(lb2)) then
lb2_ = lb2 lb2_ = lb2
else else
lb2_ = 1 lb2_ = 1
@ -408,7 +408,7 @@ Contains
end if end if
if (allocated(rrax)) then if (allocated(rrax)) then
dim = size(rrax,1) dim = size(rrax,1)
lbi1 = lbound(rrax,1) lbi1 = lbound(rrax,1)
dim2 = size(rrax,2) dim2 = size(rrax,2)
@ -437,7 +437,7 @@ Contains
goto 9999 goto 9999
end if end if
endif endif
if (present(pad)) then if (present(pad)) then
rrax(lb1_-1+dim+1:lb1_-1+len1,:) = pad rrax(lb1_-1+dim+1:lb1_-1+len1,:) = pad
rrax(lb1_:lb1_-1+dim,lb2_-1+dim2+1:lb2_-1+len2) = pad rrax(lb1_:lb1_-1+dim,lb2_-1+dim2+1:lb2_-1+len2) = pad
endif endif
@ -453,7 +453,7 @@ Contains
Subroutine psb_r_me_i2_rk2(len1,len2,rrax,info,pad,lb1,lb2) Subroutine psb_r_me_i2_rk2(len1,len2,rrax,info,pad,lb1,lb2)
use psb_error_mod use psb_error_mod
! ...Subroutine Arguments ! ...Subroutine Arguments
integer(psb_mpk_),Intent(in) :: len1 integer(psb_mpk_),Intent(in) :: len1
integer(psb_epk_),Intent(in) :: len2 integer(psb_epk_),Intent(in) :: len2
integer(psb_i2pk_),allocatable :: rrax(:,:) integer(psb_i2pk_),allocatable :: rrax(:,:)
@ -471,13 +471,13 @@ Contains
name='psb_r_me_i2_rk2' name='psb_r_me_i2_rk2'
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
info=psb_success_ info=psb_success_
if (present(lb1)) then if (present(lb1)) then
lb1_ = lb1 lb1_ = lb1
else else
lb1_ = 1 lb1_ = 1
endif endif
if (present(lb2)) then if (present(lb2)) then
lb2_ = lb2 lb2_ = lb2
else else
lb2_ = 1 lb2_ = 1
@ -486,7 +486,7 @@ Contains
ub2_ = lb2_ + len2 -1 ub2_ = lb2_ + len2 -1
if (len1 < 0) then if (len1 < 0) then
err=4025 err=4025
call psb_errpush(err,name, m_err=(/len1/), & call psb_errpush(err,name, m_err=(/len1/), &
& a_err='integer(psb_i2pk_)') & a_err='integer(psb_i2pk_)')
goto 9999 goto 9999
@ -499,7 +499,7 @@ Contains
end if end if
if (allocated(rrax)) then if (allocated(rrax)) then
dim = size(rrax,1) dim = size(rrax,1)
lbi1 = lbound(rrax,1) lbi1 = lbound(rrax,1)
dim2 = size(rrax,2) dim2 = size(rrax,2)
@ -528,7 +528,7 @@ Contains
goto 9999 goto 9999
end if end if
endif endif
if (present(pad)) then if (present(pad)) then
rrax(lb1_-1+dim+1:lb1_-1+len1,:) = pad rrax(lb1_-1+dim+1:lb1_-1+len1,:) = pad
rrax(lb1_:lb1_-1+dim,lb2_-1+dim2+1:lb2_-1+len2) = pad rrax(lb1_:lb1_-1+dim,lb2_-1+dim2+1:lb2_-1+len2) = pad
endif endif
@ -544,7 +544,7 @@ Contains
Subroutine psb_r_em_i2_rk2(len1,len2,rrax,info,pad,lb1,lb2) Subroutine psb_r_em_i2_rk2(len1,len2,rrax,info,pad,lb1,lb2)
use psb_error_mod use psb_error_mod
! ...Subroutine Arguments ! ...Subroutine Arguments
integer(psb_epk_),Intent(in) :: len1 integer(psb_epk_),Intent(in) :: len1
integer(psb_mpk_),Intent(in) :: len2 integer(psb_mpk_),Intent(in) :: len2
integer(psb_i2pk_),allocatable :: rrax(:,:) integer(psb_i2pk_),allocatable :: rrax(:,:)
@ -562,13 +562,13 @@ Contains
name='psb_r_me_i2_rk2' name='psb_r_me_i2_rk2'
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
info=psb_success_ info=psb_success_
if (present(lb1)) then if (present(lb1)) then
lb1_ = lb1 lb1_ = lb1
else else
lb1_ = 1 lb1_ = 1
endif endif
if (present(lb2)) then if (present(lb2)) then
lb2_ = lb2 lb2_ = lb2
else else
lb2_ = 1 lb2_ = 1
@ -577,7 +577,7 @@ Contains
ub2_ = lb2_ + len2 -1 ub2_ = lb2_ + len2 -1
if (len1 < 0) then if (len1 < 0) then
err=4025 err=4025
call psb_errpush(err,name, e_err=(/len1/), & call psb_errpush(err,name, e_err=(/len1/), &
& a_err='integer(psb_i2pk_)') & a_err='integer(psb_i2pk_)')
goto 9999 goto 9999
@ -590,7 +590,7 @@ Contains
end if end if
if (allocated(rrax)) then if (allocated(rrax)) then
dim = size(rrax,1) dim = size(rrax,1)
lbi1 = lbound(rrax,1) lbi1 = lbound(rrax,1)
dim2 = size(rrax,2) dim2 = size(rrax,2)
@ -619,7 +619,7 @@ Contains
goto 9999 goto 9999
end if end if
endif endif
if (present(pad)) then if (present(pad)) then
rrax(lb1_-1+dim+1:lb1_-1+len1,:) = pad rrax(lb1_-1+dim+1:lb1_-1+len1,:) = pad
rrax(lb1_:lb1_-1+dim,lb2_-1+dim2+1:lb2_-1+len2) = pad rrax(lb1_:lb1_-1+dim,lb2_-1+dim2+1:lb2_-1+len2) = pad
endif endif
@ -635,7 +635,7 @@ Contains
Subroutine psb_r_m_2_i2_rk1(len,rrax,y,info,pad) Subroutine psb_r_m_2_i2_rk1(len,rrax,y,info,pad)
use psb_error_mod use psb_error_mod
! ...Subroutine Arguments ! ...Subroutine Arguments
integer(psb_mpk_),Intent(in) :: len integer(psb_mpk_),Intent(in) :: len
integer(psb_i2pk_),allocatable, intent(inout) :: rrax(:),y(:) integer(psb_i2pk_),allocatable, intent(inout) :: rrax(:),y(:)
@ -648,7 +648,7 @@ Contains
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
info=psb_success_ info=psb_success_
if(psb_errstatus_fatal()) then if(psb_errstatus_fatal()) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
goto 9999 goto 9999
end if end if
@ -676,7 +676,7 @@ Contains
Subroutine psb_r_e_2_i2_rk1(len,rrax,y,info,pad) Subroutine psb_r_e_2_i2_rk1(len,rrax,y,info,pad)
use psb_error_mod use psb_error_mod
! ...Subroutine Arguments ! ...Subroutine Arguments
integer(psb_epk_),Intent(in) :: len integer(psb_epk_),Intent(in) :: len
integer(psb_i2pk_),allocatable, intent(inout) :: rrax(:),y(:) integer(psb_i2pk_),allocatable, intent(inout) :: rrax(:),y(:)
@ -689,7 +689,7 @@ Contains
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
info=psb_success_ info=psb_success_
if(psb_errstatus_fatal()) then if(psb_errstatus_fatal()) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
goto 9999 goto 9999
end if end if
@ -717,10 +717,10 @@ Contains
subroutine psb_ab_cpy_i2_s(vin,vout,info) subroutine psb_ab_cpy_i2_s(vin,vout,info)
use psb_error_mod use psb_error_mod
! ...Subroutine Arguments ! ...Subroutine Arguments
integer(psb_i2pk_), allocatable, intent(in) :: vin integer(psb_i2pk_), allocatable, intent(in) :: vin
integer(psb_i2pk_), allocatable, intent(out) :: vout integer(psb_i2pk_), allocatable, intent(out) :: vout
integer(psb_ipk_) :: info integer(psb_ipk_) :: info
@ -733,14 +733,14 @@ Contains
name='psb_ab_cpy_i2_s' name='psb_ab_cpy_i2_s'
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
info=psb_success_ info=psb_success_
if(psb_errstatus_fatal()) then if(psb_errstatus_fatal()) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
goto 9999 goto 9999
end if end if
if (allocated(vin)) then if (allocated(vin)) then
call psb_realloc(vout,info) call psb_realloc(vout,info)
if (info /= psb_success_) then if (info /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
char_err='psb_realloc' char_err='psb_realloc'
call psb_errpush(info,name,a_err=char_err) call psb_errpush(info,name,a_err=char_err)
@ -759,38 +759,42 @@ Contains
end subroutine psb_ab_cpy_i2_s end subroutine psb_ab_cpy_i2_s
subroutine psb_ab_cpy_i2_rk1(vin,vout,info) subroutine psb_ab_cpy_i2_rk1(vin,vout,info)
use psb_error_mod use psb_error_mod
! ...Subroutine Arguments ! ...Subroutine Arguments
integer(psb_i2pk_), allocatable, intent(in) :: vin(:) integer(psb_i2pk_), allocatable, intent(in) :: vin(:)
integer(psb_i2pk_), allocatable, intent(out) :: vout(:) integer(psb_i2pk_), allocatable, intent(out) :: vout(:)
integer(psb_ipk_) :: info integer(psb_ipk_) :: info
! ...Local Variables ! ...Local Variables
integer(psb_ipk_) :: isz,err_act,lb integer(psb_ipk_) :: isz,err_act,lb, i
character(len=30) :: name, char_err character(len=30) :: name, char_err
logical, parameter :: debug=.false. logical, parameter :: debug=.false.
name='psb_ab_cpy_i2_rk1' name='psb_ab_cpy_i2_rk1'
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
info=psb_success_ info=psb_success_
if(psb_errstatus_fatal()) then if(psb_errstatus_fatal()) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
goto 9999 goto 9999
end if end if
if (allocated(vin)) then if (allocated(vin)) then
isz = size(vin) isz = size(vin)
lb = lbound(vin,1) lb = lbound(vin,1)
call psb_realloc(isz,vout,info,lb=lb) call psb_realloc(isz,vout,info,lb=lb)
if (info /= psb_success_) then if (info /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
char_err='psb_realloc' char_err='psb_realloc'
call psb_errpush(info,name,a_err=char_err) call psb_errpush(info,name,a_err=char_err)
goto 9999 goto 9999
else else
vout(:) = vin(:) !$omp parallel do private(i)
do i=lb,lb+isz-1
vout(i) = vin(i)
end do
!$omp end parallel do
endif endif
endif endif
@ -803,40 +807,42 @@ Contains
end subroutine psb_ab_cpy_i2_rk1 end subroutine psb_ab_cpy_i2_rk1
subroutine psb_ab_cpy_i2_rk2(vin,vout,info) subroutine psb_ab_cpy_i2_rk2(vin,vout,info)
use psb_error_mod use psb_error_mod
! ...Subroutine Arguments ! ...Subroutine Arguments
integer(psb_i2pk_), allocatable, intent(in) :: vin(:,:) integer(psb_i2pk_), allocatable, intent(in) :: vin(:,:)
integer(psb_i2pk_), allocatable, intent(out) :: vout(:,:) integer(psb_i2pk_), allocatable, intent(out) :: vout(:,:)
integer(psb_ipk_) :: info integer(psb_ipk_) :: info
! ...Local Variables ! ...Local Variables
integer(psb_ipk_) :: isz1, isz2,err_act, lb1, lb2 integer(psb_ipk_) :: isz1, isz2,err_act, lb1, lb2
character(len=30) :: name, char_err character(len=30) :: name, char_err
logical, parameter :: debug=.false. logical, parameter :: debug=.false.
name='psb_ab_cpy_i2_rk2' name='psb_ab_cpy_i2_rk2'
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
info=psb_success_ info=psb_success_
if(psb_errstatus_fatal()) then if(psb_errstatus_fatal()) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
goto 9999 goto 9999
end if end if
if (allocated(vin)) then if (allocated(vin)) then
isz1 = size(vin,1) isz1 = size(vin,1)
isz2 = size(vin,2) isz2 = size(vin,2)
lb1 = lbound(vin,1) lb1 = lbound(vin,1)
lb2 = lbound(vin,2) lb2 = lbound(vin,2)
call psb_realloc(isz1,isz2,vout,info,lb1=lb1,lb2=lb2) call psb_realloc(isz1,isz2,vout,info,lb1=lb1,lb2=lb2)
if (info /= psb_success_) then if (info /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
char_err='psb_realloc' char_err='psb_realloc'
call psb_errpush(info,name,a_err=char_err) call psb_errpush(info,name,a_err=char_err)
goto 9999 goto 9999
else else
!$omp workshare
vout(:,:) = vin(:,:) vout(:,:) = vin(:,:)
!$omp end workshare
endif endif
endif endif
@ -850,10 +856,10 @@ Contains
end subroutine psb_ab_cpy_i2_rk2 end subroutine psb_ab_cpy_i2_rk2
subroutine psb_cpy_i2_rk1(vin,vout,info) subroutine psb_cpy_i2_rk1(vin,vout,info)
use psb_error_mod use psb_error_mod
! ...Subroutine Arguments ! ...Subroutine Arguments
integer(psb_i2pk_), intent(in) :: vin(:) integer(psb_i2pk_), intent(in) :: vin(:)
integer(psb_i2pk_), allocatable, intent(out) :: vout(:) integer(psb_i2pk_), allocatable, intent(out) :: vout(:)
integer(psb_ipk_) :: info integer(psb_ipk_) :: info
@ -866,14 +872,14 @@ Contains
name='psb_cpy_i2_rk1' name='psb_cpy_i2_rk1'
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
info=psb_success_ info=psb_success_
if(psb_errstatus_fatal()) then if(psb_errstatus_fatal()) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
goto 9999 goto 9999
end if end if
isz = size(vin) isz = size(vin)
lb = lbound(vin,1) lb = lbound(vin,1)
call psb_realloc(isz,vout,info,lb=lb) call psb_realloc(isz,vout,info,lb=lb)
if (info /= psb_success_) then if (info /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
char_err='psb_realloc' char_err='psb_realloc'
call psb_errpush(info,name,a_err=char_err) call psb_errpush(info,name,a_err=char_err)
@ -891,23 +897,23 @@ Contains
end subroutine psb_cpy_i2_rk1 end subroutine psb_cpy_i2_rk1
subroutine psb_cpy_i2_rk2(vin,vout,info) subroutine psb_cpy_i2_rk2(vin,vout,info)
use psb_error_mod use psb_error_mod
! ...Subroutine Arguments ! ...Subroutine Arguments
integer(psb_i2pk_), intent(in) :: vin(:,:) integer(psb_i2pk_), intent(in) :: vin(:,:)
integer(psb_i2pk_), allocatable, intent(out) :: vout(:,:) integer(psb_i2pk_), allocatable, intent(out) :: vout(:,:)
integer(psb_ipk_) :: info integer(psb_ipk_) :: info
! ...Local Variables ! ...Local Variables
integer(psb_ipk_) :: isz1, isz2,err_act, lb1, lb2 integer(psb_ipk_) :: isz1, isz2,err_act, lb1, lb2
character(len=30) :: name, char_err character(len=30) :: name, char_err
logical, parameter :: debug=.false. logical, parameter :: debug=.false.
name='psb_safe_cpy' name='psb_safe_cpy'
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
info=psb_success_ info=psb_success_
if(psb_errstatus_fatal()) then if(psb_errstatus_fatal()) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
goto 9999 goto 9999
end if end if
@ -917,7 +923,7 @@ Contains
lb1 = lbound(vin,1) lb1 = lbound(vin,1)
lb2 = lbound(vin,2) lb2 = lbound(vin,2)
call psb_realloc(isz1,isz2,vout,info,lb1=lb1,lb2=lb2) call psb_realloc(isz1,isz2,vout,info,lb1=lb1,lb2=lb2)
if (info /= psb_success_) then if (info /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
char_err='psb_realloc' char_err='psb_realloc'
call psb_errpush(info,name,a_err=char_err) call psb_errpush(info,name,a_err=char_err)
@ -940,7 +946,7 @@ Contains
integer(psb_epk_) :: val integer(psb_epk_) :: val
integer(psb_i2pk_), allocatable, intent(in) :: vin(:) integer(psb_i2pk_), allocatable, intent(in) :: vin(:)
if (.not.allocated(vin)) then if (.not.allocated(vin)) then
val = 0 val = 0
else else
val = size(vin) val = size(vin)
@ -955,10 +961,10 @@ Contains
integer(psb_ipk_) :: dim_ integer(psb_ipk_) :: dim_
if (.not.allocated(vin)) then if (.not.allocated(vin)) then
val = 0 val = 0
else else
if (present(dim)) then if (present(dim)) then
dim_= dim dim_= dim
val = size(vin,dim=dim_) val = size(vin,dim=dim_)
else else
@ -970,7 +976,7 @@ Contains
Subroutine psb_ensure_m_sz_i2_rk1(len,v,info,pad,addsz,newsz) Subroutine psb_ensure_m_sz_i2_rk1(len,v,info,pad,addsz,newsz)
use psb_error_mod use psb_error_mod
! ...Subroutine Arguments ! ...Subroutine Arguments
integer(psb_mpk_),Intent(in) :: len integer(psb_mpk_),Intent(in) :: len
integer(psb_i2pk_),allocatable, intent(inout) :: v(:) integer(psb_i2pk_),allocatable, intent(inout) :: v(:)
integer(psb_ipk_) :: info integer(psb_ipk_) :: info
@ -986,29 +992,11 @@ Contains
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
info = psb_success_ info = psb_success_
if (psb_errstatus_fatal()) then if (psb_errstatus_fatal()) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
goto 9999 goto 9999
end if 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
isz = psb_size(v) isz = psb_size(v)
If (len > isz) Then If (len > isz) Then
#if defined(OPENMP) #if defined(OPENMP)
@ -1017,7 +1005,7 @@ Contains
if (present(newsz)) then if (present(newsz)) then
isz = max(len+1,1,newsz) isz = max(len+1,1,newsz)
else if (present(addsz)) then else if (present(addsz)) then
isz = max(len,1,isz+addsz)) isz = max(len,1,isz+addsz)
else else
isz = max(len,1,int(1.25*isz)) isz = max(len,1,int(1.25*isz))
endif endif
@ -1065,7 +1053,7 @@ Contains
Subroutine psb_ensure_e_sz_i2_rk1(len,v,info,pad,addsz,newsz) Subroutine psb_ensure_e_sz_i2_rk1(len,v,info,pad,addsz,newsz)
use psb_error_mod use psb_error_mod
! ...Subroutine Arguments ! ...Subroutine Arguments
integer(psb_epk_),Intent(in) :: len integer(psb_epk_),Intent(in) :: len
integer(psb_i2pk_),allocatable, intent(inout) :: v(:) integer(psb_i2pk_),allocatable, intent(inout) :: v(:)
integer(psb_ipk_) :: info integer(psb_ipk_) :: info
@ -1081,7 +1069,7 @@ Contains
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
info = psb_success_ info = psb_success_
if (psb_errstatus_fatal()) then if (psb_errstatus_fatal()) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
goto 9999 goto 9999
end if end if
@ -1116,9 +1104,9 @@ Contains
Subroutine psb_move_alloc_i2_rk1(vin,vout,info) Subroutine psb_move_alloc_i2_rk1(vin,vout,info)
use psb_error_mod use psb_error_mod
integer(psb_i2pk_), allocatable, intent(inout) :: vin(:),vout(:) integer(psb_i2pk_), allocatable, intent(inout) :: vin(:),vout(:)
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
!
! !
!
info=psb_success_ info=psb_success_
call move_alloc(vin,vout) call move_alloc(vin,vout)
@ -1127,9 +1115,9 @@ Contains
Subroutine psb_move_alloc_i2_rk2(vin,vout,info) Subroutine psb_move_alloc_i2_rk2(vin,vout,info)
use psb_error_mod use psb_error_mod
integer(psb_i2pk_), allocatable, intent(inout) :: vin(:,:),vout(:,:) integer(psb_i2pk_), allocatable, intent(inout) :: vin(:,:),vout(:,:)
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
!
! !
!
info=psb_success_ info=psb_success_
call move_alloc(vin,vout) call move_alloc(vin,vout)

214
base/modules/auxil/psb_m_realloc_mod.F90
Unescape Escape View File

@ -1,9 +1,9 @@
! !
! Parallel Sparse BLAS version 3.5 ! Parallel Sparse BLAS version 3.5
! (C) Copyright 2006-2018 ! (C) Copyright 2006-2018
! Salvatore Filippone ! Salvatore Filippone
! Alfredo Buttari ! Alfredo Buttari
! !
! Redistribution and use in source and binary forms, with or without ! Redistribution and use in source and binary forms, with or without
! modification, are permitted provided that the following conditions ! modification, are permitted provided that the following conditions
! are met: ! are met:
@ -15,7 +15,7 @@
! 3. The name of the PSBLAS group or the names of its contributors may ! 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 ! not be used to endorse or promote products derived from this
! software without specific written permission. ! software without specific written permission.
! !
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR ! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
@ -27,16 +27,16 @@
! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ! 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 ! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
! POSSIBILITY OF SUCH DAMAGE. ! POSSIBILITY OF SUCH DAMAGE.
! !
! !
module psb_m_realloc_mod module psb_m_realloc_mod
use psb_const_mod use psb_const_mod
implicit none implicit none
! !
! psb_realloc will reallocate the input array to have exactly ! psb_realloc will reallocate the input array to have exactly
! the size specified, possibly shortening it. ! the size specified, possibly shortening it.
! !
Interface psb_realloc Interface psb_realloc
module procedure psb_r_m_s module procedure psb_r_m_s
@ -49,7 +49,7 @@ module psb_m_realloc_mod
module procedure psb_r_m_2_m_rk1 module procedure psb_r_m_2_m_rk1
module procedure psb_r_e_2_m_rk1 module procedure psb_r_e_2_m_rk1
end Interface psb_realloc end Interface psb_realloc
interface psb_move_alloc interface psb_move_alloc
@ -66,7 +66,7 @@ module psb_m_realloc_mod
! !
! psb_ensure_size will reallocate the input array if necessary ! psb_ensure_size will reallocate the input array if necessary
! to guarantee that its size is at least as large as the ! to guarantee that its size is at least as large as the
! value required, usually with some room to spare. ! value required, usually with some room to spare.
! !
interface psb_ensure_size interface psb_ensure_size
@ -74,7 +74,7 @@ module psb_m_realloc_mod
end Interface psb_ensure_size end Interface psb_ensure_size
! !
! psb_size returns 0 if argument is not allocated. ! psb_size returns 0 if argument is not allocated.
! !
interface psb_size interface psb_size
module procedure psb_size_m_rk1, psb_size_m_rk2 module procedure psb_size_m_rk1, psb_size_m_rk2
@ -86,7 +86,7 @@ Contains
Subroutine psb_r_m_s(rrax,info) Subroutine psb_r_m_s(rrax,info)
use psb_error_mod use psb_error_mod
! ...Subroutine Arguments ! ...Subroutine Arguments
integer(psb_mpk_), allocatable, intent(inout) :: rrax integer(psb_mpk_), allocatable, intent(inout) :: rrax
integer(psb_ipk_) :: info integer(psb_ipk_) :: info
@ -97,9 +97,9 @@ Contains
name='psb_r_m_s' name='psb_r_m_s'
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
info=psb_success_ info=psb_success_
if (.not.allocated(rrax)) then if (.not.allocated(rrax)) then
Allocate(rrax,stat=info) Allocate(rrax,stat=info)
if (info /= psb_success_) then if (info /= psb_success_) then
err=4025 err=4025
@ -122,7 +122,7 @@ Contains
Subroutine psb_r_m_m_rk1(len,rrax,info,pad,lb) Subroutine psb_r_m_m_rk1(len,rrax,info,pad,lb)
use psb_error_mod use psb_error_mod
! ...Subroutine Arguments ! ...Subroutine Arguments
integer(psb_mpk_),Intent(in) :: len integer(psb_mpk_),Intent(in) :: len
integer(psb_mpk_), allocatable, intent(inout) :: rrax(:) integer(psb_mpk_), allocatable, intent(inout) :: rrax(:)
integer(psb_ipk_) :: info integer(psb_ipk_) :: info
@ -138,7 +138,7 @@ Contains
name='psb_r_m_m_rk1' name='psb_r_m_m_rk1'
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
info=psb_success_ info=psb_success_
if (debug) write(psb_err_unit,*) 'reallocate D',len if (debug) write(psb_err_unit,*) 'reallocate D',len
if (present(lb)) then if (present(lb)) then
@ -146,7 +146,7 @@ Contains
else else
lb_ = 1 lb_ = 1
endif endif
if ((len<0)) then if ((len<0)) then
err=4025 err=4025
call psb_errpush(err,name, l_err=(/len*1_psb_lpk_/), & call psb_errpush(err,name, l_err=(/len*1_psb_lpk_/), &
& a_err='integer(psb_mpk_)') & a_err='integer(psb_mpk_)')
@ -154,7 +154,7 @@ Contains
end if end if
ub_ = lb_ + len-1 ub_ = lb_ + len-1
if (allocated(rrax)) then if (allocated(rrax)) then
dim = size(rrax) dim = size(rrax)
lbi = lbound(rrax,1) lbi = lbound(rrax,1)
If ((dim /= len).or.(lbi /= lb_)) Then If ((dim /= len).or.(lbi /= lb_)) Then
@ -178,7 +178,7 @@ Contains
goto 9999 goto 9999
end if end if
endif endif
if (present(pad)) then if (present(pad)) then
!$omp parallel do private(i) shared(dim,len) !$omp parallel do private(i) shared(dim,len)
do i=lb_-1+dim+1,lb_-1+len do i=lb_-1+dim+1,lb_-1+len
rrax(i) = pad rrax(i) = pad
@ -196,7 +196,7 @@ Contains
Subroutine psb_r_m_m_rk2(len1,len2,rrax,info,pad,lb1,lb2) Subroutine psb_r_m_m_rk2(len1,len2,rrax,info,pad,lb1,lb2)
use psb_error_mod use psb_error_mod
! ...Subroutine Arguments ! ...Subroutine Arguments
integer(psb_mpk_),Intent(in) :: len1,len2 integer(psb_mpk_),Intent(in) :: len1,len2
integer(psb_mpk_),allocatable :: rrax(:,:) integer(psb_mpk_),allocatable :: rrax(:,:)
integer(psb_ipk_) :: info integer(psb_ipk_) :: info
@ -212,13 +212,13 @@ Contains
name='psb_r_m_m_rk2' name='psb_r_m_m_rk2'
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
info=psb_success_ info=psb_success_
if (present(lb1)) then if (present(lb1)) then
lb1_ = lb1 lb1_ = lb1
else else
lb1_ = 1 lb1_ = 1
endif endif
if (present(lb2)) then if (present(lb2)) then
lb2_ = lb2 lb2_ = lb2
else else
lb2_ = 1 lb2_ = 1
@ -227,7 +227,7 @@ Contains
ub2_ = lb2_ + len2 -1 ub2_ = lb2_ + len2 -1
if (len1 < 0) then if (len1 < 0) then
err=4025 err=4025
call psb_errpush(err,name, l_err=(/len1*1_psb_lpk_/), & call psb_errpush(err,name, l_err=(/len1*1_psb_lpk_/), &
& a_err='integer(psb_mpk_)') & a_err='integer(psb_mpk_)')
goto 9999 goto 9999
@ -240,7 +240,7 @@ Contains
end if end if
if (allocated(rrax)) then if (allocated(rrax)) then
dim = size(rrax,1) dim = size(rrax,1)
lbi1 = lbound(rrax,1) lbi1 = lbound(rrax,1)
dim2 = size(rrax,2) dim2 = size(rrax,2)
@ -269,7 +269,7 @@ Contains
goto 9999 goto 9999
end if end if
endif endif
if (present(pad)) then if (present(pad)) then
!$omp parallel do private(i) shared(lb1_,dim,len1) !$omp parallel do private(i) shared(lb1_,dim,len1)
do i=lb1_-1+dim+1,lb1_-1+len1 do i=lb1_-1+dim+1,lb1_-1+len1
rrax(i,:) = pad rrax(i,:) = pad
@ -293,7 +293,7 @@ Contains
Subroutine psb_r_e_m_rk1(len,rrax,info,pad,lb) Subroutine psb_r_e_m_rk1(len,rrax,info,pad,lb)
use psb_error_mod use psb_error_mod
! ...Subroutine Arguments ! ...Subroutine Arguments
integer(psb_epk_),Intent(in) :: len integer(psb_epk_),Intent(in) :: len
integer(psb_mpk_), allocatable, intent(inout) :: rrax(:) integer(psb_mpk_), allocatable, intent(inout) :: rrax(:)
integer(psb_ipk_) :: info integer(psb_ipk_) :: info
@ -309,7 +309,7 @@ Contains
name='psb_r_m_m_rk1' name='psb_r_m_m_rk1'
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
info=psb_success_ info=psb_success_
if (debug) write(psb_err_unit,*) 'reallocate D',len if (debug) write(psb_err_unit,*) 'reallocate D',len
if (present(lb)) then if (present(lb)) then
@ -317,7 +317,7 @@ Contains
else else
lb_ = 1 lb_ = 1
endif endif
if ((len<0)) then if ((len<0)) then
err=4025 err=4025
call psb_errpush(err,name, e_err=(/len/), & call psb_errpush(err,name, e_err=(/len/), &
& a_err='integer(psb_mpk_)') & a_err='integer(psb_mpk_)')
@ -325,7 +325,7 @@ Contains
end if end if
ub_ = lb_ + len-1 ub_ = lb_ + len-1
if (allocated(rrax)) then if (allocated(rrax)) then
dim = size(rrax) dim = size(rrax)
lbi = lbound(rrax,1) lbi = lbound(rrax,1)
If ((dim /= len).or.(lbi /= lb_)) Then If ((dim /= len).or.(lbi /= lb_)) Then
@ -349,7 +349,7 @@ Contains
goto 9999 goto 9999
end if end if
endif endif
if (present(pad)) then if (present(pad)) then
rrax(lb_-1+dim+1:lb_-1+len) = pad rrax(lb_-1+dim+1:lb_-1+len) = pad
endif endif
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
@ -364,7 +364,7 @@ Contains
Subroutine psb_r_e_m_rk2(len1,len2,rrax,info,pad,lb1,lb2) Subroutine psb_r_e_m_rk2(len1,len2,rrax,info,pad,lb1,lb2)
use psb_error_mod use psb_error_mod
! ...Subroutine Arguments ! ...Subroutine Arguments
integer(psb_epk_),Intent(in) :: len1,len2 integer(psb_epk_),Intent(in) :: len1,len2
integer(psb_mpk_),allocatable :: rrax(:,:) integer(psb_mpk_),allocatable :: rrax(:,:)
integer(psb_ipk_) :: info integer(psb_ipk_) :: info
@ -380,13 +380,13 @@ Contains
name='psb_r_e_m_rk2' name='psb_r_e_m_rk2'
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
info=psb_success_ info=psb_success_
if (present(lb1)) then if (present(lb1)) then
lb1_ = lb1 lb1_ = lb1
else else
lb1_ = 1 lb1_ = 1
endif endif
if (present(lb2)) then if (present(lb2)) then
lb2_ = lb2 lb2_ = lb2
else else
lb2_ = 1 lb2_ = 1
@ -408,7 +408,7 @@ Contains
end if end if
if (allocated(rrax)) then if (allocated(rrax)) then
dim = size(rrax,1) dim = size(rrax,1)
lbi1 = lbound(rrax,1) lbi1 = lbound(rrax,1)
dim2 = size(rrax,2) dim2 = size(rrax,2)
@ -437,7 +437,7 @@ Contains
goto 9999 goto 9999
end if end if
endif endif
if (present(pad)) then if (present(pad)) then
rrax(lb1_-1+dim+1:lb1_-1+len1,:) = pad rrax(lb1_-1+dim+1:lb1_-1+len1,:) = pad
rrax(lb1_:lb1_-1+dim,lb2_-1+dim2+1:lb2_-1+len2) = pad rrax(lb1_:lb1_-1+dim,lb2_-1+dim2+1:lb2_-1+len2) = pad
endif endif
@ -453,7 +453,7 @@ Contains
Subroutine psb_r_me_m_rk2(len1,len2,rrax,info,pad,lb1,lb2) Subroutine psb_r_me_m_rk2(len1,len2,rrax,info,pad,lb1,lb2)
use psb_error_mod use psb_error_mod
! ...Subroutine Arguments ! ...Subroutine Arguments
integer(psb_mpk_),Intent(in) :: len1 integer(psb_mpk_),Intent(in) :: len1
integer(psb_epk_),Intent(in) :: len2 integer(psb_epk_),Intent(in) :: len2
integer(psb_mpk_),allocatable :: rrax(:,:) integer(psb_mpk_),allocatable :: rrax(:,:)
@ -471,13 +471,13 @@ Contains
name='psb_r_me_m_rk2' name='psb_r_me_m_rk2'
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
info=psb_success_ info=psb_success_
if (present(lb1)) then if (present(lb1)) then
lb1_ = lb1 lb1_ = lb1
else else
lb1_ = 1 lb1_ = 1
endif endif
if (present(lb2)) then if (present(lb2)) then
lb2_ = lb2 lb2_ = lb2
else else
lb2_ = 1 lb2_ = 1
@ -486,7 +486,7 @@ Contains
ub2_ = lb2_ + len2 -1 ub2_ = lb2_ + len2 -1
if (len1 < 0) then if (len1 < 0) then
err=4025 err=4025
call psb_errpush(err,name, m_err=(/len1/), & call psb_errpush(err,name, m_err=(/len1/), &
& a_err='integer(psb_mpk_)') & a_err='integer(psb_mpk_)')
goto 9999 goto 9999
@ -499,7 +499,7 @@ Contains
end if end if
if (allocated(rrax)) then if (allocated(rrax)) then
dim = size(rrax,1) dim = size(rrax,1)
lbi1 = lbound(rrax,1) lbi1 = lbound(rrax,1)
dim2 = size(rrax,2) dim2 = size(rrax,2)
@ -528,7 +528,7 @@ Contains
goto 9999 goto 9999
end if end if
endif endif
if (present(pad)) then if (present(pad)) then
rrax(lb1_-1+dim+1:lb1_-1+len1,:) = pad rrax(lb1_-1+dim+1:lb1_-1+len1,:) = pad
rrax(lb1_:lb1_-1+dim,lb2_-1+dim2+1:lb2_-1+len2) = pad rrax(lb1_:lb1_-1+dim,lb2_-1+dim2+1:lb2_-1+len2) = pad
endif endif
@ -544,7 +544,7 @@ Contains
Subroutine psb_r_em_m_rk2(len1,len2,rrax,info,pad,lb1,lb2) Subroutine psb_r_em_m_rk2(len1,len2,rrax,info,pad,lb1,lb2)
use psb_error_mod use psb_error_mod
! ...Subroutine Arguments ! ...Subroutine Arguments
integer(psb_epk_),Intent(in) :: len1 integer(psb_epk_),Intent(in) :: len1
integer(psb_mpk_),Intent(in) :: len2 integer(psb_mpk_),Intent(in) :: len2
integer(psb_mpk_),allocatable :: rrax(:,:) integer(psb_mpk_),allocatable :: rrax(:,:)
@ -562,13 +562,13 @@ Contains
name='psb_r_me_m_rk2' name='psb_r_me_m_rk2'
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
info=psb_success_ info=psb_success_
if (present(lb1)) then if (present(lb1)) then
lb1_ = lb1 lb1_ = lb1
else else
lb1_ = 1 lb1_ = 1
endif endif
if (present(lb2)) then if (present(lb2)) then
lb2_ = lb2 lb2_ = lb2
else else
lb2_ = 1 lb2_ = 1
@ -577,7 +577,7 @@ Contains
ub2_ = lb2_ + len2 -1 ub2_ = lb2_ + len2 -1
if (len1 < 0) then if (len1 < 0) then
err=4025 err=4025
call psb_errpush(err,name, e_err=(/len1/), & call psb_errpush(err,name, e_err=(/len1/), &
& a_err='integer(psb_mpk_)') & a_err='integer(psb_mpk_)')
goto 9999 goto 9999
@ -590,7 +590,7 @@ Contains
end if end if
if (allocated(rrax)) then if (allocated(rrax)) then
dim = size(rrax,1) dim = size(rrax,1)
lbi1 = lbound(rrax,1) lbi1 = lbound(rrax,1)
dim2 = size(rrax,2) dim2 = size(rrax,2)
@ -619,7 +619,7 @@ Contains
goto 9999 goto 9999
end if end if
endif endif
if (present(pad)) then if (present(pad)) then
rrax(lb1_-1+dim+1:lb1_-1+len1,:) = pad rrax(lb1_-1+dim+1:lb1_-1+len1,:) = pad
rrax(lb1_:lb1_-1+dim,lb2_-1+dim2+1:lb2_-1+len2) = pad rrax(lb1_:lb1_-1+dim,lb2_-1+dim2+1:lb2_-1+len2) = pad
endif endif
@ -635,7 +635,7 @@ Contains
Subroutine psb_r_m_2_m_rk1(len,rrax,y,info,pad) Subroutine psb_r_m_2_m_rk1(len,rrax,y,info,pad)
use psb_error_mod use psb_error_mod
! ...Subroutine Arguments ! ...Subroutine Arguments
integer(psb_mpk_),Intent(in) :: len integer(psb_mpk_),Intent(in) :: len
integer(psb_mpk_),allocatable, intent(inout) :: rrax(:),y(:) integer(psb_mpk_),allocatable, intent(inout) :: rrax(:),y(:)
@ -648,7 +648,7 @@ Contains
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
info=psb_success_ info=psb_success_
if(psb_errstatus_fatal()) then if(psb_errstatus_fatal()) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
goto 9999 goto 9999
end if end if
@ -676,7 +676,7 @@ Contains
Subroutine psb_r_e_2_m_rk1(len,rrax,y,info,pad) Subroutine psb_r_e_2_m_rk1(len,rrax,y,info,pad)
use psb_error_mod use psb_error_mod
! ...Subroutine Arguments ! ...Subroutine Arguments
integer(psb_epk_),Intent(in) :: len integer(psb_epk_),Intent(in) :: len
integer(psb_mpk_),allocatable, intent(inout) :: rrax(:),y(:) integer(psb_mpk_),allocatable, intent(inout) :: rrax(:),y(:)
@ -689,7 +689,7 @@ Contains
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
info=psb_success_ info=psb_success_
if(psb_errstatus_fatal()) then if(psb_errstatus_fatal()) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
goto 9999 goto 9999
end if end if
@ -717,10 +717,10 @@ Contains
subroutine psb_ab_cpy_m_s(vin,vout,info) subroutine psb_ab_cpy_m_s(vin,vout,info)
use psb_error_mod use psb_error_mod
! ...Subroutine Arguments ! ...Subroutine Arguments
integer(psb_mpk_), allocatable, intent(in) :: vin integer(psb_mpk_), allocatable, intent(in) :: vin
integer(psb_mpk_), allocatable, intent(out) :: vout integer(psb_mpk_), allocatable, intent(out) :: vout
integer(psb_ipk_) :: info integer(psb_ipk_) :: info
@ -733,14 +733,14 @@ Contains
name='psb_ab_cpy_m_s' name='psb_ab_cpy_m_s'
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
info=psb_success_ info=psb_success_
if(psb_errstatus_fatal()) then if(psb_errstatus_fatal()) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
goto 9999 goto 9999
end if end if
if (allocated(vin)) then if (allocated(vin)) then
call psb_realloc(vout,info) call psb_realloc(vout,info)
if (info /= psb_success_) then if (info /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
char_err='psb_realloc' char_err='psb_realloc'
call psb_errpush(info,name,a_err=char_err) call psb_errpush(info,name,a_err=char_err)
@ -759,38 +759,42 @@ Contains
end subroutine psb_ab_cpy_m_s end subroutine psb_ab_cpy_m_s
subroutine psb_ab_cpy_m_rk1(vin,vout,info) subroutine psb_ab_cpy_m_rk1(vin,vout,info)
use psb_error_mod use psb_error_mod
! ...Subroutine Arguments ! ...Subroutine Arguments
integer(psb_mpk_), allocatable, intent(in) :: vin(:) integer(psb_mpk_), allocatable, intent(in) :: vin(:)
integer(psb_mpk_), allocatable, intent(out) :: vout(:) integer(psb_mpk_), allocatable, intent(out) :: vout(:)
integer(psb_ipk_) :: info integer(psb_ipk_) :: info
! ...Local Variables ! ...Local Variables
integer(psb_ipk_) :: isz,err_act,lb integer(psb_ipk_) :: isz,err_act,lb, i
character(len=30) :: name, char_err character(len=30) :: name, char_err
logical, parameter :: debug=.false. logical, parameter :: debug=.false.
name='psb_ab_cpy_m_rk1' name='psb_ab_cpy_m_rk1'
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
info=psb_success_ info=psb_success_
if(psb_errstatus_fatal()) then if(psb_errstatus_fatal()) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
goto 9999 goto 9999
end if end if
if (allocated(vin)) then if (allocated(vin)) then
isz = size(vin) isz = size(vin)
lb = lbound(vin,1) lb = lbound(vin,1)
call psb_realloc(isz,vout,info,lb=lb) call psb_realloc(isz,vout,info,lb=lb)
if (info /= psb_success_) then if (info /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
char_err='psb_realloc' char_err='psb_realloc'
call psb_errpush(info,name,a_err=char_err) call psb_errpush(info,name,a_err=char_err)
goto 9999 goto 9999
else else
vout(:) = vin(:) !$omp parallel do private(i)
do i=lb,lb+isz-1
vout(i) = vin(i)
end do
!$omp end parallel do
endif endif
endif endif
@ -803,40 +807,42 @@ Contains
end subroutine psb_ab_cpy_m_rk1 end subroutine psb_ab_cpy_m_rk1
subroutine psb_ab_cpy_m_rk2(vin,vout,info) subroutine psb_ab_cpy_m_rk2(vin,vout,info)
use psb_error_mod use psb_error_mod
! ...Subroutine Arguments ! ...Subroutine Arguments
integer(psb_mpk_), allocatable, intent(in) :: vin(:,:) integer(psb_mpk_), allocatable, intent(in) :: vin(:,:)
integer(psb_mpk_), allocatable, intent(out) :: vout(:,:) integer(psb_mpk_), allocatable, intent(out) :: vout(:,:)
integer(psb_ipk_) :: info integer(psb_ipk_) :: info
! ...Local Variables ! ...Local Variables
integer(psb_ipk_) :: isz1, isz2,err_act, lb1, lb2 integer(psb_ipk_) :: isz1, isz2,err_act, lb1, lb2
character(len=30) :: name, char_err character(len=30) :: name, char_err
logical, parameter :: debug=.false. logical, parameter :: debug=.false.
name='psb_ab_cpy_m_rk2' name='psb_ab_cpy_m_rk2'
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
info=psb_success_ info=psb_success_
if(psb_errstatus_fatal()) then if(psb_errstatus_fatal()) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
goto 9999 goto 9999
end if end if
if (allocated(vin)) then if (allocated(vin)) then
isz1 = size(vin,1) isz1 = size(vin,1)
isz2 = size(vin,2) isz2 = size(vin,2)
lb1 = lbound(vin,1) lb1 = lbound(vin,1)
lb2 = lbound(vin,2) lb2 = lbound(vin,2)
call psb_realloc(isz1,isz2,vout,info,lb1=lb1,lb2=lb2) call psb_realloc(isz1,isz2,vout,info,lb1=lb1,lb2=lb2)
if (info /= psb_success_) then if (info /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
char_err='psb_realloc' char_err='psb_realloc'
call psb_errpush(info,name,a_err=char_err) call psb_errpush(info,name,a_err=char_err)
goto 9999 goto 9999
else else
!$omp workshare
vout(:,:) = vin(:,:) vout(:,:) = vin(:,:)
!$omp end workshare
endif endif
endif endif
@ -850,10 +856,10 @@ Contains
end subroutine psb_ab_cpy_m_rk2 end subroutine psb_ab_cpy_m_rk2
subroutine psb_cpy_m_rk1(vin,vout,info) subroutine psb_cpy_m_rk1(vin,vout,info)
use psb_error_mod use psb_error_mod
! ...Subroutine Arguments ! ...Subroutine Arguments
integer(psb_mpk_), intent(in) :: vin(:) integer(psb_mpk_), intent(in) :: vin(:)
integer(psb_mpk_), allocatable, intent(out) :: vout(:) integer(psb_mpk_), allocatable, intent(out) :: vout(:)
integer(psb_ipk_) :: info integer(psb_ipk_) :: info
@ -866,14 +872,14 @@ Contains
name='psb_cpy_m_rk1' name='psb_cpy_m_rk1'
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
info=psb_success_ info=psb_success_
if(psb_errstatus_fatal()) then if(psb_errstatus_fatal()) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
goto 9999 goto 9999
end if end if
isz = size(vin) isz = size(vin)
lb = lbound(vin,1) lb = lbound(vin,1)
call psb_realloc(isz,vout,info,lb=lb) call psb_realloc(isz,vout,info,lb=lb)
if (info /= psb_success_) then if (info /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
char_err='psb_realloc' char_err='psb_realloc'
call psb_errpush(info,name,a_err=char_err) call psb_errpush(info,name,a_err=char_err)
@ -891,23 +897,23 @@ Contains
end subroutine psb_cpy_m_rk1 end subroutine psb_cpy_m_rk1
subroutine psb_cpy_m_rk2(vin,vout,info) subroutine psb_cpy_m_rk2(vin,vout,info)
use psb_error_mod use psb_error_mod
! ...Subroutine Arguments ! ...Subroutine Arguments
integer(psb_mpk_), intent(in) :: vin(:,:) integer(psb_mpk_), intent(in) :: vin(:,:)
integer(psb_mpk_), allocatable, intent(out) :: vout(:,:) integer(psb_mpk_), allocatable, intent(out) :: vout(:,:)
integer(psb_ipk_) :: info integer(psb_ipk_) :: info
! ...Local Variables ! ...Local Variables
integer(psb_ipk_) :: isz1, isz2,err_act, lb1, lb2 integer(psb_ipk_) :: isz1, isz2,err_act, lb1, lb2
character(len=30) :: name, char_err character(len=30) :: name, char_err
logical, parameter :: debug=.false. logical, parameter :: debug=.false.
name='psb_safe_cpy' name='psb_safe_cpy'
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
info=psb_success_ info=psb_success_
if(psb_errstatus_fatal()) then if(psb_errstatus_fatal()) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
goto 9999 goto 9999
end if end if
@ -917,7 +923,7 @@ Contains
lb1 = lbound(vin,1) lb1 = lbound(vin,1)
lb2 = lbound(vin,2) lb2 = lbound(vin,2)
call psb_realloc(isz1,isz2,vout,info,lb1=lb1,lb2=lb2) call psb_realloc(isz1,isz2,vout,info,lb1=lb1,lb2=lb2)
if (info /= psb_success_) then if (info /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
char_err='psb_realloc' char_err='psb_realloc'
call psb_errpush(info,name,a_err=char_err) call psb_errpush(info,name,a_err=char_err)
@ -940,7 +946,7 @@ Contains
integer(psb_epk_) :: val integer(psb_epk_) :: val
integer(psb_mpk_), allocatable, intent(in) :: vin(:) integer(psb_mpk_), allocatable, intent(in) :: vin(:)
if (.not.allocated(vin)) then if (.not.allocated(vin)) then
val = 0 val = 0
else else
val = size(vin) val = size(vin)
@ -955,10 +961,10 @@ Contains
integer(psb_ipk_) :: dim_ integer(psb_ipk_) :: dim_
if (.not.allocated(vin)) then if (.not.allocated(vin)) then
val = 0 val = 0
else else
if (present(dim)) then if (present(dim)) then
dim_= dim dim_= dim
val = size(vin,dim=dim_) val = size(vin,dim=dim_)
else else
@ -970,7 +976,7 @@ Contains
Subroutine psb_ensure_m_sz_m_rk1(len,v,info,pad,addsz,newsz) Subroutine psb_ensure_m_sz_m_rk1(len,v,info,pad,addsz,newsz)
use psb_error_mod use psb_error_mod
! ...Subroutine Arguments ! ...Subroutine Arguments
integer(psb_mpk_),Intent(in) :: len integer(psb_mpk_),Intent(in) :: len
integer(psb_mpk_),allocatable, intent(inout) :: v(:) integer(psb_mpk_),allocatable, intent(inout) :: v(:)
integer(psb_ipk_) :: info integer(psb_ipk_) :: info
@ -986,29 +992,11 @@ Contains
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
info = psb_success_ info = psb_success_
if (psb_errstatus_fatal()) then if (psb_errstatus_fatal()) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
goto 9999 goto 9999
end if 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
isz = psb_size(v) isz = psb_size(v)
If (len > isz) Then If (len > isz) Then
#if defined(OPENMP) #if defined(OPENMP)
@ -1017,7 +1005,7 @@ Contains
if (present(newsz)) then if (present(newsz)) then
isz = max(len+1,1,newsz) isz = max(len+1,1,newsz)
else if (present(addsz)) then else if (present(addsz)) then
isz = max(len,1,isz+addsz)) isz = max(len,1,isz+addsz)
else else
isz = max(len,1,int(1.25*isz)) isz = max(len,1,int(1.25*isz))
endif endif
@ -1065,7 +1053,7 @@ Contains
Subroutine psb_ensure_e_sz_m_rk1(len,v,info,pad,addsz,newsz) Subroutine psb_ensure_e_sz_m_rk1(len,v,info,pad,addsz,newsz)
use psb_error_mod use psb_error_mod
! ...Subroutine Arguments ! ...Subroutine Arguments
integer(psb_epk_),Intent(in) :: len integer(psb_epk_),Intent(in) :: len
integer(psb_mpk_),allocatable, intent(inout) :: v(:) integer(psb_mpk_),allocatable, intent(inout) :: v(:)
integer(psb_ipk_) :: info integer(psb_ipk_) :: info
@ -1081,7 +1069,7 @@ Contains
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
info = psb_success_ info = psb_success_
if (psb_errstatus_fatal()) then if (psb_errstatus_fatal()) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
goto 9999 goto 9999
end if end if
@ -1116,9 +1104,9 @@ Contains
Subroutine psb_move_alloc_m_rk1(vin,vout,info) Subroutine psb_move_alloc_m_rk1(vin,vout,info)
use psb_error_mod use psb_error_mod
integer(psb_mpk_), allocatable, intent(inout) :: vin(:),vout(:) integer(psb_mpk_), allocatable, intent(inout) :: vin(:),vout(:)
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
!
! !
!
info=psb_success_ info=psb_success_
call move_alloc(vin,vout) call move_alloc(vin,vout)
@ -1127,9 +1115,9 @@ Contains
Subroutine psb_move_alloc_m_rk2(vin,vout,info) Subroutine psb_move_alloc_m_rk2(vin,vout,info)
use psb_error_mod use psb_error_mod
integer(psb_mpk_), allocatable, intent(inout) :: vin(:,:),vout(:,:) integer(psb_mpk_), allocatable, intent(inout) :: vin(:,:),vout(:,:)
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
!
! !
!
info=psb_success_ info=psb_success_
call move_alloc(vin,vout) call move_alloc(vin,vout)

214
base/modules/auxil/psb_s_realloc_mod.F90
Unescape Escape View File

@ -1,9 +1,9 @@
! !
! Parallel Sparse BLAS version 3.5 ! Parallel Sparse BLAS version 3.5
! (C) Copyright 2006-2018 ! (C) Copyright 2006-2018
! Salvatore Filippone ! Salvatore Filippone
! Alfredo Buttari ! Alfredo Buttari
! !
! Redistribution and use in source and binary forms, with or without ! Redistribution and use in source and binary forms, with or without
! modification, are permitted provided that the following conditions ! modification, are permitted provided that the following conditions
! are met: ! are met:
@ -15,7 +15,7 @@
! 3. The name of the PSBLAS group or the names of its contributors may ! 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 ! not be used to endorse or promote products derived from this
! software without specific written permission. ! software without specific written permission.
! !
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR ! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
@ -27,16 +27,16 @@
! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ! 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 ! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
! POSSIBILITY OF SUCH DAMAGE. ! POSSIBILITY OF SUCH DAMAGE.
! !
! !
module psb_s_realloc_mod module psb_s_realloc_mod
use psb_const_mod use psb_const_mod
implicit none implicit none
! !
! psb_realloc will reallocate the input array to have exactly ! psb_realloc will reallocate the input array to have exactly
! the size specified, possibly shortening it. ! the size specified, possibly shortening it.
! !
Interface psb_realloc Interface psb_realloc
module procedure psb_r_s_s module procedure psb_r_s_s
@ -49,7 +49,7 @@ module psb_s_realloc_mod
module procedure psb_r_m_2_s_rk1 module procedure psb_r_m_2_s_rk1
module procedure psb_r_e_2_s_rk1 module procedure psb_r_e_2_s_rk1
end Interface psb_realloc end Interface psb_realloc
interface psb_move_alloc interface psb_move_alloc
@ -66,7 +66,7 @@ module psb_s_realloc_mod
! !
! psb_ensure_size will reallocate the input array if necessary ! psb_ensure_size will reallocate the input array if necessary
! to guarantee that its size is at least as large as the ! to guarantee that its size is at least as large as the
! value required, usually with some room to spare. ! value required, usually with some room to spare.
! !
interface psb_ensure_size interface psb_ensure_size
@ -74,7 +74,7 @@ module psb_s_realloc_mod
end Interface psb_ensure_size end Interface psb_ensure_size
! !
! psb_size returns 0 if argument is not allocated. ! psb_size returns 0 if argument is not allocated.
! !
interface psb_size interface psb_size
module procedure psb_size_s_rk1, psb_size_s_rk2 module procedure psb_size_s_rk1, psb_size_s_rk2
@ -86,7 +86,7 @@ Contains
Subroutine psb_r_s_s(rrax,info) Subroutine psb_r_s_s(rrax,info)
use psb_error_mod use psb_error_mod
! ...Subroutine Arguments ! ...Subroutine Arguments
real(psb_spk_), allocatable, intent(inout) :: rrax real(psb_spk_), allocatable, intent(inout) :: rrax
integer(psb_ipk_) :: info integer(psb_ipk_) :: info
@ -97,9 +97,9 @@ Contains
name='psb_r_s_s' name='psb_r_s_s'
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
info=psb_success_ info=psb_success_
if (.not.allocated(rrax)) then if (.not.allocated(rrax)) then
Allocate(rrax,stat=info) Allocate(rrax,stat=info)
if (info /= psb_success_) then if (info /= psb_success_) then
err=4025 err=4025
@ -122,7 +122,7 @@ Contains
Subroutine psb_r_m_s_rk1(len,rrax,info,pad,lb) Subroutine psb_r_m_s_rk1(len,rrax,info,pad,lb)
use psb_error_mod use psb_error_mod
! ...Subroutine Arguments ! ...Subroutine Arguments
integer(psb_mpk_),Intent(in) :: len integer(psb_mpk_),Intent(in) :: len
real(psb_spk_), allocatable, intent(inout) :: rrax(:) real(psb_spk_), allocatable, intent(inout) :: rrax(:)
integer(psb_ipk_) :: info integer(psb_ipk_) :: info
@ -138,7 +138,7 @@ Contains
name='psb_r_m_s_rk1' name='psb_r_m_s_rk1'
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
info=psb_success_ info=psb_success_
if (debug) write(psb_err_unit,*) 'reallocate D',len if (debug) write(psb_err_unit,*) 'reallocate D',len
if (present(lb)) then if (present(lb)) then
@ -146,7 +146,7 @@ Contains
else else
lb_ = 1 lb_ = 1
endif endif
if ((len<0)) then if ((len<0)) then
err=4025 err=4025
call psb_errpush(err,name, l_err=(/len*1_psb_lpk_/), & call psb_errpush(err,name, l_err=(/len*1_psb_lpk_/), &
& a_err='real(psb_spk_)') & a_err='real(psb_spk_)')
@ -154,7 +154,7 @@ Contains
end if end if
ub_ = lb_ + len-1 ub_ = lb_ + len-1
if (allocated(rrax)) then if (allocated(rrax)) then
dim = size(rrax) dim = size(rrax)
lbi = lbound(rrax,1) lbi = lbound(rrax,1)
If ((dim /= len).or.(lbi /= lb_)) Then If ((dim /= len).or.(lbi /= lb_)) Then
@ -178,7 +178,7 @@ Contains
goto 9999 goto 9999
end if end if
endif endif
if (present(pad)) then if (present(pad)) then
!$omp parallel do private(i) shared(dim,len) !$omp parallel do private(i) shared(dim,len)
do i=lb_-1+dim+1,lb_-1+len do i=lb_-1+dim+1,lb_-1+len
rrax(i) = pad rrax(i) = pad
@ -196,7 +196,7 @@ Contains
Subroutine psb_r_m_s_rk2(len1,len2,rrax,info,pad,lb1,lb2) Subroutine psb_r_m_s_rk2(len1,len2,rrax,info,pad,lb1,lb2)
use psb_error_mod use psb_error_mod
! ...Subroutine Arguments ! ...Subroutine Arguments
integer(psb_mpk_),Intent(in) :: len1,len2 integer(psb_mpk_),Intent(in) :: len1,len2
real(psb_spk_),allocatable :: rrax(:,:) real(psb_spk_),allocatable :: rrax(:,:)
integer(psb_ipk_) :: info integer(psb_ipk_) :: info
@ -212,13 +212,13 @@ Contains
name='psb_r_m_s_rk2' name='psb_r_m_s_rk2'
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
info=psb_success_ info=psb_success_
if (present(lb1)) then if (present(lb1)) then
lb1_ = lb1 lb1_ = lb1
else else
lb1_ = 1 lb1_ = 1
endif endif
if (present(lb2)) then if (present(lb2)) then
lb2_ = lb2 lb2_ = lb2
else else
lb2_ = 1 lb2_ = 1
@ -227,7 +227,7 @@ Contains
ub2_ = lb2_ + len2 -1 ub2_ = lb2_ + len2 -1
if (len1 < 0) then if (len1 < 0) then
err=4025 err=4025
call psb_errpush(err,name, l_err=(/len1*1_psb_lpk_/), & call psb_errpush(err,name, l_err=(/len1*1_psb_lpk_/), &
& a_err='real(psb_spk_)') & a_err='real(psb_spk_)')
goto 9999 goto 9999
@ -240,7 +240,7 @@ Contains
end if end if
if (allocated(rrax)) then if (allocated(rrax)) then
dim = size(rrax,1) dim = size(rrax,1)
lbi1 = lbound(rrax,1) lbi1 = lbound(rrax,1)
dim2 = size(rrax,2) dim2 = size(rrax,2)
@ -269,7 +269,7 @@ Contains
goto 9999 goto 9999
end if end if
endif endif
if (present(pad)) then if (present(pad)) then
!$omp parallel do private(i) shared(lb1_,dim,len1) !$omp parallel do private(i) shared(lb1_,dim,len1)
do i=lb1_-1+dim+1,lb1_-1+len1 do i=lb1_-1+dim+1,lb1_-1+len1
rrax(i,:) = pad rrax(i,:) = pad
@ -293,7 +293,7 @@ Contains
Subroutine psb_r_e_s_rk1(len,rrax,info,pad,lb) Subroutine psb_r_e_s_rk1(len,rrax,info,pad,lb)
use psb_error_mod use psb_error_mod
! ...Subroutine Arguments ! ...Subroutine Arguments
integer(psb_epk_),Intent(in) :: len integer(psb_epk_),Intent(in) :: len
real(psb_spk_), allocatable, intent(inout) :: rrax(:) real(psb_spk_), allocatable, intent(inout) :: rrax(:)
integer(psb_ipk_) :: info integer(psb_ipk_) :: info
@ -309,7 +309,7 @@ Contains
name='psb_r_m_s_rk1' name='psb_r_m_s_rk1'
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
info=psb_success_ info=psb_success_
if (debug) write(psb_err_unit,*) 'reallocate D',len if (debug) write(psb_err_unit,*) 'reallocate D',len
if (present(lb)) then if (present(lb)) then
@ -317,7 +317,7 @@ Contains
else else
lb_ = 1 lb_ = 1
endif endif
if ((len<0)) then if ((len<0)) then
err=4025 err=4025
call psb_errpush(err,name, e_err=(/len/), & call psb_errpush(err,name, e_err=(/len/), &
& a_err='real(psb_spk_)') & a_err='real(psb_spk_)')
@ -325,7 +325,7 @@ Contains
end if end if
ub_ = lb_ + len-1 ub_ = lb_ + len-1
if (allocated(rrax)) then if (allocated(rrax)) then
dim = size(rrax) dim = size(rrax)
lbi = lbound(rrax,1) lbi = lbound(rrax,1)
If ((dim /= len).or.(lbi /= lb_)) Then If ((dim /= len).or.(lbi /= lb_)) Then
@ -349,7 +349,7 @@ Contains
goto 9999 goto 9999
end if end if
endif endif
if (present(pad)) then if (present(pad)) then
rrax(lb_-1+dim+1:lb_-1+len) = pad rrax(lb_-1+dim+1:lb_-1+len) = pad
endif endif
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
@ -364,7 +364,7 @@ Contains
Subroutine psb_r_e_s_rk2(len1,len2,rrax,info,pad,lb1,lb2) Subroutine psb_r_e_s_rk2(len1,len2,rrax,info,pad,lb1,lb2)
use psb_error_mod use psb_error_mod
! ...Subroutine Arguments ! ...Subroutine Arguments
integer(psb_epk_),Intent(in) :: len1,len2 integer(psb_epk_),Intent(in) :: len1,len2
real(psb_spk_),allocatable :: rrax(:,:) real(psb_spk_),allocatable :: rrax(:,:)
integer(psb_ipk_) :: info integer(psb_ipk_) :: info
@ -380,13 +380,13 @@ Contains
name='psb_r_e_s_rk2' name='psb_r_e_s_rk2'
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
info=psb_success_ info=psb_success_
if (present(lb1)) then if (present(lb1)) then
lb1_ = lb1 lb1_ = lb1
else else
lb1_ = 1 lb1_ = 1
endif endif
if (present(lb2)) then if (present(lb2)) then
lb2_ = lb2 lb2_ = lb2
else else
lb2_ = 1 lb2_ = 1
@ -408,7 +408,7 @@ Contains
end if end if
if (allocated(rrax)) then if (allocated(rrax)) then
dim = size(rrax,1) dim = size(rrax,1)
lbi1 = lbound(rrax,1) lbi1 = lbound(rrax,1)
dim2 = size(rrax,2) dim2 = size(rrax,2)
@ -437,7 +437,7 @@ Contains
goto 9999 goto 9999
end if end if
endif endif
if (present(pad)) then if (present(pad)) then
rrax(lb1_-1+dim+1:lb1_-1+len1,:) = pad rrax(lb1_-1+dim+1:lb1_-1+len1,:) = pad
rrax(lb1_:lb1_-1+dim,lb2_-1+dim2+1:lb2_-1+len2) = pad rrax(lb1_:lb1_-1+dim,lb2_-1+dim2+1:lb2_-1+len2) = pad
endif endif
@ -453,7 +453,7 @@ Contains
Subroutine psb_r_me_s_rk2(len1,len2,rrax,info,pad,lb1,lb2) Subroutine psb_r_me_s_rk2(len1,len2,rrax,info,pad,lb1,lb2)
use psb_error_mod use psb_error_mod
! ...Subroutine Arguments ! ...Subroutine Arguments
integer(psb_mpk_),Intent(in) :: len1 integer(psb_mpk_),Intent(in) :: len1
integer(psb_epk_),Intent(in) :: len2 integer(psb_epk_),Intent(in) :: len2
real(psb_spk_),allocatable :: rrax(:,:) real(psb_spk_),allocatable :: rrax(:,:)
@ -471,13 +471,13 @@ Contains
name='psb_r_me_s_rk2' name='psb_r_me_s_rk2'
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
info=psb_success_ info=psb_success_
if (present(lb1)) then if (present(lb1)) then
lb1_ = lb1 lb1_ = lb1
else else
lb1_ = 1 lb1_ = 1
endif endif
if (present(lb2)) then if (present(lb2)) then
lb2_ = lb2 lb2_ = lb2
else else
lb2_ = 1 lb2_ = 1
@ -486,7 +486,7 @@ Contains
ub2_ = lb2_ + len2 -1 ub2_ = lb2_ + len2 -1
if (len1 < 0) then if (len1 < 0) then
err=4025 err=4025
call psb_errpush(err,name, m_err=(/len1/), & call psb_errpush(err,name, m_err=(/len1/), &
& a_err='real(psb_spk_)') & a_err='real(psb_spk_)')
goto 9999 goto 9999
@ -499,7 +499,7 @@ Contains
end if end if
if (allocated(rrax)) then if (allocated(rrax)) then
dim = size(rrax,1) dim = size(rrax,1)
lbi1 = lbound(rrax,1) lbi1 = lbound(rrax,1)
dim2 = size(rrax,2) dim2 = size(rrax,2)
@ -528,7 +528,7 @@ Contains
goto 9999 goto 9999
end if end if
endif endif
if (present(pad)) then if (present(pad)) then
rrax(lb1_-1+dim+1:lb1_-1+len1,:) = pad rrax(lb1_-1+dim+1:lb1_-1+len1,:) = pad
rrax(lb1_:lb1_-1+dim,lb2_-1+dim2+1:lb2_-1+len2) = pad rrax(lb1_:lb1_-1+dim,lb2_-1+dim2+1:lb2_-1+len2) = pad
endif endif
@ -544,7 +544,7 @@ Contains
Subroutine psb_r_em_s_rk2(len1,len2,rrax,info,pad,lb1,lb2) Subroutine psb_r_em_s_rk2(len1,len2,rrax,info,pad,lb1,lb2)
use psb_error_mod use psb_error_mod
! ...Subroutine Arguments ! ...Subroutine Arguments
integer(psb_epk_),Intent(in) :: len1 integer(psb_epk_),Intent(in) :: len1
integer(psb_mpk_),Intent(in) :: len2 integer(psb_mpk_),Intent(in) :: len2
real(psb_spk_),allocatable :: rrax(:,:) real(psb_spk_),allocatable :: rrax(:,:)
@ -562,13 +562,13 @@ Contains
name='psb_r_me_s_rk2' name='psb_r_me_s_rk2'
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
info=psb_success_ info=psb_success_
if (present(lb1)) then if (present(lb1)) then
lb1_ = lb1 lb1_ = lb1
else else
lb1_ = 1 lb1_ = 1
endif endif
if (present(lb2)) then if (present(lb2)) then
lb2_ = lb2 lb2_ = lb2
else else
lb2_ = 1 lb2_ = 1
@ -577,7 +577,7 @@ Contains
ub2_ = lb2_ + len2 -1 ub2_ = lb2_ + len2 -1
if (len1 < 0) then if (len1 < 0) then
err=4025 err=4025
call psb_errpush(err,name, e_err=(/len1/), & call psb_errpush(err,name, e_err=(/len1/), &
& a_err='real(psb_spk_)') & a_err='real(psb_spk_)')
goto 9999 goto 9999
@ -590,7 +590,7 @@ Contains
end if end if
if (allocated(rrax)) then if (allocated(rrax)) then
dim = size(rrax,1) dim = size(rrax,1)
lbi1 = lbound(rrax,1) lbi1 = lbound(rrax,1)
dim2 = size(rrax,2) dim2 = size(rrax,2)
@ -619,7 +619,7 @@ Contains
goto 9999 goto 9999
end if end if
endif endif
if (present(pad)) then if (present(pad)) then
rrax(lb1_-1+dim+1:lb1_-1+len1,:) = pad rrax(lb1_-1+dim+1:lb1_-1+len1,:) = pad
rrax(lb1_:lb1_-1+dim,lb2_-1+dim2+1:lb2_-1+len2) = pad rrax(lb1_:lb1_-1+dim,lb2_-1+dim2+1:lb2_-1+len2) = pad
endif endif
@ -635,7 +635,7 @@ Contains
Subroutine psb_r_m_2_s_rk1(len,rrax,y,info,pad) Subroutine psb_r_m_2_s_rk1(len,rrax,y,info,pad)
use psb_error_mod use psb_error_mod
! ...Subroutine Arguments ! ...Subroutine Arguments
integer(psb_mpk_),Intent(in) :: len integer(psb_mpk_),Intent(in) :: len
real(psb_spk_),allocatable, intent(inout) :: rrax(:),y(:) real(psb_spk_),allocatable, intent(inout) :: rrax(:),y(:)
@ -648,7 +648,7 @@ Contains
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
info=psb_success_ info=psb_success_
if(psb_errstatus_fatal()) then if(psb_errstatus_fatal()) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
goto 9999 goto 9999
end if end if
@ -676,7 +676,7 @@ Contains
Subroutine psb_r_e_2_s_rk1(len,rrax,y,info,pad) Subroutine psb_r_e_2_s_rk1(len,rrax,y,info,pad)
use psb_error_mod use psb_error_mod
! ...Subroutine Arguments ! ...Subroutine Arguments
integer(psb_epk_),Intent(in) :: len integer(psb_epk_),Intent(in) :: len
real(psb_spk_),allocatable, intent(inout) :: rrax(:),y(:) real(psb_spk_),allocatable, intent(inout) :: rrax(:),y(:)
@ -689,7 +689,7 @@ Contains
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
info=psb_success_ info=psb_success_
if(psb_errstatus_fatal()) then if(psb_errstatus_fatal()) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
goto 9999 goto 9999
end if end if
@ -717,10 +717,10 @@ Contains
subroutine psb_ab_cpy_s_s(vin,vout,info) subroutine psb_ab_cpy_s_s(vin,vout,info)
use psb_error_mod use psb_error_mod
! ...Subroutine Arguments ! ...Subroutine Arguments
real(psb_spk_), allocatable, intent(in) :: vin real(psb_spk_), allocatable, intent(in) :: vin
real(psb_spk_), allocatable, intent(out) :: vout real(psb_spk_), allocatable, intent(out) :: vout
integer(psb_ipk_) :: info integer(psb_ipk_) :: info
@ -733,14 +733,14 @@ Contains
name='psb_ab_cpy_s_s' name='psb_ab_cpy_s_s'
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
info=psb_success_ info=psb_success_
if(psb_errstatus_fatal()) then if(psb_errstatus_fatal()) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
goto 9999 goto 9999
end if end if
if (allocated(vin)) then if (allocated(vin)) then
call psb_realloc(vout,info) call psb_realloc(vout,info)
if (info /= psb_success_) then if (info /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
char_err='psb_realloc' char_err='psb_realloc'
call psb_errpush(info,name,a_err=char_err) call psb_errpush(info,name,a_err=char_err)
@ -759,38 +759,42 @@ Contains
end subroutine psb_ab_cpy_s_s end subroutine psb_ab_cpy_s_s
subroutine psb_ab_cpy_s_rk1(vin,vout,info) subroutine psb_ab_cpy_s_rk1(vin,vout,info)
use psb_error_mod use psb_error_mod
! ...Subroutine Arguments ! ...Subroutine Arguments
real(psb_spk_), allocatable, intent(in) :: vin(:) real(psb_spk_), allocatable, intent(in) :: vin(:)
real(psb_spk_), allocatable, intent(out) :: vout(:) real(psb_spk_), allocatable, intent(out) :: vout(:)
integer(psb_ipk_) :: info integer(psb_ipk_) :: info
! ...Local Variables ! ...Local Variables
integer(psb_ipk_) :: isz,err_act,lb integer(psb_ipk_) :: isz,err_act,lb, i
character(len=30) :: name, char_err character(len=30) :: name, char_err
logical, parameter :: debug=.false. logical, parameter :: debug=.false.
name='psb_ab_cpy_s_rk1' name='psb_ab_cpy_s_rk1'
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
info=psb_success_ info=psb_success_
if(psb_errstatus_fatal()) then if(psb_errstatus_fatal()) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
goto 9999 goto 9999
end if end if
if (allocated(vin)) then if (allocated(vin)) then
isz = size(vin) isz = size(vin)
lb = lbound(vin,1) lb = lbound(vin,1)
call psb_realloc(isz,vout,info,lb=lb) call psb_realloc(isz,vout,info,lb=lb)
if (info /= psb_success_) then if (info /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
char_err='psb_realloc' char_err='psb_realloc'
call psb_errpush(info,name,a_err=char_err) call psb_errpush(info,name,a_err=char_err)
goto 9999 goto 9999
else else
vout(:) = vin(:) !$omp parallel do private(i)
do i=lb,lb+isz-1
vout(i) = vin(i)
end do
!$omp end parallel do
endif endif
endif endif
@ -803,40 +807,42 @@ Contains
end subroutine psb_ab_cpy_s_rk1 end subroutine psb_ab_cpy_s_rk1
subroutine psb_ab_cpy_s_rk2(vin,vout,info) subroutine psb_ab_cpy_s_rk2(vin,vout,info)
use psb_error_mod use psb_error_mod
! ...Subroutine Arguments ! ...Subroutine Arguments
real(psb_spk_), allocatable, intent(in) :: vin(:,:) real(psb_spk_), allocatable, intent(in) :: vin(:,:)
real(psb_spk_), allocatable, intent(out) :: vout(:,:) real(psb_spk_), allocatable, intent(out) :: vout(:,:)
integer(psb_ipk_) :: info integer(psb_ipk_) :: info
! ...Local Variables ! ...Local Variables
integer(psb_ipk_) :: isz1, isz2,err_act, lb1, lb2 integer(psb_ipk_) :: isz1, isz2,err_act, lb1, lb2
character(len=30) :: name, char_err character(len=30) :: name, char_err
logical, parameter :: debug=.false. logical, parameter :: debug=.false.
name='psb_ab_cpy_s_rk2' name='psb_ab_cpy_s_rk2'
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
info=psb_success_ info=psb_success_
if(psb_errstatus_fatal()) then if(psb_errstatus_fatal()) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
goto 9999 goto 9999
end if end if
if (allocated(vin)) then if (allocated(vin)) then
isz1 = size(vin,1) isz1 = size(vin,1)
isz2 = size(vin,2) isz2 = size(vin,2)
lb1 = lbound(vin,1) lb1 = lbound(vin,1)
lb2 = lbound(vin,2) lb2 = lbound(vin,2)
call psb_realloc(isz1,isz2,vout,info,lb1=lb1,lb2=lb2) call psb_realloc(isz1,isz2,vout,info,lb1=lb1,lb2=lb2)
if (info /= psb_success_) then if (info /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
char_err='psb_realloc' char_err='psb_realloc'
call psb_errpush(info,name,a_err=char_err) call psb_errpush(info,name,a_err=char_err)
goto 9999 goto 9999
else else
!$omp workshare
vout(:,:) = vin(:,:) vout(:,:) = vin(:,:)
!$omp end workshare
endif endif
endif endif
@ -850,10 +856,10 @@ Contains
end subroutine psb_ab_cpy_s_rk2 end subroutine psb_ab_cpy_s_rk2
subroutine psb_cpy_s_rk1(vin,vout,info) subroutine psb_cpy_s_rk1(vin,vout,info)
use psb_error_mod use psb_error_mod
! ...Subroutine Arguments ! ...Subroutine Arguments
real(psb_spk_), intent(in) :: vin(:) real(psb_spk_), intent(in) :: vin(:)
real(psb_spk_), allocatable, intent(out) :: vout(:) real(psb_spk_), allocatable, intent(out) :: vout(:)
integer(psb_ipk_) :: info integer(psb_ipk_) :: info
@ -866,14 +872,14 @@ Contains
name='psb_cpy_s_rk1' name='psb_cpy_s_rk1'
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
info=psb_success_ info=psb_success_
if(psb_errstatus_fatal()) then if(psb_errstatus_fatal()) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
goto 9999 goto 9999
end if end if
isz = size(vin) isz = size(vin)
lb = lbound(vin,1) lb = lbound(vin,1)
call psb_realloc(isz,vout,info,lb=lb) call psb_realloc(isz,vout,info,lb=lb)
if (info /= psb_success_) then if (info /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
char_err='psb_realloc' char_err='psb_realloc'
call psb_errpush(info,name,a_err=char_err) call psb_errpush(info,name,a_err=char_err)
@ -891,23 +897,23 @@ Contains
end subroutine psb_cpy_s_rk1 end subroutine psb_cpy_s_rk1
subroutine psb_cpy_s_rk2(vin,vout,info) subroutine psb_cpy_s_rk2(vin,vout,info)
use psb_error_mod use psb_error_mod
! ...Subroutine Arguments ! ...Subroutine Arguments
real(psb_spk_), intent(in) :: vin(:,:) real(psb_spk_), intent(in) :: vin(:,:)
real(psb_spk_), allocatable, intent(out) :: vout(:,:) real(psb_spk_), allocatable, intent(out) :: vout(:,:)
integer(psb_ipk_) :: info integer(psb_ipk_) :: info
! ...Local Variables ! ...Local Variables
integer(psb_ipk_) :: isz1, isz2,err_act, lb1, lb2 integer(psb_ipk_) :: isz1, isz2,err_act, lb1, lb2
character(len=30) :: name, char_err character(len=30) :: name, char_err
logical, parameter :: debug=.false. logical, parameter :: debug=.false.
name='psb_safe_cpy' name='psb_safe_cpy'
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
info=psb_success_ info=psb_success_
if(psb_errstatus_fatal()) then if(psb_errstatus_fatal()) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
goto 9999 goto 9999
end if end if
@ -917,7 +923,7 @@ Contains
lb1 = lbound(vin,1) lb1 = lbound(vin,1)
lb2 = lbound(vin,2) lb2 = lbound(vin,2)
call psb_realloc(isz1,isz2,vout,info,lb1=lb1,lb2=lb2) call psb_realloc(isz1,isz2,vout,info,lb1=lb1,lb2=lb2)
if (info /= psb_success_) then if (info /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
char_err='psb_realloc' char_err='psb_realloc'
call psb_errpush(info,name,a_err=char_err) call psb_errpush(info,name,a_err=char_err)
@ -940,7 +946,7 @@ Contains
integer(psb_epk_) :: val integer(psb_epk_) :: val
real(psb_spk_), allocatable, intent(in) :: vin(:) real(psb_spk_), allocatable, intent(in) :: vin(:)
if (.not.allocated(vin)) then if (.not.allocated(vin)) then
val = 0 val = 0
else else
val = size(vin) val = size(vin)
@ -955,10 +961,10 @@ Contains
integer(psb_ipk_) :: dim_ integer(psb_ipk_) :: dim_
if (.not.allocated(vin)) then if (.not.allocated(vin)) then
val = 0 val = 0
else else
if (present(dim)) then if (present(dim)) then
dim_= dim dim_= dim
val = size(vin,dim=dim_) val = size(vin,dim=dim_)
else else
@ -970,7 +976,7 @@ Contains
Subroutine psb_ensure_m_sz_s_rk1(len,v,info,pad,addsz,newsz) Subroutine psb_ensure_m_sz_s_rk1(len,v,info,pad,addsz,newsz)
use psb_error_mod use psb_error_mod
! ...Subroutine Arguments ! ...Subroutine Arguments
integer(psb_mpk_),Intent(in) :: len integer(psb_mpk_),Intent(in) :: len
real(psb_spk_),allocatable, intent(inout) :: v(:) real(psb_spk_),allocatable, intent(inout) :: v(:)
integer(psb_ipk_) :: info integer(psb_ipk_) :: info
@ -986,29 +992,11 @@ Contains
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
info = psb_success_ info = psb_success_
if (psb_errstatus_fatal()) then if (psb_errstatus_fatal()) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
goto 9999 goto 9999
end if 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
isz = psb_size(v) isz = psb_size(v)
If (len > isz) Then If (len > isz) Then
#if defined(OPENMP) #if defined(OPENMP)
@ -1017,7 +1005,7 @@ Contains
if (present(newsz)) then if (present(newsz)) then
isz = max(len+1,1,newsz) isz = max(len+1,1,newsz)
else if (present(addsz)) then else if (present(addsz)) then
isz = max(len,1,isz+addsz)) isz = max(len,1,isz+addsz)
else else
isz = max(len,1,int(1.25*isz)) isz = max(len,1,int(1.25*isz))
endif endif
@ -1065,7 +1053,7 @@ Contains
Subroutine psb_ensure_e_sz_s_rk1(len,v,info,pad,addsz,newsz) Subroutine psb_ensure_e_sz_s_rk1(len,v,info,pad,addsz,newsz)
use psb_error_mod use psb_error_mod
! ...Subroutine Arguments ! ...Subroutine Arguments
integer(psb_epk_),Intent(in) :: len integer(psb_epk_),Intent(in) :: len
real(psb_spk_),allocatable, intent(inout) :: v(:) real(psb_spk_),allocatable, intent(inout) :: v(:)
integer(psb_ipk_) :: info integer(psb_ipk_) :: info
@ -1081,7 +1069,7 @@ Contains
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
info = psb_success_ info = psb_success_
if (psb_errstatus_fatal()) then if (psb_errstatus_fatal()) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
goto 9999 goto 9999
end if end if
@ -1116,9 +1104,9 @@ Contains
Subroutine psb_move_alloc_s_rk1(vin,vout,info) Subroutine psb_move_alloc_s_rk1(vin,vout,info)
use psb_error_mod use psb_error_mod
real(psb_spk_), allocatable, intent(inout) :: vin(:),vout(:) real(psb_spk_), allocatable, intent(inout) :: vin(:),vout(:)
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
!
! !
!
info=psb_success_ info=psb_success_
call move_alloc(vin,vout) call move_alloc(vin,vout)
@ -1127,9 +1115,9 @@ Contains
Subroutine psb_move_alloc_s_rk2(vin,vout,info) Subroutine psb_move_alloc_s_rk2(vin,vout,info)
use psb_error_mod use psb_error_mod
real(psb_spk_), allocatable, intent(inout) :: vin(:,:),vout(:,:) real(psb_spk_), allocatable, intent(inout) :: vin(:,:),vout(:,:)
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
!
! !
!
info=psb_success_ info=psb_success_
call move_alloc(vin,vout) call move_alloc(vin,vout)

214
base/modules/auxil/psb_z_realloc_mod.F90
Unescape Escape View File

@ -1,9 +1,9 @@
! !
! Parallel Sparse BLAS version 3.5 ! Parallel Sparse BLAS version 3.5
! (C) Copyright 2006-2018 ! (C) Copyright 2006-2018
! Salvatore Filippone ! Salvatore Filippone
! Alfredo Buttari ! Alfredo Buttari
! !
! Redistribution and use in source and binary forms, with or without ! Redistribution and use in source and binary forms, with or without
! modification, are permitted provided that the following conditions ! modification, are permitted provided that the following conditions
! are met: ! are met:
@ -15,7 +15,7 @@
! 3. The name of the PSBLAS group or the names of its contributors may ! 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 ! not be used to endorse or promote products derived from this
! software without specific written permission. ! software without specific written permission.
! !
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR ! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
@ -27,16 +27,16 @@
! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ! 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 ! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
! POSSIBILITY OF SUCH DAMAGE. ! POSSIBILITY OF SUCH DAMAGE.
! !
! !
module psb_z_realloc_mod module psb_z_realloc_mod
use psb_const_mod use psb_const_mod
implicit none implicit none
! !
! psb_realloc will reallocate the input array to have exactly ! psb_realloc will reallocate the input array to have exactly
! the size specified, possibly shortening it. ! the size specified, possibly shortening it.
! !
Interface psb_realloc Interface psb_realloc
module procedure psb_r_z_s module procedure psb_r_z_s
@ -49,7 +49,7 @@ module psb_z_realloc_mod
module procedure psb_r_m_2_z_rk1 module procedure psb_r_m_2_z_rk1
module procedure psb_r_e_2_z_rk1 module procedure psb_r_e_2_z_rk1
end Interface psb_realloc end Interface psb_realloc
interface psb_move_alloc interface psb_move_alloc
@ -66,7 +66,7 @@ module psb_z_realloc_mod
! !
! psb_ensure_size will reallocate the input array if necessary ! psb_ensure_size will reallocate the input array if necessary
! to guarantee that its size is at least as large as the ! to guarantee that its size is at least as large as the
! value required, usually with some room to spare. ! value required, usually with some room to spare.
! !
interface psb_ensure_size interface psb_ensure_size
@ -74,7 +74,7 @@ module psb_z_realloc_mod
end Interface psb_ensure_size end Interface psb_ensure_size
! !
! psb_size returns 0 if argument is not allocated. ! psb_size returns 0 if argument is not allocated.
! !
interface psb_size interface psb_size
module procedure psb_size_z_rk1, psb_size_z_rk2 module procedure psb_size_z_rk1, psb_size_z_rk2
@ -86,7 +86,7 @@ Contains
Subroutine psb_r_z_s(rrax,info) Subroutine psb_r_z_s(rrax,info)
use psb_error_mod use psb_error_mod
! ...Subroutine Arguments ! ...Subroutine Arguments
complex(psb_dpk_), allocatable, intent(inout) :: rrax complex(psb_dpk_), allocatable, intent(inout) :: rrax
integer(psb_ipk_) :: info integer(psb_ipk_) :: info
@ -97,9 +97,9 @@ Contains
name='psb_r_z_s' name='psb_r_z_s'
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
info=psb_success_ info=psb_success_
if (.not.allocated(rrax)) then if (.not.allocated(rrax)) then
Allocate(rrax,stat=info) Allocate(rrax,stat=info)
if (info /= psb_success_) then if (info /= psb_success_) then
err=4025 err=4025
@ -122,7 +122,7 @@ Contains
Subroutine psb_r_m_z_rk1(len,rrax,info,pad,lb) Subroutine psb_r_m_z_rk1(len,rrax,info,pad,lb)
use psb_error_mod use psb_error_mod
! ...Subroutine Arguments ! ...Subroutine Arguments
integer(psb_mpk_),Intent(in) :: len integer(psb_mpk_),Intent(in) :: len
complex(psb_dpk_), allocatable, intent(inout) :: rrax(:) complex(psb_dpk_), allocatable, intent(inout) :: rrax(:)
integer(psb_ipk_) :: info integer(psb_ipk_) :: info
@ -138,7 +138,7 @@ Contains
name='psb_r_m_z_rk1' name='psb_r_m_z_rk1'
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
info=psb_success_ info=psb_success_
if (debug) write(psb_err_unit,*) 'reallocate D',len if (debug) write(psb_err_unit,*) 'reallocate D',len
if (present(lb)) then if (present(lb)) then
@ -146,7 +146,7 @@ Contains
else else
lb_ = 1 lb_ = 1
endif endif
if ((len<0)) then if ((len<0)) then
err=4025 err=4025
call psb_errpush(err,name, l_err=(/len*1_psb_lpk_/), & call psb_errpush(err,name, l_err=(/len*1_psb_lpk_/), &
& a_err='complex(psb_dpk_)') & a_err='complex(psb_dpk_)')
@ -154,7 +154,7 @@ Contains
end if end if
ub_ = lb_ + len-1 ub_ = lb_ + len-1
if (allocated(rrax)) then if (allocated(rrax)) then
dim = size(rrax) dim = size(rrax)
lbi = lbound(rrax,1) lbi = lbound(rrax,1)
If ((dim /= len).or.(lbi /= lb_)) Then If ((dim /= len).or.(lbi /= lb_)) Then
@ -178,7 +178,7 @@ Contains
goto 9999 goto 9999
end if end if
endif endif
if (present(pad)) then if (present(pad)) then
!$omp parallel do private(i) shared(dim,len) !$omp parallel do private(i) shared(dim,len)
do i=lb_-1+dim+1,lb_-1+len do i=lb_-1+dim+1,lb_-1+len
rrax(i) = pad rrax(i) = pad
@ -196,7 +196,7 @@ Contains
Subroutine psb_r_m_z_rk2(len1,len2,rrax,info,pad,lb1,lb2) Subroutine psb_r_m_z_rk2(len1,len2,rrax,info,pad,lb1,lb2)
use psb_error_mod use psb_error_mod
! ...Subroutine Arguments ! ...Subroutine Arguments
integer(psb_mpk_),Intent(in) :: len1,len2 integer(psb_mpk_),Intent(in) :: len1,len2
complex(psb_dpk_),allocatable :: rrax(:,:) complex(psb_dpk_),allocatable :: rrax(:,:)
integer(psb_ipk_) :: info integer(psb_ipk_) :: info
@ -212,13 +212,13 @@ Contains
name='psb_r_m_z_rk2' name='psb_r_m_z_rk2'
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
info=psb_success_ info=psb_success_
if (present(lb1)) then if (present(lb1)) then
lb1_ = lb1 lb1_ = lb1
else else
lb1_ = 1 lb1_ = 1
endif endif
if (present(lb2)) then if (present(lb2)) then
lb2_ = lb2 lb2_ = lb2
else else
lb2_ = 1 lb2_ = 1
@ -227,7 +227,7 @@ Contains
ub2_ = lb2_ + len2 -1 ub2_ = lb2_ + len2 -1
if (len1 < 0) then if (len1 < 0) then
err=4025 err=4025
call psb_errpush(err,name, l_err=(/len1*1_psb_lpk_/), & call psb_errpush(err,name, l_err=(/len1*1_psb_lpk_/), &
& a_err='complex(psb_dpk_)') & a_err='complex(psb_dpk_)')
goto 9999 goto 9999
@ -240,7 +240,7 @@ Contains
end if end if
if (allocated(rrax)) then if (allocated(rrax)) then
dim = size(rrax,1) dim = size(rrax,1)
lbi1 = lbound(rrax,1) lbi1 = lbound(rrax,1)
dim2 = size(rrax,2) dim2 = size(rrax,2)
@ -269,7 +269,7 @@ Contains
goto 9999 goto 9999
end if end if
endif endif
if (present(pad)) then if (present(pad)) then
!$omp parallel do private(i) shared(lb1_,dim,len1) !$omp parallel do private(i) shared(lb1_,dim,len1)
do i=lb1_-1+dim+1,lb1_-1+len1 do i=lb1_-1+dim+1,lb1_-1+len1
rrax(i,:) = pad rrax(i,:) = pad
@ -293,7 +293,7 @@ Contains
Subroutine psb_r_e_z_rk1(len,rrax,info,pad,lb) Subroutine psb_r_e_z_rk1(len,rrax,info,pad,lb)
use psb_error_mod use psb_error_mod
! ...Subroutine Arguments ! ...Subroutine Arguments
integer(psb_epk_),Intent(in) :: len integer(psb_epk_),Intent(in) :: len
complex(psb_dpk_), allocatable, intent(inout) :: rrax(:) complex(psb_dpk_), allocatable, intent(inout) :: rrax(:)
integer(psb_ipk_) :: info integer(psb_ipk_) :: info
@ -309,7 +309,7 @@ Contains
name='psb_r_m_z_rk1' name='psb_r_m_z_rk1'
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
info=psb_success_ info=psb_success_
if (debug) write(psb_err_unit,*) 'reallocate D',len if (debug) write(psb_err_unit,*) 'reallocate D',len
if (present(lb)) then if (present(lb)) then
@ -317,7 +317,7 @@ Contains
else else
lb_ = 1 lb_ = 1
endif endif
if ((len<0)) then if ((len<0)) then
err=4025 err=4025
call psb_errpush(err,name, e_err=(/len/), & call psb_errpush(err,name, e_err=(/len/), &
& a_err='complex(psb_dpk_)') & a_err='complex(psb_dpk_)')
@ -325,7 +325,7 @@ Contains
end if end if
ub_ = lb_ + len-1 ub_ = lb_ + len-1
if (allocated(rrax)) then if (allocated(rrax)) then
dim = size(rrax) dim = size(rrax)
lbi = lbound(rrax,1) lbi = lbound(rrax,1)
If ((dim /= len).or.(lbi /= lb_)) Then If ((dim /= len).or.(lbi /= lb_)) Then
@ -349,7 +349,7 @@ Contains
goto 9999 goto 9999
end if end if
endif endif
if (present(pad)) then if (present(pad)) then
rrax(lb_-1+dim+1:lb_-1+len) = pad rrax(lb_-1+dim+1:lb_-1+len) = pad
endif endif
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
@ -364,7 +364,7 @@ Contains
Subroutine psb_r_e_z_rk2(len1,len2,rrax,info,pad,lb1,lb2) Subroutine psb_r_e_z_rk2(len1,len2,rrax,info,pad,lb1,lb2)
use psb_error_mod use psb_error_mod
! ...Subroutine Arguments ! ...Subroutine Arguments
integer(psb_epk_),Intent(in) :: len1,len2 integer(psb_epk_),Intent(in) :: len1,len2
complex(psb_dpk_),allocatable :: rrax(:,:) complex(psb_dpk_),allocatable :: rrax(:,:)
integer(psb_ipk_) :: info integer(psb_ipk_) :: info
@ -380,13 +380,13 @@ Contains
name='psb_r_e_z_rk2' name='psb_r_e_z_rk2'
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
info=psb_success_ info=psb_success_
if (present(lb1)) then if (present(lb1)) then
lb1_ = lb1 lb1_ = lb1
else else
lb1_ = 1 lb1_ = 1
endif endif
if (present(lb2)) then if (present(lb2)) then
lb2_ = lb2 lb2_ = lb2
else else
lb2_ = 1 lb2_ = 1
@ -408,7 +408,7 @@ Contains
end if end if
if (allocated(rrax)) then if (allocated(rrax)) then
dim = size(rrax,1) dim = size(rrax,1)
lbi1 = lbound(rrax,1) lbi1 = lbound(rrax,1)
dim2 = size(rrax,2) dim2 = size(rrax,2)
@ -437,7 +437,7 @@ Contains
goto 9999 goto 9999
end if end if
endif endif
if (present(pad)) then if (present(pad)) then
rrax(lb1_-1+dim+1:lb1_-1+len1,:) = pad rrax(lb1_-1+dim+1:lb1_-1+len1,:) = pad
rrax(lb1_:lb1_-1+dim,lb2_-1+dim2+1:lb2_-1+len2) = pad rrax(lb1_:lb1_-1+dim,lb2_-1+dim2+1:lb2_-1+len2) = pad
endif endif
@ -453,7 +453,7 @@ Contains
Subroutine psb_r_me_z_rk2(len1,len2,rrax,info,pad,lb1,lb2) Subroutine psb_r_me_z_rk2(len1,len2,rrax,info,pad,lb1,lb2)
use psb_error_mod use psb_error_mod
! ...Subroutine Arguments ! ...Subroutine Arguments
integer(psb_mpk_),Intent(in) :: len1 integer(psb_mpk_),Intent(in) :: len1
integer(psb_epk_),Intent(in) :: len2 integer(psb_epk_),Intent(in) :: len2
complex(psb_dpk_),allocatable :: rrax(:,:) complex(psb_dpk_),allocatable :: rrax(:,:)
@ -471,13 +471,13 @@ Contains
name='psb_r_me_z_rk2' name='psb_r_me_z_rk2'
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
info=psb_success_ info=psb_success_
if (present(lb1)) then if (present(lb1)) then
lb1_ = lb1 lb1_ = lb1
else else
lb1_ = 1 lb1_ = 1
endif endif
if (present(lb2)) then if (present(lb2)) then
lb2_ = lb2 lb2_ = lb2
else else
lb2_ = 1 lb2_ = 1
@ -486,7 +486,7 @@ Contains
ub2_ = lb2_ + len2 -1 ub2_ = lb2_ + len2 -1
if (len1 < 0) then if (len1 < 0) then
err=4025 err=4025
call psb_errpush(err,name, m_err=(/len1/), & call psb_errpush(err,name, m_err=(/len1/), &
& a_err='complex(psb_dpk_)') & a_err='complex(psb_dpk_)')
goto 9999 goto 9999
@ -499,7 +499,7 @@ Contains
end if end if
if (allocated(rrax)) then if (allocated(rrax)) then
dim = size(rrax,1) dim = size(rrax,1)
lbi1 = lbound(rrax,1) lbi1 = lbound(rrax,1)
dim2 = size(rrax,2) dim2 = size(rrax,2)
@ -528,7 +528,7 @@ Contains
goto 9999 goto 9999
end if end if
endif endif
if (present(pad)) then if (present(pad)) then
rrax(lb1_-1+dim+1:lb1_-1+len1,:) = pad rrax(lb1_-1+dim+1:lb1_-1+len1,:) = pad
rrax(lb1_:lb1_-1+dim,lb2_-1+dim2+1:lb2_-1+len2) = pad rrax(lb1_:lb1_-1+dim,lb2_-1+dim2+1:lb2_-1+len2) = pad
endif endif
@ -544,7 +544,7 @@ Contains
Subroutine psb_r_em_z_rk2(len1,len2,rrax,info,pad,lb1,lb2) Subroutine psb_r_em_z_rk2(len1,len2,rrax,info,pad,lb1,lb2)
use psb_error_mod use psb_error_mod
! ...Subroutine Arguments ! ...Subroutine Arguments
integer(psb_epk_),Intent(in) :: len1 integer(psb_epk_),Intent(in) :: len1
integer(psb_mpk_),Intent(in) :: len2 integer(psb_mpk_),Intent(in) :: len2
complex(psb_dpk_),allocatable :: rrax(:,:) complex(psb_dpk_),allocatable :: rrax(:,:)
@ -562,13 +562,13 @@ Contains
name='psb_r_me_z_rk2' name='psb_r_me_z_rk2'
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
info=psb_success_ info=psb_success_
if (present(lb1)) then if (present(lb1)) then
lb1_ = lb1 lb1_ = lb1
else else
lb1_ = 1 lb1_ = 1
endif endif
if (present(lb2)) then if (present(lb2)) then
lb2_ = lb2 lb2_ = lb2
else else
lb2_ = 1 lb2_ = 1
@ -577,7 +577,7 @@ Contains
ub2_ = lb2_ + len2 -1 ub2_ = lb2_ + len2 -1
if (len1 < 0) then if (len1 < 0) then
err=4025 err=4025
call psb_errpush(err,name, e_err=(/len1/), & call psb_errpush(err,name, e_err=(/len1/), &
& a_err='complex(psb_dpk_)') & a_err='complex(psb_dpk_)')
goto 9999 goto 9999
@ -590,7 +590,7 @@ Contains
end if end if
if (allocated(rrax)) then if (allocated(rrax)) then
dim = size(rrax,1) dim = size(rrax,1)
lbi1 = lbound(rrax,1) lbi1 = lbound(rrax,1)
dim2 = size(rrax,2) dim2 = size(rrax,2)
@ -619,7 +619,7 @@ Contains
goto 9999 goto 9999
end if end if
endif endif
if (present(pad)) then if (present(pad)) then
rrax(lb1_-1+dim+1:lb1_-1+len1,:) = pad rrax(lb1_-1+dim+1:lb1_-1+len1,:) = pad
rrax(lb1_:lb1_-1+dim,lb2_-1+dim2+1:lb2_-1+len2) = pad rrax(lb1_:lb1_-1+dim,lb2_-1+dim2+1:lb2_-1+len2) = pad
endif endif
@ -635,7 +635,7 @@ Contains
Subroutine psb_r_m_2_z_rk1(len,rrax,y,info,pad) Subroutine psb_r_m_2_z_rk1(len,rrax,y,info,pad)
use psb_error_mod use psb_error_mod
! ...Subroutine Arguments ! ...Subroutine Arguments
integer(psb_mpk_),Intent(in) :: len integer(psb_mpk_),Intent(in) :: len
complex(psb_dpk_),allocatable, intent(inout) :: rrax(:),y(:) complex(psb_dpk_),allocatable, intent(inout) :: rrax(:),y(:)
@ -648,7 +648,7 @@ Contains
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
info=psb_success_ info=psb_success_
if(psb_errstatus_fatal()) then if(psb_errstatus_fatal()) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
goto 9999 goto 9999
end if end if
@ -676,7 +676,7 @@ Contains
Subroutine psb_r_e_2_z_rk1(len,rrax,y,info,pad) Subroutine psb_r_e_2_z_rk1(len,rrax,y,info,pad)
use psb_error_mod use psb_error_mod
! ...Subroutine Arguments ! ...Subroutine Arguments
integer(psb_epk_),Intent(in) :: len integer(psb_epk_),Intent(in) :: len
complex(psb_dpk_),allocatable, intent(inout) :: rrax(:),y(:) complex(psb_dpk_),allocatable, intent(inout) :: rrax(:),y(:)
@ -689,7 +689,7 @@ Contains
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
info=psb_success_ info=psb_success_
if(psb_errstatus_fatal()) then if(psb_errstatus_fatal()) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
goto 9999 goto 9999
end if end if
@ -717,10 +717,10 @@ Contains
subroutine psb_ab_cpy_z_s(vin,vout,info) subroutine psb_ab_cpy_z_s(vin,vout,info)
use psb_error_mod use psb_error_mod
! ...Subroutine Arguments ! ...Subroutine Arguments
complex(psb_dpk_), allocatable, intent(in) :: vin complex(psb_dpk_), allocatable, intent(in) :: vin
complex(psb_dpk_), allocatable, intent(out) :: vout complex(psb_dpk_), allocatable, intent(out) :: vout
integer(psb_ipk_) :: info integer(psb_ipk_) :: info
@ -733,14 +733,14 @@ Contains
name='psb_ab_cpy_z_s' name='psb_ab_cpy_z_s'
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
info=psb_success_ info=psb_success_
if(psb_errstatus_fatal()) then if(psb_errstatus_fatal()) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
goto 9999 goto 9999
end if end if
if (allocated(vin)) then if (allocated(vin)) then
call psb_realloc(vout,info) call psb_realloc(vout,info)
if (info /= psb_success_) then if (info /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
char_err='psb_realloc' char_err='psb_realloc'
call psb_errpush(info,name,a_err=char_err) call psb_errpush(info,name,a_err=char_err)
@ -759,38 +759,42 @@ Contains
end subroutine psb_ab_cpy_z_s end subroutine psb_ab_cpy_z_s
subroutine psb_ab_cpy_z_rk1(vin,vout,info) subroutine psb_ab_cpy_z_rk1(vin,vout,info)
use psb_error_mod use psb_error_mod
! ...Subroutine Arguments ! ...Subroutine Arguments
complex(psb_dpk_), allocatable, intent(in) :: vin(:) complex(psb_dpk_), allocatable, intent(in) :: vin(:)
complex(psb_dpk_), allocatable, intent(out) :: vout(:) complex(psb_dpk_), allocatable, intent(out) :: vout(:)
integer(psb_ipk_) :: info integer(psb_ipk_) :: info
! ...Local Variables ! ...Local Variables
integer(psb_ipk_) :: isz,err_act,lb integer(psb_ipk_) :: isz,err_act,lb, i
character(len=30) :: name, char_err character(len=30) :: name, char_err
logical, parameter :: debug=.false. logical, parameter :: debug=.false.
name='psb_ab_cpy_z_rk1' name='psb_ab_cpy_z_rk1'
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
info=psb_success_ info=psb_success_
if(psb_errstatus_fatal()) then if(psb_errstatus_fatal()) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
goto 9999 goto 9999
end if end if
if (allocated(vin)) then if (allocated(vin)) then
isz = size(vin) isz = size(vin)
lb = lbound(vin,1) lb = lbound(vin,1)
call psb_realloc(isz,vout,info,lb=lb) call psb_realloc(isz,vout,info,lb=lb)
if (info /= psb_success_) then if (info /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
char_err='psb_realloc' char_err='psb_realloc'
call psb_errpush(info,name,a_err=char_err) call psb_errpush(info,name,a_err=char_err)
goto 9999 goto 9999
else else
vout(:) = vin(:) !$omp parallel do private(i)
do i=lb,lb+isz-1
vout(i) = vin(i)
end do
!$omp end parallel do
endif endif
endif endif
@ -803,40 +807,42 @@ Contains
end subroutine psb_ab_cpy_z_rk1 end subroutine psb_ab_cpy_z_rk1
subroutine psb_ab_cpy_z_rk2(vin,vout,info) subroutine psb_ab_cpy_z_rk2(vin,vout,info)
use psb_error_mod use psb_error_mod
! ...Subroutine Arguments ! ...Subroutine Arguments
complex(psb_dpk_), allocatable, intent(in) :: vin(:,:) complex(psb_dpk_), allocatable, intent(in) :: vin(:,:)
complex(psb_dpk_), allocatable, intent(out) :: vout(:,:) complex(psb_dpk_), allocatable, intent(out) :: vout(:,:)
integer(psb_ipk_) :: info integer(psb_ipk_) :: info
! ...Local Variables ! ...Local Variables
integer(psb_ipk_) :: isz1, isz2,err_act, lb1, lb2 integer(psb_ipk_) :: isz1, isz2,err_act, lb1, lb2
character(len=30) :: name, char_err character(len=30) :: name, char_err
logical, parameter :: debug=.false. logical, parameter :: debug=.false.
name='psb_ab_cpy_z_rk2' name='psb_ab_cpy_z_rk2'
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
info=psb_success_ info=psb_success_
if(psb_errstatus_fatal()) then if(psb_errstatus_fatal()) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
goto 9999 goto 9999
end if end if
if (allocated(vin)) then if (allocated(vin)) then
isz1 = size(vin,1) isz1 = size(vin,1)
isz2 = size(vin,2) isz2 = size(vin,2)
lb1 = lbound(vin,1) lb1 = lbound(vin,1)
lb2 = lbound(vin,2) lb2 = lbound(vin,2)
call psb_realloc(isz1,isz2,vout,info,lb1=lb1,lb2=lb2) call psb_realloc(isz1,isz2,vout,info,lb1=lb1,lb2=lb2)
if (info /= psb_success_) then if (info /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
char_err='psb_realloc' char_err='psb_realloc'
call psb_errpush(info,name,a_err=char_err) call psb_errpush(info,name,a_err=char_err)
goto 9999 goto 9999
else else
!$omp workshare
vout(:,:) = vin(:,:) vout(:,:) = vin(:,:)
!$omp end workshare
endif endif
endif endif
@ -850,10 +856,10 @@ Contains
end subroutine psb_ab_cpy_z_rk2 end subroutine psb_ab_cpy_z_rk2
subroutine psb_cpy_z_rk1(vin,vout,info) subroutine psb_cpy_z_rk1(vin,vout,info)
use psb_error_mod use psb_error_mod
! ...Subroutine Arguments ! ...Subroutine Arguments
complex(psb_dpk_), intent(in) :: vin(:) complex(psb_dpk_), intent(in) :: vin(:)
complex(psb_dpk_), allocatable, intent(out) :: vout(:) complex(psb_dpk_), allocatable, intent(out) :: vout(:)
integer(psb_ipk_) :: info integer(psb_ipk_) :: info
@ -866,14 +872,14 @@ Contains
name='psb_cpy_z_rk1' name='psb_cpy_z_rk1'
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
info=psb_success_ info=psb_success_
if(psb_errstatus_fatal()) then if(psb_errstatus_fatal()) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
goto 9999 goto 9999
end if end if
isz = size(vin) isz = size(vin)
lb = lbound(vin,1) lb = lbound(vin,1)
call psb_realloc(isz,vout,info,lb=lb) call psb_realloc(isz,vout,info,lb=lb)
if (info /= psb_success_) then if (info /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
char_err='psb_realloc' char_err='psb_realloc'
call psb_errpush(info,name,a_err=char_err) call psb_errpush(info,name,a_err=char_err)
@ -891,23 +897,23 @@ Contains
end subroutine psb_cpy_z_rk1 end subroutine psb_cpy_z_rk1
subroutine psb_cpy_z_rk2(vin,vout,info) subroutine psb_cpy_z_rk2(vin,vout,info)
use psb_error_mod use psb_error_mod
! ...Subroutine Arguments ! ...Subroutine Arguments
complex(psb_dpk_), intent(in) :: vin(:,:) complex(psb_dpk_), intent(in) :: vin(:,:)
complex(psb_dpk_), allocatable, intent(out) :: vout(:,:) complex(psb_dpk_), allocatable, intent(out) :: vout(:,:)
integer(psb_ipk_) :: info integer(psb_ipk_) :: info
! ...Local Variables ! ...Local Variables
integer(psb_ipk_) :: isz1, isz2,err_act, lb1, lb2 integer(psb_ipk_) :: isz1, isz2,err_act, lb1, lb2
character(len=30) :: name, char_err character(len=30) :: name, char_err
logical, parameter :: debug=.false. logical, parameter :: debug=.false.
name='psb_safe_cpy' name='psb_safe_cpy'
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
info=psb_success_ info=psb_success_
if(psb_errstatus_fatal()) then if(psb_errstatus_fatal()) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
goto 9999 goto 9999
end if end if
@ -917,7 +923,7 @@ Contains
lb1 = lbound(vin,1) lb1 = lbound(vin,1)
lb2 = lbound(vin,2) lb2 = lbound(vin,2)
call psb_realloc(isz1,isz2,vout,info,lb1=lb1,lb2=lb2) call psb_realloc(isz1,isz2,vout,info,lb1=lb1,lb2=lb2)
if (info /= psb_success_) then if (info /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
char_err='psb_realloc' char_err='psb_realloc'
call psb_errpush(info,name,a_err=char_err) call psb_errpush(info,name,a_err=char_err)
@ -940,7 +946,7 @@ Contains
integer(psb_epk_) :: val integer(psb_epk_) :: val
complex(psb_dpk_), allocatable, intent(in) :: vin(:) complex(psb_dpk_), allocatable, intent(in) :: vin(:)
if (.not.allocated(vin)) then if (.not.allocated(vin)) then
val = 0 val = 0
else else
val = size(vin) val = size(vin)
@ -955,10 +961,10 @@ Contains
integer(psb_ipk_) :: dim_ integer(psb_ipk_) :: dim_
if (.not.allocated(vin)) then if (.not.allocated(vin)) then
val = 0 val = 0
else else
if (present(dim)) then if (present(dim)) then
dim_= dim dim_= dim
val = size(vin,dim=dim_) val = size(vin,dim=dim_)
else else
@ -970,7 +976,7 @@ Contains
Subroutine psb_ensure_m_sz_z_rk1(len,v,info,pad,addsz,newsz) Subroutine psb_ensure_m_sz_z_rk1(len,v,info,pad,addsz,newsz)
use psb_error_mod use psb_error_mod
! ...Subroutine Arguments ! ...Subroutine Arguments
integer(psb_mpk_),Intent(in) :: len integer(psb_mpk_),Intent(in) :: len
complex(psb_dpk_),allocatable, intent(inout) :: v(:) complex(psb_dpk_),allocatable, intent(inout) :: v(:)
integer(psb_ipk_) :: info integer(psb_ipk_) :: info
@ -986,29 +992,11 @@ Contains
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
info = psb_success_ info = psb_success_
if (psb_errstatus_fatal()) then if (psb_errstatus_fatal()) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
goto 9999 goto 9999
end if 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
isz = psb_size(v) isz = psb_size(v)
If (len > isz) Then If (len > isz) Then
#if defined(OPENMP) #if defined(OPENMP)
@ -1017,7 +1005,7 @@ Contains
if (present(newsz)) then if (present(newsz)) then
isz = max(len+1,1,newsz) isz = max(len+1,1,newsz)
else if (present(addsz)) then else if (present(addsz)) then
isz = max(len,1,isz+addsz)) isz = max(len,1,isz+addsz)
else else
isz = max(len,1,int(1.25*isz)) isz = max(len,1,int(1.25*isz))
endif endif
@ -1065,7 +1053,7 @@ Contains
Subroutine psb_ensure_e_sz_z_rk1(len,v,info,pad,addsz,newsz) Subroutine psb_ensure_e_sz_z_rk1(len,v,info,pad,addsz,newsz)
use psb_error_mod use psb_error_mod
! ...Subroutine Arguments ! ...Subroutine Arguments
integer(psb_epk_),Intent(in) :: len integer(psb_epk_),Intent(in) :: len
complex(psb_dpk_),allocatable, intent(inout) :: v(:) complex(psb_dpk_),allocatable, intent(inout) :: v(:)
integer(psb_ipk_) :: info integer(psb_ipk_) :: info
@ -1081,7 +1069,7 @@ Contains
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
info = psb_success_ info = psb_success_
if (psb_errstatus_fatal()) then if (psb_errstatus_fatal()) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
goto 9999 goto 9999
end if end if
@ -1116,9 +1104,9 @@ Contains
Subroutine psb_move_alloc_z_rk1(vin,vout,info) Subroutine psb_move_alloc_z_rk1(vin,vout,info)
use psb_error_mod use psb_error_mod
complex(psb_dpk_), allocatable, intent(inout) :: vin(:),vout(:) complex(psb_dpk_), allocatable, intent(inout) :: vin(:),vout(:)
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
!
! !
!
info=psb_success_ info=psb_success_
call move_alloc(vin,vout) call move_alloc(vin,vout)
@ -1127,9 +1115,9 @@ Contains
Subroutine psb_move_alloc_z_rk2(vin,vout,info) Subroutine psb_move_alloc_z_rk2(vin,vout,info)
use psb_error_mod use psb_error_mod
complex(psb_dpk_), allocatable, intent(inout) :: vin(:,:),vout(:,:) complex(psb_dpk_), allocatable, intent(inout) :: vin(:,:),vout(:,:)
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
!
! !
!
info=psb_success_ info=psb_success_
call move_alloc(vin,vout) call move_alloc(vin,vout)

Write Preview
Loading…
Cancel
Save