From 301528e9d9e799c1e13da5fbd6ba7daa8e81a78f Mon Sep 17 00:00:00 2001 From: Cirdans-Home Date: Thu, 19 Oct 2023 13:41:13 +0200 Subject: [PATCH] Merged with development to fix --- base/modules/auxil/psb_c_realloc_mod.F90 | 214 ++++++++++------------ base/modules/auxil/psb_d_realloc_mod.F90 | 214 ++++++++++------------ base/modules/auxil/psb_e_realloc_mod.F90 | 214 ++++++++++------------ base/modules/auxil/psb_i2_realloc_mod.F90 | 214 ++++++++++------------ base/modules/auxil/psb_m_realloc_mod.F90 | 214 ++++++++++------------ base/modules/auxil/psb_s_realloc_mod.F90 | 214 ++++++++++------------ base/modules/auxil/psb_z_realloc_mod.F90 | 214 ++++++++++------------ 7 files changed, 707 insertions(+), 791 deletions(-) diff --git a/base/modules/auxil/psb_c_realloc_mod.F90 b/base/modules/auxil/psb_c_realloc_mod.F90 index 4cea4683..188ca21e 100644 --- a/base/modules/auxil/psb_c_realloc_mod.F90 +++ b/base/modules/auxil/psb_c_realloc_mod.F90 @@ -1,9 +1,9 @@ -! +! ! Parallel Sparse BLAS version 3.5 ! (C) Copyright 2006-2018 -! Salvatore Filippone -! Alfredo Buttari -! +! Salvatore Filippone +! Alfredo Buttari +! ! Redistribution and use in source and binary forms, with or without ! modification, are permitted provided that the following conditions ! are met: @@ -15,7 +15,7 @@ ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this ! software without specific written permission. -! +! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED ! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR @@ -27,16 +27,16 @@ ! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE ! POSSIBILITY OF SUCH DAMAGE. -! -! +! +! module psb_c_realloc_mod use psb_const_mod implicit none ! - ! psb_realloc will reallocate the input array to have exactly - ! the size specified, possibly shortening it. + ! psb_realloc will reallocate the input array to have exactly + ! the size specified, possibly shortening it. ! Interface psb_realloc 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_e_2_c_rk1 - + end Interface psb_realloc interface psb_move_alloc @@ -66,7 +66,7 @@ module psb_c_realloc_mod ! ! 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. ! interface psb_ensure_size @@ -74,7 +74,7 @@ module psb_c_realloc_mod 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 module procedure psb_size_c_rk1, psb_size_c_rk2 @@ -86,7 +86,7 @@ Contains Subroutine psb_r_c_s(rrax,info) use psb_error_mod - ! ...Subroutine Arguments + ! ...Subroutine Arguments complex(psb_spk_), allocatable, intent(inout) :: rrax integer(psb_ipk_) :: info @@ -97,9 +97,9 @@ Contains name='psb_r_c_s' 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) if (info /= psb_success_) then err=4025 @@ -122,7 +122,7 @@ Contains Subroutine psb_r_m_c_rk1(len,rrax,info,pad,lb) use psb_error_mod - ! ...Subroutine Arguments + ! ...Subroutine Arguments integer(psb_mpk_),Intent(in) :: len complex(psb_spk_), allocatable, intent(inout) :: rrax(:) integer(psb_ipk_) :: info @@ -138,7 +138,7 @@ Contains name='psb_r_m_c_rk1' call psb_erractionsave(err_act) - info=psb_success_ + info=psb_success_ if (debug) write(psb_err_unit,*) 'reallocate D',len if (present(lb)) then @@ -146,7 +146,7 @@ Contains else lb_ = 1 endif - if ((len<0)) then + if ((len<0)) then err=4025 call psb_errpush(err,name, l_err=(/len*1_psb_lpk_/), & & a_err='complex(psb_spk_)') @@ -154,7 +154,7 @@ Contains end if ub_ = lb_ + len-1 - if (allocated(rrax)) then + if (allocated(rrax)) then dim = size(rrax) lbi = lbound(rrax,1) If ((dim /= len).or.(lbi /= lb_)) Then @@ -178,7 +178,7 @@ Contains goto 9999 end if endif - if (present(pad)) then + if (present(pad)) then !$omp parallel do private(i) shared(dim,len) do i=lb_-1+dim+1,lb_-1+len rrax(i) = pad @@ -196,7 +196,7 @@ Contains Subroutine psb_r_m_c_rk2(len1,len2,rrax,info,pad,lb1,lb2) use psb_error_mod - ! ...Subroutine Arguments + ! ...Subroutine Arguments integer(psb_mpk_),Intent(in) :: len1,len2 complex(psb_spk_),allocatable :: rrax(:,:) integer(psb_ipk_) :: info @@ -212,13 +212,13 @@ Contains name='psb_r_m_c_rk2' call psb_erractionsave(err_act) - info=psb_success_ - if (present(lb1)) then + info=psb_success_ + if (present(lb1)) then lb1_ = lb1 else lb1_ = 1 endif - if (present(lb2)) then + if (present(lb2)) then lb2_ = lb2 else lb2_ = 1 @@ -227,7 +227,7 @@ Contains ub2_ = lb2_ + len2 -1 if (len1 < 0) then - err=4025 + err=4025 call psb_errpush(err,name, l_err=(/len1*1_psb_lpk_/), & & a_err='complex(psb_spk_)') goto 9999 @@ -240,7 +240,7 @@ Contains end if - if (allocated(rrax)) then + if (allocated(rrax)) then dim = size(rrax,1) lbi1 = lbound(rrax,1) dim2 = size(rrax,2) @@ -269,7 +269,7 @@ Contains goto 9999 end if endif - if (present(pad)) then + if (present(pad)) then !$omp parallel do private(i) shared(lb1_,dim,len1) do i=lb1_-1+dim+1,lb1_-1+len1 rrax(i,:) = pad @@ -293,7 +293,7 @@ Contains Subroutine psb_r_e_c_rk1(len,rrax,info,pad,lb) use psb_error_mod - ! ...Subroutine Arguments + ! ...Subroutine Arguments integer(psb_epk_),Intent(in) :: len complex(psb_spk_), allocatable, intent(inout) :: rrax(:) integer(psb_ipk_) :: info @@ -309,7 +309,7 @@ Contains name='psb_r_m_c_rk1' call psb_erractionsave(err_act) - info=psb_success_ + info=psb_success_ if (debug) write(psb_err_unit,*) 'reallocate D',len if (present(lb)) then @@ -317,7 +317,7 @@ Contains else lb_ = 1 endif - if ((len<0)) then + if ((len<0)) then err=4025 call psb_errpush(err,name, e_err=(/len/), & & a_err='complex(psb_spk_)') @@ -325,7 +325,7 @@ Contains end if ub_ = lb_ + len-1 - if (allocated(rrax)) then + if (allocated(rrax)) then dim = size(rrax) lbi = lbound(rrax,1) If ((dim /= len).or.(lbi /= lb_)) Then @@ -349,7 +349,7 @@ Contains goto 9999 end if endif - if (present(pad)) then + if (present(pad)) then rrax(lb_-1+dim+1:lb_-1+len) = pad endif call psb_erractionrestore(err_act) @@ -364,7 +364,7 @@ Contains Subroutine psb_r_e_c_rk2(len1,len2,rrax,info,pad,lb1,lb2) use psb_error_mod - ! ...Subroutine Arguments + ! ...Subroutine Arguments integer(psb_epk_),Intent(in) :: len1,len2 complex(psb_spk_),allocatable :: rrax(:,:) integer(psb_ipk_) :: info @@ -380,13 +380,13 @@ Contains name='psb_r_e_c_rk2' call psb_erractionsave(err_act) - info=psb_success_ - if (present(lb1)) then + info=psb_success_ + if (present(lb1)) then lb1_ = lb1 else lb1_ = 1 endif - if (present(lb2)) then + if (present(lb2)) then lb2_ = lb2 else lb2_ = 1 @@ -408,7 +408,7 @@ Contains end if - if (allocated(rrax)) then + if (allocated(rrax)) then dim = size(rrax,1) lbi1 = lbound(rrax,1) dim2 = size(rrax,2) @@ -437,7 +437,7 @@ Contains goto 9999 end if endif - if (present(pad)) then + if (present(pad)) then rrax(lb1_-1+dim+1:lb1_-1+len1,:) = pad rrax(lb1_:lb1_-1+dim,lb2_-1+dim2+1:lb2_-1+len2) = pad endif @@ -453,7 +453,7 @@ Contains Subroutine psb_r_me_c_rk2(len1,len2,rrax,info,pad,lb1,lb2) use psb_error_mod - ! ...Subroutine Arguments + ! ...Subroutine Arguments integer(psb_mpk_),Intent(in) :: len1 integer(psb_epk_),Intent(in) :: len2 complex(psb_spk_),allocatable :: rrax(:,:) @@ -471,13 +471,13 @@ Contains name='psb_r_me_c_rk2' call psb_erractionsave(err_act) - info=psb_success_ - if (present(lb1)) then + info=psb_success_ + if (present(lb1)) then lb1_ = lb1 else lb1_ = 1 endif - if (present(lb2)) then + if (present(lb2)) then lb2_ = lb2 else lb2_ = 1 @@ -486,7 +486,7 @@ Contains ub2_ = lb2_ + len2 -1 if (len1 < 0) then - err=4025 + err=4025 call psb_errpush(err,name, m_err=(/len1/), & & a_err='complex(psb_spk_)') goto 9999 @@ -499,7 +499,7 @@ Contains end if - if (allocated(rrax)) then + if (allocated(rrax)) then dim = size(rrax,1) lbi1 = lbound(rrax,1) dim2 = size(rrax,2) @@ -528,7 +528,7 @@ Contains goto 9999 end if endif - if (present(pad)) then + if (present(pad)) then rrax(lb1_-1+dim+1:lb1_-1+len1,:) = pad rrax(lb1_:lb1_-1+dim,lb2_-1+dim2+1:lb2_-1+len2) = pad endif @@ -544,7 +544,7 @@ Contains Subroutine psb_r_em_c_rk2(len1,len2,rrax,info,pad,lb1,lb2) use psb_error_mod - ! ...Subroutine Arguments + ! ...Subroutine Arguments integer(psb_epk_),Intent(in) :: len1 integer(psb_mpk_),Intent(in) :: len2 complex(psb_spk_),allocatable :: rrax(:,:) @@ -562,13 +562,13 @@ Contains name='psb_r_me_c_rk2' call psb_erractionsave(err_act) - info=psb_success_ - if (present(lb1)) then + info=psb_success_ + if (present(lb1)) then lb1_ = lb1 else lb1_ = 1 endif - if (present(lb2)) then + if (present(lb2)) then lb2_ = lb2 else lb2_ = 1 @@ -577,7 +577,7 @@ Contains ub2_ = lb2_ + len2 -1 if (len1 < 0) then - err=4025 + err=4025 call psb_errpush(err,name, e_err=(/len1/), & & a_err='complex(psb_spk_)') goto 9999 @@ -590,7 +590,7 @@ Contains end if - if (allocated(rrax)) then + if (allocated(rrax)) then dim = size(rrax,1) lbi1 = lbound(rrax,1) dim2 = size(rrax,2) @@ -619,7 +619,7 @@ Contains goto 9999 end if endif - if (present(pad)) then + if (present(pad)) then rrax(lb1_-1+dim+1:lb1_-1+len1,:) = pad rrax(lb1_:lb1_-1+dim,lb2_-1+dim2+1:lb2_-1+len2) = pad endif @@ -635,7 +635,7 @@ Contains Subroutine psb_r_m_2_c_rk1(len,rrax,y,info,pad) use psb_error_mod - ! ...Subroutine Arguments + ! ...Subroutine Arguments integer(psb_mpk_),Intent(in) :: len complex(psb_spk_),allocatable, intent(inout) :: rrax(:),y(:) @@ -648,7 +648,7 @@ Contains call psb_erractionsave(err_act) info=psb_success_ - if(psb_errstatus_fatal()) then + if(psb_errstatus_fatal()) then info=psb_err_from_subroutine_ goto 9999 end if @@ -676,7 +676,7 @@ Contains Subroutine psb_r_e_2_c_rk1(len,rrax,y,info,pad) use psb_error_mod - ! ...Subroutine Arguments + ! ...Subroutine Arguments integer(psb_epk_),Intent(in) :: len complex(psb_spk_),allocatable, intent(inout) :: rrax(:),y(:) @@ -689,7 +689,7 @@ Contains call psb_erractionsave(err_act) info=psb_success_ - if(psb_errstatus_fatal()) then + if(psb_errstatus_fatal()) then info=psb_err_from_subroutine_ goto 9999 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 - ! ...Subroutine Arguments + ! ...Subroutine Arguments complex(psb_spk_), allocatable, intent(in) :: vin complex(psb_spk_), allocatable, intent(out) :: vout integer(psb_ipk_) :: info @@ -733,14 +733,14 @@ Contains name='psb_ab_cpy_c_s' call psb_erractionsave(err_act) info=psb_success_ - if(psb_errstatus_fatal()) then + if(psb_errstatus_fatal()) then info=psb_err_from_subroutine_ goto 9999 end if - if (allocated(vin)) then + if (allocated(vin)) then call psb_realloc(vout,info) - if (info /= psb_success_) then + if (info /= psb_success_) then info=psb_err_from_subroutine_ char_err='psb_realloc' call psb_errpush(info,name,a_err=char_err) @@ -759,38 +759,42 @@ Contains 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 - ! ...Subroutine Arguments + ! ...Subroutine Arguments complex(psb_spk_), allocatable, intent(in) :: vin(:) complex(psb_spk_), allocatable, intent(out) :: vout(:) integer(psb_ipk_) :: info ! ...Local Variables - integer(psb_ipk_) :: isz,err_act,lb + integer(psb_ipk_) :: isz,err_act,lb, i character(len=30) :: name, char_err logical, parameter :: debug=.false. name='psb_ab_cpy_c_rk1' call psb_erractionsave(err_act) info=psb_success_ - if(psb_errstatus_fatal()) then + if(psb_errstatus_fatal()) then info=psb_err_from_subroutine_ goto 9999 end if - if (allocated(vin)) then + if (allocated(vin)) then isz = size(vin) lb = lbound(vin,1) call psb_realloc(isz,vout,info,lb=lb) - if (info /= psb_success_) then + if (info /= psb_success_) then info=psb_err_from_subroutine_ char_err='psb_realloc' call psb_errpush(info,name,a_err=char_err) goto 9999 else - vout(:) = vin(:) + !$omp parallel do private(i) + do i=lb,lb+isz-1 + vout(i) = vin(i) + end do + !$omp end parallel do endif endif @@ -803,40 +807,42 @@ Contains 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 - ! ...Subroutine Arguments + ! ...Subroutine Arguments complex(psb_spk_), allocatable, intent(in) :: vin(:,:) complex(psb_spk_), allocatable, intent(out) :: vout(:,:) integer(psb_ipk_) :: info ! ...Local Variables - integer(psb_ipk_) :: isz1, isz2,err_act, lb1, lb2 + integer(psb_ipk_) :: isz1, isz2,err_act, lb1, lb2 character(len=30) :: name, char_err logical, parameter :: debug=.false. name='psb_ab_cpy_c_rk2' call psb_erractionsave(err_act) info=psb_success_ - if(psb_errstatus_fatal()) then + if(psb_errstatus_fatal()) then info=psb_err_from_subroutine_ goto 9999 end if - if (allocated(vin)) then + if (allocated(vin)) then isz1 = size(vin,1) isz2 = size(vin,2) lb1 = lbound(vin,1) lb2 = lbound(vin,2) call psb_realloc(isz1,isz2,vout,info,lb1=lb1,lb2=lb2) - if (info /= psb_success_) then + if (info /= psb_success_) then info=psb_err_from_subroutine_ char_err='psb_realloc' call psb_errpush(info,name,a_err=char_err) goto 9999 else + !$omp workshare vout(:,:) = vin(:,:) + !$omp end workshare endif endif @@ -850,10 +856,10 @@ Contains 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 - ! ...Subroutine Arguments + ! ...Subroutine Arguments complex(psb_spk_), intent(in) :: vin(:) complex(psb_spk_), allocatable, intent(out) :: vout(:) integer(psb_ipk_) :: info @@ -866,14 +872,14 @@ Contains name='psb_cpy_c_rk1' call psb_erractionsave(err_act) info=psb_success_ - if(psb_errstatus_fatal()) then + if(psb_errstatus_fatal()) then info=psb_err_from_subroutine_ goto 9999 end if isz = size(vin) lb = lbound(vin,1) call psb_realloc(isz,vout,info,lb=lb) - if (info /= psb_success_) then + if (info /= psb_success_) then info=psb_err_from_subroutine_ char_err='psb_realloc' call psb_errpush(info,name,a_err=char_err) @@ -891,23 +897,23 @@ Contains 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 - ! ...Subroutine Arguments + ! ...Subroutine Arguments complex(psb_spk_), intent(in) :: vin(:,:) complex(psb_spk_), allocatable, intent(out) :: vout(:,:) integer(psb_ipk_) :: info ! ...Local Variables - integer(psb_ipk_) :: isz1, isz2,err_act, lb1, lb2 + integer(psb_ipk_) :: isz1, isz2,err_act, lb1, lb2 character(len=30) :: name, char_err logical, parameter :: debug=.false. name='psb_safe_cpy' call psb_erractionsave(err_act) info=psb_success_ - if(psb_errstatus_fatal()) then + if(psb_errstatus_fatal()) then info=psb_err_from_subroutine_ goto 9999 end if @@ -917,7 +923,7 @@ Contains lb1 = lbound(vin,1) lb2 = lbound(vin,2) 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_ char_err='psb_realloc' call psb_errpush(info,name,a_err=char_err) @@ -940,7 +946,7 @@ Contains integer(psb_epk_) :: val complex(psb_spk_), allocatable, intent(in) :: vin(:) - if (.not.allocated(vin)) then + if (.not.allocated(vin)) then val = 0 else val = size(vin) @@ -955,10 +961,10 @@ Contains integer(psb_ipk_) :: dim_ - if (.not.allocated(vin)) then + if (.not.allocated(vin)) then val = 0 else - if (present(dim)) then + if (present(dim)) then dim_= dim val = size(vin,dim=dim_) else @@ -970,7 +976,7 @@ Contains Subroutine psb_ensure_m_sz_c_rk1(len,v,info,pad,addsz,newsz) use psb_error_mod - ! ...Subroutine Arguments + ! ...Subroutine Arguments integer(psb_mpk_),Intent(in) :: len complex(psb_spk_),allocatable, intent(inout) :: v(:) integer(psb_ipk_) :: info @@ -986,29 +992,11 @@ Contains call psb_erractionsave(err_act) info = psb_success_ - if (psb_errstatus_fatal()) then + if (psb_errstatus_fatal()) then info=psb_err_from_subroutine_ goto 9999 end if -!!$ If (len > psb_size(v)) Then -!!$ if (present(newsz)) then -!!$ isz = (max(len+1,newsz)) -!!$ else -!!$ if (present(addsz)) then -!!$ isz = len+max(1,addsz) -!!$ else -!!$ isz = max(len+10, int(1.25*len)) -!!$ endif -!!$ endif -!!$ -!!$ call psb_realloc(isz,v,info,pad=pad) -!!$ if (info /= psb_success_) then -!!$ info=psb_err_from_subroutine_ -!!$ call psb_errpush(info,name,a_err='psb_realloc') -!!$ goto 9999 -!!$ End If -!!$ end If isz = psb_size(v) If (len > isz) Then #if defined(OPENMP) @@ -1017,7 +1005,7 @@ Contains if (present(newsz)) then isz = max(len+1,1,newsz) else if (present(addsz)) then - isz = max(len,1,isz+addsz)) + isz = max(len,1,isz+addsz) else isz = max(len,1,int(1.25*isz)) endif @@ -1065,7 +1053,7 @@ Contains Subroutine psb_ensure_e_sz_c_rk1(len,v,info,pad,addsz,newsz) use psb_error_mod - ! ...Subroutine Arguments + ! ...Subroutine Arguments integer(psb_epk_),Intent(in) :: len complex(psb_spk_),allocatable, intent(inout) :: v(:) integer(psb_ipk_) :: info @@ -1081,7 +1069,7 @@ Contains call psb_erractionsave(err_act) info = psb_success_ - if (psb_errstatus_fatal()) then + if (psb_errstatus_fatal()) then info=psb_err_from_subroutine_ goto 9999 end if @@ -1116,9 +1104,9 @@ Contains Subroutine psb_move_alloc_c_rk1(vin,vout,info) use psb_error_mod complex(psb_spk_), allocatable, intent(inout) :: vin(:),vout(:) - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info + ! ! - ! info=psb_success_ call move_alloc(vin,vout) @@ -1127,9 +1115,9 @@ Contains Subroutine psb_move_alloc_c_rk2(vin,vout,info) use psb_error_mod complex(psb_spk_), allocatable, intent(inout) :: vin(:,:),vout(:,:) - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info + ! ! - ! info=psb_success_ call move_alloc(vin,vout) diff --git a/base/modules/auxil/psb_d_realloc_mod.F90 b/base/modules/auxil/psb_d_realloc_mod.F90 index f30435fe..5cd5311c 100644 --- a/base/modules/auxil/psb_d_realloc_mod.F90 +++ b/base/modules/auxil/psb_d_realloc_mod.F90 @@ -1,9 +1,9 @@ -! +! ! Parallel Sparse BLAS version 3.5 ! (C) Copyright 2006-2018 -! Salvatore Filippone -! Alfredo Buttari -! +! Salvatore Filippone +! Alfredo Buttari +! ! Redistribution and use in source and binary forms, with or without ! modification, are permitted provided that the following conditions ! are met: @@ -15,7 +15,7 @@ ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this ! software without specific written permission. -! +! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED ! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR @@ -27,16 +27,16 @@ ! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE ! POSSIBILITY OF SUCH DAMAGE. -! -! +! +! module psb_d_realloc_mod use psb_const_mod implicit none ! - ! psb_realloc will reallocate the input array to have exactly - ! the size specified, possibly shortening it. + ! psb_realloc will reallocate the input array to have exactly + ! the size specified, possibly shortening it. ! Interface psb_realloc 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_e_2_d_rk1 - + end Interface psb_realloc interface psb_move_alloc @@ -66,7 +66,7 @@ module psb_d_realloc_mod ! ! 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. ! interface psb_ensure_size @@ -74,7 +74,7 @@ module psb_d_realloc_mod 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 module procedure psb_size_d_rk1, psb_size_d_rk2 @@ -86,7 +86,7 @@ Contains Subroutine psb_r_d_s(rrax,info) use psb_error_mod - ! ...Subroutine Arguments + ! ...Subroutine Arguments real(psb_dpk_), allocatable, intent(inout) :: rrax integer(psb_ipk_) :: info @@ -97,9 +97,9 @@ Contains name='psb_r_d_s' 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) if (info /= psb_success_) then err=4025 @@ -122,7 +122,7 @@ Contains Subroutine psb_r_m_d_rk1(len,rrax,info,pad,lb) use psb_error_mod - ! ...Subroutine Arguments + ! ...Subroutine Arguments integer(psb_mpk_),Intent(in) :: len real(psb_dpk_), allocatable, intent(inout) :: rrax(:) integer(psb_ipk_) :: info @@ -138,7 +138,7 @@ Contains name='psb_r_m_d_rk1' call psb_erractionsave(err_act) - info=psb_success_ + info=psb_success_ if (debug) write(psb_err_unit,*) 'reallocate D',len if (present(lb)) then @@ -146,7 +146,7 @@ Contains else lb_ = 1 endif - if ((len<0)) then + if ((len<0)) then err=4025 call psb_errpush(err,name, l_err=(/len*1_psb_lpk_/), & & a_err='real(psb_dpk_)') @@ -154,7 +154,7 @@ Contains end if ub_ = lb_ + len-1 - if (allocated(rrax)) then + if (allocated(rrax)) then dim = size(rrax) lbi = lbound(rrax,1) If ((dim /= len).or.(lbi /= lb_)) Then @@ -178,7 +178,7 @@ Contains goto 9999 end if endif - if (present(pad)) then + if (present(pad)) then !$omp parallel do private(i) shared(dim,len) do i=lb_-1+dim+1,lb_-1+len rrax(i) = pad @@ -196,7 +196,7 @@ Contains Subroutine psb_r_m_d_rk2(len1,len2,rrax,info,pad,lb1,lb2) use psb_error_mod - ! ...Subroutine Arguments + ! ...Subroutine Arguments integer(psb_mpk_),Intent(in) :: len1,len2 real(psb_dpk_),allocatable :: rrax(:,:) integer(psb_ipk_) :: info @@ -212,13 +212,13 @@ Contains name='psb_r_m_d_rk2' call psb_erractionsave(err_act) - info=psb_success_ - if (present(lb1)) then + info=psb_success_ + if (present(lb1)) then lb1_ = lb1 else lb1_ = 1 endif - if (present(lb2)) then + if (present(lb2)) then lb2_ = lb2 else lb2_ = 1 @@ -227,7 +227,7 @@ Contains ub2_ = lb2_ + len2 -1 if (len1 < 0) then - err=4025 + err=4025 call psb_errpush(err,name, l_err=(/len1*1_psb_lpk_/), & & a_err='real(psb_dpk_)') goto 9999 @@ -240,7 +240,7 @@ Contains end if - if (allocated(rrax)) then + if (allocated(rrax)) then dim = size(rrax,1) lbi1 = lbound(rrax,1) dim2 = size(rrax,2) @@ -269,7 +269,7 @@ Contains goto 9999 end if endif - if (present(pad)) then + if (present(pad)) then !$omp parallel do private(i) shared(lb1_,dim,len1) do i=lb1_-1+dim+1,lb1_-1+len1 rrax(i,:) = pad @@ -293,7 +293,7 @@ Contains Subroutine psb_r_e_d_rk1(len,rrax,info,pad,lb) use psb_error_mod - ! ...Subroutine Arguments + ! ...Subroutine Arguments integer(psb_epk_),Intent(in) :: len real(psb_dpk_), allocatable, intent(inout) :: rrax(:) integer(psb_ipk_) :: info @@ -309,7 +309,7 @@ Contains name='psb_r_m_d_rk1' call psb_erractionsave(err_act) - info=psb_success_ + info=psb_success_ if (debug) write(psb_err_unit,*) 'reallocate D',len if (present(lb)) then @@ -317,7 +317,7 @@ Contains else lb_ = 1 endif - if ((len<0)) then + if ((len<0)) then err=4025 call psb_errpush(err,name, e_err=(/len/), & & a_err='real(psb_dpk_)') @@ -325,7 +325,7 @@ Contains end if ub_ = lb_ + len-1 - if (allocated(rrax)) then + if (allocated(rrax)) then dim = size(rrax) lbi = lbound(rrax,1) If ((dim /= len).or.(lbi /= lb_)) Then @@ -349,7 +349,7 @@ Contains goto 9999 end if endif - if (present(pad)) then + if (present(pad)) then rrax(lb_-1+dim+1:lb_-1+len) = pad endif call psb_erractionrestore(err_act) @@ -364,7 +364,7 @@ Contains Subroutine psb_r_e_d_rk2(len1,len2,rrax,info,pad,lb1,lb2) use psb_error_mod - ! ...Subroutine Arguments + ! ...Subroutine Arguments integer(psb_epk_),Intent(in) :: len1,len2 real(psb_dpk_),allocatable :: rrax(:,:) integer(psb_ipk_) :: info @@ -380,13 +380,13 @@ Contains name='psb_r_e_d_rk2' call psb_erractionsave(err_act) - info=psb_success_ - if (present(lb1)) then + info=psb_success_ + if (present(lb1)) then lb1_ = lb1 else lb1_ = 1 endif - if (present(lb2)) then + if (present(lb2)) then lb2_ = lb2 else lb2_ = 1 @@ -408,7 +408,7 @@ Contains end if - if (allocated(rrax)) then + if (allocated(rrax)) then dim = size(rrax,1) lbi1 = lbound(rrax,1) dim2 = size(rrax,2) @@ -437,7 +437,7 @@ Contains goto 9999 end if endif - if (present(pad)) then + if (present(pad)) then rrax(lb1_-1+dim+1:lb1_-1+len1,:) = pad rrax(lb1_:lb1_-1+dim,lb2_-1+dim2+1:lb2_-1+len2) = pad endif @@ -453,7 +453,7 @@ Contains Subroutine psb_r_me_d_rk2(len1,len2,rrax,info,pad,lb1,lb2) use psb_error_mod - ! ...Subroutine Arguments + ! ...Subroutine Arguments integer(psb_mpk_),Intent(in) :: len1 integer(psb_epk_),Intent(in) :: len2 real(psb_dpk_),allocatable :: rrax(:,:) @@ -471,13 +471,13 @@ Contains name='psb_r_me_d_rk2' call psb_erractionsave(err_act) - info=psb_success_ - if (present(lb1)) then + info=psb_success_ + if (present(lb1)) then lb1_ = lb1 else lb1_ = 1 endif - if (present(lb2)) then + if (present(lb2)) then lb2_ = lb2 else lb2_ = 1 @@ -486,7 +486,7 @@ Contains ub2_ = lb2_ + len2 -1 if (len1 < 0) then - err=4025 + err=4025 call psb_errpush(err,name, m_err=(/len1/), & & a_err='real(psb_dpk_)') goto 9999 @@ -499,7 +499,7 @@ Contains end if - if (allocated(rrax)) then + if (allocated(rrax)) then dim = size(rrax,1) lbi1 = lbound(rrax,1) dim2 = size(rrax,2) @@ -528,7 +528,7 @@ Contains goto 9999 end if endif - if (present(pad)) then + if (present(pad)) then rrax(lb1_-1+dim+1:lb1_-1+len1,:) = pad rrax(lb1_:lb1_-1+dim,lb2_-1+dim2+1:lb2_-1+len2) = pad endif @@ -544,7 +544,7 @@ Contains Subroutine psb_r_em_d_rk2(len1,len2,rrax,info,pad,lb1,lb2) use psb_error_mod - ! ...Subroutine Arguments + ! ...Subroutine Arguments integer(psb_epk_),Intent(in) :: len1 integer(psb_mpk_),Intent(in) :: len2 real(psb_dpk_),allocatable :: rrax(:,:) @@ -562,13 +562,13 @@ Contains name='psb_r_me_d_rk2' call psb_erractionsave(err_act) - info=psb_success_ - if (present(lb1)) then + info=psb_success_ + if (present(lb1)) then lb1_ = lb1 else lb1_ = 1 endif - if (present(lb2)) then + if (present(lb2)) then lb2_ = lb2 else lb2_ = 1 @@ -577,7 +577,7 @@ Contains ub2_ = lb2_ + len2 -1 if (len1 < 0) then - err=4025 + err=4025 call psb_errpush(err,name, e_err=(/len1/), & & a_err='real(psb_dpk_)') goto 9999 @@ -590,7 +590,7 @@ Contains end if - if (allocated(rrax)) then + if (allocated(rrax)) then dim = size(rrax,1) lbi1 = lbound(rrax,1) dim2 = size(rrax,2) @@ -619,7 +619,7 @@ Contains goto 9999 end if endif - if (present(pad)) then + if (present(pad)) then rrax(lb1_-1+dim+1:lb1_-1+len1,:) = pad rrax(lb1_:lb1_-1+dim,lb2_-1+dim2+1:lb2_-1+len2) = pad endif @@ -635,7 +635,7 @@ Contains Subroutine psb_r_m_2_d_rk1(len,rrax,y,info,pad) use psb_error_mod - ! ...Subroutine Arguments + ! ...Subroutine Arguments integer(psb_mpk_),Intent(in) :: len real(psb_dpk_),allocatable, intent(inout) :: rrax(:),y(:) @@ -648,7 +648,7 @@ Contains call psb_erractionsave(err_act) info=psb_success_ - if(psb_errstatus_fatal()) then + if(psb_errstatus_fatal()) then info=psb_err_from_subroutine_ goto 9999 end if @@ -676,7 +676,7 @@ Contains Subroutine psb_r_e_2_d_rk1(len,rrax,y,info,pad) use psb_error_mod - ! ...Subroutine Arguments + ! ...Subroutine Arguments integer(psb_epk_),Intent(in) :: len real(psb_dpk_),allocatable, intent(inout) :: rrax(:),y(:) @@ -689,7 +689,7 @@ Contains call psb_erractionsave(err_act) info=psb_success_ - if(psb_errstatus_fatal()) then + if(psb_errstatus_fatal()) then info=psb_err_from_subroutine_ goto 9999 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 - ! ...Subroutine Arguments + ! ...Subroutine Arguments real(psb_dpk_), allocatable, intent(in) :: vin real(psb_dpk_), allocatable, intent(out) :: vout integer(psb_ipk_) :: info @@ -733,14 +733,14 @@ Contains name='psb_ab_cpy_d_s' call psb_erractionsave(err_act) info=psb_success_ - if(psb_errstatus_fatal()) then + if(psb_errstatus_fatal()) then info=psb_err_from_subroutine_ goto 9999 end if - if (allocated(vin)) then + if (allocated(vin)) then call psb_realloc(vout,info) - if (info /= psb_success_) then + if (info /= psb_success_) then info=psb_err_from_subroutine_ char_err='psb_realloc' call psb_errpush(info,name,a_err=char_err) @@ -759,38 +759,42 @@ Contains 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 - ! ...Subroutine Arguments + ! ...Subroutine Arguments real(psb_dpk_), allocatable, intent(in) :: vin(:) real(psb_dpk_), allocatable, intent(out) :: vout(:) integer(psb_ipk_) :: info ! ...Local Variables - integer(psb_ipk_) :: isz,err_act,lb + integer(psb_ipk_) :: isz,err_act,lb, i character(len=30) :: name, char_err logical, parameter :: debug=.false. name='psb_ab_cpy_d_rk1' call psb_erractionsave(err_act) info=psb_success_ - if(psb_errstatus_fatal()) then + if(psb_errstatus_fatal()) then info=psb_err_from_subroutine_ goto 9999 end if - if (allocated(vin)) then + if (allocated(vin)) then isz = size(vin) lb = lbound(vin,1) call psb_realloc(isz,vout,info,lb=lb) - if (info /= psb_success_) then + if (info /= psb_success_) then info=psb_err_from_subroutine_ char_err='psb_realloc' call psb_errpush(info,name,a_err=char_err) goto 9999 else - vout(:) = vin(:) + !$omp parallel do private(i) + do i=lb,lb+isz-1 + vout(i) = vin(i) + end do + !$omp end parallel do endif endif @@ -803,40 +807,42 @@ Contains 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 - ! ...Subroutine Arguments + ! ...Subroutine Arguments real(psb_dpk_), allocatable, intent(in) :: vin(:,:) real(psb_dpk_), allocatable, intent(out) :: vout(:,:) integer(psb_ipk_) :: info ! ...Local Variables - integer(psb_ipk_) :: isz1, isz2,err_act, lb1, lb2 + integer(psb_ipk_) :: isz1, isz2,err_act, lb1, lb2 character(len=30) :: name, char_err logical, parameter :: debug=.false. name='psb_ab_cpy_d_rk2' call psb_erractionsave(err_act) info=psb_success_ - if(psb_errstatus_fatal()) then + if(psb_errstatus_fatal()) then info=psb_err_from_subroutine_ goto 9999 end if - if (allocated(vin)) then + if (allocated(vin)) then isz1 = size(vin,1) isz2 = size(vin,2) lb1 = lbound(vin,1) lb2 = lbound(vin,2) call psb_realloc(isz1,isz2,vout,info,lb1=lb1,lb2=lb2) - if (info /= psb_success_) then + if (info /= psb_success_) then info=psb_err_from_subroutine_ char_err='psb_realloc' call psb_errpush(info,name,a_err=char_err) goto 9999 else + !$omp workshare vout(:,:) = vin(:,:) + !$omp end workshare endif endif @@ -850,10 +856,10 @@ Contains 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 - ! ...Subroutine Arguments + ! ...Subroutine Arguments real(psb_dpk_), intent(in) :: vin(:) real(psb_dpk_), allocatable, intent(out) :: vout(:) integer(psb_ipk_) :: info @@ -866,14 +872,14 @@ Contains name='psb_cpy_d_rk1' call psb_erractionsave(err_act) info=psb_success_ - if(psb_errstatus_fatal()) then + if(psb_errstatus_fatal()) then info=psb_err_from_subroutine_ goto 9999 end if isz = size(vin) lb = lbound(vin,1) call psb_realloc(isz,vout,info,lb=lb) - if (info /= psb_success_) then + if (info /= psb_success_) then info=psb_err_from_subroutine_ char_err='psb_realloc' call psb_errpush(info,name,a_err=char_err) @@ -891,23 +897,23 @@ Contains 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 - ! ...Subroutine Arguments + ! ...Subroutine Arguments real(psb_dpk_), intent(in) :: vin(:,:) real(psb_dpk_), allocatable, intent(out) :: vout(:,:) integer(psb_ipk_) :: info ! ...Local Variables - integer(psb_ipk_) :: isz1, isz2,err_act, lb1, lb2 + integer(psb_ipk_) :: isz1, isz2,err_act, lb1, lb2 character(len=30) :: name, char_err logical, parameter :: debug=.false. name='psb_safe_cpy' call psb_erractionsave(err_act) info=psb_success_ - if(psb_errstatus_fatal()) then + if(psb_errstatus_fatal()) then info=psb_err_from_subroutine_ goto 9999 end if @@ -917,7 +923,7 @@ Contains lb1 = lbound(vin,1) lb2 = lbound(vin,2) 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_ char_err='psb_realloc' call psb_errpush(info,name,a_err=char_err) @@ -940,7 +946,7 @@ Contains integer(psb_epk_) :: val real(psb_dpk_), allocatable, intent(in) :: vin(:) - if (.not.allocated(vin)) then + if (.not.allocated(vin)) then val = 0 else val = size(vin) @@ -955,10 +961,10 @@ Contains integer(psb_ipk_) :: dim_ - if (.not.allocated(vin)) then + if (.not.allocated(vin)) then val = 0 else - if (present(dim)) then + if (present(dim)) then dim_= dim val = size(vin,dim=dim_) else @@ -970,7 +976,7 @@ Contains Subroutine psb_ensure_m_sz_d_rk1(len,v,info,pad,addsz,newsz) use psb_error_mod - ! ...Subroutine Arguments + ! ...Subroutine Arguments integer(psb_mpk_),Intent(in) :: len real(psb_dpk_),allocatable, intent(inout) :: v(:) integer(psb_ipk_) :: info @@ -986,29 +992,11 @@ Contains call psb_erractionsave(err_act) info = psb_success_ - if (psb_errstatus_fatal()) then + if (psb_errstatus_fatal()) then info=psb_err_from_subroutine_ goto 9999 end if -!!$ If (len > psb_size(v)) Then -!!$ if (present(newsz)) then -!!$ isz = (max(len+1,newsz)) -!!$ else -!!$ if (present(addsz)) then -!!$ isz = len+max(1,addsz) -!!$ else -!!$ isz = max(len+10, int(1.25*len)) -!!$ endif -!!$ endif -!!$ -!!$ call psb_realloc(isz,v,info,pad=pad) -!!$ if (info /= psb_success_) then -!!$ info=psb_err_from_subroutine_ -!!$ call psb_errpush(info,name,a_err='psb_realloc') -!!$ goto 9999 -!!$ End If -!!$ end If isz = psb_size(v) If (len > isz) Then #if defined(OPENMP) @@ -1017,7 +1005,7 @@ Contains if (present(newsz)) then isz = max(len+1,1,newsz) else if (present(addsz)) then - isz = max(len,1,isz+addsz)) + isz = max(len,1,isz+addsz) else isz = max(len,1,int(1.25*isz)) endif @@ -1065,7 +1053,7 @@ Contains Subroutine psb_ensure_e_sz_d_rk1(len,v,info,pad,addsz,newsz) use psb_error_mod - ! ...Subroutine Arguments + ! ...Subroutine Arguments integer(psb_epk_),Intent(in) :: len real(psb_dpk_),allocatable, intent(inout) :: v(:) integer(psb_ipk_) :: info @@ -1081,7 +1069,7 @@ Contains call psb_erractionsave(err_act) info = psb_success_ - if (psb_errstatus_fatal()) then + if (psb_errstatus_fatal()) then info=psb_err_from_subroutine_ goto 9999 end if @@ -1116,9 +1104,9 @@ Contains Subroutine psb_move_alloc_d_rk1(vin,vout,info) use psb_error_mod real(psb_dpk_), allocatable, intent(inout) :: vin(:),vout(:) - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info + ! ! - ! info=psb_success_ call move_alloc(vin,vout) @@ -1127,9 +1115,9 @@ Contains Subroutine psb_move_alloc_d_rk2(vin,vout,info) use psb_error_mod real(psb_dpk_), allocatable, intent(inout) :: vin(:,:),vout(:,:) - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info + ! ! - ! info=psb_success_ call move_alloc(vin,vout) diff --git a/base/modules/auxil/psb_e_realloc_mod.F90 b/base/modules/auxil/psb_e_realloc_mod.F90 index 0cf321f4..eb765225 100644 --- a/base/modules/auxil/psb_e_realloc_mod.F90 +++ b/base/modules/auxil/psb_e_realloc_mod.F90 @@ -1,9 +1,9 @@ -! +! ! Parallel Sparse BLAS version 3.5 ! (C) Copyright 2006-2018 -! Salvatore Filippone -! Alfredo Buttari -! +! Salvatore Filippone +! Alfredo Buttari +! ! Redistribution and use in source and binary forms, with or without ! modification, are permitted provided that the following conditions ! are met: @@ -15,7 +15,7 @@ ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this ! software without specific written permission. -! +! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED ! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR @@ -27,16 +27,16 @@ ! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE ! POSSIBILITY OF SUCH DAMAGE. -! -! +! +! module psb_e_realloc_mod use psb_const_mod implicit none ! - ! psb_realloc will reallocate the input array to have exactly - ! the size specified, possibly shortening it. + ! psb_realloc will reallocate the input array to have exactly + ! the size specified, possibly shortening it. ! Interface psb_realloc 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_e_2_e_rk1 - + end Interface psb_realloc interface psb_move_alloc @@ -66,7 +66,7 @@ module psb_e_realloc_mod ! ! 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. ! interface psb_ensure_size @@ -74,7 +74,7 @@ module psb_e_realloc_mod 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 module procedure psb_size_e_rk1, psb_size_e_rk2 @@ -86,7 +86,7 @@ Contains Subroutine psb_r_e_s(rrax,info) use psb_error_mod - ! ...Subroutine Arguments + ! ...Subroutine Arguments integer(psb_epk_), allocatable, intent(inout) :: rrax integer(psb_ipk_) :: info @@ -97,9 +97,9 @@ Contains name='psb_r_e_s' 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) if (info /= psb_success_) then err=4025 @@ -122,7 +122,7 @@ Contains Subroutine psb_r_m_e_rk1(len,rrax,info,pad,lb) use psb_error_mod - ! ...Subroutine Arguments + ! ...Subroutine Arguments integer(psb_mpk_),Intent(in) :: len integer(psb_epk_), allocatable, intent(inout) :: rrax(:) integer(psb_ipk_) :: info @@ -138,7 +138,7 @@ Contains name='psb_r_m_e_rk1' call psb_erractionsave(err_act) - info=psb_success_ + info=psb_success_ if (debug) write(psb_err_unit,*) 'reallocate D',len if (present(lb)) then @@ -146,7 +146,7 @@ Contains else lb_ = 1 endif - if ((len<0)) then + if ((len<0)) then err=4025 call psb_errpush(err,name, l_err=(/len*1_psb_lpk_/), & & a_err='integer(psb_epk_)') @@ -154,7 +154,7 @@ Contains end if ub_ = lb_ + len-1 - if (allocated(rrax)) then + if (allocated(rrax)) then dim = size(rrax) lbi = lbound(rrax,1) If ((dim /= len).or.(lbi /= lb_)) Then @@ -178,7 +178,7 @@ Contains goto 9999 end if endif - if (present(pad)) then + if (present(pad)) then !$omp parallel do private(i) shared(dim,len) do i=lb_-1+dim+1,lb_-1+len rrax(i) = pad @@ -196,7 +196,7 @@ Contains Subroutine psb_r_m_e_rk2(len1,len2,rrax,info,pad,lb1,lb2) use psb_error_mod - ! ...Subroutine Arguments + ! ...Subroutine Arguments integer(psb_mpk_),Intent(in) :: len1,len2 integer(psb_epk_),allocatable :: rrax(:,:) integer(psb_ipk_) :: info @@ -212,13 +212,13 @@ Contains name='psb_r_m_e_rk2' call psb_erractionsave(err_act) - info=psb_success_ - if (present(lb1)) then + info=psb_success_ + if (present(lb1)) then lb1_ = lb1 else lb1_ = 1 endif - if (present(lb2)) then + if (present(lb2)) then lb2_ = lb2 else lb2_ = 1 @@ -227,7 +227,7 @@ Contains ub2_ = lb2_ + len2 -1 if (len1 < 0) then - err=4025 + err=4025 call psb_errpush(err,name, l_err=(/len1*1_psb_lpk_/), & & a_err='integer(psb_epk_)') goto 9999 @@ -240,7 +240,7 @@ Contains end if - if (allocated(rrax)) then + if (allocated(rrax)) then dim = size(rrax,1) lbi1 = lbound(rrax,1) dim2 = size(rrax,2) @@ -269,7 +269,7 @@ Contains goto 9999 end if endif - if (present(pad)) then + if (present(pad)) then !$omp parallel do private(i) shared(lb1_,dim,len1) do i=lb1_-1+dim+1,lb1_-1+len1 rrax(i,:) = pad @@ -293,7 +293,7 @@ Contains Subroutine psb_r_e_e_rk1(len,rrax,info,pad,lb) use psb_error_mod - ! ...Subroutine Arguments + ! ...Subroutine Arguments integer(psb_epk_),Intent(in) :: len integer(psb_epk_), allocatable, intent(inout) :: rrax(:) integer(psb_ipk_) :: info @@ -309,7 +309,7 @@ Contains name='psb_r_m_e_rk1' call psb_erractionsave(err_act) - info=psb_success_ + info=psb_success_ if (debug) write(psb_err_unit,*) 'reallocate D',len if (present(lb)) then @@ -317,7 +317,7 @@ Contains else lb_ = 1 endif - if ((len<0)) then + if ((len<0)) then err=4025 call psb_errpush(err,name, e_err=(/len/), & & a_err='integer(psb_epk_)') @@ -325,7 +325,7 @@ Contains end if ub_ = lb_ + len-1 - if (allocated(rrax)) then + if (allocated(rrax)) then dim = size(rrax) lbi = lbound(rrax,1) If ((dim /= len).or.(lbi /= lb_)) Then @@ -349,7 +349,7 @@ Contains goto 9999 end if endif - if (present(pad)) then + if (present(pad)) then rrax(lb_-1+dim+1:lb_-1+len) = pad endif call psb_erractionrestore(err_act) @@ -364,7 +364,7 @@ Contains Subroutine psb_r_e_e_rk2(len1,len2,rrax,info,pad,lb1,lb2) use psb_error_mod - ! ...Subroutine Arguments + ! ...Subroutine Arguments integer(psb_epk_),Intent(in) :: len1,len2 integer(psb_epk_),allocatable :: rrax(:,:) integer(psb_ipk_) :: info @@ -380,13 +380,13 @@ Contains name='psb_r_e_e_rk2' call psb_erractionsave(err_act) - info=psb_success_ - if (present(lb1)) then + info=psb_success_ + if (present(lb1)) then lb1_ = lb1 else lb1_ = 1 endif - if (present(lb2)) then + if (present(lb2)) then lb2_ = lb2 else lb2_ = 1 @@ -408,7 +408,7 @@ Contains end if - if (allocated(rrax)) then + if (allocated(rrax)) then dim = size(rrax,1) lbi1 = lbound(rrax,1) dim2 = size(rrax,2) @@ -437,7 +437,7 @@ Contains goto 9999 end if endif - if (present(pad)) then + if (present(pad)) then rrax(lb1_-1+dim+1:lb1_-1+len1,:) = pad rrax(lb1_:lb1_-1+dim,lb2_-1+dim2+1:lb2_-1+len2) = pad endif @@ -453,7 +453,7 @@ Contains Subroutine psb_r_me_e_rk2(len1,len2,rrax,info,pad,lb1,lb2) use psb_error_mod - ! ...Subroutine Arguments + ! ...Subroutine Arguments integer(psb_mpk_),Intent(in) :: len1 integer(psb_epk_),Intent(in) :: len2 integer(psb_epk_),allocatable :: rrax(:,:) @@ -471,13 +471,13 @@ Contains name='psb_r_me_e_rk2' call psb_erractionsave(err_act) - info=psb_success_ - if (present(lb1)) then + info=psb_success_ + if (present(lb1)) then lb1_ = lb1 else lb1_ = 1 endif - if (present(lb2)) then + if (present(lb2)) then lb2_ = lb2 else lb2_ = 1 @@ -486,7 +486,7 @@ Contains ub2_ = lb2_ + len2 -1 if (len1 < 0) then - err=4025 + err=4025 call psb_errpush(err,name, m_err=(/len1/), & & a_err='integer(psb_epk_)') goto 9999 @@ -499,7 +499,7 @@ Contains end if - if (allocated(rrax)) then + if (allocated(rrax)) then dim = size(rrax,1) lbi1 = lbound(rrax,1) dim2 = size(rrax,2) @@ -528,7 +528,7 @@ Contains goto 9999 end if endif - if (present(pad)) then + if (present(pad)) then rrax(lb1_-1+dim+1:lb1_-1+len1,:) = pad rrax(lb1_:lb1_-1+dim,lb2_-1+dim2+1:lb2_-1+len2) = pad endif @@ -544,7 +544,7 @@ Contains Subroutine psb_r_em_e_rk2(len1,len2,rrax,info,pad,lb1,lb2) use psb_error_mod - ! ...Subroutine Arguments + ! ...Subroutine Arguments integer(psb_epk_),Intent(in) :: len1 integer(psb_mpk_),Intent(in) :: len2 integer(psb_epk_),allocatable :: rrax(:,:) @@ -562,13 +562,13 @@ Contains name='psb_r_me_e_rk2' call psb_erractionsave(err_act) - info=psb_success_ - if (present(lb1)) then + info=psb_success_ + if (present(lb1)) then lb1_ = lb1 else lb1_ = 1 endif - if (present(lb2)) then + if (present(lb2)) then lb2_ = lb2 else lb2_ = 1 @@ -577,7 +577,7 @@ Contains ub2_ = lb2_ + len2 -1 if (len1 < 0) then - err=4025 + err=4025 call psb_errpush(err,name, e_err=(/len1/), & & a_err='integer(psb_epk_)') goto 9999 @@ -590,7 +590,7 @@ Contains end if - if (allocated(rrax)) then + if (allocated(rrax)) then dim = size(rrax,1) lbi1 = lbound(rrax,1) dim2 = size(rrax,2) @@ -619,7 +619,7 @@ Contains goto 9999 end if endif - if (present(pad)) then + if (present(pad)) then rrax(lb1_-1+dim+1:lb1_-1+len1,:) = pad rrax(lb1_:lb1_-1+dim,lb2_-1+dim2+1:lb2_-1+len2) = pad endif @@ -635,7 +635,7 @@ Contains Subroutine psb_r_m_2_e_rk1(len,rrax,y,info,pad) use psb_error_mod - ! ...Subroutine Arguments + ! ...Subroutine Arguments integer(psb_mpk_),Intent(in) :: len integer(psb_epk_),allocatable, intent(inout) :: rrax(:),y(:) @@ -648,7 +648,7 @@ Contains call psb_erractionsave(err_act) info=psb_success_ - if(psb_errstatus_fatal()) then + if(psb_errstatus_fatal()) then info=psb_err_from_subroutine_ goto 9999 end if @@ -676,7 +676,7 @@ Contains Subroutine psb_r_e_2_e_rk1(len,rrax,y,info,pad) use psb_error_mod - ! ...Subroutine Arguments + ! ...Subroutine Arguments integer(psb_epk_),Intent(in) :: len integer(psb_epk_),allocatable, intent(inout) :: rrax(:),y(:) @@ -689,7 +689,7 @@ Contains call psb_erractionsave(err_act) info=psb_success_ - if(psb_errstatus_fatal()) then + if(psb_errstatus_fatal()) then info=psb_err_from_subroutine_ goto 9999 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 - ! ...Subroutine Arguments + ! ...Subroutine Arguments integer(psb_epk_), allocatable, intent(in) :: vin integer(psb_epk_), allocatable, intent(out) :: vout integer(psb_ipk_) :: info @@ -733,14 +733,14 @@ Contains name='psb_ab_cpy_e_s' call psb_erractionsave(err_act) info=psb_success_ - if(psb_errstatus_fatal()) then + if(psb_errstatus_fatal()) then info=psb_err_from_subroutine_ goto 9999 end if - if (allocated(vin)) then + if (allocated(vin)) then call psb_realloc(vout,info) - if (info /= psb_success_) then + if (info /= psb_success_) then info=psb_err_from_subroutine_ char_err='psb_realloc' call psb_errpush(info,name,a_err=char_err) @@ -759,38 +759,42 @@ Contains 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 - ! ...Subroutine Arguments + ! ...Subroutine Arguments integer(psb_epk_), allocatable, intent(in) :: vin(:) integer(psb_epk_), allocatable, intent(out) :: vout(:) integer(psb_ipk_) :: info ! ...Local Variables - integer(psb_ipk_) :: isz,err_act,lb + integer(psb_ipk_) :: isz,err_act,lb, i character(len=30) :: name, char_err logical, parameter :: debug=.false. name='psb_ab_cpy_e_rk1' call psb_erractionsave(err_act) info=psb_success_ - if(psb_errstatus_fatal()) then + if(psb_errstatus_fatal()) then info=psb_err_from_subroutine_ goto 9999 end if - if (allocated(vin)) then + if (allocated(vin)) then isz = size(vin) lb = lbound(vin,1) call psb_realloc(isz,vout,info,lb=lb) - if (info /= psb_success_) then + if (info /= psb_success_) then info=psb_err_from_subroutine_ char_err='psb_realloc' call psb_errpush(info,name,a_err=char_err) goto 9999 else - vout(:) = vin(:) + !$omp parallel do private(i) + do i=lb,lb+isz-1 + vout(i) = vin(i) + end do + !$omp end parallel do endif endif @@ -803,40 +807,42 @@ Contains 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 - ! ...Subroutine Arguments + ! ...Subroutine Arguments integer(psb_epk_), allocatable, intent(in) :: vin(:,:) integer(psb_epk_), allocatable, intent(out) :: vout(:,:) integer(psb_ipk_) :: info ! ...Local Variables - integer(psb_ipk_) :: isz1, isz2,err_act, lb1, lb2 + integer(psb_ipk_) :: isz1, isz2,err_act, lb1, lb2 character(len=30) :: name, char_err logical, parameter :: debug=.false. name='psb_ab_cpy_e_rk2' call psb_erractionsave(err_act) info=psb_success_ - if(psb_errstatus_fatal()) then + if(psb_errstatus_fatal()) then info=psb_err_from_subroutine_ goto 9999 end if - if (allocated(vin)) then + if (allocated(vin)) then isz1 = size(vin,1) isz2 = size(vin,2) lb1 = lbound(vin,1) lb2 = lbound(vin,2) call psb_realloc(isz1,isz2,vout,info,lb1=lb1,lb2=lb2) - if (info /= psb_success_) then + if (info /= psb_success_) then info=psb_err_from_subroutine_ char_err='psb_realloc' call psb_errpush(info,name,a_err=char_err) goto 9999 else + !$omp workshare vout(:,:) = vin(:,:) + !$omp end workshare endif endif @@ -850,10 +856,10 @@ Contains 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 - ! ...Subroutine Arguments + ! ...Subroutine Arguments integer(psb_epk_), intent(in) :: vin(:) integer(psb_epk_), allocatable, intent(out) :: vout(:) integer(psb_ipk_) :: info @@ -866,14 +872,14 @@ Contains name='psb_cpy_e_rk1' call psb_erractionsave(err_act) info=psb_success_ - if(psb_errstatus_fatal()) then + if(psb_errstatus_fatal()) then info=psb_err_from_subroutine_ goto 9999 end if isz = size(vin) lb = lbound(vin,1) call psb_realloc(isz,vout,info,lb=lb) - if (info /= psb_success_) then + if (info /= psb_success_) then info=psb_err_from_subroutine_ char_err='psb_realloc' call psb_errpush(info,name,a_err=char_err) @@ -891,23 +897,23 @@ Contains 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 - ! ...Subroutine Arguments + ! ...Subroutine Arguments integer(psb_epk_), intent(in) :: vin(:,:) integer(psb_epk_), allocatable, intent(out) :: vout(:,:) integer(psb_ipk_) :: info ! ...Local Variables - integer(psb_ipk_) :: isz1, isz2,err_act, lb1, lb2 + integer(psb_ipk_) :: isz1, isz2,err_act, lb1, lb2 character(len=30) :: name, char_err logical, parameter :: debug=.false. name='psb_safe_cpy' call psb_erractionsave(err_act) info=psb_success_ - if(psb_errstatus_fatal()) then + if(psb_errstatus_fatal()) then info=psb_err_from_subroutine_ goto 9999 end if @@ -917,7 +923,7 @@ Contains lb1 = lbound(vin,1) lb2 = lbound(vin,2) 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_ char_err='psb_realloc' call psb_errpush(info,name,a_err=char_err) @@ -940,7 +946,7 @@ Contains integer(psb_epk_) :: val integer(psb_epk_), allocatable, intent(in) :: vin(:) - if (.not.allocated(vin)) then + if (.not.allocated(vin)) then val = 0 else val = size(vin) @@ -955,10 +961,10 @@ Contains integer(psb_ipk_) :: dim_ - if (.not.allocated(vin)) then + if (.not.allocated(vin)) then val = 0 else - if (present(dim)) then + if (present(dim)) then dim_= dim val = size(vin,dim=dim_) else @@ -970,7 +976,7 @@ Contains Subroutine psb_ensure_m_sz_e_rk1(len,v,info,pad,addsz,newsz) use psb_error_mod - ! ...Subroutine Arguments + ! ...Subroutine Arguments integer(psb_mpk_),Intent(in) :: len integer(psb_epk_),allocatable, intent(inout) :: v(:) integer(psb_ipk_) :: info @@ -986,29 +992,11 @@ Contains call psb_erractionsave(err_act) info = psb_success_ - if (psb_errstatus_fatal()) then + if (psb_errstatus_fatal()) then info=psb_err_from_subroutine_ goto 9999 end if -!!$ If (len > psb_size(v)) Then -!!$ if (present(newsz)) then -!!$ isz = (max(len+1,newsz)) -!!$ else -!!$ if (present(addsz)) then -!!$ isz = len+max(1,addsz) -!!$ else -!!$ isz = max(len+10, int(1.25*len)) -!!$ endif -!!$ endif -!!$ -!!$ call psb_realloc(isz,v,info,pad=pad) -!!$ if (info /= psb_success_) then -!!$ info=psb_err_from_subroutine_ -!!$ call psb_errpush(info,name,a_err='psb_realloc') -!!$ goto 9999 -!!$ End If -!!$ end If isz = psb_size(v) If (len > isz) Then #if defined(OPENMP) @@ -1017,7 +1005,7 @@ Contains if (present(newsz)) then isz = max(len+1,1,newsz) else if (present(addsz)) then - isz = max(len,1,isz+addsz)) + isz = max(len,1,isz+addsz) else isz = max(len,1,int(1.25*isz)) endif @@ -1065,7 +1053,7 @@ Contains Subroutine psb_ensure_e_sz_e_rk1(len,v,info,pad,addsz,newsz) use psb_error_mod - ! ...Subroutine Arguments + ! ...Subroutine Arguments integer(psb_epk_),Intent(in) :: len integer(psb_epk_),allocatable, intent(inout) :: v(:) integer(psb_ipk_) :: info @@ -1081,7 +1069,7 @@ Contains call psb_erractionsave(err_act) info = psb_success_ - if (psb_errstatus_fatal()) then + if (psb_errstatus_fatal()) then info=psb_err_from_subroutine_ goto 9999 end if @@ -1116,9 +1104,9 @@ Contains Subroutine psb_move_alloc_e_rk1(vin,vout,info) use psb_error_mod integer(psb_epk_), allocatable, intent(inout) :: vin(:),vout(:) - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info + ! ! - ! info=psb_success_ call move_alloc(vin,vout) @@ -1127,9 +1115,9 @@ Contains Subroutine psb_move_alloc_e_rk2(vin,vout,info) use psb_error_mod integer(psb_epk_), allocatable, intent(inout) :: vin(:,:),vout(:,:) - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info + ! ! - ! info=psb_success_ call move_alloc(vin,vout) diff --git a/base/modules/auxil/psb_i2_realloc_mod.F90 b/base/modules/auxil/psb_i2_realloc_mod.F90 index cebd8695..4cc892a1 100644 --- a/base/modules/auxil/psb_i2_realloc_mod.F90 +++ b/base/modules/auxil/psb_i2_realloc_mod.F90 @@ -1,9 +1,9 @@ -! +! ! Parallel Sparse BLAS version 3.5 ! (C) Copyright 2006-2018 -! Salvatore Filippone -! Alfredo Buttari -! +! Salvatore Filippone +! Alfredo Buttari +! ! Redistribution and use in source and binary forms, with or without ! modification, are permitted provided that the following conditions ! are met: @@ -15,7 +15,7 @@ ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this ! software without specific written permission. -! +! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED ! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR @@ -27,16 +27,16 @@ ! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE ! POSSIBILITY OF SUCH DAMAGE. -! -! +! +! module psb_i2_realloc_mod use psb_const_mod implicit none ! - ! psb_realloc will reallocate the input array to have exactly - ! the size specified, possibly shortening it. + ! psb_realloc will reallocate the input array to have exactly + ! the size specified, possibly shortening it. ! Interface psb_realloc 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_e_2_i2_rk1 - + end Interface psb_realloc interface psb_move_alloc @@ -66,7 +66,7 @@ module psb_i2_realloc_mod ! ! 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. ! interface psb_ensure_size @@ -74,7 +74,7 @@ module psb_i2_realloc_mod 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 module procedure psb_size_i2_rk1, psb_size_i2_rk2 @@ -86,7 +86,7 @@ Contains Subroutine psb_r_i2_s(rrax,info) use psb_error_mod - ! ...Subroutine Arguments + ! ...Subroutine Arguments integer(psb_i2pk_), allocatable, intent(inout) :: rrax integer(psb_ipk_) :: info @@ -97,9 +97,9 @@ Contains name='psb_r_i2_s' 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) if (info /= psb_success_) then err=4025 @@ -122,7 +122,7 @@ Contains Subroutine psb_r_m_i2_rk1(len,rrax,info,pad,lb) use psb_error_mod - ! ...Subroutine Arguments + ! ...Subroutine Arguments integer(psb_mpk_),Intent(in) :: len integer(psb_i2pk_), allocatable, intent(inout) :: rrax(:) integer(psb_ipk_) :: info @@ -138,7 +138,7 @@ Contains name='psb_r_m_i2_rk1' call psb_erractionsave(err_act) - info=psb_success_ + info=psb_success_ if (debug) write(psb_err_unit,*) 'reallocate D',len if (present(lb)) then @@ -146,7 +146,7 @@ Contains else lb_ = 1 endif - if ((len<0)) then + if ((len<0)) then err=4025 call psb_errpush(err,name, l_err=(/len*1_psb_lpk_/), & & a_err='integer(psb_i2pk_)') @@ -154,7 +154,7 @@ Contains end if ub_ = lb_ + len-1 - if (allocated(rrax)) then + if (allocated(rrax)) then dim = size(rrax) lbi = lbound(rrax,1) If ((dim /= len).or.(lbi /= lb_)) Then @@ -178,7 +178,7 @@ Contains goto 9999 end if endif - if (present(pad)) then + if (present(pad)) then !$omp parallel do private(i) shared(dim,len) do i=lb_-1+dim+1,lb_-1+len rrax(i) = pad @@ -196,7 +196,7 @@ Contains Subroutine psb_r_m_i2_rk2(len1,len2,rrax,info,pad,lb1,lb2) use psb_error_mod - ! ...Subroutine Arguments + ! ...Subroutine Arguments integer(psb_mpk_),Intent(in) :: len1,len2 integer(psb_i2pk_),allocatable :: rrax(:,:) integer(psb_ipk_) :: info @@ -212,13 +212,13 @@ Contains name='psb_r_m_i2_rk2' call psb_erractionsave(err_act) - info=psb_success_ - if (present(lb1)) then + info=psb_success_ + if (present(lb1)) then lb1_ = lb1 else lb1_ = 1 endif - if (present(lb2)) then + if (present(lb2)) then lb2_ = lb2 else lb2_ = 1 @@ -227,7 +227,7 @@ Contains ub2_ = lb2_ + len2 -1 if (len1 < 0) then - err=4025 + err=4025 call psb_errpush(err,name, l_err=(/len1*1_psb_lpk_/), & & a_err='integer(psb_i2pk_)') goto 9999 @@ -240,7 +240,7 @@ Contains end if - if (allocated(rrax)) then + if (allocated(rrax)) then dim = size(rrax,1) lbi1 = lbound(rrax,1) dim2 = size(rrax,2) @@ -269,7 +269,7 @@ Contains goto 9999 end if endif - if (present(pad)) then + if (present(pad)) then !$omp parallel do private(i) shared(lb1_,dim,len1) do i=lb1_-1+dim+1,lb1_-1+len1 rrax(i,:) = pad @@ -293,7 +293,7 @@ Contains Subroutine psb_r_e_i2_rk1(len,rrax,info,pad,lb) use psb_error_mod - ! ...Subroutine Arguments + ! ...Subroutine Arguments integer(psb_epk_),Intent(in) :: len integer(psb_i2pk_), allocatable, intent(inout) :: rrax(:) integer(psb_ipk_) :: info @@ -309,7 +309,7 @@ Contains name='psb_r_m_i2_rk1' call psb_erractionsave(err_act) - info=psb_success_ + info=psb_success_ if (debug) write(psb_err_unit,*) 'reallocate D',len if (present(lb)) then @@ -317,7 +317,7 @@ Contains else lb_ = 1 endif - if ((len<0)) then + if ((len<0)) then err=4025 call psb_errpush(err,name, e_err=(/len/), & & a_err='integer(psb_i2pk_)') @@ -325,7 +325,7 @@ Contains end if ub_ = lb_ + len-1 - if (allocated(rrax)) then + if (allocated(rrax)) then dim = size(rrax) lbi = lbound(rrax,1) If ((dim /= len).or.(lbi /= lb_)) Then @@ -349,7 +349,7 @@ Contains goto 9999 end if endif - if (present(pad)) then + if (present(pad)) then rrax(lb_-1+dim+1:lb_-1+len) = pad endif call psb_erractionrestore(err_act) @@ -364,7 +364,7 @@ Contains Subroutine psb_r_e_i2_rk2(len1,len2,rrax,info,pad,lb1,lb2) use psb_error_mod - ! ...Subroutine Arguments + ! ...Subroutine Arguments integer(psb_epk_),Intent(in) :: len1,len2 integer(psb_i2pk_),allocatable :: rrax(:,:) integer(psb_ipk_) :: info @@ -380,13 +380,13 @@ Contains name='psb_r_e_i2_rk2' call psb_erractionsave(err_act) - info=psb_success_ - if (present(lb1)) then + info=psb_success_ + if (present(lb1)) then lb1_ = lb1 else lb1_ = 1 endif - if (present(lb2)) then + if (present(lb2)) then lb2_ = lb2 else lb2_ = 1 @@ -408,7 +408,7 @@ Contains end if - if (allocated(rrax)) then + if (allocated(rrax)) then dim = size(rrax,1) lbi1 = lbound(rrax,1) dim2 = size(rrax,2) @@ -437,7 +437,7 @@ Contains goto 9999 end if endif - if (present(pad)) then + if (present(pad)) then rrax(lb1_-1+dim+1:lb1_-1+len1,:) = pad rrax(lb1_:lb1_-1+dim,lb2_-1+dim2+1:lb2_-1+len2) = pad endif @@ -453,7 +453,7 @@ Contains Subroutine psb_r_me_i2_rk2(len1,len2,rrax,info,pad,lb1,lb2) use psb_error_mod - ! ...Subroutine Arguments + ! ...Subroutine Arguments integer(psb_mpk_),Intent(in) :: len1 integer(psb_epk_),Intent(in) :: len2 integer(psb_i2pk_),allocatable :: rrax(:,:) @@ -471,13 +471,13 @@ Contains name='psb_r_me_i2_rk2' call psb_erractionsave(err_act) - info=psb_success_ - if (present(lb1)) then + info=psb_success_ + if (present(lb1)) then lb1_ = lb1 else lb1_ = 1 endif - if (present(lb2)) then + if (present(lb2)) then lb2_ = lb2 else lb2_ = 1 @@ -486,7 +486,7 @@ Contains ub2_ = lb2_ + len2 -1 if (len1 < 0) then - err=4025 + err=4025 call psb_errpush(err,name, m_err=(/len1/), & & a_err='integer(psb_i2pk_)') goto 9999 @@ -499,7 +499,7 @@ Contains end if - if (allocated(rrax)) then + if (allocated(rrax)) then dim = size(rrax,1) lbi1 = lbound(rrax,1) dim2 = size(rrax,2) @@ -528,7 +528,7 @@ Contains goto 9999 end if endif - if (present(pad)) then + if (present(pad)) then rrax(lb1_-1+dim+1:lb1_-1+len1,:) = pad rrax(lb1_:lb1_-1+dim,lb2_-1+dim2+1:lb2_-1+len2) = pad endif @@ -544,7 +544,7 @@ Contains Subroutine psb_r_em_i2_rk2(len1,len2,rrax,info,pad,lb1,lb2) use psb_error_mod - ! ...Subroutine Arguments + ! ...Subroutine Arguments integer(psb_epk_),Intent(in) :: len1 integer(psb_mpk_),Intent(in) :: len2 integer(psb_i2pk_),allocatable :: rrax(:,:) @@ -562,13 +562,13 @@ Contains name='psb_r_me_i2_rk2' call psb_erractionsave(err_act) - info=psb_success_ - if (present(lb1)) then + info=psb_success_ + if (present(lb1)) then lb1_ = lb1 else lb1_ = 1 endif - if (present(lb2)) then + if (present(lb2)) then lb2_ = lb2 else lb2_ = 1 @@ -577,7 +577,7 @@ Contains ub2_ = lb2_ + len2 -1 if (len1 < 0) then - err=4025 + err=4025 call psb_errpush(err,name, e_err=(/len1/), & & a_err='integer(psb_i2pk_)') goto 9999 @@ -590,7 +590,7 @@ Contains end if - if (allocated(rrax)) then + if (allocated(rrax)) then dim = size(rrax,1) lbi1 = lbound(rrax,1) dim2 = size(rrax,2) @@ -619,7 +619,7 @@ Contains goto 9999 end if endif - if (present(pad)) then + if (present(pad)) then rrax(lb1_-1+dim+1:lb1_-1+len1,:) = pad rrax(lb1_:lb1_-1+dim,lb2_-1+dim2+1:lb2_-1+len2) = pad endif @@ -635,7 +635,7 @@ Contains Subroutine psb_r_m_2_i2_rk1(len,rrax,y,info,pad) use psb_error_mod - ! ...Subroutine Arguments + ! ...Subroutine Arguments integer(psb_mpk_),Intent(in) :: len integer(psb_i2pk_),allocatable, intent(inout) :: rrax(:),y(:) @@ -648,7 +648,7 @@ Contains call psb_erractionsave(err_act) info=psb_success_ - if(psb_errstatus_fatal()) then + if(psb_errstatus_fatal()) then info=psb_err_from_subroutine_ goto 9999 end if @@ -676,7 +676,7 @@ Contains Subroutine psb_r_e_2_i2_rk1(len,rrax,y,info,pad) use psb_error_mod - ! ...Subroutine Arguments + ! ...Subroutine Arguments integer(psb_epk_),Intent(in) :: len integer(psb_i2pk_),allocatable, intent(inout) :: rrax(:),y(:) @@ -689,7 +689,7 @@ Contains call psb_erractionsave(err_act) info=psb_success_ - if(psb_errstatus_fatal()) then + if(psb_errstatus_fatal()) then info=psb_err_from_subroutine_ goto 9999 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 - ! ...Subroutine Arguments + ! ...Subroutine Arguments integer(psb_i2pk_), allocatable, intent(in) :: vin integer(psb_i2pk_), allocatable, intent(out) :: vout integer(psb_ipk_) :: info @@ -733,14 +733,14 @@ Contains name='psb_ab_cpy_i2_s' call psb_erractionsave(err_act) info=psb_success_ - if(psb_errstatus_fatal()) then + if(psb_errstatus_fatal()) then info=psb_err_from_subroutine_ goto 9999 end if - if (allocated(vin)) then + if (allocated(vin)) then call psb_realloc(vout,info) - if (info /= psb_success_) then + if (info /= psb_success_) then info=psb_err_from_subroutine_ char_err='psb_realloc' call psb_errpush(info,name,a_err=char_err) @@ -759,38 +759,42 @@ Contains 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 - ! ...Subroutine Arguments + ! ...Subroutine Arguments integer(psb_i2pk_), allocatable, intent(in) :: vin(:) integer(psb_i2pk_), allocatable, intent(out) :: vout(:) integer(psb_ipk_) :: info ! ...Local Variables - integer(psb_ipk_) :: isz,err_act,lb + integer(psb_ipk_) :: isz,err_act,lb, i character(len=30) :: name, char_err logical, parameter :: debug=.false. name='psb_ab_cpy_i2_rk1' call psb_erractionsave(err_act) info=psb_success_ - if(psb_errstatus_fatal()) then + if(psb_errstatus_fatal()) then info=psb_err_from_subroutine_ goto 9999 end if - if (allocated(vin)) then + if (allocated(vin)) then isz = size(vin) lb = lbound(vin,1) call psb_realloc(isz,vout,info,lb=lb) - if (info /= psb_success_) then + if (info /= psb_success_) then info=psb_err_from_subroutine_ char_err='psb_realloc' call psb_errpush(info,name,a_err=char_err) goto 9999 else - vout(:) = vin(:) + !$omp parallel do private(i) + do i=lb,lb+isz-1 + vout(i) = vin(i) + end do + !$omp end parallel do endif endif @@ -803,40 +807,42 @@ Contains 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 - ! ...Subroutine Arguments + ! ...Subroutine Arguments integer(psb_i2pk_), allocatable, intent(in) :: vin(:,:) integer(psb_i2pk_), allocatable, intent(out) :: vout(:,:) integer(psb_ipk_) :: info ! ...Local Variables - integer(psb_ipk_) :: isz1, isz2,err_act, lb1, lb2 + integer(psb_ipk_) :: isz1, isz2,err_act, lb1, lb2 character(len=30) :: name, char_err logical, parameter :: debug=.false. name='psb_ab_cpy_i2_rk2' call psb_erractionsave(err_act) info=psb_success_ - if(psb_errstatus_fatal()) then + if(psb_errstatus_fatal()) then info=psb_err_from_subroutine_ goto 9999 end if - if (allocated(vin)) then + if (allocated(vin)) then isz1 = size(vin,1) isz2 = size(vin,2) lb1 = lbound(vin,1) lb2 = lbound(vin,2) call psb_realloc(isz1,isz2,vout,info,lb1=lb1,lb2=lb2) - if (info /= psb_success_) then + if (info /= psb_success_) then info=psb_err_from_subroutine_ char_err='psb_realloc' call psb_errpush(info,name,a_err=char_err) goto 9999 else + !$omp workshare vout(:,:) = vin(:,:) + !$omp end workshare endif endif @@ -850,10 +856,10 @@ Contains 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 - ! ...Subroutine Arguments + ! ...Subroutine Arguments integer(psb_i2pk_), intent(in) :: vin(:) integer(psb_i2pk_), allocatable, intent(out) :: vout(:) integer(psb_ipk_) :: info @@ -866,14 +872,14 @@ Contains name='psb_cpy_i2_rk1' call psb_erractionsave(err_act) info=psb_success_ - if(psb_errstatus_fatal()) then + if(psb_errstatus_fatal()) then info=psb_err_from_subroutine_ goto 9999 end if isz = size(vin) lb = lbound(vin,1) call psb_realloc(isz,vout,info,lb=lb) - if (info /= psb_success_) then + if (info /= psb_success_) then info=psb_err_from_subroutine_ char_err='psb_realloc' call psb_errpush(info,name,a_err=char_err) @@ -891,23 +897,23 @@ Contains 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 - ! ...Subroutine Arguments + ! ...Subroutine Arguments integer(psb_i2pk_), intent(in) :: vin(:,:) integer(psb_i2pk_), allocatable, intent(out) :: vout(:,:) integer(psb_ipk_) :: info ! ...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 logical, parameter :: debug=.false. name='psb_safe_cpy' call psb_erractionsave(err_act) info=psb_success_ - if(psb_errstatus_fatal()) then + if(psb_errstatus_fatal()) then info=psb_err_from_subroutine_ goto 9999 end if @@ -917,7 +923,7 @@ Contains lb1 = lbound(vin,1) lb2 = lbound(vin,2) 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_ char_err='psb_realloc' call psb_errpush(info,name,a_err=char_err) @@ -940,7 +946,7 @@ Contains integer(psb_epk_) :: val integer(psb_i2pk_), allocatable, intent(in) :: vin(:) - if (.not.allocated(vin)) then + if (.not.allocated(vin)) then val = 0 else val = size(vin) @@ -955,10 +961,10 @@ Contains integer(psb_ipk_) :: dim_ - if (.not.allocated(vin)) then + if (.not.allocated(vin)) then val = 0 else - if (present(dim)) then + if (present(dim)) then dim_= dim val = size(vin,dim=dim_) else @@ -970,7 +976,7 @@ Contains Subroutine psb_ensure_m_sz_i2_rk1(len,v,info,pad,addsz,newsz) use psb_error_mod - ! ...Subroutine Arguments + ! ...Subroutine Arguments integer(psb_mpk_),Intent(in) :: len integer(psb_i2pk_),allocatable, intent(inout) :: v(:) integer(psb_ipk_) :: info @@ -986,29 +992,11 @@ Contains call psb_erractionsave(err_act) info = psb_success_ - if (psb_errstatus_fatal()) then + if (psb_errstatus_fatal()) then info=psb_err_from_subroutine_ goto 9999 end if -!!$ If (len > psb_size(v)) Then -!!$ if (present(newsz)) then -!!$ isz = (max(len+1,newsz)) -!!$ else -!!$ if (present(addsz)) then -!!$ isz = len+max(1,addsz) -!!$ else -!!$ isz = max(len+10, int(1.25*len)) -!!$ endif -!!$ endif -!!$ -!!$ call psb_realloc(isz,v,info,pad=pad) -!!$ if (info /= psb_success_) then -!!$ info=psb_err_from_subroutine_ -!!$ call psb_errpush(info,name,a_err='psb_realloc') -!!$ goto 9999 -!!$ End If -!!$ end If isz = psb_size(v) If (len > isz) Then #if defined(OPENMP) @@ -1017,7 +1005,7 @@ Contains if (present(newsz)) then isz = max(len+1,1,newsz) else if (present(addsz)) then - isz = max(len,1,isz+addsz)) + isz = max(len,1,isz+addsz) else isz = max(len,1,int(1.25*isz)) endif @@ -1065,7 +1053,7 @@ Contains Subroutine psb_ensure_e_sz_i2_rk1(len,v,info,pad,addsz,newsz) use psb_error_mod - ! ...Subroutine Arguments + ! ...Subroutine Arguments integer(psb_epk_),Intent(in) :: len integer(psb_i2pk_),allocatable, intent(inout) :: v(:) integer(psb_ipk_) :: info @@ -1081,7 +1069,7 @@ Contains call psb_erractionsave(err_act) info = psb_success_ - if (psb_errstatus_fatal()) then + if (psb_errstatus_fatal()) then info=psb_err_from_subroutine_ goto 9999 end if @@ -1116,9 +1104,9 @@ Contains Subroutine psb_move_alloc_i2_rk1(vin,vout,info) use psb_error_mod integer(psb_i2pk_), allocatable, intent(inout) :: vin(:),vout(:) - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info + ! ! - ! info=psb_success_ call move_alloc(vin,vout) @@ -1127,9 +1115,9 @@ Contains Subroutine psb_move_alloc_i2_rk2(vin,vout,info) use psb_error_mod integer(psb_i2pk_), allocatable, intent(inout) :: vin(:,:),vout(:,:) - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info + ! ! - ! info=psb_success_ call move_alloc(vin,vout) diff --git a/base/modules/auxil/psb_m_realloc_mod.F90 b/base/modules/auxil/psb_m_realloc_mod.F90 index 42b981b4..86348ee3 100644 --- a/base/modules/auxil/psb_m_realloc_mod.F90 +++ b/base/modules/auxil/psb_m_realloc_mod.F90 @@ -1,9 +1,9 @@ -! +! ! Parallel Sparse BLAS version 3.5 ! (C) Copyright 2006-2018 -! Salvatore Filippone -! Alfredo Buttari -! +! Salvatore Filippone +! Alfredo Buttari +! ! Redistribution and use in source and binary forms, with or without ! modification, are permitted provided that the following conditions ! are met: @@ -15,7 +15,7 @@ ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this ! software without specific written permission. -! +! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED ! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR @@ -27,16 +27,16 @@ ! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE ! POSSIBILITY OF SUCH DAMAGE. -! -! +! +! module psb_m_realloc_mod use psb_const_mod implicit none ! - ! psb_realloc will reallocate the input array to have exactly - ! the size specified, possibly shortening it. + ! psb_realloc will reallocate the input array to have exactly + ! the size specified, possibly shortening it. ! Interface psb_realloc module procedure psb_r_m_s @@ -49,7 +49,7 @@ module psb_m_realloc_mod module procedure psb_r_m_2_m_rk1 module procedure psb_r_e_2_m_rk1 - + end Interface psb_realloc interface psb_move_alloc @@ -66,7 +66,7 @@ module psb_m_realloc_mod ! ! 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. ! interface psb_ensure_size @@ -74,7 +74,7 @@ module psb_m_realloc_mod 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 module procedure psb_size_m_rk1, psb_size_m_rk2 @@ -86,7 +86,7 @@ Contains Subroutine psb_r_m_s(rrax,info) use psb_error_mod - ! ...Subroutine Arguments + ! ...Subroutine Arguments integer(psb_mpk_), allocatable, intent(inout) :: rrax integer(psb_ipk_) :: info @@ -97,9 +97,9 @@ Contains name='psb_r_m_s' 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) if (info /= psb_success_) then err=4025 @@ -122,7 +122,7 @@ Contains Subroutine psb_r_m_m_rk1(len,rrax,info,pad,lb) use psb_error_mod - ! ...Subroutine Arguments + ! ...Subroutine Arguments integer(psb_mpk_),Intent(in) :: len integer(psb_mpk_), allocatable, intent(inout) :: rrax(:) integer(psb_ipk_) :: info @@ -138,7 +138,7 @@ Contains name='psb_r_m_m_rk1' call psb_erractionsave(err_act) - info=psb_success_ + info=psb_success_ if (debug) write(psb_err_unit,*) 'reallocate D',len if (present(lb)) then @@ -146,7 +146,7 @@ Contains else lb_ = 1 endif - if ((len<0)) then + if ((len<0)) then err=4025 call psb_errpush(err,name, l_err=(/len*1_psb_lpk_/), & & a_err='integer(psb_mpk_)') @@ -154,7 +154,7 @@ Contains end if ub_ = lb_ + len-1 - if (allocated(rrax)) then + if (allocated(rrax)) then dim = size(rrax) lbi = lbound(rrax,1) If ((dim /= len).or.(lbi /= lb_)) Then @@ -178,7 +178,7 @@ Contains goto 9999 end if endif - if (present(pad)) then + if (present(pad)) then !$omp parallel do private(i) shared(dim,len) do i=lb_-1+dim+1,lb_-1+len rrax(i) = pad @@ -196,7 +196,7 @@ Contains Subroutine psb_r_m_m_rk2(len1,len2,rrax,info,pad,lb1,lb2) use psb_error_mod - ! ...Subroutine Arguments + ! ...Subroutine Arguments integer(psb_mpk_),Intent(in) :: len1,len2 integer(psb_mpk_),allocatable :: rrax(:,:) integer(psb_ipk_) :: info @@ -212,13 +212,13 @@ Contains name='psb_r_m_m_rk2' call psb_erractionsave(err_act) - info=psb_success_ - if (present(lb1)) then + info=psb_success_ + if (present(lb1)) then lb1_ = lb1 else lb1_ = 1 endif - if (present(lb2)) then + if (present(lb2)) then lb2_ = lb2 else lb2_ = 1 @@ -227,7 +227,7 @@ Contains ub2_ = lb2_ + len2 -1 if (len1 < 0) then - err=4025 + err=4025 call psb_errpush(err,name, l_err=(/len1*1_psb_lpk_/), & & a_err='integer(psb_mpk_)') goto 9999 @@ -240,7 +240,7 @@ Contains end if - if (allocated(rrax)) then + if (allocated(rrax)) then dim = size(rrax,1) lbi1 = lbound(rrax,1) dim2 = size(rrax,2) @@ -269,7 +269,7 @@ Contains goto 9999 end if endif - if (present(pad)) then + if (present(pad)) then !$omp parallel do private(i) shared(lb1_,dim,len1) do i=lb1_-1+dim+1,lb1_-1+len1 rrax(i,:) = pad @@ -293,7 +293,7 @@ Contains Subroutine psb_r_e_m_rk1(len,rrax,info,pad,lb) use psb_error_mod - ! ...Subroutine Arguments + ! ...Subroutine Arguments integer(psb_epk_),Intent(in) :: len integer(psb_mpk_), allocatable, intent(inout) :: rrax(:) integer(psb_ipk_) :: info @@ -309,7 +309,7 @@ Contains name='psb_r_m_m_rk1' call psb_erractionsave(err_act) - info=psb_success_ + info=psb_success_ if (debug) write(psb_err_unit,*) 'reallocate D',len if (present(lb)) then @@ -317,7 +317,7 @@ Contains else lb_ = 1 endif - if ((len<0)) then + if ((len<0)) then err=4025 call psb_errpush(err,name, e_err=(/len/), & & a_err='integer(psb_mpk_)') @@ -325,7 +325,7 @@ Contains end if ub_ = lb_ + len-1 - if (allocated(rrax)) then + if (allocated(rrax)) then dim = size(rrax) lbi = lbound(rrax,1) If ((dim /= len).or.(lbi /= lb_)) Then @@ -349,7 +349,7 @@ Contains goto 9999 end if endif - if (present(pad)) then + if (present(pad)) then rrax(lb_-1+dim+1:lb_-1+len) = pad endif call psb_erractionrestore(err_act) @@ -364,7 +364,7 @@ Contains Subroutine psb_r_e_m_rk2(len1,len2,rrax,info,pad,lb1,lb2) use psb_error_mod - ! ...Subroutine Arguments + ! ...Subroutine Arguments integer(psb_epk_),Intent(in) :: len1,len2 integer(psb_mpk_),allocatable :: rrax(:,:) integer(psb_ipk_) :: info @@ -380,13 +380,13 @@ Contains name='psb_r_e_m_rk2' call psb_erractionsave(err_act) - info=psb_success_ - if (present(lb1)) then + info=psb_success_ + if (present(lb1)) then lb1_ = lb1 else lb1_ = 1 endif - if (present(lb2)) then + if (present(lb2)) then lb2_ = lb2 else lb2_ = 1 @@ -408,7 +408,7 @@ Contains end if - if (allocated(rrax)) then + if (allocated(rrax)) then dim = size(rrax,1) lbi1 = lbound(rrax,1) dim2 = size(rrax,2) @@ -437,7 +437,7 @@ Contains goto 9999 end if endif - if (present(pad)) then + if (present(pad)) then rrax(lb1_-1+dim+1:lb1_-1+len1,:) = pad rrax(lb1_:lb1_-1+dim,lb2_-1+dim2+1:lb2_-1+len2) = pad endif @@ -453,7 +453,7 @@ Contains Subroutine psb_r_me_m_rk2(len1,len2,rrax,info,pad,lb1,lb2) use psb_error_mod - ! ...Subroutine Arguments + ! ...Subroutine Arguments integer(psb_mpk_),Intent(in) :: len1 integer(psb_epk_),Intent(in) :: len2 integer(psb_mpk_),allocatable :: rrax(:,:) @@ -471,13 +471,13 @@ Contains name='psb_r_me_m_rk2' call psb_erractionsave(err_act) - info=psb_success_ - if (present(lb1)) then + info=psb_success_ + if (present(lb1)) then lb1_ = lb1 else lb1_ = 1 endif - if (present(lb2)) then + if (present(lb2)) then lb2_ = lb2 else lb2_ = 1 @@ -486,7 +486,7 @@ Contains ub2_ = lb2_ + len2 -1 if (len1 < 0) then - err=4025 + err=4025 call psb_errpush(err,name, m_err=(/len1/), & & a_err='integer(psb_mpk_)') goto 9999 @@ -499,7 +499,7 @@ Contains end if - if (allocated(rrax)) then + if (allocated(rrax)) then dim = size(rrax,1) lbi1 = lbound(rrax,1) dim2 = size(rrax,2) @@ -528,7 +528,7 @@ Contains goto 9999 end if endif - if (present(pad)) then + if (present(pad)) then rrax(lb1_-1+dim+1:lb1_-1+len1,:) = pad rrax(lb1_:lb1_-1+dim,lb2_-1+dim2+1:lb2_-1+len2) = pad endif @@ -544,7 +544,7 @@ Contains Subroutine psb_r_em_m_rk2(len1,len2,rrax,info,pad,lb1,lb2) use psb_error_mod - ! ...Subroutine Arguments + ! ...Subroutine Arguments integer(psb_epk_),Intent(in) :: len1 integer(psb_mpk_),Intent(in) :: len2 integer(psb_mpk_),allocatable :: rrax(:,:) @@ -562,13 +562,13 @@ Contains name='psb_r_me_m_rk2' call psb_erractionsave(err_act) - info=psb_success_ - if (present(lb1)) then + info=psb_success_ + if (present(lb1)) then lb1_ = lb1 else lb1_ = 1 endif - if (present(lb2)) then + if (present(lb2)) then lb2_ = lb2 else lb2_ = 1 @@ -577,7 +577,7 @@ Contains ub2_ = lb2_ + len2 -1 if (len1 < 0) then - err=4025 + err=4025 call psb_errpush(err,name, e_err=(/len1/), & & a_err='integer(psb_mpk_)') goto 9999 @@ -590,7 +590,7 @@ Contains end if - if (allocated(rrax)) then + if (allocated(rrax)) then dim = size(rrax,1) lbi1 = lbound(rrax,1) dim2 = size(rrax,2) @@ -619,7 +619,7 @@ Contains goto 9999 end if endif - if (present(pad)) then + if (present(pad)) then rrax(lb1_-1+dim+1:lb1_-1+len1,:) = pad rrax(lb1_:lb1_-1+dim,lb2_-1+dim2+1:lb2_-1+len2) = pad endif @@ -635,7 +635,7 @@ Contains Subroutine psb_r_m_2_m_rk1(len,rrax,y,info,pad) use psb_error_mod - ! ...Subroutine Arguments + ! ...Subroutine Arguments integer(psb_mpk_),Intent(in) :: len integer(psb_mpk_),allocatable, intent(inout) :: rrax(:),y(:) @@ -648,7 +648,7 @@ Contains call psb_erractionsave(err_act) info=psb_success_ - if(psb_errstatus_fatal()) then + if(psb_errstatus_fatal()) then info=psb_err_from_subroutine_ goto 9999 end if @@ -676,7 +676,7 @@ Contains Subroutine psb_r_e_2_m_rk1(len,rrax,y,info,pad) use psb_error_mod - ! ...Subroutine Arguments + ! ...Subroutine Arguments integer(psb_epk_),Intent(in) :: len integer(psb_mpk_),allocatable, intent(inout) :: rrax(:),y(:) @@ -689,7 +689,7 @@ Contains call psb_erractionsave(err_act) info=psb_success_ - if(psb_errstatus_fatal()) then + if(psb_errstatus_fatal()) then info=psb_err_from_subroutine_ goto 9999 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 - ! ...Subroutine Arguments + ! ...Subroutine Arguments integer(psb_mpk_), allocatable, intent(in) :: vin integer(psb_mpk_), allocatable, intent(out) :: vout integer(psb_ipk_) :: info @@ -733,14 +733,14 @@ Contains name='psb_ab_cpy_m_s' call psb_erractionsave(err_act) info=psb_success_ - if(psb_errstatus_fatal()) then + if(psb_errstatus_fatal()) then info=psb_err_from_subroutine_ goto 9999 end if - if (allocated(vin)) then + if (allocated(vin)) then call psb_realloc(vout,info) - if (info /= psb_success_) then + if (info /= psb_success_) then info=psb_err_from_subroutine_ char_err='psb_realloc' call psb_errpush(info,name,a_err=char_err) @@ -759,38 +759,42 @@ Contains 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 - ! ...Subroutine Arguments + ! ...Subroutine Arguments integer(psb_mpk_), allocatable, intent(in) :: vin(:) integer(psb_mpk_), allocatable, intent(out) :: vout(:) integer(psb_ipk_) :: info ! ...Local Variables - integer(psb_ipk_) :: isz,err_act,lb + integer(psb_ipk_) :: isz,err_act,lb, i character(len=30) :: name, char_err logical, parameter :: debug=.false. name='psb_ab_cpy_m_rk1' call psb_erractionsave(err_act) info=psb_success_ - if(psb_errstatus_fatal()) then + if(psb_errstatus_fatal()) then info=psb_err_from_subroutine_ goto 9999 end if - if (allocated(vin)) then + if (allocated(vin)) then isz = size(vin) lb = lbound(vin,1) call psb_realloc(isz,vout,info,lb=lb) - if (info /= psb_success_) then + if (info /= psb_success_) then info=psb_err_from_subroutine_ char_err='psb_realloc' call psb_errpush(info,name,a_err=char_err) goto 9999 else - vout(:) = vin(:) + !$omp parallel do private(i) + do i=lb,lb+isz-1 + vout(i) = vin(i) + end do + !$omp end parallel do endif endif @@ -803,40 +807,42 @@ Contains 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 - ! ...Subroutine Arguments + ! ...Subroutine Arguments integer(psb_mpk_), allocatable, intent(in) :: vin(:,:) integer(psb_mpk_), allocatable, intent(out) :: vout(:,:) integer(psb_ipk_) :: info ! ...Local Variables - integer(psb_ipk_) :: isz1, isz2,err_act, lb1, lb2 + integer(psb_ipk_) :: isz1, isz2,err_act, lb1, lb2 character(len=30) :: name, char_err logical, parameter :: debug=.false. name='psb_ab_cpy_m_rk2' call psb_erractionsave(err_act) info=psb_success_ - if(psb_errstatus_fatal()) then + if(psb_errstatus_fatal()) then info=psb_err_from_subroutine_ goto 9999 end if - if (allocated(vin)) then + if (allocated(vin)) then isz1 = size(vin,1) isz2 = size(vin,2) lb1 = lbound(vin,1) lb2 = lbound(vin,2) call psb_realloc(isz1,isz2,vout,info,lb1=lb1,lb2=lb2) - if (info /= psb_success_) then + if (info /= psb_success_) then info=psb_err_from_subroutine_ char_err='psb_realloc' call psb_errpush(info,name,a_err=char_err) goto 9999 else + !$omp workshare vout(:,:) = vin(:,:) + !$omp end workshare endif endif @@ -850,10 +856,10 @@ Contains 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 - ! ...Subroutine Arguments + ! ...Subroutine Arguments integer(psb_mpk_), intent(in) :: vin(:) integer(psb_mpk_), allocatable, intent(out) :: vout(:) integer(psb_ipk_) :: info @@ -866,14 +872,14 @@ Contains name='psb_cpy_m_rk1' call psb_erractionsave(err_act) info=psb_success_ - if(psb_errstatus_fatal()) then + if(psb_errstatus_fatal()) then info=psb_err_from_subroutine_ goto 9999 end if isz = size(vin) lb = lbound(vin,1) call psb_realloc(isz,vout,info,lb=lb) - if (info /= psb_success_) then + if (info /= psb_success_) then info=psb_err_from_subroutine_ char_err='psb_realloc' call psb_errpush(info,name,a_err=char_err) @@ -891,23 +897,23 @@ Contains 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 - ! ...Subroutine Arguments + ! ...Subroutine Arguments integer(psb_mpk_), intent(in) :: vin(:,:) integer(psb_mpk_), allocatable, intent(out) :: vout(:,:) integer(psb_ipk_) :: info ! ...Local Variables - integer(psb_ipk_) :: isz1, isz2,err_act, lb1, lb2 + integer(psb_ipk_) :: isz1, isz2,err_act, lb1, lb2 character(len=30) :: name, char_err logical, parameter :: debug=.false. name='psb_safe_cpy' call psb_erractionsave(err_act) info=psb_success_ - if(psb_errstatus_fatal()) then + if(psb_errstatus_fatal()) then info=psb_err_from_subroutine_ goto 9999 end if @@ -917,7 +923,7 @@ Contains lb1 = lbound(vin,1) lb2 = lbound(vin,2) 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_ char_err='psb_realloc' call psb_errpush(info,name,a_err=char_err) @@ -940,7 +946,7 @@ Contains integer(psb_epk_) :: val integer(psb_mpk_), allocatable, intent(in) :: vin(:) - if (.not.allocated(vin)) then + if (.not.allocated(vin)) then val = 0 else val = size(vin) @@ -955,10 +961,10 @@ Contains integer(psb_ipk_) :: dim_ - if (.not.allocated(vin)) then + if (.not.allocated(vin)) then val = 0 else - if (present(dim)) then + if (present(dim)) then dim_= dim val = size(vin,dim=dim_) else @@ -970,7 +976,7 @@ Contains Subroutine psb_ensure_m_sz_m_rk1(len,v,info,pad,addsz,newsz) use psb_error_mod - ! ...Subroutine Arguments + ! ...Subroutine Arguments integer(psb_mpk_),Intent(in) :: len integer(psb_mpk_),allocatable, intent(inout) :: v(:) integer(psb_ipk_) :: info @@ -986,29 +992,11 @@ Contains call psb_erractionsave(err_act) info = psb_success_ - if (psb_errstatus_fatal()) then + if (psb_errstatus_fatal()) then info=psb_err_from_subroutine_ goto 9999 end if -!!$ If (len > psb_size(v)) Then -!!$ if (present(newsz)) then -!!$ isz = (max(len+1,newsz)) -!!$ else -!!$ if (present(addsz)) then -!!$ isz = len+max(1,addsz) -!!$ else -!!$ isz = max(len+10, int(1.25*len)) -!!$ endif -!!$ endif -!!$ -!!$ call psb_realloc(isz,v,info,pad=pad) -!!$ if (info /= psb_success_) then -!!$ info=psb_err_from_subroutine_ -!!$ call psb_errpush(info,name,a_err='psb_realloc') -!!$ goto 9999 -!!$ End If -!!$ end If isz = psb_size(v) If (len > isz) Then #if defined(OPENMP) @@ -1017,7 +1005,7 @@ Contains if (present(newsz)) then isz = max(len+1,1,newsz) else if (present(addsz)) then - isz = max(len,1,isz+addsz)) + isz = max(len,1,isz+addsz) else isz = max(len,1,int(1.25*isz)) endif @@ -1065,7 +1053,7 @@ Contains Subroutine psb_ensure_e_sz_m_rk1(len,v,info,pad,addsz,newsz) use psb_error_mod - ! ...Subroutine Arguments + ! ...Subroutine Arguments integer(psb_epk_),Intent(in) :: len integer(psb_mpk_),allocatable, intent(inout) :: v(:) integer(psb_ipk_) :: info @@ -1081,7 +1069,7 @@ Contains call psb_erractionsave(err_act) info = psb_success_ - if (psb_errstatus_fatal()) then + if (psb_errstatus_fatal()) then info=psb_err_from_subroutine_ goto 9999 end if @@ -1116,9 +1104,9 @@ Contains Subroutine psb_move_alloc_m_rk1(vin,vout,info) use psb_error_mod integer(psb_mpk_), allocatable, intent(inout) :: vin(:),vout(:) - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info + ! ! - ! info=psb_success_ call move_alloc(vin,vout) @@ -1127,9 +1115,9 @@ Contains Subroutine psb_move_alloc_m_rk2(vin,vout,info) use psb_error_mod integer(psb_mpk_), allocatable, intent(inout) :: vin(:,:),vout(:,:) - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info + ! ! - ! info=psb_success_ call move_alloc(vin,vout) diff --git a/base/modules/auxil/psb_s_realloc_mod.F90 b/base/modules/auxil/psb_s_realloc_mod.F90 index 8d2d5af1..9ca7bfa3 100644 --- a/base/modules/auxil/psb_s_realloc_mod.F90 +++ b/base/modules/auxil/psb_s_realloc_mod.F90 @@ -1,9 +1,9 @@ -! +! ! Parallel Sparse BLAS version 3.5 ! (C) Copyright 2006-2018 -! Salvatore Filippone -! Alfredo Buttari -! +! Salvatore Filippone +! Alfredo Buttari +! ! Redistribution and use in source and binary forms, with or without ! modification, are permitted provided that the following conditions ! are met: @@ -15,7 +15,7 @@ ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this ! software without specific written permission. -! +! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED ! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR @@ -27,16 +27,16 @@ ! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE ! POSSIBILITY OF SUCH DAMAGE. -! -! +! +! module psb_s_realloc_mod use psb_const_mod implicit none ! - ! psb_realloc will reallocate the input array to have exactly - ! the size specified, possibly shortening it. + ! psb_realloc will reallocate the input array to have exactly + ! the size specified, possibly shortening it. ! Interface psb_realloc 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_e_2_s_rk1 - + end Interface psb_realloc interface psb_move_alloc @@ -66,7 +66,7 @@ module psb_s_realloc_mod ! ! 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. ! interface psb_ensure_size @@ -74,7 +74,7 @@ module psb_s_realloc_mod 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 module procedure psb_size_s_rk1, psb_size_s_rk2 @@ -86,7 +86,7 @@ Contains Subroutine psb_r_s_s(rrax,info) use psb_error_mod - ! ...Subroutine Arguments + ! ...Subroutine Arguments real(psb_spk_), allocatable, intent(inout) :: rrax integer(psb_ipk_) :: info @@ -97,9 +97,9 @@ Contains name='psb_r_s_s' 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) if (info /= psb_success_) then err=4025 @@ -122,7 +122,7 @@ Contains Subroutine psb_r_m_s_rk1(len,rrax,info,pad,lb) use psb_error_mod - ! ...Subroutine Arguments + ! ...Subroutine Arguments integer(psb_mpk_),Intent(in) :: len real(psb_spk_), allocatable, intent(inout) :: rrax(:) integer(psb_ipk_) :: info @@ -138,7 +138,7 @@ Contains name='psb_r_m_s_rk1' call psb_erractionsave(err_act) - info=psb_success_ + info=psb_success_ if (debug) write(psb_err_unit,*) 'reallocate D',len if (present(lb)) then @@ -146,7 +146,7 @@ Contains else lb_ = 1 endif - if ((len<0)) then + if ((len<0)) then err=4025 call psb_errpush(err,name, l_err=(/len*1_psb_lpk_/), & & a_err='real(psb_spk_)') @@ -154,7 +154,7 @@ Contains end if ub_ = lb_ + len-1 - if (allocated(rrax)) then + if (allocated(rrax)) then dim = size(rrax) lbi = lbound(rrax,1) If ((dim /= len).or.(lbi /= lb_)) Then @@ -178,7 +178,7 @@ Contains goto 9999 end if endif - if (present(pad)) then + if (present(pad)) then !$omp parallel do private(i) shared(dim,len) do i=lb_-1+dim+1,lb_-1+len rrax(i) = pad @@ -196,7 +196,7 @@ Contains Subroutine psb_r_m_s_rk2(len1,len2,rrax,info,pad,lb1,lb2) use psb_error_mod - ! ...Subroutine Arguments + ! ...Subroutine Arguments integer(psb_mpk_),Intent(in) :: len1,len2 real(psb_spk_),allocatable :: rrax(:,:) integer(psb_ipk_) :: info @@ -212,13 +212,13 @@ Contains name='psb_r_m_s_rk2' call psb_erractionsave(err_act) - info=psb_success_ - if (present(lb1)) then + info=psb_success_ + if (present(lb1)) then lb1_ = lb1 else lb1_ = 1 endif - if (present(lb2)) then + if (present(lb2)) then lb2_ = lb2 else lb2_ = 1 @@ -227,7 +227,7 @@ Contains ub2_ = lb2_ + len2 -1 if (len1 < 0) then - err=4025 + err=4025 call psb_errpush(err,name, l_err=(/len1*1_psb_lpk_/), & & a_err='real(psb_spk_)') goto 9999 @@ -240,7 +240,7 @@ Contains end if - if (allocated(rrax)) then + if (allocated(rrax)) then dim = size(rrax,1) lbi1 = lbound(rrax,1) dim2 = size(rrax,2) @@ -269,7 +269,7 @@ Contains goto 9999 end if endif - if (present(pad)) then + if (present(pad)) then !$omp parallel do private(i) shared(lb1_,dim,len1) do i=lb1_-1+dim+1,lb1_-1+len1 rrax(i,:) = pad @@ -293,7 +293,7 @@ Contains Subroutine psb_r_e_s_rk1(len,rrax,info,pad,lb) use psb_error_mod - ! ...Subroutine Arguments + ! ...Subroutine Arguments integer(psb_epk_),Intent(in) :: len real(psb_spk_), allocatable, intent(inout) :: rrax(:) integer(psb_ipk_) :: info @@ -309,7 +309,7 @@ Contains name='psb_r_m_s_rk1' call psb_erractionsave(err_act) - info=psb_success_ + info=psb_success_ if (debug) write(psb_err_unit,*) 'reallocate D',len if (present(lb)) then @@ -317,7 +317,7 @@ Contains else lb_ = 1 endif - if ((len<0)) then + if ((len<0)) then err=4025 call psb_errpush(err,name, e_err=(/len/), & & a_err='real(psb_spk_)') @@ -325,7 +325,7 @@ Contains end if ub_ = lb_ + len-1 - if (allocated(rrax)) then + if (allocated(rrax)) then dim = size(rrax) lbi = lbound(rrax,1) If ((dim /= len).or.(lbi /= lb_)) Then @@ -349,7 +349,7 @@ Contains goto 9999 end if endif - if (present(pad)) then + if (present(pad)) then rrax(lb_-1+dim+1:lb_-1+len) = pad endif call psb_erractionrestore(err_act) @@ -364,7 +364,7 @@ Contains Subroutine psb_r_e_s_rk2(len1,len2,rrax,info,pad,lb1,lb2) use psb_error_mod - ! ...Subroutine Arguments + ! ...Subroutine Arguments integer(psb_epk_),Intent(in) :: len1,len2 real(psb_spk_),allocatable :: rrax(:,:) integer(psb_ipk_) :: info @@ -380,13 +380,13 @@ Contains name='psb_r_e_s_rk2' call psb_erractionsave(err_act) - info=psb_success_ - if (present(lb1)) then + info=psb_success_ + if (present(lb1)) then lb1_ = lb1 else lb1_ = 1 endif - if (present(lb2)) then + if (present(lb2)) then lb2_ = lb2 else lb2_ = 1 @@ -408,7 +408,7 @@ Contains end if - if (allocated(rrax)) then + if (allocated(rrax)) then dim = size(rrax,1) lbi1 = lbound(rrax,1) dim2 = size(rrax,2) @@ -437,7 +437,7 @@ Contains goto 9999 end if endif - if (present(pad)) then + if (present(pad)) then rrax(lb1_-1+dim+1:lb1_-1+len1,:) = pad rrax(lb1_:lb1_-1+dim,lb2_-1+dim2+1:lb2_-1+len2) = pad endif @@ -453,7 +453,7 @@ Contains Subroutine psb_r_me_s_rk2(len1,len2,rrax,info,pad,lb1,lb2) use psb_error_mod - ! ...Subroutine Arguments + ! ...Subroutine Arguments integer(psb_mpk_),Intent(in) :: len1 integer(psb_epk_),Intent(in) :: len2 real(psb_spk_),allocatable :: rrax(:,:) @@ -471,13 +471,13 @@ Contains name='psb_r_me_s_rk2' call psb_erractionsave(err_act) - info=psb_success_ - if (present(lb1)) then + info=psb_success_ + if (present(lb1)) then lb1_ = lb1 else lb1_ = 1 endif - if (present(lb2)) then + if (present(lb2)) then lb2_ = lb2 else lb2_ = 1 @@ -486,7 +486,7 @@ Contains ub2_ = lb2_ + len2 -1 if (len1 < 0) then - err=4025 + err=4025 call psb_errpush(err,name, m_err=(/len1/), & & a_err='real(psb_spk_)') goto 9999 @@ -499,7 +499,7 @@ Contains end if - if (allocated(rrax)) then + if (allocated(rrax)) then dim = size(rrax,1) lbi1 = lbound(rrax,1) dim2 = size(rrax,2) @@ -528,7 +528,7 @@ Contains goto 9999 end if endif - if (present(pad)) then + if (present(pad)) then rrax(lb1_-1+dim+1:lb1_-1+len1,:) = pad rrax(lb1_:lb1_-1+dim,lb2_-1+dim2+1:lb2_-1+len2) = pad endif @@ -544,7 +544,7 @@ Contains Subroutine psb_r_em_s_rk2(len1,len2,rrax,info,pad,lb1,lb2) use psb_error_mod - ! ...Subroutine Arguments + ! ...Subroutine Arguments integer(psb_epk_),Intent(in) :: len1 integer(psb_mpk_),Intent(in) :: len2 real(psb_spk_),allocatable :: rrax(:,:) @@ -562,13 +562,13 @@ Contains name='psb_r_me_s_rk2' call psb_erractionsave(err_act) - info=psb_success_ - if (present(lb1)) then + info=psb_success_ + if (present(lb1)) then lb1_ = lb1 else lb1_ = 1 endif - if (present(lb2)) then + if (present(lb2)) then lb2_ = lb2 else lb2_ = 1 @@ -577,7 +577,7 @@ Contains ub2_ = lb2_ + len2 -1 if (len1 < 0) then - err=4025 + err=4025 call psb_errpush(err,name, e_err=(/len1/), & & a_err='real(psb_spk_)') goto 9999 @@ -590,7 +590,7 @@ Contains end if - if (allocated(rrax)) then + if (allocated(rrax)) then dim = size(rrax,1) lbi1 = lbound(rrax,1) dim2 = size(rrax,2) @@ -619,7 +619,7 @@ Contains goto 9999 end if endif - if (present(pad)) then + if (present(pad)) then rrax(lb1_-1+dim+1:lb1_-1+len1,:) = pad rrax(lb1_:lb1_-1+dim,lb2_-1+dim2+1:lb2_-1+len2) = pad endif @@ -635,7 +635,7 @@ Contains Subroutine psb_r_m_2_s_rk1(len,rrax,y,info,pad) use psb_error_mod - ! ...Subroutine Arguments + ! ...Subroutine Arguments integer(psb_mpk_),Intent(in) :: len real(psb_spk_),allocatable, intent(inout) :: rrax(:),y(:) @@ -648,7 +648,7 @@ Contains call psb_erractionsave(err_act) info=psb_success_ - if(psb_errstatus_fatal()) then + if(psb_errstatus_fatal()) then info=psb_err_from_subroutine_ goto 9999 end if @@ -676,7 +676,7 @@ Contains Subroutine psb_r_e_2_s_rk1(len,rrax,y,info,pad) use psb_error_mod - ! ...Subroutine Arguments + ! ...Subroutine Arguments integer(psb_epk_),Intent(in) :: len real(psb_spk_),allocatable, intent(inout) :: rrax(:),y(:) @@ -689,7 +689,7 @@ Contains call psb_erractionsave(err_act) info=psb_success_ - if(psb_errstatus_fatal()) then + if(psb_errstatus_fatal()) then info=psb_err_from_subroutine_ goto 9999 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 - ! ...Subroutine Arguments + ! ...Subroutine Arguments real(psb_spk_), allocatable, intent(in) :: vin real(psb_spk_), allocatable, intent(out) :: vout integer(psb_ipk_) :: info @@ -733,14 +733,14 @@ Contains name='psb_ab_cpy_s_s' call psb_erractionsave(err_act) info=psb_success_ - if(psb_errstatus_fatal()) then + if(psb_errstatus_fatal()) then info=psb_err_from_subroutine_ goto 9999 end if - if (allocated(vin)) then + if (allocated(vin)) then call psb_realloc(vout,info) - if (info /= psb_success_) then + if (info /= psb_success_) then info=psb_err_from_subroutine_ char_err='psb_realloc' call psb_errpush(info,name,a_err=char_err) @@ -759,38 +759,42 @@ Contains 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 - ! ...Subroutine Arguments + ! ...Subroutine Arguments real(psb_spk_), allocatable, intent(in) :: vin(:) real(psb_spk_), allocatable, intent(out) :: vout(:) integer(psb_ipk_) :: info ! ...Local Variables - integer(psb_ipk_) :: isz,err_act,lb + integer(psb_ipk_) :: isz,err_act,lb, i character(len=30) :: name, char_err logical, parameter :: debug=.false. name='psb_ab_cpy_s_rk1' call psb_erractionsave(err_act) info=psb_success_ - if(psb_errstatus_fatal()) then + if(psb_errstatus_fatal()) then info=psb_err_from_subroutine_ goto 9999 end if - if (allocated(vin)) then + if (allocated(vin)) then isz = size(vin) lb = lbound(vin,1) call psb_realloc(isz,vout,info,lb=lb) - if (info /= psb_success_) then + if (info /= psb_success_) then info=psb_err_from_subroutine_ char_err='psb_realloc' call psb_errpush(info,name,a_err=char_err) goto 9999 else - vout(:) = vin(:) + !$omp parallel do private(i) + do i=lb,lb+isz-1 + vout(i) = vin(i) + end do + !$omp end parallel do endif endif @@ -803,40 +807,42 @@ Contains 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 - ! ...Subroutine Arguments + ! ...Subroutine Arguments real(psb_spk_), allocatable, intent(in) :: vin(:,:) real(psb_spk_), allocatable, intent(out) :: vout(:,:) integer(psb_ipk_) :: info ! ...Local Variables - integer(psb_ipk_) :: isz1, isz2,err_act, lb1, lb2 + integer(psb_ipk_) :: isz1, isz2,err_act, lb1, lb2 character(len=30) :: name, char_err logical, parameter :: debug=.false. name='psb_ab_cpy_s_rk2' call psb_erractionsave(err_act) info=psb_success_ - if(psb_errstatus_fatal()) then + if(psb_errstatus_fatal()) then info=psb_err_from_subroutine_ goto 9999 end if - if (allocated(vin)) then + if (allocated(vin)) then isz1 = size(vin,1) isz2 = size(vin,2) lb1 = lbound(vin,1) lb2 = lbound(vin,2) call psb_realloc(isz1,isz2,vout,info,lb1=lb1,lb2=lb2) - if (info /= psb_success_) then + if (info /= psb_success_) then info=psb_err_from_subroutine_ char_err='psb_realloc' call psb_errpush(info,name,a_err=char_err) goto 9999 else + !$omp workshare vout(:,:) = vin(:,:) + !$omp end workshare endif endif @@ -850,10 +856,10 @@ Contains 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 - ! ...Subroutine Arguments + ! ...Subroutine Arguments real(psb_spk_), intent(in) :: vin(:) real(psb_spk_), allocatable, intent(out) :: vout(:) integer(psb_ipk_) :: info @@ -866,14 +872,14 @@ Contains name='psb_cpy_s_rk1' call psb_erractionsave(err_act) info=psb_success_ - if(psb_errstatus_fatal()) then + if(psb_errstatus_fatal()) then info=psb_err_from_subroutine_ goto 9999 end if isz = size(vin) lb = lbound(vin,1) call psb_realloc(isz,vout,info,lb=lb) - if (info /= psb_success_) then + if (info /= psb_success_) then info=psb_err_from_subroutine_ char_err='psb_realloc' call psb_errpush(info,name,a_err=char_err) @@ -891,23 +897,23 @@ Contains 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 - ! ...Subroutine Arguments + ! ...Subroutine Arguments real(psb_spk_), intent(in) :: vin(:,:) real(psb_spk_), allocatable, intent(out) :: vout(:,:) integer(psb_ipk_) :: info ! ...Local Variables - integer(psb_ipk_) :: isz1, isz2,err_act, lb1, lb2 + integer(psb_ipk_) :: isz1, isz2,err_act, lb1, lb2 character(len=30) :: name, char_err logical, parameter :: debug=.false. name='psb_safe_cpy' call psb_erractionsave(err_act) info=psb_success_ - if(psb_errstatus_fatal()) then + if(psb_errstatus_fatal()) then info=psb_err_from_subroutine_ goto 9999 end if @@ -917,7 +923,7 @@ Contains lb1 = lbound(vin,1) lb2 = lbound(vin,2) 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_ char_err='psb_realloc' call psb_errpush(info,name,a_err=char_err) @@ -940,7 +946,7 @@ Contains integer(psb_epk_) :: val real(psb_spk_), allocatable, intent(in) :: vin(:) - if (.not.allocated(vin)) then + if (.not.allocated(vin)) then val = 0 else val = size(vin) @@ -955,10 +961,10 @@ Contains integer(psb_ipk_) :: dim_ - if (.not.allocated(vin)) then + if (.not.allocated(vin)) then val = 0 else - if (present(dim)) then + if (present(dim)) then dim_= dim val = size(vin,dim=dim_) else @@ -970,7 +976,7 @@ Contains Subroutine psb_ensure_m_sz_s_rk1(len,v,info,pad,addsz,newsz) use psb_error_mod - ! ...Subroutine Arguments + ! ...Subroutine Arguments integer(psb_mpk_),Intent(in) :: len real(psb_spk_),allocatable, intent(inout) :: v(:) integer(psb_ipk_) :: info @@ -986,29 +992,11 @@ Contains call psb_erractionsave(err_act) info = psb_success_ - if (psb_errstatus_fatal()) then + if (psb_errstatus_fatal()) then info=psb_err_from_subroutine_ goto 9999 end if -!!$ If (len > psb_size(v)) Then -!!$ if (present(newsz)) then -!!$ isz = (max(len+1,newsz)) -!!$ else -!!$ if (present(addsz)) then -!!$ isz = len+max(1,addsz) -!!$ else -!!$ isz = max(len+10, int(1.25*len)) -!!$ endif -!!$ endif -!!$ -!!$ call psb_realloc(isz,v,info,pad=pad) -!!$ if (info /= psb_success_) then -!!$ info=psb_err_from_subroutine_ -!!$ call psb_errpush(info,name,a_err='psb_realloc') -!!$ goto 9999 -!!$ End If -!!$ end If isz = psb_size(v) If (len > isz) Then #if defined(OPENMP) @@ -1017,7 +1005,7 @@ Contains if (present(newsz)) then isz = max(len+1,1,newsz) else if (present(addsz)) then - isz = max(len,1,isz+addsz)) + isz = max(len,1,isz+addsz) else isz = max(len,1,int(1.25*isz)) endif @@ -1065,7 +1053,7 @@ Contains Subroutine psb_ensure_e_sz_s_rk1(len,v,info,pad,addsz,newsz) use psb_error_mod - ! ...Subroutine Arguments + ! ...Subroutine Arguments integer(psb_epk_),Intent(in) :: len real(psb_spk_),allocatable, intent(inout) :: v(:) integer(psb_ipk_) :: info @@ -1081,7 +1069,7 @@ Contains call psb_erractionsave(err_act) info = psb_success_ - if (psb_errstatus_fatal()) then + if (psb_errstatus_fatal()) then info=psb_err_from_subroutine_ goto 9999 end if @@ -1116,9 +1104,9 @@ Contains Subroutine psb_move_alloc_s_rk1(vin,vout,info) use psb_error_mod real(psb_spk_), allocatable, intent(inout) :: vin(:),vout(:) - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info + ! ! - ! info=psb_success_ call move_alloc(vin,vout) @@ -1127,9 +1115,9 @@ Contains Subroutine psb_move_alloc_s_rk2(vin,vout,info) use psb_error_mod real(psb_spk_), allocatable, intent(inout) :: vin(:,:),vout(:,:) - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info + ! ! - ! info=psb_success_ call move_alloc(vin,vout) diff --git a/base/modules/auxil/psb_z_realloc_mod.F90 b/base/modules/auxil/psb_z_realloc_mod.F90 index e81b767a..b5fe09c0 100644 --- a/base/modules/auxil/psb_z_realloc_mod.F90 +++ b/base/modules/auxil/psb_z_realloc_mod.F90 @@ -1,9 +1,9 @@ -! +! ! Parallel Sparse BLAS version 3.5 ! (C) Copyright 2006-2018 -! Salvatore Filippone -! Alfredo Buttari -! +! Salvatore Filippone +! Alfredo Buttari +! ! Redistribution and use in source and binary forms, with or without ! modification, are permitted provided that the following conditions ! are met: @@ -15,7 +15,7 @@ ! 3. The name of the PSBLAS group or the names of its contributors may ! not be used to endorse or promote products derived from this ! software without specific written permission. -! +! ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED ! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR @@ -27,16 +27,16 @@ ! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE ! POSSIBILITY OF SUCH DAMAGE. -! -! +! +! module psb_z_realloc_mod use psb_const_mod implicit none ! - ! psb_realloc will reallocate the input array to have exactly - ! the size specified, possibly shortening it. + ! psb_realloc will reallocate the input array to have exactly + ! the size specified, possibly shortening it. ! Interface psb_realloc 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_e_2_z_rk1 - + end Interface psb_realloc interface psb_move_alloc @@ -66,7 +66,7 @@ module psb_z_realloc_mod ! ! 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. ! interface psb_ensure_size @@ -74,7 +74,7 @@ module psb_z_realloc_mod 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 module procedure psb_size_z_rk1, psb_size_z_rk2 @@ -86,7 +86,7 @@ Contains Subroutine psb_r_z_s(rrax,info) use psb_error_mod - ! ...Subroutine Arguments + ! ...Subroutine Arguments complex(psb_dpk_), allocatable, intent(inout) :: rrax integer(psb_ipk_) :: info @@ -97,9 +97,9 @@ Contains name='psb_r_z_s' 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) if (info /= psb_success_) then err=4025 @@ -122,7 +122,7 @@ Contains Subroutine psb_r_m_z_rk1(len,rrax,info,pad,lb) use psb_error_mod - ! ...Subroutine Arguments + ! ...Subroutine Arguments integer(psb_mpk_),Intent(in) :: len complex(psb_dpk_), allocatable, intent(inout) :: rrax(:) integer(psb_ipk_) :: info @@ -138,7 +138,7 @@ Contains name='psb_r_m_z_rk1' call psb_erractionsave(err_act) - info=psb_success_ + info=psb_success_ if (debug) write(psb_err_unit,*) 'reallocate D',len if (present(lb)) then @@ -146,7 +146,7 @@ Contains else lb_ = 1 endif - if ((len<0)) then + if ((len<0)) then err=4025 call psb_errpush(err,name, l_err=(/len*1_psb_lpk_/), & & a_err='complex(psb_dpk_)') @@ -154,7 +154,7 @@ Contains end if ub_ = lb_ + len-1 - if (allocated(rrax)) then + if (allocated(rrax)) then dim = size(rrax) lbi = lbound(rrax,1) If ((dim /= len).or.(lbi /= lb_)) Then @@ -178,7 +178,7 @@ Contains goto 9999 end if endif - if (present(pad)) then + if (present(pad)) then !$omp parallel do private(i) shared(dim,len) do i=lb_-1+dim+1,lb_-1+len rrax(i) = pad @@ -196,7 +196,7 @@ Contains Subroutine psb_r_m_z_rk2(len1,len2,rrax,info,pad,lb1,lb2) use psb_error_mod - ! ...Subroutine Arguments + ! ...Subroutine Arguments integer(psb_mpk_),Intent(in) :: len1,len2 complex(psb_dpk_),allocatable :: rrax(:,:) integer(psb_ipk_) :: info @@ -212,13 +212,13 @@ Contains name='psb_r_m_z_rk2' call psb_erractionsave(err_act) - info=psb_success_ - if (present(lb1)) then + info=psb_success_ + if (present(lb1)) then lb1_ = lb1 else lb1_ = 1 endif - if (present(lb2)) then + if (present(lb2)) then lb2_ = lb2 else lb2_ = 1 @@ -227,7 +227,7 @@ Contains ub2_ = lb2_ + len2 -1 if (len1 < 0) then - err=4025 + err=4025 call psb_errpush(err,name, l_err=(/len1*1_psb_lpk_/), & & a_err='complex(psb_dpk_)') goto 9999 @@ -240,7 +240,7 @@ Contains end if - if (allocated(rrax)) then + if (allocated(rrax)) then dim = size(rrax,1) lbi1 = lbound(rrax,1) dim2 = size(rrax,2) @@ -269,7 +269,7 @@ Contains goto 9999 end if endif - if (present(pad)) then + if (present(pad)) then !$omp parallel do private(i) shared(lb1_,dim,len1) do i=lb1_-1+dim+1,lb1_-1+len1 rrax(i,:) = pad @@ -293,7 +293,7 @@ Contains Subroutine psb_r_e_z_rk1(len,rrax,info,pad,lb) use psb_error_mod - ! ...Subroutine Arguments + ! ...Subroutine Arguments integer(psb_epk_),Intent(in) :: len complex(psb_dpk_), allocatable, intent(inout) :: rrax(:) integer(psb_ipk_) :: info @@ -309,7 +309,7 @@ Contains name='psb_r_m_z_rk1' call psb_erractionsave(err_act) - info=psb_success_ + info=psb_success_ if (debug) write(psb_err_unit,*) 'reallocate D',len if (present(lb)) then @@ -317,7 +317,7 @@ Contains else lb_ = 1 endif - if ((len<0)) then + if ((len<0)) then err=4025 call psb_errpush(err,name, e_err=(/len/), & & a_err='complex(psb_dpk_)') @@ -325,7 +325,7 @@ Contains end if ub_ = lb_ + len-1 - if (allocated(rrax)) then + if (allocated(rrax)) then dim = size(rrax) lbi = lbound(rrax,1) If ((dim /= len).or.(lbi /= lb_)) Then @@ -349,7 +349,7 @@ Contains goto 9999 end if endif - if (present(pad)) then + if (present(pad)) then rrax(lb_-1+dim+1:lb_-1+len) = pad endif call psb_erractionrestore(err_act) @@ -364,7 +364,7 @@ Contains Subroutine psb_r_e_z_rk2(len1,len2,rrax,info,pad,lb1,lb2) use psb_error_mod - ! ...Subroutine Arguments + ! ...Subroutine Arguments integer(psb_epk_),Intent(in) :: len1,len2 complex(psb_dpk_),allocatable :: rrax(:,:) integer(psb_ipk_) :: info @@ -380,13 +380,13 @@ Contains name='psb_r_e_z_rk2' call psb_erractionsave(err_act) - info=psb_success_ - if (present(lb1)) then + info=psb_success_ + if (present(lb1)) then lb1_ = lb1 else lb1_ = 1 endif - if (present(lb2)) then + if (present(lb2)) then lb2_ = lb2 else lb2_ = 1 @@ -408,7 +408,7 @@ Contains end if - if (allocated(rrax)) then + if (allocated(rrax)) then dim = size(rrax,1) lbi1 = lbound(rrax,1) dim2 = size(rrax,2) @@ -437,7 +437,7 @@ Contains goto 9999 end if endif - if (present(pad)) then + if (present(pad)) then rrax(lb1_-1+dim+1:lb1_-1+len1,:) = pad rrax(lb1_:lb1_-1+dim,lb2_-1+dim2+1:lb2_-1+len2) = pad endif @@ -453,7 +453,7 @@ Contains Subroutine psb_r_me_z_rk2(len1,len2,rrax,info,pad,lb1,lb2) use psb_error_mod - ! ...Subroutine Arguments + ! ...Subroutine Arguments integer(psb_mpk_),Intent(in) :: len1 integer(psb_epk_),Intent(in) :: len2 complex(psb_dpk_),allocatable :: rrax(:,:) @@ -471,13 +471,13 @@ Contains name='psb_r_me_z_rk2' call psb_erractionsave(err_act) - info=psb_success_ - if (present(lb1)) then + info=psb_success_ + if (present(lb1)) then lb1_ = lb1 else lb1_ = 1 endif - if (present(lb2)) then + if (present(lb2)) then lb2_ = lb2 else lb2_ = 1 @@ -486,7 +486,7 @@ Contains ub2_ = lb2_ + len2 -1 if (len1 < 0) then - err=4025 + err=4025 call psb_errpush(err,name, m_err=(/len1/), & & a_err='complex(psb_dpk_)') goto 9999 @@ -499,7 +499,7 @@ Contains end if - if (allocated(rrax)) then + if (allocated(rrax)) then dim = size(rrax,1) lbi1 = lbound(rrax,1) dim2 = size(rrax,2) @@ -528,7 +528,7 @@ Contains goto 9999 end if endif - if (present(pad)) then + if (present(pad)) then rrax(lb1_-1+dim+1:lb1_-1+len1,:) = pad rrax(lb1_:lb1_-1+dim,lb2_-1+dim2+1:lb2_-1+len2) = pad endif @@ -544,7 +544,7 @@ Contains Subroutine psb_r_em_z_rk2(len1,len2,rrax,info,pad,lb1,lb2) use psb_error_mod - ! ...Subroutine Arguments + ! ...Subroutine Arguments integer(psb_epk_),Intent(in) :: len1 integer(psb_mpk_),Intent(in) :: len2 complex(psb_dpk_),allocatable :: rrax(:,:) @@ -562,13 +562,13 @@ Contains name='psb_r_me_z_rk2' call psb_erractionsave(err_act) - info=psb_success_ - if (present(lb1)) then + info=psb_success_ + if (present(lb1)) then lb1_ = lb1 else lb1_ = 1 endif - if (present(lb2)) then + if (present(lb2)) then lb2_ = lb2 else lb2_ = 1 @@ -577,7 +577,7 @@ Contains ub2_ = lb2_ + len2 -1 if (len1 < 0) then - err=4025 + err=4025 call psb_errpush(err,name, e_err=(/len1/), & & a_err='complex(psb_dpk_)') goto 9999 @@ -590,7 +590,7 @@ Contains end if - if (allocated(rrax)) then + if (allocated(rrax)) then dim = size(rrax,1) lbi1 = lbound(rrax,1) dim2 = size(rrax,2) @@ -619,7 +619,7 @@ Contains goto 9999 end if endif - if (present(pad)) then + if (present(pad)) then rrax(lb1_-1+dim+1:lb1_-1+len1,:) = pad rrax(lb1_:lb1_-1+dim,lb2_-1+dim2+1:lb2_-1+len2) = pad endif @@ -635,7 +635,7 @@ Contains Subroutine psb_r_m_2_z_rk1(len,rrax,y,info,pad) use psb_error_mod - ! ...Subroutine Arguments + ! ...Subroutine Arguments integer(psb_mpk_),Intent(in) :: len complex(psb_dpk_),allocatable, intent(inout) :: rrax(:),y(:) @@ -648,7 +648,7 @@ Contains call psb_erractionsave(err_act) info=psb_success_ - if(psb_errstatus_fatal()) then + if(psb_errstatus_fatal()) then info=psb_err_from_subroutine_ goto 9999 end if @@ -676,7 +676,7 @@ Contains Subroutine psb_r_e_2_z_rk1(len,rrax,y,info,pad) use psb_error_mod - ! ...Subroutine Arguments + ! ...Subroutine Arguments integer(psb_epk_),Intent(in) :: len complex(psb_dpk_),allocatable, intent(inout) :: rrax(:),y(:) @@ -689,7 +689,7 @@ Contains call psb_erractionsave(err_act) info=psb_success_ - if(psb_errstatus_fatal()) then + if(psb_errstatus_fatal()) then info=psb_err_from_subroutine_ goto 9999 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 - ! ...Subroutine Arguments + ! ...Subroutine Arguments complex(psb_dpk_), allocatable, intent(in) :: vin complex(psb_dpk_), allocatable, intent(out) :: vout integer(psb_ipk_) :: info @@ -733,14 +733,14 @@ Contains name='psb_ab_cpy_z_s' call psb_erractionsave(err_act) info=psb_success_ - if(psb_errstatus_fatal()) then + if(psb_errstatus_fatal()) then info=psb_err_from_subroutine_ goto 9999 end if - if (allocated(vin)) then + if (allocated(vin)) then call psb_realloc(vout,info) - if (info /= psb_success_) then + if (info /= psb_success_) then info=psb_err_from_subroutine_ char_err='psb_realloc' call psb_errpush(info,name,a_err=char_err) @@ -759,38 +759,42 @@ Contains 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 - ! ...Subroutine Arguments + ! ...Subroutine Arguments complex(psb_dpk_), allocatable, intent(in) :: vin(:) complex(psb_dpk_), allocatable, intent(out) :: vout(:) integer(psb_ipk_) :: info ! ...Local Variables - integer(psb_ipk_) :: isz,err_act,lb + integer(psb_ipk_) :: isz,err_act,lb, i character(len=30) :: name, char_err logical, parameter :: debug=.false. name='psb_ab_cpy_z_rk1' call psb_erractionsave(err_act) info=psb_success_ - if(psb_errstatus_fatal()) then + if(psb_errstatus_fatal()) then info=psb_err_from_subroutine_ goto 9999 end if - if (allocated(vin)) then + if (allocated(vin)) then isz = size(vin) lb = lbound(vin,1) call psb_realloc(isz,vout,info,lb=lb) - if (info /= psb_success_) then + if (info /= psb_success_) then info=psb_err_from_subroutine_ char_err='psb_realloc' call psb_errpush(info,name,a_err=char_err) goto 9999 else - vout(:) = vin(:) + !$omp parallel do private(i) + do i=lb,lb+isz-1 + vout(i) = vin(i) + end do + !$omp end parallel do endif endif @@ -803,40 +807,42 @@ Contains 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 - ! ...Subroutine Arguments + ! ...Subroutine Arguments complex(psb_dpk_), allocatable, intent(in) :: vin(:,:) complex(psb_dpk_), allocatable, intent(out) :: vout(:,:) integer(psb_ipk_) :: info ! ...Local Variables - integer(psb_ipk_) :: isz1, isz2,err_act, lb1, lb2 + integer(psb_ipk_) :: isz1, isz2,err_act, lb1, lb2 character(len=30) :: name, char_err logical, parameter :: debug=.false. name='psb_ab_cpy_z_rk2' call psb_erractionsave(err_act) info=psb_success_ - if(psb_errstatus_fatal()) then + if(psb_errstatus_fatal()) then info=psb_err_from_subroutine_ goto 9999 end if - if (allocated(vin)) then + if (allocated(vin)) then isz1 = size(vin,1) isz2 = size(vin,2) lb1 = lbound(vin,1) lb2 = lbound(vin,2) call psb_realloc(isz1,isz2,vout,info,lb1=lb1,lb2=lb2) - if (info /= psb_success_) then + if (info /= psb_success_) then info=psb_err_from_subroutine_ char_err='psb_realloc' call psb_errpush(info,name,a_err=char_err) goto 9999 else + !$omp workshare vout(:,:) = vin(:,:) + !$omp end workshare endif endif @@ -850,10 +856,10 @@ Contains 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 - ! ...Subroutine Arguments + ! ...Subroutine Arguments complex(psb_dpk_), intent(in) :: vin(:) complex(psb_dpk_), allocatable, intent(out) :: vout(:) integer(psb_ipk_) :: info @@ -866,14 +872,14 @@ Contains name='psb_cpy_z_rk1' call psb_erractionsave(err_act) info=psb_success_ - if(psb_errstatus_fatal()) then + if(psb_errstatus_fatal()) then info=psb_err_from_subroutine_ goto 9999 end if isz = size(vin) lb = lbound(vin,1) call psb_realloc(isz,vout,info,lb=lb) - if (info /= psb_success_) then + if (info /= psb_success_) then info=psb_err_from_subroutine_ char_err='psb_realloc' call psb_errpush(info,name,a_err=char_err) @@ -891,23 +897,23 @@ Contains 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 - ! ...Subroutine Arguments + ! ...Subroutine Arguments complex(psb_dpk_), intent(in) :: vin(:,:) complex(psb_dpk_), allocatable, intent(out) :: vout(:,:) integer(psb_ipk_) :: info ! ...Local Variables - integer(psb_ipk_) :: isz1, isz2,err_act, lb1, lb2 + integer(psb_ipk_) :: isz1, isz2,err_act, lb1, lb2 character(len=30) :: name, char_err logical, parameter :: debug=.false. name='psb_safe_cpy' call psb_erractionsave(err_act) info=psb_success_ - if(psb_errstatus_fatal()) then + if(psb_errstatus_fatal()) then info=psb_err_from_subroutine_ goto 9999 end if @@ -917,7 +923,7 @@ Contains lb1 = lbound(vin,1) lb2 = lbound(vin,2) 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_ char_err='psb_realloc' call psb_errpush(info,name,a_err=char_err) @@ -940,7 +946,7 @@ Contains integer(psb_epk_) :: val complex(psb_dpk_), allocatable, intent(in) :: vin(:) - if (.not.allocated(vin)) then + if (.not.allocated(vin)) then val = 0 else val = size(vin) @@ -955,10 +961,10 @@ Contains integer(psb_ipk_) :: dim_ - if (.not.allocated(vin)) then + if (.not.allocated(vin)) then val = 0 else - if (present(dim)) then + if (present(dim)) then dim_= dim val = size(vin,dim=dim_) else @@ -970,7 +976,7 @@ Contains Subroutine psb_ensure_m_sz_z_rk1(len,v,info,pad,addsz,newsz) use psb_error_mod - ! ...Subroutine Arguments + ! ...Subroutine Arguments integer(psb_mpk_),Intent(in) :: len complex(psb_dpk_),allocatable, intent(inout) :: v(:) integer(psb_ipk_) :: info @@ -986,29 +992,11 @@ Contains call psb_erractionsave(err_act) info = psb_success_ - if (psb_errstatus_fatal()) then + if (psb_errstatus_fatal()) then info=psb_err_from_subroutine_ goto 9999 end if -!!$ If (len > psb_size(v)) Then -!!$ if (present(newsz)) then -!!$ isz = (max(len+1,newsz)) -!!$ else -!!$ if (present(addsz)) then -!!$ isz = len+max(1,addsz) -!!$ else -!!$ isz = max(len+10, int(1.25*len)) -!!$ endif -!!$ endif -!!$ -!!$ call psb_realloc(isz,v,info,pad=pad) -!!$ if (info /= psb_success_) then -!!$ info=psb_err_from_subroutine_ -!!$ call psb_errpush(info,name,a_err='psb_realloc') -!!$ goto 9999 -!!$ End If -!!$ end If isz = psb_size(v) If (len > isz) Then #if defined(OPENMP) @@ -1017,7 +1005,7 @@ Contains if (present(newsz)) then isz = max(len+1,1,newsz) else if (present(addsz)) then - isz = max(len,1,isz+addsz)) + isz = max(len,1,isz+addsz) else isz = max(len,1,int(1.25*isz)) endif @@ -1065,7 +1053,7 @@ Contains Subroutine psb_ensure_e_sz_z_rk1(len,v,info,pad,addsz,newsz) use psb_error_mod - ! ...Subroutine Arguments + ! ...Subroutine Arguments integer(psb_epk_),Intent(in) :: len complex(psb_dpk_),allocatable, intent(inout) :: v(:) integer(psb_ipk_) :: info @@ -1081,7 +1069,7 @@ Contains call psb_erractionsave(err_act) info = psb_success_ - if (psb_errstatus_fatal()) then + if (psb_errstatus_fatal()) then info=psb_err_from_subroutine_ goto 9999 end if @@ -1116,9 +1104,9 @@ Contains Subroutine psb_move_alloc_z_rk1(vin,vout,info) use psb_error_mod complex(psb_dpk_), allocatable, intent(inout) :: vin(:),vout(:) - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info + ! ! - ! info=psb_success_ call move_alloc(vin,vout) @@ -1127,9 +1115,9 @@ Contains Subroutine psb_move_alloc_z_rk2(vin,vout,info) use psb_error_mod complex(psb_dpk_), allocatable, intent(inout) :: vin(:,:),vout(:,:) - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info + ! ! - ! info=psb_success_ call move_alloc(vin,vout)