diff --git a/Changelog b/Changelog index 3d9f047f5..36a996d85 100644 --- a/Changelog +++ b/Changelog @@ -1,6 +1,12 @@ Changelog. A lot less detailed than usual, at least for past history. +2007/09/14: Second round of serial changes: merged into trunk, fixed + JAD regeneration and srch_upd now works. + +2007/09/10: First round of serial changes: implemented serial + psb_spcnv unifying multiple functionalities. + 2007/09/04: Implemented RGMRES for complex data. 2007/06/04: Fixed implementation of fctint and coins: assume size diff --git a/base/modules/psb_serial_mod.f90 b/base/modules/psb_serial_mod.f90 index 924730f65..80f292126 100644 --- a/base/modules/psb_serial_mod.f90 +++ b/base/modules/psb_serial_mod.f90 @@ -140,10 +140,45 @@ module psb_serial_mod subroutine psb_cest(afmt, m,n,nnz, lia1, lia2, lar, iup, info) integer, intent(in) :: m,n,nnz,iup integer, intent(out) :: lia1, lia2, lar, info - character, intent(inout) :: afmt*5 + character(len=*), intent(inout) :: afmt end subroutine psb_cest end interface + interface psb_spcnv + subroutine psb_dspcnv2(ain, a, info, afmt, upd, dupl) + use psb_spmat_type + type(psb_dspmat_type), intent (in) :: ain + type(psb_dspmat_type), intent (out) :: a + integer, intent(out) :: info + integer,optional, intent(in) :: dupl, upd + character(len=*), optional, intent(in) :: afmt + end subroutine psb_dspcnv2 + subroutine psb_dspcnv1(a, info, afmt, upd, dupl) + use psb_spmat_type + type(psb_dspmat_type), intent (inout) :: a + integer, intent(out) :: info + integer,optional, intent(in) :: dupl, upd + character(len=*), optional, intent(in) :: afmt + end subroutine psb_dspcnv1 + subroutine psb_zspcnv2(ain, a, info, afmt, upd, dupl) + use psb_spmat_type + type(psb_zspmat_type), intent (in) :: ain + type(psb_zspmat_type), intent (out) :: a + integer, intent(out) :: info + integer,optional, intent(in) :: dupl, upd + character(len=*), optional, intent(in) :: afmt + end subroutine psb_zspcnv2 + subroutine psb_zspcnv1(a, info, afmt, upd, dupl) + use psb_spmat_type + type(psb_zspmat_type), intent (inout) :: a + integer, intent(out) :: info + integer,optional, intent(in) :: dupl, upd + character(len=*), optional, intent(in) :: afmt + end subroutine psb_zspcnv1 + end interface + + + interface psb_fixcoo subroutine psb_dfixcoo(a,info,idir) use psb_spmat_type @@ -466,10 +501,13 @@ module psb_serial_mod module procedure imsort_u end interface interface psb_qsort - module procedure iqsort + module procedure iqsort, dqsort, zqsort end interface - integer, parameter :: psb_sort_up_=1, psb_sort_down_=-1 + integer, parameter :: psb_sort_up_=1, psb_sort_down_=-1 + integer, parameter :: psb_lsort_up_=2, psb_lsort_down_=-2 + integer, parameter :: psb_asort_up_=3, psb_asort_down_=-3 + integer, parameter :: psb_alsort_up_=4, psb_alsort_down_=-4 integer, parameter :: psb_sort_ovw_idx_=0, psb_sort_keep_idx_=1 contains @@ -587,52 +625,231 @@ contains name='psb_qsort' call psb_erractionsave(err_act) + if (present(flag)) then + flag_ = flag + else + flag_ = psb_sort_ovw_idx_ + end if + select case(flag_) + case( psb_sort_ovw_idx_, psb_sort_keep_idx_) + ! OK keep going + case default + call psb_errpush(30,name,i_err=(/4,flag_,0,0,0/)) + goto 9999 + end select + if (present(dir)) then dir_ = dir else dir_= psb_sort_up_ end if + + n = size(x) + select case(dir_) case( psb_sort_up_, psb_sort_down_) + if (present(ix)) then + if (size(ix) < n) then + call psb_errpush(35,name,i_err=(/2,size(ix),0,0,0/)) + goto 9999 + end if + + call isrx(n,x,ix,dir_,flag_) + else + call isr(n,x,dir_) + end if + + case( psb_asort_up_, psb_asort_down_) ! OK keep going + if (present(ix)) then + if (size(ix) < n) then + call psb_errpush(35,name,i_err=(/2,size(ix),0,0,0/)) + goto 9999 + end if + + call iasrx(n,x,ix,dir_,flag_) + else + call iasr(n,x,dir_) + end if + case default call psb_errpush(30,name,i_err=(/3,dir_,0,0,0/)) goto 9999 end select + + +9999 continue + if (err_act.eq.psb_act_abort_) then + call psb_error() + return + end if + end subroutine iqsort + + + subroutine dqsort(x,ix,dir,flag) + use psb_error_mod + implicit none + real(kind(1.d0)), intent(inout) :: x(:) + integer, optional, intent(in) :: dir, flag + integer, optional, intent(inout) :: ix(:) + + integer :: dir_, flag_, n, err_act + + character(len=20) :: name + + name='psb_qsort' + call psb_erractionsave(err_act) + + if (present(flag)) then + flag_ = flag + else + flag_ = psb_sort_ovw_idx_ + end if + select case(flag_) + case( psb_sort_ovw_idx_, psb_sort_keep_idx_) + ! OK keep going + case default + call psb_errpush(30,name,i_err=(/4,flag_,0,0,0/)) + goto 9999 + end select + + if (present(dir)) then + dir_ = dir + else + dir_= psb_sort_up_ + end if + n = size(x) - - if (present(ix)) then - if (size(ix) < n) then - call psb_errpush(35,name,i_err=(/2,size(ix),0,0,0/)) - goto 9999 + + select case(dir_) + case( psb_sort_up_, psb_sort_down_) + if (present(ix)) then + if (size(ix) < n) then + call psb_errpush(35,name,i_err=(/2,size(ix),0,0,0/)) + goto 9999 + end if + + call dsrx(n,x,ix,dir_,flag_) + else + call dsr(n,x,dir_) end if - if (present(flag)) then - flag_ = flag - else - flag_ = psb_sort_ovw_idx_ + + case( psb_asort_up_, psb_asort_down_) + ! OK keep going + if (present(ix)) then + if (size(ix) < n) then + call psb_errpush(35,name,i_err=(/2,size(ix),0,0,0/)) + goto 9999 + end if + + call dasrx(n,x,ix,dir_,flag_) + else + call dasr(n,x,dir_) end if - select case(flag_) - case( psb_sort_ovw_idx_, psb_sort_keep_idx_) - ! OK keep going - case default - call psb_errpush(30,name,i_err=(/4,flag_,0,0,0/)) - goto 9999 - end select + + case default + call psb_errpush(30,name,i_err=(/3,dir_,0,0,0/)) + goto 9999 + end select + + + +9999 continue + if (err_act.eq.psb_act_abort_) then + call psb_error() + return + end if + end subroutine dqsort + + + subroutine zqsort(x,ix,dir,flag) + use psb_error_mod + implicit none + complex(kind(1.d0)), intent(inout) :: x(:) + integer, optional, intent(in) :: dir, flag + integer, optional, intent(inout) :: ix(:) + + integer :: dir_, flag_, n, err_act + + character(len=20) :: name - call isrx(n,x,ix,dir_,flag_) + name='psb_qsort' + call psb_erractionsave(err_act) + + if (present(flag)) then + flag_ = flag + else + flag_ = psb_sort_ovw_idx_ + end if + select case(flag_) + case( psb_sort_ovw_idx_, psb_sort_keep_idx_) + ! OK keep going + case default + call psb_errpush(30,name,i_err=(/4,flag_,0,0,0/)) + goto 9999 + end select + + if (present(dir)) then + dir_ = dir else - call isr(n,x,dir_) + dir_= psb_lsort_up_ end if + n = size(x) + + select case(dir_) + case( psb_lsort_up_, psb_lsort_down_) + if (present(ix)) then + if (size(ix) < n) then + call psb_errpush(35,name,i_err=(/2,size(ix),0,0,0/)) + goto 9999 + end if + + call zlsrx(n,x,ix,dir_,flag_) + else + call zlsr(n,x,dir_) + end if + + case( psb_alsort_up_, psb_alsort_down_) + ! OK keep going + if (present(ix)) then + if (size(ix) < n) then + call psb_errpush(35,name,i_err=(/2,size(ix),0,0,0/)) + goto 9999 + end if + + call zalsrx(n,x,ix,dir_,flag_) + else + call zalsr(n,x,dir_) + end if + + case( psb_asort_up_, psb_asort_down_) + ! OK keep going + if (present(ix)) then + if (size(ix) < n) then + call psb_errpush(35,name,i_err=(/2,size(ix),0,0,0/)) + goto 9999 + end if + + call zasrx(n,x,ix,dir_,flag_) + else + call zasr(n,x,dir_) + end if + + case default + call psb_errpush(30,name,i_err=(/3,dir_,0,0,0/)) + goto 9999 + end select + + + 9999 continue if (err_act.eq.psb_act_abort_) then call psb_error() return end if - end subroutine iqsort - - + end subroutine zqsort end module psb_serial_mod diff --git a/base/modules/psb_spmat_type.f90 b/base/modules/psb_spmat_type.f90 index d71332529..3178a2090 100644 --- a/base/modules/psb_spmat_type.f90 +++ b/base/modules/psb_spmat_type.f90 @@ -48,25 +48,55 @@ module psb_spmat_type ! ! Entries and values for spmat%info ! - integer, parameter :: psb_nnz_=1 integer, parameter :: psb_del_bnd_=7, psb_srtd_=8 integer, parameter :: psb_state_=9 integer, parameter :: psb_upd_pnt_=10 integer, parameter :: psb_dupl_=11, psb_upd_=12 integer, parameter :: psb_ifasize_=16 + ! + ! + ! Possible matrix states. + ! + ! A sparse matrix can move between states according to the + ! following state transition table. + ! In Out Routine + ! ---------------------------------- + ! Null Build psb_sp_all + ! Build Build psb_coins + ! Build Assembeld psb_spcnv + ! Assembled Assembled psb_spcnv + ! Assembled Update psb_sp_reinit + ! Update Update psb_coins + ! Update Assembled psb_spcnv + ! * unchanged psb_sp_reall + ! Assembled Null psb_sp_free + ! + ! Note that psb_spcnv is overloaded in two flavours, + ! psb_spcnv(a,info) + ! psb_spcnv(a,b,info) + ! in the second variant, the IN state applies to A and + ! the OUT state applies to B. + ! + ! integer, parameter :: psb_spmat_null_=0, psb_spmat_bld_=1 integer, parameter :: psb_spmat_asb_=2, psb_spmat_upd_=4 + integer, parameter :: psb_ireg_flgs_=10, psb_ip2_=0 integer, parameter :: psb_iflag_=2, psb_ichk_=3 integer, parameter :: psb_nnzt_=4, psb_zero_=5,psb_ipc_=6 + ! Duplicate coefficients handling + ! These are usually set while calling spcnv as one of its + ! optional arugments. integer, parameter :: psb_dupl_ovwrt_ = 0 integer, parameter :: psb_dupl_add_ = 1 integer, parameter :: psb_dupl_err_ = 2 integer, parameter :: psb_dupl_def_ = psb_dupl_ovwrt_ - integer, parameter :: psb_upd_dflt_ = 0 + ! Matrix update mode integer, parameter :: psb_upd_srch_ = 98764 integer, parameter :: psb_upd_perm_ = 98765 + integer, parameter :: psb_upd_dflt_ = psb_upd_srch_ + ! Mark a COO matrix with sorted entries. integer, parameter :: psb_isrtdcoo_ = 98761 integer, parameter :: psb_maxjdrows_=8, psb_minjdrows_=4 integer, parameter :: psb_dbleint_=2 @@ -379,8 +409,9 @@ contains a%fida = 'COO' a%descra = 'GUN' a%infoa(:) = 0 - a%m = 0 - a%k = 0 + a%infoa(psb_state_) = psb_spmat_bld_ + a%m = 0 + a%k = 0 if (debug) write(0,*) 'SPALL : end' Return @@ -412,6 +443,7 @@ contains a%fida = 'COO' a%descra = 'GUN' a%infoa(:) = 0 + a%infoa(psb_state_) = psb_spmat_bld_ if (debug) write(0,*) 'SPALL : end' Return @@ -445,6 +477,7 @@ contains a%fida = 'COO' a%descra = 'GUN' a%infoa(:) = 0 + a%infoa(psb_state_) = psb_spmat_bld_ if (debug) write(0,*) 'spall : end' return @@ -471,6 +504,7 @@ contains a%fida = 'COO' a%descra = 'GUN' a%infoa(:) = 0 + a%infoa(psb_state_) = psb_spmat_bld_ a%m = 0 a%k = 0 if (debug) write(0,*) 'SPALL : end' @@ -718,18 +752,18 @@ contains ia = size(a%aspk) return endif - select case(toupper(a%fida)) - case('CSR') + select case(tolower(a%fida)) + case('csr') nza = a%ia2(a%m+1)-1 ia = nza i1 = nza i2 = a%m + 1 - case('COO') + case('coo','coi') nza = a%infoa(psb_nnz_) i1 = nza i2 = nza ia = nza - case('JAD') + case('jad') ! Feeling lazy today i1 = size(a%ia1) i2 = size(a%ia2) @@ -936,6 +970,7 @@ contains a%fida = 'COO' a%descra = 'GUN' a%infoa(:) = 0 + a%infoa(psb_state_) = psb_spmat_bld_ a%m = 0 a%k = 0 if (debug) write(0,*) 'SPALL : end' @@ -969,6 +1004,7 @@ contains a%fida = 'COO' a%descra = 'GUN' a%infoa(:) = 0 + a%infoa(psb_state_) = psb_spmat_bld_ if (debug) write(0,*) 'SPALL : end' Return @@ -1002,6 +1038,7 @@ contains a%fida = 'COO' a%descra = 'GUN' a%infoa(:) = 0 + a%infoa(psb_state_) = psb_spmat_bld_ if (debug) write(0,*) 'spall : end' return @@ -1029,6 +1066,7 @@ contains a%fida = 'COO' a%descra = 'GUN' a%infoa(:) = 0 + a%infoa(psb_state_) = psb_spmat_bld_ a%m = 0 a%k = 0 if (debug) write(0,*) 'SPALL : end' @@ -1222,18 +1260,18 @@ contains ia = size(a%aspk) return endif - select case(toupper(a%fida)) - case('CSR') + select case(tolower(a%fida)) + case('csr') nza = a%ia2(a%m+1)-1 ia = nza i1 = nza i2 = a%m + 1 - case('COO') + case('coo','coi') nza = a%infoa(psb_nnz_) i1 = nza i2 = nza ia = nza - case('JAD') + case('jad') ! Feeling lazy today i1 = size(a%ia1) i2 = size(a%ia2) diff --git a/base/modules/psb_tools_mod.f90 b/base/modules/psb_tools_mod.f90 index 6d9280f92..7e0f3af4a 100644 --- a/base/modules/psb_tools_mod.f90 +++ b/base/modules/psb_tools_mod.f90 @@ -31,6 +31,7 @@ Module psb_tools_mod use psb_const_mod use psb_gps_mod + use psb_spmat_type interface psb_geall ! 2-D double precision version @@ -447,7 +448,7 @@ Module psb_tools_mod type(psb_desc_type), intent(in) :: desc_a integer, intent(out) :: info integer,optional, intent(in) :: dupl, upd - character, optional, intent(in) :: afmt*5 + character(len=*), optional, intent(in) :: afmt end subroutine psb_dspasb subroutine psb_zspasb(a,desc_a, info, afmt, upd, dupl) use psb_descriptor_type @@ -456,32 +457,33 @@ Module psb_tools_mod type(psb_desc_type), intent(in) :: desc_a integer, intent(out) :: info integer,optional, intent(in) :: dupl, upd - character, optional, intent(in) :: afmt*5 + character(len=*), optional, intent(in) :: afmt end subroutine psb_zspasb end interface - interface psb_spcnv - subroutine psb_dspcnv(a,b,desc_a,info) - use psb_descriptor_type - use psb_spmat_type - type(psb_dspmat_type), intent(in) :: a - type(psb_dspmat_type), intent(out) :: b - type(psb_desc_type), intent(in) :: desc_a - integer, intent(out) :: info - end subroutine psb_dspcnv - subroutine psb_zspcnv(a,b,desc_a,info) - use psb_descriptor_type - use psb_spmat_type - type(psb_zspmat_type), intent(in) :: a - type(psb_zspmat_type), intent(out) :: b - type(psb_desc_type), intent(in) :: desc_a - integer, intent(out) :: info - end subroutine psb_zspcnv - end interface +!!$ interface psb_spcnv +!!$ subroutine psb_dspcnv(a,b,desc_a,info) +!!$ use psb_descriptor_type +!!$ use psb_spmat_type +!!$ type(psb_dspmat_type), intent(in) :: a +!!$ type(psb_dspmat_type), intent(out) :: b +!!$ type(psb_desc_type), intent(in) :: desc_a +!!$ integer, intent(out) :: info +!!$ end subroutine psb_dspcnv +!!$ subroutine psb_zspcnv(a,b,desc_a,info) +!!$ use psb_descriptor_type +!!$ use psb_spmat_type +!!$ type(psb_zspmat_type), intent(in) :: a +!!$ type(psb_zspmat_type), intent(out) :: b +!!$ type(psb_desc_type), intent(in) :: desc_a +!!$ integer, intent(out) :: info +!!$ end subroutine psb_zspcnv +!!$ end interface interface psb_spfree + module procedure psb_dsp_free, psb_zsp_free subroutine psb_dspfree(a, desc_a,info) use psb_descriptor_type use psb_spmat_type diff --git a/base/serial/Makefile b/base/serial/Makefile index c4c0e6fd0..b5130cd22 100644 --- a/base/serial/Makefile +++ b/base/serial/Makefile @@ -1,14 +1,14 @@ include ../../Make.inc -FOBJS = psb_cest.o psb_dcoins.o psb_dcsdp.o psb_dcsmm.o psb_dcsmv.o \ +FOBJS = psb_cest.o psb_dcoins.o psb_dcsmm.o psb_dcsmv.o \ psb_dcsnmi.o psb_dcsprt.o psb_dcsrws.o psb_dcssm.o psb_dcssv.o \ psb_dfixcoo.o psb_dipcoo2csr.o psb_dipcsr2coo.o psb_dneigh.o \ psb_dnumbmm.o psb_drwextd.o psb_dspgtdiag.o psb_dspgtblk.o \ - psb_dspscal.o psb_dsymbmm.o psb_dtransp.o psb_dspclip.o\ - psb_dipcoo2csc.o psb_dspgetrow.o lsame.o psb_zspgetrow.o\ + psb_dspscal.o psb_dsymbmm.o psb_dtransp.o psb_dspclip.o psb_dspcnv.o\ + psb_regen_mod.o psb_dipcoo2csc.o psb_dspgetrow.o lsame.o psb_zspgetrow.o\ psb_zcsmm.o psb_zcsmv.o psb_zspgtdiag.o psb_zspgtblk.o\ - psb_zcsnmi.o psb_zcsrws.o psb_zcssm.o psb_zcssv.o psb_zcsdp.o\ + psb_zcsnmi.o psb_zcsrws.o psb_zcssm.o psb_zcssv.o psb_zspcnv.o\ psb_zfixcoo.o psb_zipcoo2csr.o psb_zipcsr2coo.o psb_zipcoo2csc.o \ psb_zcoins.o psb_zcsprt.o psb_zneigh.o psb_ztransp.o psb_ztransc.o\ psb_zrwextd.o psb_zsymbmm.o psb_znumbmm.o psb_zspscal.o psb_zspclip.o\ @@ -26,7 +26,8 @@ lib: auxd cood csrd jadd f77d dpd lib1 lib1: $(FOBJS) psb_dcoins.o psb_zcoins.o: psb_update_mod.o -psb_dspgetrow.o: psb_getrow_mod.o +psb_dspgetrow.o psb_zspgetrow.o: psb_getrow_mod.o +psb_dspcnv.o pzb_zspcnv.o: psb_regen_mod.o auxd: (cd aux; make lib) diff --git a/base/serial/aux/Makefile b/base/serial/aux/Makefile index 10938cf73..cf8243aa1 100644 --- a/base/serial/aux/Makefile +++ b/base/serial/aux/Makefile @@ -3,8 +3,12 @@ include ../../../Make.inc # The object files # -FOBJS = isr.o isrx.o msort_up.o msort_dw.o\ - isaperm.o ibsrch.o issrch.o imsr.o imsrx.o imsru.o +FOBJS = isr.o isrx.o iasr.o iasrx.o msort_up.o msort_dw.o\ + isaperm.o ibsrch.o issrch.o imsr.o imsrx.o imsru.o\ + dsr.o dsrx.o dasr.o dasrx.o \ + zlcmp_mod.o zlsr.o zlsrx.o \ + zalcmp_mod.o zalsr.o zalsrx.o \ + zacmp_mod.o zasr.o zasrx.o OBJS=$(FOBJS) @@ -26,9 +30,12 @@ default: lib lib: $(OBJS) $(AR) $(LIBDIR)/$(LIBNAME) $(OBJS) $(RANLIB) $(LIBDIR)/$(LIBNAME) +zlsr.o zlsrx.o: zlcmp_mod.o +zalsr.o zalsrx.o: zalcmp_mod.o +zasr.o zasrx.o: zacmp_mod.o clean: - /bin/rm -f $(OBJS) + /bin/rm -f $(OBJS) *$(.mod) veryclean: clean diff --git a/base/serial/aux/dasr.f90 b/base/serial/aux/dasr.f90 new file mode 100644 index 000000000..f0581efd3 --- /dev/null +++ b/base/serial/aux/dasr.f90 @@ -0,0 +1,361 @@ +!!$ +!!$ Parallel Sparse BLAS v2.0 +!!$ (C) Copyright 2006 Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari University of Rome Tor Vergata +!!$ +!!$ Redistribution and use in source and binary forms, with or without +!!$ modification, are permitted provided that the following conditions +!!$ are met: +!!$ 1. Redistributions of source code must retain the above copyright +!!$ notice, this list of conditions and the following disclaimer. +!!$ 2. Redistributions in binary form must reproduce the above copyright +!!$ notice, this list of conditions, and the following disclaimer in the +!!$ documentation and/or other materials provided with the distribution. +!!$ 3. The name of the PSBLAS group or the names of its contributors may +!!$ not be used to endorse or promote products derived from this +!!$ software without specific written permission. +!!$ +!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +!!$ POSSIBILITY OF SUCH DAMAGE. +!!$ +!!$ + +subroutine dasr(n,x,dir) + use psb_serial_mod + implicit none + ! + ! Quicksort on absolute value. + ! Adapted from a number of sources, including Don Knuth's TAOCP. + ! + ! .. Scalar Arguments .. + integer, intent(in) :: n, dir + real(kind(1.d0)) :: x(n) + ! .. + ! .. Local Scalars .. + real(kind(1.d0)) :: xx, piv, xt, xk + integer i, j, ilx, iux, istp, lpiv + integer n1, n2 + + integer, parameter :: maxstack=64,nparms=3,ithrs=16 + integer :: istack(nparms,maxstack) + ! .. + + ! + ! small inputs will only get through insertion sort. + ! + select case(dir) + + case(psb_asort_up_) + + if (n > ithrs) then + ! + ! Init stack pointer + ! + istp = 1 + istack(1,istp) = 1 + istack(2,istp) = n + + do + if (istp <= 0) exit + ilx = istack(1,istp) + iux = istack(2,istp) + istp = istp - 1 + !$$$ write(0,*) 'Debug 1: ',ilx,iux + ! + ! Choose a pivot with median-of-three heuristics, leave it + ! in the LPIV location + ! + i = ilx + j = iux + lpiv = (i+j)/2 + piv = abs(x(lpiv)) + if (piv < abs(x(i))) then + xt = x(i) + x(i) = x(lpiv) + x(lpiv) = xt + piv = abs(x(lpiv)) + endif + if (piv > abs(x(j))) then + xt = x(j) + x(j) = x(lpiv) + x(lpiv) = xt + piv = abs(x(lpiv)) + endif + if (piv < abs(x(i))) then + xt = x(i) + x(i) = x(lpiv) + x(lpiv) = xt + piv = abs(x(lpiv)) + endif + ! + ! now piv is correct; place it into first location + + xt = x(i) + x(i) = x(lpiv) + x(lpiv) = xt + + i = ilx - 1 + j = iux + 1 + + outer_up: do + in_up1: do + i = i + 1 + xk = abs(x(i)) + if (xk >= piv) exit in_up1 + end do in_up1 + ! + ! Ensure finite termination for next loop + ! + xt = x(i) + x(i) = piv + in_up2:do + j = j - 1 + xk = abs(x(j)) + if (xk <= piv) exit in_up2 + end do in_up2 + x(i) = xt + + if (j > i) then + xt = x(i) + x(i) = x(j) + x(j) = xt + else + exit outer_up + end if + end do outer_up + if (i == ilx) then + if (x(i) /= piv) then + write(0,*) 'Should never ever get here????!!!!' + stop + endif + i = i + 1 + endif + + n1 = (i-1)-ilx+1 + n2 = iux-(i)+1 + if (n1 > n2) then + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call disr_up(n1,x(ilx:i-1)) + endif + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call disr_up(n2,x(i:iux)) + endif + else + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call disr_up(n2,x(i:iux)) + endif + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call disr_up(n1,x(ilx:i-1)) + endif + endif + enddo + else + call disr_up(n,x) + endif + + case(psb_asort_down_) + + + if (n > ithrs) then + ! + ! Init stack pointer + ! + istp = 1 + istack(1,istp) = 1 + istack(2,istp) = n + + do + if (istp <= 0) exit + ilx = istack(1,istp) + iux = istack(2,istp) + istp = istp - 1 + !$$$ write(0,*) 'Debug 1: ',ilx,iux + ! + ! Choose a pivot with median-of-three heuristics, leave it + ! in the LPIV location + ! + i = ilx + j = iux + lpiv = (i+j)/2 + piv = abs(x(lpiv)) + if (piv > abs(x(i))) then + xt = x(i) + x(i) = x(lpiv) + x(lpiv) = xt + piv = abs(x(lpiv)) + endif + if (piv < abs(x(j))) then + xt = x(j) + x(j) = x(lpiv) + x(lpiv) = xt + piv = abs(x(lpiv)) + endif + if (piv > abs(x(i))) then + xt = x(i) + x(i) = x(lpiv) + x(lpiv) = xt + piv = abs(x(lpiv)) + endif + ! + ! now piv is correct; place it into first location + + xt = x(i) + x(i) = x(lpiv) + x(lpiv) = xt + + i = ilx - 1 + j = iux + 1 + + outer_dw: do + in_dw1: do + i = i + 1 + xk = abs(x(i)) + if (xk <= piv) exit in_dw1 + end do in_dw1 + ! + ! Ensure finite termination for next loop + ! + xt = x(i) + x(i) = piv + in_dw2:do + j = j - 1 + xk = abs(x(j)) + if (xk >= piv) exit in_dw2 + end do in_dw2 + x(i) = xt + + if (j > i) then + xt = x(i) + x(i) = x(j) + x(j) = xt + else + exit outer_dw + end if + end do outer_dw + if (i == ilx) then + if (x(i) /= piv) then + write(0,*) 'Should never ever get here????!!!!' + stop + endif + i = i + 1 + endif + + n1 = (i-1)-ilx+1 + n2 = iux-(i)+1 + if (n1 > n2) then + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call disr_dw(n1,x(ilx:i-1)) + endif + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call disr_dw(n2,x(i:iux)) + endif + else + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call disr_dw(n2,x(i:iux)) + endif + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call disr_dw(n1,x(ilx:i-1)) + endif + endif + enddo + else + call disr_dw(n,x) + endif + + case default + write(0,*) 'isr error !',dir + end select + + + return + +contains + + subroutine disr_up(n,x) + implicit none + integer :: n + real(kind(1.d0)) :: x(n) + integer :: i,j + real(kind(1.d0)) :: xx,xax + + do j=n-1,1,-1 + if (abs(x(j+1)) < abs(x(j))) then + xx = x(j) + xax = abs(xx) + i=j+1 + do + x(i-1) = x(i) + i = i+1 + if (i>n) exit + if (abs(x(i)) >= xax) exit + end do + x(i-1) = xx + endif + enddo + end subroutine disr_up + + subroutine disr_dw(n,x) + implicit none + integer :: n + real(kind(1.d0)) :: x(n) + integer :: i,j + real(kind(1.d0)) :: xx,xax + + do j=n-1,1,-1 + if (abs(x(j+1)) > abs(x(j))) then + xx = x(j) + xax = abs(xx) + i=j+1 + do + x(i-1) = x(i) + i = i+1 + if (i>n) exit + if (abs(x(i)) <= xax) exit + end do + x(i-1) = xx + endif + enddo + end subroutine disr_dw + +end subroutine dasr diff --git a/base/serial/aux/dasrx.f90 b/base/serial/aux/dasrx.f90 new file mode 100644 index 000000000..ddfb1ef87 --- /dev/null +++ b/base/serial/aux/dasrx.f90 @@ -0,0 +1,409 @@ +!!$ +!!$ Parallel Sparse BLAS v2.0 +!!$ (C) Copyright 2006 Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari University of Rome Tor Vergata +!!$ +!!$ Redistribution and use in source and binary forms, with or without +!!$ modification, are permitted provided that the following conditions +!!$ are met: +!!$ 1. Redistributions of source code must retain the above copyright +!!$ notice, this list of conditions and the following disclaimer. +!!$ 2. Redistributions in binary form must reproduce the above copyright +!!$ notice, this list of conditions, and the following disclaimer in the +!!$ documentation and/or other materials provided with the distribution. +!!$ 3. The name of the PSBLAS group or the names of its contributors may +!!$ not be used to endorse or promote products derived from this +!!$ software without specific written permission. +!!$ +!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +!!$ POSSIBILITY OF SUCH DAMAGE. +!!$ +!!$ +subroutine dasrx(n,x,indx,dir,flag) + use psb_serial_mod + implicit none + ! + ! Quicksort on absolute value with indices into original positions. + ! Adapted from a number of sources, including Don Knuth's TAOCP. + ! + ! .. Scalar Arguments .. + integer, intent(in) :: n, dir, flag + real(kind(1.d0)) :: x(n) + integer :: indx(n) + ! .. + ! .. Local Scalars .. + real(kind(1.d0)) :: xx, piv, xt, xk + integer i, j, ii, ilx, iux, istp, lpiv + integer ixt, n1, n2 + + integer, parameter :: maxstack=64,nparms=3,ithrs=16 + integer :: istack(nparms,maxstack) + ! .. + + select case(flag) + case(psb_sort_ovw_idx_) + do i=1, n + indx(i) = i + enddo + case(psb_sort_keep_idx_) + ! do nothing + case default + write(0,*) 'Error in isrx: invalid flag',flag + end select + ! + + ! + ! small inputs will only get through insertion sort. + ! + select case(dir) + + case(psb_asort_up_) + + if (n > ithrs) then + ! + ! Init stack pointer + ! + istp = 1 + istack(1,istp) = 1 + istack(2,istp) = n + + do + if (istp <= 0) exit + ilx = istack(1,istp) + iux = istack(2,istp) + istp = istp - 1 + !$$$ write(0,*) 'Debug 1: ',ilx,iux + ! + ! Choose a pivot with median-of-three heuristics, leave it + ! in the LPIV location + ! + i = ilx + j = iux + lpiv = (i+j)/2 + piv = abs(x(lpiv)) + if (piv < abs(x(i))) then + xt = x(i) + ixt = indx(i) + x(i) = x(lpiv) + indx(i) = indx(lpiv) + x(lpiv) = xt + indx(lpiv) = ixt + piv = abs(x(lpiv)) + endif + if (piv > abs(x(j))) then + xt = x(j) + ixt = indx(j) + x(j) = x(lpiv) + indx(j) = indx(lpiv) + x(lpiv) = xt + indx(lpiv) = ixt + piv = abs(x(lpiv)) + endif + if (piv < abs(x(i))) then + xt = x(i) + ixt = indx(i) + x(i) = x(lpiv) + indx(i) = indx(lpiv) + x(lpiv) = xt + indx(lpiv) = ixt + piv = abs(x(lpiv)) + endif + ! + ! now piv is correct; place it into first location + xt = x(i) + ixt = indx(i) + x(i) = x(lpiv) + indx(i) = indx(lpiv) + x(lpiv) = xt + indx(lpiv) = ixt + + i = ilx - 1 + j = iux + 1 + + outer_up: do + in_up1: do + i = i + 1 + xk = abs(x(i)) + if (xk >= piv) exit in_up1 + end do in_up1 + ! + ! Ensure finite termination for next loop + ! + xt = x(i) + x(i) = piv + in_up2:do + j = j - 1 + xk = abs(x(j)) + if (xk <= piv) exit in_up2 + end do in_up2 + x(i) = xt + + if (j > i) then + xt = x(i) + ixt = indx(i) + x(i) = x(j) + indx(i) = indx(j) + x(j) = xt + indx(j) = ixt + else + exit outer_up + end if + end do outer_up + if (i == ilx) then + if (x(i) /= piv) then + write(0,*) 'Should never ever get here????!!!!' + stop + endif + i = i + 1 + endif + + n1 = (i-1)-ilx+1 + n2 = iux-(i)+1 + if (n1 > n2) then + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call idasrx_up(n1,x(ilx:i-1),indx(ilx:i-1)) + endif + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call idasrx_up(n2,x(i:iux),indx(i:iux)) + endif + else + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call idasrx_up(n2,x(i:iux),indx(i:iux)) + endif + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call idasrx_up(n1,x(ilx:i-1),indx(ilx:i-1)) + endif + endif + enddo + else + call idasrx_up(n,x,indx) + endif + + case(psb_asort_down_) + + + if (n > ithrs) then + ! + ! Init stack pointer + ! + istp = 1 + istack(1,istp) = 1 + istack(2,istp) = n + + do + if (istp <= 0) exit + ilx = istack(1,istp) + iux = istack(2,istp) + istp = istp - 1 + !$$$ write(0,*) 'Debug 1: ',ilx,iux + ! + ! Choose a pivot with median-of-three heuristics, leave it + ! in the LPIV location + ! + i = ilx + j = iux + lpiv = (i+j)/2 + piv = abs(x(lpiv)) + if (piv > abs(x(i))) then + xt = x(i) + ixt = indx(i) + x(i) = x(lpiv) + indx(i) = indx(lpiv) + x(lpiv) = xt + indx(lpiv) = ixt + piv = abs(x(lpiv)) + endif + if (piv < abs(x(j))) then + xt = x(j) + ixt = indx(j) + x(j) = x(lpiv) + indx(j) = indx(lpiv) + x(lpiv) = xt + indx(lpiv) = ixt + piv = abs(x(lpiv)) + endif + if (piv > abs(x(i))) then + xt = x(i) + ixt = indx(i) + x(i) = x(lpiv) + indx(i) = indx(lpiv) + x(lpiv) = xt + indx(lpiv) = ixt + piv = abs(x(lpiv)) + endif + ! + ! now piv is correct; place it into first location + xt = x(i) + ixt = indx(i) + x(i) = x(lpiv) + indx(i) = indx(lpiv) + x(lpiv) = xt + indx(lpiv) = ixt + + i = ilx - 1 + j = iux + 1 + + outer_dw: do + in_dw1: do + i = i + 1 + xk = abs(x(i)) + if (xk <= piv) exit in_dw1 + end do in_dw1 + ! + ! Ensure finite termination for next loop + ! + xt = x(i) + x(i) = piv + in_dw2:do + j = j - 1 + xk = abs(x(j)) + if (xk >= piv) exit in_dw2 + end do in_dw2 + x(i) = xt + + if (j > i) then + xt = x(i) + ixt = indx(i) + x(i) = x(j) + indx(i) = indx(j) + x(j) = xt + indx(j) = ixt + else + exit outer_dw + end if + end do outer_dw + if (i == ilx) then + if (x(i) /= piv) then + write(0,*) 'Should never ever get here????!!!!' + stop + endif + i = i + 1 + endif + + n1 = (i-1)-ilx+1 + n2 = iux-(i)+1 + if (n1 > n2) then + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call idasrx_dw(n1,x(ilx:i-1),indx(ilx:i-1)) + endif + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call idasrx_dw(n2,x(i:iux),indx(i:iux)) + endif + else + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call idasrx_dw(n2,x(i:iux),indx(i:iux)) + endif + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call idasrx_dw(n1,x(ilx:i-1),indx(ilx:i-1)) + endif + endif + enddo + else + call idasrx_dw(n,x,indx) + endif + + case default + write(0,*) 'isrx error dir ',dir + end select + + + return + +contains + + subroutine idasrx_up(n,x,indx) + implicit none + integer :: n + real(kind(1.d0)) :: x(n) + integer :: indx(n) + integer :: i,j,ix + real(kind(1.d0)) :: xx,xax + + do j=n-1,1,-1 + if (abs(x(j+1)) < abs(x(j))) then + xx = x(j) + ix = indx(j) + xax = abs(xx) + i=j+1 + do + x(i-1) = x(i) + indx(i-1) = indx(i) + i = i+1 + if (i>n) exit + if (abs(x(i)) >= xax) exit + end do + x(i-1) = xx + indx(i-1) = ix + endif + enddo + end subroutine idasrx_up + + subroutine idasrx_dw(n,x,indx) + implicit none + integer :: n + real(kind(1.d0)) :: x(n) + integer :: indx(n) + integer :: i,j,ix + real(kind(1.d0)) :: xx,xax + + do j=n-1,1,-1 + if (abs(x(j+1)) > abs(x(j))) then + xx = x(j) + ix = indx(j) + xax = abs(xx) + i=j+1 + do + x(i-1) = x(i) + indx(i-1) = indx(i) + i = i+1 + if (i>n) exit + if (abs(x(i)) <= xax) exit + end do + x(i-1) = xx + indx(i-1) = ix + endif + enddo + end subroutine idasrx_dw + +end subroutine dasrx diff --git a/base/serial/aux/dsr.f90 b/base/serial/aux/dsr.f90 new file mode 100644 index 000000000..d8a352e7c --- /dev/null +++ b/base/serial/aux/dsr.f90 @@ -0,0 +1,359 @@ +!!$ +!!$ Parallel Sparse BLAS v2.0 +!!$ (C) Copyright 2006 Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari University of Rome Tor Vergata +!!$ +!!$ Redistribution and use in source and binary forms, with or without +!!$ modification, are permitted provided that the following conditions +!!$ are met: +!!$ 1. Redistributions of source code must retain the above copyright +!!$ notice, this list of conditions and the following disclaimer. +!!$ 2. Redistributions in binary form must reproduce the above copyright +!!$ notice, this list of conditions, and the following disclaimer in the +!!$ documentation and/or other materials provided with the distribution. +!!$ 3. The name of the PSBLAS group or the names of its contributors may +!!$ not be used to endorse or promote products derived from this +!!$ software without specific written permission. +!!$ +!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +!!$ POSSIBILITY OF SUCH DAMAGE. +!!$ +!!$ + +subroutine dsr(n,x,dir) + use psb_serial_mod + implicit none + ! + ! Quicksort. + ! Adapted from a number of sources, including Don Knuth's TAOCP. + ! + ! .. Scalar Arguments .. + integer, intent(in) :: n, dir + real(kind(1.d0)) :: x(n) + ! .. + ! .. Local Scalars .. + real(kind(1.d0)) :: xx, piv, xt, xk + integer i, j, ilx, iux, istp, lpiv + integer n1, n2 + + integer, parameter :: maxstack=64,nparms=3,ithrs=16 + integer :: istack(nparms,maxstack) + ! .. + + ! + ! small inputs will only get through insertion sort. + ! + select case(dir) + + case(psb_sort_up_) + + if (n > ithrs) then + ! + ! Init stack pointer + ! + istp = 1 + istack(1,istp) = 1 + istack(2,istp) = n + + do + if (istp <= 0) exit + ilx = istack(1,istp) + iux = istack(2,istp) + istp = istp - 1 + !$$$ write(0,*) 'Debug 1: ',ilx,iux + ! + ! Choose a pivot with median-of-three heuristics, leave it + ! in the LPIV location + ! + i = ilx + j = iux + lpiv = (i+j)/2 + piv = x(lpiv) + if (piv < x(i)) then + xt = x(i) + x(i) = x(lpiv) + x(lpiv) = xt + piv = x(lpiv) + endif + if (piv > x(j)) then + xt = x(j) + x(j) = x(lpiv) + x(lpiv) = xt + piv = x(lpiv) + endif + if (piv < x(i)) then + xt = x(i) + x(i) = x(lpiv) + x(lpiv) = xt + piv = x(lpiv) + endif + ! + ! now piv is correct; place it into first location + + xt = x(i) + x(i) = x(lpiv) + x(lpiv) = xt + + i = ilx - 1 + j = iux + 1 + + outer_up: do + in_up1: do + i = i + 1 + xk = x(i) + if (xk >= piv) exit in_up1 + end do in_up1 + ! + ! Ensure finite termination for next loop + ! + xt = xk + x(i) = piv + in_up2:do + j = j - 1 + xk = x(j) + if (xk <= piv) exit in_up2 + end do in_up2 + x(i) = xt + + if (j > i) then + xt = x(i) + x(i) = x(j) + x(j) = xt + else + exit outer_up + end if + end do outer_up + if (i == ilx) then + if (x(i) /= piv) then + write(0,*) 'Should never ever get here????!!!!' + stop + endif + i = i + 1 + endif + + n1 = (i-1)-ilx+1 + n2 = iux-(i)+1 + if (n1 > n2) then + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call disr_up(n1,x(ilx:i-1)) + endif + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call disr_up(n2,x(i:iux)) + endif + else + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call disr_up(n2,x(i:iux)) + endif + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call disr_up(n1,x(ilx:i-1)) + endif + endif + enddo + else + call disr_up(n,x) + endif + + case(psb_sort_down_) + + + if (n > ithrs) then + ! + ! Init stack pointer + ! + istp = 1 + istack(1,istp) = 1 + istack(2,istp) = n + + do + if (istp <= 0) exit + ilx = istack(1,istp) + iux = istack(2,istp) + istp = istp - 1 + !$$$ write(0,*) 'Debug 1: ',ilx,iux + ! + ! Choose a pivot with median-of-three heuristics, leave it + ! in the LPIV location + ! + i = ilx + j = iux + lpiv = (i+j)/2 + piv = x(lpiv) + if (piv > x(i)) then + xt = x(i) + x(i) = x(lpiv) + x(lpiv) = xt + piv = x(lpiv) + endif + if (piv < x(j)) then + xt = x(j) + x(j) = x(lpiv) + x(lpiv) = xt + piv = x(lpiv) + endif + if (piv > x(i)) then + xt = x(i) + x(i) = x(lpiv) + x(lpiv) = xt + piv = x(lpiv) + endif + ! + ! now piv is correct; place it into first location + + xt = x(i) + x(i) = x(lpiv) + x(lpiv) = xt + + i = ilx - 1 + j = iux + 1 + + outer_dw: do + in_dw1: do + i = i + 1 + xk = x(i) + if (xk <= piv) exit in_dw1 + end do in_dw1 + ! + ! Ensure finite termination for next loop + ! + xt = xk + x(i) = piv + in_dw2:do + j = j - 1 + xk = x(j) + if (xk >= piv) exit in_dw2 + end do in_dw2 + x(i) = xt + + if (j > i) then + xt = x(i) + x(i) = x(j) + x(j) = xt + else + exit outer_dw + end if + end do outer_dw + if (i == ilx) then + if (x(i) /= piv) then + write(0,*) 'Should never ever get here????!!!!' + stop + endif + i = i + 1 + endif + + n1 = (i-1)-ilx+1 + n2 = iux-(i)+1 + if (n1 > n2) then + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call disr_dw(n1,x(ilx:i-1)) + endif + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call disr_dw(n2,x(i:iux)) + endif + else + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call disr_dw(n2,x(i:iux)) + endif + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call disr_dw(n1,x(ilx:i-1)) + endif + endif + enddo + else + call disr_dw(n,x) + endif + + case default + write(0,*) 'isr error !',dir + end select + + + return + +contains + + subroutine disr_up(n,x) + implicit none + integer :: n + real(kind(1.d0)) :: x(n) + integer :: i,j + real(kind(1.d0)) :: xx + + do j=n-1,1,-1 + if (x(j+1) < x(j)) then + xx = x(j) + i=j+1 + do + x(i-1) = x(i) + i = i+1 + if (i>n) exit + if (x(i) >= xx) exit + end do + x(i-1) = xx + endif + enddo + end subroutine disr_up + + subroutine disr_dw(n,x) + implicit none + integer :: n + real(kind(1.d0)) :: x(n) + integer :: i,j + real(kind(1.d0)) :: xx + + do j=n-1,1,-1 + if (x(j+1) > x(j)) then + xx = x(j) + i=j+1 + do + x(i-1) = x(i) + i = i+1 + if (i>n) exit + if (x(i) <= xx) exit + end do + x(i-1) = xx + endif + enddo + end subroutine disr_dw + +end subroutine dsr diff --git a/base/serial/aux/dsrx.f90 b/base/serial/aux/dsrx.f90 new file mode 100644 index 000000000..e56228b5c --- /dev/null +++ b/base/serial/aux/dsrx.f90 @@ -0,0 +1,409 @@ +!!$ +!!$ Parallel Sparse BLAS v2.0 +!!$ (C) Copyright 2006 Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari University of Rome Tor Vergata +!!$ +!!$ Redistribution and use in source and binary forms, with or without +!!$ modification, are permitted provided that the following conditions +!!$ are met: +!!$ 1. Redistributions of source code must retain the above copyright +!!$ notice, this list of conditions and the following disclaimer. +!!$ 2. Redistributions in binary form must reproduce the above copyright +!!$ notice, this list of conditions, and the following disclaimer in the +!!$ documentation and/or other materials provided with the distribution. +!!$ 3. The name of the PSBLAS group or the names of its contributors may +!!$ not be used to endorse or promote products derived from this +!!$ software without specific written permission. +!!$ +!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +!!$ POSSIBILITY OF SUCH DAMAGE. +!!$ +!!$ +subroutine dsrx(n,x,indx,dir,flag) + use psb_serial_mod + implicit none + ! + ! Quicksort with indices into original positions. + ! Adapted from a number of sources, including Don Knuth's TAOCP. + ! + ! .. Scalar Arguments .. + integer, intent(in) :: n, dir, flag + real(kind(1.d0)) :: x(n) + integer :: indx(n) + ! .. + ! .. Local Scalars .. + real(kind(1.d0)) :: xx, piv, xk, xt + integer i, j, ii, ilx, iux, istp, lpiv + integer ixt, n1, n2 + + integer, parameter :: maxstack=64,nparms=3,ithrs=16 + integer :: istack(nparms,maxstack) + ! .. + + select case(flag) + case(psb_sort_ovw_idx_) + do i=1, n + indx(i) = i + enddo + case(psb_sort_keep_idx_) + ! do nothing + case default + write(0,*) 'Error in isrx: invalid flag',flag + end select + ! + + ! + ! small inputs will only get through insertion sort. + ! + select case(dir) + + case(psb_sort_up_) + + if (n > ithrs) then + ! + ! Init stack pointer + ! + istp = 1 + istack(1,istp) = 1 + istack(2,istp) = n + + do + if (istp <= 0) exit + ilx = istack(1,istp) + iux = istack(2,istp) + istp = istp - 1 + !$$$ write(0,*) 'Debug 1: ',ilx,iux + ! + ! Choose a pivot with median-of-three heuristics, leave it + ! in the LPIV location + ! + i = ilx + j = iux + lpiv = (i+j)/2 + piv = x(lpiv) + if (piv < x(i)) then + xt = x(i) + ixt = indx(i) + x(i) = x(lpiv) + indx(i) = indx(lpiv) + x(lpiv) = xt + indx(lpiv) = ixt + piv = x(lpiv) + endif + if (piv > x(j)) then + xt = x(j) + ixt = indx(j) + x(j) = x(lpiv) + indx(j) = indx(lpiv) + x(lpiv) = xt + indx(lpiv) = ixt + piv = x(lpiv) + endif + if (piv < x(i)) then + xt = x(i) + ixt = indx(i) + x(i) = x(lpiv) + indx(i) = indx(lpiv) + x(lpiv) = xt + indx(lpiv) = ixt + piv = x(lpiv) + endif + ! + ! now piv is correct; place it into first location + xt = x(i) + ixt = indx(i) + x(i) = x(lpiv) + indx(i) = indx(lpiv) + x(lpiv) = xt + indx(lpiv) = ixt + piv = x(lpiv) + + i = ilx - 1 + j = iux + 1 + + outer_up: do + in_up1: do + i = i + 1 + xk = x(i) + if (xk >= piv) exit in_up1 + end do in_up1 + ! + ! Ensure finite termination for next loop + ! + xt = xk + x(i) = piv + in_up2:do + j = j - 1 + xk = x(j) + if (xk <= piv) exit in_up2 + end do in_up2 + x(i) = xt + + if (j > i) then + xt = x(i) + ixt = indx(i) + x(i) = x(j) + indx(i) = indx(j) + x(j) = xt + indx(j) = ixt + else + exit outer_up + end if + end do outer_up + if (i == ilx) then + if (x(i) /= piv) then + write(0,*) 'Should never ever get here????!!!!' + stop + endif + i = i + 1 + endif + + n1 = (i-1)-ilx+1 + n2 = iux-(i)+1 + if (n1 > n2) then + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call idsrx_up(n1,x(ilx:i-1),indx(ilx:i-1)) + endif + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call idsrx_up(n2,x(i:iux),indx(i:iux)) + endif + else + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call idsrx_up(n2,x(i:iux),indx(i:iux)) + endif + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call idsrx_up(n1,x(ilx:i-1),indx(ilx:i-1)) + endif + endif + enddo + else + call idsrx_up(n,x,indx) + endif + + case(psb_sort_down_) + + + if (n > ithrs) then + ! + ! Init stack pointer + ! + istp = 1 + istack(1,istp) = 1 + istack(2,istp) = n + + do + if (istp <= 0) exit + ilx = istack(1,istp) + iux = istack(2,istp) + istp = istp - 1 + !$$$ write(0,*) 'Debug 1: ',ilx,iux + ! + ! Choose a pivot with median-of-three heuristics, leave it + ! in the LPIV location + ! + i = ilx + j = iux + lpiv = (i+j)/2 + piv = x(lpiv) + if (piv > x(i)) then + xt = x(i) + ixt = indx(i) + x(i) = x(lpiv) + indx(i) = indx(lpiv) + x(lpiv) = xt + indx(lpiv) = ixt + piv = x(lpiv) + endif + if (piv < x(j)) then + xt = x(j) + ixt = indx(j) + x(j) = x(lpiv) + indx(j) = indx(lpiv) + x(lpiv) = xt + indx(lpiv) = ixt + piv = x(lpiv) + endif + if (piv > x(i)) then + xt = x(i) + ixt = indx(i) + x(i) = x(lpiv) + indx(i) = indx(lpiv) + x(lpiv) = xt + indx(lpiv) = ixt + piv = x(lpiv) + endif + ! + ! now piv is correct; place it into first location + xt = x(i) + ixt = indx(i) + x(i) = x(lpiv) + indx(i) = indx(lpiv) + x(lpiv) = xt + indx(lpiv) = ixt + piv = x(lpiv) + + i = ilx - 1 + j = iux + 1 + + outer_dw: do + in_dw1: do + i = i + 1 + xk = x(i) + if (xk <= piv) exit in_dw1 + end do in_dw1 + ! + ! Ensure finite termination for next loop + ! + xt = xk + x(i) = piv + in_dw2:do + j = j - 1 + xk = x(j) + if (xk >= piv) exit in_dw2 + end do in_dw2 + x(i) = xt + + if (j > i) then + xt = x(i) + ixt = indx(i) + x(i) = x(j) + indx(i) = indx(j) + x(j) = xt + indx(j) = ixt + else + exit outer_dw + end if + end do outer_dw + if (i == ilx) then + if (x(i) /= piv) then + write(0,*) 'Should never ever get here????!!!!' + stop + endif + i = i + 1 + endif + + n1 = (i-1)-ilx+1 + n2 = iux-(i)+1 + if (n1 > n2) then + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call idsrx_dw(n1,x(ilx:i-1),indx(ilx:i-1)) + endif + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call idsrx_dw(n2,x(i:iux),indx(i:iux)) + endif + else + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call idsrx_dw(n2,x(i:iux),indx(i:iux)) + endif + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call idsrx_dw(n1,x(ilx:i-1),indx(ilx:i-1)) + endif + endif + enddo + else + call idsrx_dw(n,x,indx) + endif + + case default + write(0,*) 'isrx error dir ',dir + end select + + + return + +contains + + subroutine idsrx_up(n,x,indx) + implicit none + integer :: n + real(kind(1.d0)) :: x(n) + integer :: indx(n) + integer :: i,j,ix + real(kind(1.d0)) :: xx + + do j=n-1,1,-1 + if (x(j+1) < x(j)) then + xx = x(j) + ix = indx(j) + i=j+1 + do + x(i-1) = x(i) + indx(i-1) = indx(i) + i = i+1 + if (i>n) exit + if (x(i) >= xx) exit + end do + x(i-1) = xx + indx(i-1) = ix + endif + enddo + end subroutine idsrx_up + + subroutine idsrx_dw(n,x,indx) + implicit none + integer :: n + real(kind(1.d0)) :: x(n) + integer :: indx(n) + integer :: i,j,ix + real(kind(1.d0)) :: xx + + do j=n-1,1,-1 + if (x(j+1) > x(j)) then + xx = x(j) + ix = indx(j) + i=j+1 + do + x(i-1) = x(i) + indx(i-1) = indx(i) + i = i+1 + if (i>n) exit + if (x(i) <= xx) exit + end do + x(i-1) = xx + indx(i-1) = ix + endif + enddo + end subroutine idsrx_dw + +end subroutine dsrx diff --git a/base/serial/aux/iasr.f90 b/base/serial/aux/iasr.f90 new file mode 100644 index 000000000..b88289757 --- /dev/null +++ b/base/serial/aux/iasr.f90 @@ -0,0 +1,361 @@ +!!$ +!!$ Parallel Sparse BLAS v2.0 +!!$ (C) Copyright 2006 Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari University of Rome Tor Vergata +!!$ +!!$ Redistribution and use in source and binary forms, with or without +!!$ modification, are permitted provided that the following conditions +!!$ are met: +!!$ 1. Redistributions of source code must retain the above copyright +!!$ notice, this list of conditions and the following disclaimer. +!!$ 2. Redistributions in binary form must reproduce the above copyright +!!$ notice, this list of conditions, and the following disclaimer in the +!!$ documentation and/or other materials provided with the distribution. +!!$ 3. The name of the PSBLAS group or the names of its contributors may +!!$ not be used to endorse or promote products derived from this +!!$ software without specific written permission. +!!$ +!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +!!$ POSSIBILITY OF SUCH DAMAGE. +!!$ +!!$ + +subroutine iasr(n,x,dir) + use psb_serial_mod + implicit none + ! + ! Quicksort on absolute value. + ! Adapted from a number of sources, including Don Knuth's TAOCP. + ! + ! .. Scalar Arguments .. + integer, intent(in) :: n, dir + integer :: x(n) + ! .. + ! .. Local Scalars .. + integer :: xx, piv, xt, xk + integer i, j, ilx, iux, istp, lpiv + integer n1, n2 + + integer, parameter :: maxstack=64,nparms=3,ithrs=16 + integer :: istack(nparms,maxstack) + ! .. + + ! + ! small inputs will only get through insertion sort. + ! + select case(dir) + + case(psb_asort_up_) + + if (n > ithrs) then + ! + ! Init stack pointer + ! + istp = 1 + istack(1,istp) = 1 + istack(2,istp) = n + + do + if (istp <= 0) exit + ilx = istack(1,istp) + iux = istack(2,istp) + istp = istp - 1 + !$$$ write(0,*) 'Debug 1: ',ilx,iux + ! + ! Choose a pivot with median-of-three heuristics, leave it + ! in the LPIV location + ! + i = ilx + j = iux + lpiv = (i+j)/2 + piv = abs(x(lpiv)) + if (piv < abs(x(i))) then + xt = x(i) + x(i) = x(lpiv) + x(lpiv) = xt + piv = abs(x(lpiv)) + endif + if (piv > abs(x(j))) then + xt = x(j) + x(j) = x(lpiv) + x(lpiv) = xt + piv = abs(x(lpiv)) + endif + if (piv < abs(x(i))) then + xt = x(i) + x(i) = x(lpiv) + x(lpiv) = xt + piv = abs(x(lpiv)) + endif + ! + ! now piv is correct; place it into first location + + xt = x(i) + x(i) = x(lpiv) + x(lpiv) = xt + + i = ilx - 1 + j = iux + 1 + + outer_up: do + in_up1: do + i = i + 1 + xk = abs(x(i)) + if (xk >= piv) exit in_up1 + end do in_up1 + ! + ! Ensure finite termination for next loop + ! + xt = x(i) + x(i) = piv + in_up2:do + j = j - 1 + xk = abs(x(j)) + if (xk <= piv) exit in_up2 + end do in_up2 + x(i) = xt + + if (j > i) then + xt = x(i) + x(i) = x(j) + x(j) = xt + else + exit outer_up + end if + end do outer_up + if (i == ilx) then + if (x(i) /= piv) then + write(0,*) 'Should never ever get here????!!!!' + stop + endif + i = i + 1 + endif + + n1 = (i-1)-ilx+1 + n2 = iux-(i)+1 + if (n1 > n2) then + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call iaisr_up(n1,x(ilx:i-1)) + endif + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call iaisr_up(n2,x(i:iux)) + endif + else + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call iaisr_up(n2,x(i:iux)) + endif + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call iaisr_up(n1,x(ilx:i-1)) + endif + endif + enddo + else + call iaisr_up(n,x) + endif + + case(psb_asort_down_) + + + if (n > ithrs) then + ! + ! Init stack pointer + ! + istp = 1 + istack(1,istp) = 1 + istack(2,istp) = n + + do + if (istp <= 0) exit + ilx = istack(1,istp) + iux = istack(2,istp) + istp = istp - 1 + !$$$ write(0,*) 'Debug 1: ',ilx,iux + ! + ! Choose a pivot with median-of-three heuristics, leave it + ! in the LPIV location + ! + i = ilx + j = iux + lpiv = (i+j)/2 + piv = abs(x(lpiv)) + if (piv > abs(x(i))) then + xt = x(i) + x(i) = x(lpiv) + x(lpiv) = xt + piv = abs(x(lpiv)) + endif + if (piv < abs(x(j))) then + xt = x(j) + x(j) = x(lpiv) + x(lpiv) = xt + piv = abs(x(lpiv)) + endif + if (piv > abs(x(i))) then + xt = x(i) + x(i) = x(lpiv) + x(lpiv) = xt + piv = abs(x(lpiv)) + endif + ! + ! now piv is correct; place it into first location + + xt = x(i) + x(i) = x(lpiv) + x(lpiv) = xt + + i = ilx - 1 + j = iux + 1 + + outer_dw: do + in_dw1: do + i = i + 1 + xk = abs(x(i)) + if (xk <= piv) exit in_dw1 + end do in_dw1 + ! + ! Ensure finite termination for next loop + ! + xt = x(i) + x(i) = piv + in_dw2:do + j = j - 1 + xk = abs(x(j)) + if (xk >= piv) exit in_dw2 + end do in_dw2 + x(i) = xt + + if (j > i) then + xt = x(i) + x(i) = x(j) + x(j) = xt + else + exit outer_dw + end if + end do outer_dw + if (i == ilx) then + if (x(i) /= piv) then + write(0,*) 'Should never ever get here????!!!!' + stop + endif + i = i + 1 + endif + + n1 = (i-1)-ilx+1 + n2 = iux-(i)+1 + if (n1 > n2) then + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call iaisr_dw(n1,x(ilx:i-1)) + endif + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call iaisr_dw(n2,x(i:iux)) + endif + else + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call iaisr_dw(n2,x(i:iux)) + endif + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call iaisr_dw(n1,x(ilx:i-1)) + endif + endif + enddo + else + call iaisr_dw(n,x) + endif + + case default + write(0,*) 'isr error !',dir + end select + + + return + +contains + + subroutine iaisr_up(n,x) + implicit none + integer :: n + integer :: x(n) + integer :: i,j + integer :: xx,xax + + do j=n-1,1,-1 + if (abs(x(j+1)) < abs(x(j))) then + xx = x(j) + xax = abs(xx) + i=j+1 + do + x(i-1) = x(i) + i = i+1 + if (i>n) exit + if (abs(x(i)) >= xax) exit + end do + x(i-1) = xx + endif + enddo + end subroutine iaisr_up + + subroutine iaisr_dw(n,x) + implicit none + integer :: n + integer :: x(n) + integer :: i,j + integer :: xx,xax + + do j=n-1,1,-1 + if (abs(x(j+1)) > abs(x(j))) then + xx = x(j) + xax = abs(xx) + i=j+1 + do + x(i-1) = x(i) + i = i+1 + if (i>n) exit + if (abs(x(i)) <= xax) exit + end do + x(i-1) = xx + endif + enddo + end subroutine iaisr_dw + +end subroutine iasr diff --git a/base/serial/aux/iasrx.f90 b/base/serial/aux/iasrx.f90 new file mode 100644 index 000000000..c4576ef33 --- /dev/null +++ b/base/serial/aux/iasrx.f90 @@ -0,0 +1,409 @@ +!!$ +!!$ Parallel Sparse BLAS v2.0 +!!$ (C) Copyright 2006 Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari University of Rome Tor Vergata +!!$ +!!$ Redistribution and use in source and binary forms, with or without +!!$ modification, are permitted provided that the following conditions +!!$ are met: +!!$ 1. Redistributions of source code must retain the above copyright +!!$ notice, this list of conditions and the following disclaimer. +!!$ 2. Redistributions in binary form must reproduce the above copyright +!!$ notice, this list of conditions, and the following disclaimer in the +!!$ documentation and/or other materials provided with the distribution. +!!$ 3. The name of the PSBLAS group or the names of its contributors may +!!$ not be used to endorse or promote products derived from this +!!$ software without specific written permission. +!!$ +!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +!!$ POSSIBILITY OF SUCH DAMAGE. +!!$ +!!$ +subroutine iasrx(n,x,indx,dir,flag) + use psb_serial_mod + implicit none + ! + ! Quicksort on absolute value with indices into original positions. + ! Adapted from a number of sources, including Don Knuth's TAOCP. + ! + ! .. Scalar Arguments .. + integer, intent(in) :: n, dir, flag + integer :: x(n) + integer :: indx(n) + ! .. + ! .. Local Scalars .. + integer :: xx, piv, xt, xk + integer i, j, ii, ilx, iux, istp, lpiv + integer ixt, n1, n2 + + integer, parameter :: maxstack=64,nparms=3,ithrs=16 + integer :: istack(nparms,maxstack) + ! .. + + select case(flag) + case(psb_sort_ovw_idx_) + do i=1, n + indx(i) = i + enddo + case(psb_sort_keep_idx_) + ! do nothing + case default + write(0,*) 'Error in isrx: invalid flag',flag + end select + ! + + ! + ! small inputs will only get through insertion sort. + ! + select case(dir) + + case(psb_asort_up_) + + if (n > ithrs) then + ! + ! Init stack pointer + ! + istp = 1 + istack(1,istp) = 1 + istack(2,istp) = n + + do + if (istp <= 0) exit + ilx = istack(1,istp) + iux = istack(2,istp) + istp = istp - 1 + !$$$ write(0,*) 'Debug 1: ',ilx,iux + ! + ! Choose a pivot with median-of-three heuristics, leave it + ! in the LPIV location + ! + i = ilx + j = iux + lpiv = (i+j)/2 + piv = abs(x(lpiv)) + if (piv < abs(x(i))) then + xt = x(i) + ixt = indx(i) + x(i) = x(lpiv) + indx(i) = indx(lpiv) + x(lpiv) = xt + indx(lpiv) = ixt + piv = abs(x(lpiv)) + endif + if (piv > abs(x(j))) then + xt = x(j) + ixt = indx(j) + x(j) = x(lpiv) + indx(j) = indx(lpiv) + x(lpiv) = xt + indx(lpiv) = ixt + piv = abs(x(lpiv)) + endif + if (piv < abs(x(i))) then + xt = x(i) + ixt = indx(i) + x(i) = x(lpiv) + indx(i) = indx(lpiv) + x(lpiv) = xt + indx(lpiv) = ixt + piv = abs(x(lpiv)) + endif + ! + ! now piv is correct; place it into first location + xt = x(i) + ixt = indx(i) + x(i) = x(lpiv) + indx(i) = indx(lpiv) + x(lpiv) = xt + indx(lpiv) = ixt + + i = ilx - 1 + j = iux + 1 + + outer_up: do + in_up1: do + i = i + 1 + xk = abs(x(i)) + if (xk >= piv) exit in_up1 + end do in_up1 + ! + ! Ensure finite termination for next loop + ! + xt = x(i) + x(i) = piv + in_up2:do + j = j - 1 + xk = abs(x(j)) + if (xk <= piv) exit in_up2 + end do in_up2 + x(i) = xt + + if (j > i) then + xt = x(i) + ixt = indx(i) + x(i) = x(j) + indx(i) = indx(j) + x(j) = xt + indx(j) = ixt + else + exit outer_up + end if + end do outer_up + if (i == ilx) then + if (x(i) /= piv) then + write(0,*) 'Should never ever get here????!!!!' + stop + endif + i = i + 1 + endif + + n1 = (i-1)-ilx+1 + n2 = iux-(i)+1 + if (n1 > n2) then + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call iiasrx_up(n1,x(ilx:i-1),indx(ilx:i-1)) + endif + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call iiasrx_up(n2,x(i:iux),indx(i:iux)) + endif + else + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call iiasrx_up(n2,x(i:iux),indx(i:iux)) + endif + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call iiasrx_up(n1,x(ilx:i-1),indx(ilx:i-1)) + endif + endif + enddo + else + call iiasrx_up(n,x,indx) + endif + + case(psb_asort_down_) + + + if (n > ithrs) then + ! + ! Init stack pointer + ! + istp = 1 + istack(1,istp) = 1 + istack(2,istp) = n + + do + if (istp <= 0) exit + ilx = istack(1,istp) + iux = istack(2,istp) + istp = istp - 1 + !$$$ write(0,*) 'Debug 1: ',ilx,iux + ! + ! Choose a pivot with median-of-three heuristics, leave it + ! in the LPIV location + ! + i = ilx + j = iux + lpiv = (i+j)/2 + piv = abs(x(lpiv)) + if (piv > abs(x(i))) then + xt = x(i) + ixt = indx(i) + x(i) = x(lpiv) + indx(i) = indx(lpiv) + x(lpiv) = xt + indx(lpiv) = ixt + piv = abs(x(lpiv)) + endif + if (piv < abs(x(j))) then + xt = x(j) + ixt = indx(j) + x(j) = x(lpiv) + indx(j) = indx(lpiv) + x(lpiv) = xt + indx(lpiv) = ixt + piv = abs(x(lpiv)) + endif + if (piv > abs(x(i))) then + xt = x(i) + ixt = indx(i) + x(i) = x(lpiv) + indx(i) = indx(lpiv) + x(lpiv) = xt + indx(lpiv) = ixt + piv = abs(x(lpiv)) + endif + ! + ! now piv is correct; place it into first location + xt = x(i) + ixt = indx(i) + x(i) = x(lpiv) + indx(i) = indx(lpiv) + x(lpiv) = xt + indx(lpiv) = ixt + + i = ilx - 1 + j = iux + 1 + + outer_dw: do + in_dw1: do + i = i + 1 + xk = abs(x(i)) + if (xk <= piv) exit in_dw1 + end do in_dw1 + ! + ! Ensure finite termination for next loop + ! + xt = x(i) + x(i) = piv + in_dw2:do + j = j - 1 + xk = abs(x(j)) + if (xk >= piv) exit in_dw2 + end do in_dw2 + x(i) = xt + + if (j > i) then + xt = x(i) + ixt = indx(i) + x(i) = x(j) + indx(i) = indx(j) + x(j) = xt + indx(j) = ixt + else + exit outer_dw + end if + end do outer_dw + if (i == ilx) then + if (x(i) /= piv) then + write(0,*) 'Should never ever get here????!!!!' + stop + endif + i = i + 1 + endif + + n1 = (i-1)-ilx+1 + n2 = iux-(i)+1 + if (n1 > n2) then + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call iiasrx_dw(n1,x(ilx:i-1),indx(ilx:i-1)) + endif + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call iiasrx_dw(n2,x(i:iux),indx(i:iux)) + endif + else + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call iiasrx_dw(n2,x(i:iux),indx(i:iux)) + endif + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call iiasrx_dw(n1,x(ilx:i-1),indx(ilx:i-1)) + endif + endif + enddo + else + call iiasrx_dw(n,x,indx) + endif + + case default + write(0,*) 'isrx error dir ',dir + end select + + + return + +contains + + subroutine iiasrx_up(n,x,indx) + implicit none + integer :: n + integer :: x(n) + integer :: indx(n) + integer :: i,j,ix + integer :: xx,xax + + do j=n-1,1,-1 + if (abs(x(j+1)) < abs(x(j))) then + xx = x(j) + ix = indx(j) + xax = abs(xx) + i=j+1 + do + x(i-1) = x(i) + indx(i-1) = indx(i) + i = i+1 + if (i>n) exit + if (abs(x(i)) >= xax) exit + end do + x(i-1) = xx + indx(i-1) = ix + endif + enddo + end subroutine iiasrx_up + + subroutine iiasrx_dw(n,x,indx) + implicit none + integer :: n + integer :: x(n) + integer :: indx(n) + integer :: i,j,ix + integer :: xx,xax + + do j=n-1,1,-1 + if (abs(x(j+1)) > abs(x(j))) then + xx = x(j) + ix = indx(j) + xax = abs(xx) + i=j+1 + do + x(i-1) = x(i) + indx(i-1) = indx(i) + i = i+1 + if (i>n) exit + if (abs(x(i)) <= xax) exit + end do + x(i-1) = xx + indx(i-1) = ix + endif + enddo + end subroutine iiasrx_dw + +end subroutine iasrx diff --git a/base/serial/aux/zacmp_mod.f90 b/base/serial/aux/zacmp_mod.f90 new file mode 100644 index 000000000..bc08ea02b --- /dev/null +++ b/base/serial/aux/zacmp_mod.f90 @@ -0,0 +1,44 @@ +module zacmp_mod + interface operator(<) + module procedure zalt + end interface + interface operator(<=) + module procedure zale + end interface + interface operator(>) + module procedure zagt + end interface + interface operator(>=) + module procedure zage + end interface + +contains + + function zalt(a,b) + complex(kind(1.d0)), intent(in) :: a,b + logical :: zalt + + zalt = ((abs(real(a))+abs(aimag(a))) < (abs(real(b))+abs(aimag(b)))) + end function zalt + function zale(a,b) + complex(kind(1.d0)), intent(in) :: a,b + logical :: zale + + zale = ((abs(real(a))+abs(aimag(a))) <= (abs(real(b))+abs(aimag(b)))) + end function zale + + function zagt(a,b) + complex(kind(1.d0)), intent(in) :: a,b + logical :: zagt + + zagt = ((abs(real(a))+abs(aimag(a))) > (abs(real(b))+abs(aimag(b)))) + end function zagt + function zage(a,b) + complex(kind(1.d0)), intent(in) :: a,b + logical :: zage + + zage = ((abs(real(a))+abs(aimag(a))) >= (abs(real(b))+abs(aimag(b)))) + end function zage + +end module zacmp_mod + diff --git a/base/serial/aux/zalcmp_mod.f90 b/base/serial/aux/zalcmp_mod.f90 new file mode 100644 index 000000000..cc0c84a9e --- /dev/null +++ b/base/serial/aux/zalcmp_mod.f90 @@ -0,0 +1,48 @@ +module zalcmp_mod + interface operator(<) + module procedure zallt + end interface + interface operator(<=) + module procedure zalle + end interface + interface operator(>) + module procedure zalgt + end interface + interface operator(>=) + module procedure zalge + end interface + +contains + + function zallt(a,b) + complex(kind(1.d0)), intent(in) :: a,b + logical :: zallt + + zallt = (abs(real(a))abs(real(b))).or. & + & ((abs(real(a))==abs(real(b))).and.(abs(aimag(a))>abs(aimag(b)))) + end function zalgt + function zalge(a,b) + complex(kind(1.d0)), intent(in) :: a,b + logical :: zalge + + zalge = (abs(real(a))>abs(real(b))).or. & + & ((abs(real(a))==abs(real(b))).and.(abs(aimag(a))>=abs(aimag(b)))) + end function zalge + +end module zalcmp_mod + diff --git a/base/serial/aux/zalsr.f90 b/base/serial/aux/zalsr.f90 new file mode 100644 index 000000000..a35c01a77 --- /dev/null +++ b/base/serial/aux/zalsr.f90 @@ -0,0 +1,362 @@ +!!$ +!!$ Parallel Sparse BLAS v2.0 +!!$ (C) Copyright 2006 Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari University of Rome Tor Vergata +!!$ +!!$ Redistribution and use in source and binary forms, with or without +!!$ modification, are permitted provided that the following conditions +!!$ are met: +!!$ 1. Redistributions of source code must retain the above copyright +!!$ notice, this list of conditions and the following disclaimer. +!!$ 2. Redistributions in binary form must reproduce the above copyright +!!$ notice, this list of conditions, and the following disclaimer in the +!!$ documentation and/or other materials provided with the distribution. +!!$ 3. The name of the PSBLAS group or the names of its contributors may +!!$ not be used to endorse or promote products derived from this +!!$ software without specific written permission. +!!$ +!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +!!$ POSSIBILITY OF SUCH DAMAGE. +!!$ +!!$ + +subroutine zalsr(n,x,dir) + use psb_serial_mod + use zalcmp_mod + implicit none + ! + ! Quicksort on lexicographic comparison of complex numbers. + ! Adapted from a number of sources, including Don Knuth's TAOCP. + ! + ! .. Scalar Arguments .. + integer, intent(in) :: n, dir + complex(kind(1.d0)) :: x(n) + ! .. + ! .. Local Scalars .. + complex(kind(1.d0)) :: xx, xk, piv, xt + integer i, j, ilx, iux, istp, lpiv + integer n1, n2 + + integer, parameter :: maxstack=64,nparms=3,ithrs=16 + integer :: istack(nparms,maxstack) + ! .. + + ! + ! small inputs will only get through insertion sort. + ! + select case(dir) + + case(psb_alsort_up_) + + if (n > ithrs) then + ! + ! Init stack pointer + ! + istp = 1 + istack(1,istp) = 1 + istack(2,istp) = n + + do + if (istp <= 0) exit + ilx = istack(1,istp) + iux = istack(2,istp) + istp = istp - 1 + !$$$ write(0,*) 'Debug 1: ',ilx,iux + ! + ! Choose a pivot with median-of-three heuristics, leave it + ! in the LPIV location + ! + i = ilx + j = iux + lpiv = (i+j)/2 + piv = x(lpiv) + if (piv < x(i)) then + xt = x(i) + x(i) = x(lpiv) + x(lpiv) = xt + piv = x(lpiv) + endif + if (piv > x(j)) then + xt = x(j) + x(j) = x(lpiv) + x(lpiv) = xt + piv = x(lpiv) + endif + if (piv < x(i)) then + xt = x(i) + x(i) = x(lpiv) + x(lpiv) = xt + piv = x(lpiv) + endif + ! + ! now piv is correct; place it into first location + + xt = x(i) + x(i) = x(lpiv) + x(lpiv) = xt + + i = ilx - 1 + j = iux + 1 + + outer_up: do + in_up1: do + i = i + 1 + xk = x(i) + if (xk >= piv) exit in_up1 + end do in_up1 + ! + ! Ensure finite termination for next loop + ! + xt = xk + x(i) = piv + in_up2:do + j = j - 1 + xk = x(j) + if (xk <= piv) exit in_up2 + end do in_up2 + x(i) = xt + + if (j > i) then + xt = x(i) + x(i) = x(j) + x(j) = xt + else + exit outer_up + end if + end do outer_up + if (i == ilx) then + if (x(i) /= piv) then + write(0,*) 'Should never ever get here????!!!!' + stop + endif + i = i + 1 + endif + + n1 = (i-1)-ilx+1 + n2 = iux-(i)+1 + if (n1 > n2) then + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call izalsr_up(n1,x(ilx:i-1)) + endif + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call izalsr_up(n2,x(i:iux)) + endif + else + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call izalsr_up(n2,x(i:iux)) + endif + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call izalsr_up(n1,x(ilx:i-1)) + endif + endif + enddo + else + call izalsr_up(n,x) + endif + + case(psb_alsort_down_) + + + if (n > ithrs) then + ! + ! Init stack pointer + ! + istp = 1 + istack(1,istp) = 1 + istack(2,istp) = n + + do + if (istp <= 0) exit + ilx = istack(1,istp) + iux = istack(2,istp) + istp = istp - 1 + !$$$ write(0,*) 'Debug 1: ',ilx,iux + ! + ! Choose a pivot with median-of-three heuristics, leave it + ! in the LPIV location + ! + i = ilx + j = iux + lpiv = (i+j)/2 + piv = x(lpiv) + if (piv > x(i)) then + xt = x(i) + x(i) = x(lpiv) + x(lpiv) = xt + piv = x(lpiv) + endif + if (piv < x(j)) then + xt = x(j) + x(j) = x(lpiv) + x(lpiv) = xt + piv = x(lpiv) + endif + if (piv > x(i)) then + xt = x(i) + x(i) = x(lpiv) + x(lpiv) = xt + piv = x(lpiv) + endif + ! + ! now piv is correct; place it into first location + + xt = x(i) + x(i) = x(lpiv) + x(lpiv) = xt + + i = ilx - 1 + j = iux + 1 + + outer_dw: do + in_dw1: do + i = i + 1 + xk = x(i) + if (xk <= piv) exit in_dw1 + end do in_dw1 + ! + ! Ensure finite termination for next loop + ! + xt = xk + x(i) = piv + in_dw2:do + j = j - 1 + xk = x(j) + if (xk >= piv) exit in_dw2 + end do in_dw2 + x(i) = xt + + if (j > i) then + xt = x(i) + x(i) = x(j) + x(j) = xt + else + exit outer_dw + end if + end do outer_dw + if (i == ilx) then + if (x(i) /= piv) then + write(0,*) 'Should never ever get here????!!!!' + stop + endif + i = i + 1 + endif + + n1 = (i-1)-ilx+1 + n2 = iux-(i)+1 + if (n1 > n2) then + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call izalsr_dw(n1,x(ilx:i-1)) + endif + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call izalsr_dw(n2,x(i:iux)) + endif + else + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call izalsr_dw(n2,x(i:iux)) + endif + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call izalsr_dw(n1,x(ilx:i-1)) + endif + endif + enddo + else + call izalsr_dw(n,x) + endif + + case default + write(0,*) 'isr error !',dir + end select + + + return + +contains + + subroutine izalsr_up(n,x) + use zalcmp_mod + implicit none + integer :: n + complex(kind(1.d0)) :: x(n) + integer :: i,j + complex(kind(1.d0)) :: xx + + do j=n-1,1,-1 + if (x(j+1) < x(j)) then + xx = x(j) + i=j+1 + do + x(i-1) = x(i) + i = i+1 + if (i>n) exit + if (x(i) >= xx) exit + end do + x(i-1) = xx + endif + enddo + end subroutine izalsr_up + + subroutine izalsr_dw(n,x) + use zalcmp_mod + implicit none + integer :: n + complex(kind(1.d0)) :: x(n) + integer :: i,j + complex(kind(1.d0)) :: xx + + do j=n-1,1,-1 + if (x(j+1) > x(j)) then + xx = x(j) + i=j+1 + do + x(i-1) = x(i) + i = i+1 + if (i>n) exit + if (x(i) <= xx) exit + end do + x(i-1) = xx + endif + enddo + end subroutine izalsr_dw + +end subroutine zalsr diff --git a/base/serial/aux/zalsrx.f90 b/base/serial/aux/zalsrx.f90 new file mode 100644 index 000000000..f0e1aa8ee --- /dev/null +++ b/base/serial/aux/zalsrx.f90 @@ -0,0 +1,413 @@ +!!$ +!!$ Parallel Sparse BLAS v2.0 +!!$ (C) Copyright 2006 Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari University of Rome Tor Vergata +!!$ +!!$ Redistribution and use in source and binary forms, with or without +!!$ modification, are permitted provided that the following conditions +!!$ are met: +!!$ 1. Redistributions of source code must retain the above copyright +!!$ notice, this list of conditions and the following disclaimer. +!!$ 2. Redistributions in binary form must reproduce the above copyright +!!$ notice, this list of conditions, and the following disclaimer in the +!!$ documentation and/or other materials provided with the distribution. +!!$ 3. The name of the PSBLAS group or the names of its contributors may +!!$ not be used to endorse or promote products derived from this +!!$ software without specific written permission. +!!$ +!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +!!$ POSSIBILITY OF SUCH DAMAGE. +!!$ +!!$ +subroutine zalsrx(n,x,indx,dir,flag) + use psb_serial_mod + use zalcmp_mod + implicit none + ! + ! Quicksort with indices into original positions. + ! Adapted from a number of sources, including Don Knuth's TAOCP. + ! + ! .. Scalar Arguments .. + integer, intent(in) :: n, dir, flag + complex(kind(1.d0)) :: x(n) + integer :: indx(n) + ! .. + ! .. Local Scalars .. + complex(kind(1.d0)) :: xx, piv, xk, xt + integer i, j, ii, ilx, iux, istp, lpiv + integer ixt, n1, n2 + + integer, parameter :: maxstack=64,nparms=3,ithrs=16 + integer :: istack(nparms,maxstack) + ! .. + + select case(flag) + case(psb_sort_ovw_idx_) + do i=1, n + indx(i) = i + enddo + case(psb_sort_keep_idx_) + ! do nothing + case default + write(0,*) 'Error in isrx: invalid flag',flag + end select + ! + + ! + ! small inputs will only get through insertion sort. + ! + select case(dir) + + case(psb_alsort_up_) + + if (n > ithrs) then + ! + ! Init stack pointer + ! + istp = 1 + istack(1,istp) = 1 + istack(2,istp) = n + + do + if (istp <= 0) exit + ilx = istack(1,istp) + iux = istack(2,istp) + istp = istp - 1 + !$$$ write(0,*) 'Debug 1: ',ilx,iux + ! + ! Choose a pivot with median-of-three heuristics, leave it + ! in the LPIV location + ! + i = ilx + j = iux + lpiv = (i+j)/2 + piv = x(lpiv) + if (piv < x(i)) then + xt = x(i) + ixt = indx(i) + x(i) = x(lpiv) + indx(i) = indx(lpiv) + x(lpiv) = xt + indx(lpiv) = ixt + piv = x(lpiv) + endif + if (piv > x(j)) then + xt = x(j) + ixt = indx(j) + x(j) = x(lpiv) + indx(j) = indx(lpiv) + x(lpiv) = xt + indx(lpiv) = ixt + piv = x(lpiv) + endif + if (piv < x(i)) then + xt = x(i) + ixt = indx(i) + x(i) = x(lpiv) + indx(i) = indx(lpiv) + x(lpiv) = xt + indx(lpiv) = ixt + piv = x(lpiv) + endif + ! + ! now piv is correct; place it into first location + xt = x(i) + ixt = indx(i) + x(i) = x(lpiv) + indx(i) = indx(lpiv) + x(lpiv) = xt + indx(lpiv) = ixt + piv = x(lpiv) + + i = ilx - 1 + j = iux + 1 + + outer_up: do + in_up1: do + i = i + 1 + xk = x(i) + if (xk >= piv) exit in_up1 + end do in_up1 + ! + ! Ensure finite termination for next loop + ! + xt = xk + x(i) = piv + in_up2:do + j = j - 1 + xk = x(j) + if (xk <= piv) exit in_up2 + end do in_up2 + x(i) = xt + + if (j > i) then + xt = x(i) + ixt = indx(i) + x(i) = x(j) + indx(i) = indx(j) + x(j) = xt + indx(j) = ixt + else + exit outer_up + end if + end do outer_up + if (i == ilx) then + if (x(i) /= piv) then + write(0,*) 'Should never ever get here????!!!!' + stop + endif + i = i + 1 + endif + + n1 = (i-1)-ilx+1 + n2 = iux-(i)+1 + if (n1 > n2) then + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call izalsrx_up(n1,x(ilx:i-1),indx(ilx:i-1)) + endif + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call izalsrx_up(n2,x(i:iux),indx(i:iux)) + endif + else + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call izalsrx_up(n2,x(i:iux),indx(i:iux)) + endif + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call izalsrx_up(n1,x(ilx:i-1),indx(ilx:i-1)) + endif + endif + enddo + else + call izalsrx_up(n,x,indx) + endif + + case(psb_alsort_down_) + + + + if (n > ithrs) then + ! + ! Init stack pointer + ! + istp = 1 + istack(1,istp) = 1 + istack(2,istp) = n + + do + if (istp <= 0) exit + ilx = istack(1,istp) + iux = istack(2,istp) + istp = istp - 1 + !$$$ write(0,*) 'Debug 1: ',ilx,iux + ! + ! Choose a pivot with median-of-three heuristics, leave it + ! in the LPIV location + ! + i = ilx + j = iux + lpiv = (i+j)/2 + piv = x(lpiv) + if (piv > x(i)) then + xt = x(i) + ixt = indx(i) + x(i) = x(lpiv) + indx(i) = indx(lpiv) + x(lpiv) = xt + indx(lpiv) = ixt + piv = x(lpiv) + endif + if (piv < x(j)) then + xt = x(j) + ixt = indx(j) + x(j) = x(lpiv) + indx(j) = indx(lpiv) + x(lpiv) = xt + indx(lpiv) = ixt + piv = x(lpiv) + endif + if (piv > x(i)) then + xt = x(i) + ixt = indx(i) + x(i) = x(lpiv) + indx(i) = indx(lpiv) + x(lpiv) = xt + indx(lpiv) = ixt + piv = x(lpiv) + endif + ! + ! now piv is correct; place it into first location + xt = x(i) + ixt = indx(i) + x(i) = x(lpiv) + indx(i) = indx(lpiv) + x(lpiv) = xt + indx(lpiv) = ixt + piv = x(lpiv) + + i = ilx - 1 + j = iux + 1 + + outer_dw: do + in_dw1: do + i = i + 1 + xk = x(i) + if (xk <= piv) exit in_dw1 + end do in_dw1 + ! + ! Ensure finite termination for next loop + ! + xt = xk + x(i) = piv + in_dw2:do + j = j - 1 + xk = x(j) + if (xk >= piv) exit in_dw2 + end do in_dw2 + x(i) = xt + + if (j > i) then + xt = x(i) + ixt = indx(i) + x(i) = x(j) + indx(i) = indx(j) + x(j) = xt + indx(j) = ixt + else + exit outer_dw + end if + end do outer_dw + if (i == ilx) then + if (x(i) /= piv) then + write(0,*) 'Should never ever get here????!!!!' + stop + endif + i = i + 1 + endif + + n1 = (i-1)-ilx+1 + n2 = iux-(i)+1 + if (n1 > n2) then + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call izalsrx_dw(n1,x(ilx:i-1),indx(ilx:i-1)) + endif + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call izalsrx_dw(n2,x(i:iux),indx(i:iux)) + endif + else + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call izalsrx_dw(n2,x(i:iux),indx(i:iux)) + endif + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call izalsrx_dw(n1,x(ilx:i-1),indx(ilx:i-1)) + endif + endif + enddo + else + call izalsrx_dw(n,x,indx) + endif + + case default + write(0,*) 'isrx error dir ',dir + end select + + + return + +contains + + subroutine izalsrx_up(n,x,indx) + use zalcmp_mod + implicit none + integer :: n + complex(kind(1.d0)) :: x(n) + integer :: indx(n) + integer :: i,j,ix + complex(kind(1.d0)) :: xx + + do j=n-1,1,-1 + if (x(j+1) < x(j)) then + xx = x(j) + ix = indx(j) + i=j+1 + do + x(i-1) = x(i) + indx(i-1) = indx(i) + i = i+1 + if (i>n) exit + if (x(i) >= xx) exit + end do + x(i-1) = xx + indx(i-1) = ix + endif + enddo + end subroutine izalsrx_up + + subroutine izalsrx_dw(n,x,indx) + use zalcmp_mod + implicit none + integer :: n + complex(kind(1.d0)) :: x(n) + integer :: indx(n) + integer :: i,j,ix + complex(kind(1.d0)) :: xx + + do j=n-1,1,-1 + if (x(j+1) > x(j)) then + xx = x(j) + ix = indx(j) + i=j+1 + do + x(i-1) = x(i) + indx(i-1) = indx(i) + i = i+1 + if (i>n) exit + if (x(i) <= xx) exit + end do + x(i-1) = xx + indx(i-1) = ix + endif + enddo + end subroutine izalsrx_dw + +end subroutine zalsrx diff --git a/base/serial/aux/zasr.f90 b/base/serial/aux/zasr.f90 new file mode 100644 index 000000000..99e9292f6 --- /dev/null +++ b/base/serial/aux/zasr.f90 @@ -0,0 +1,362 @@ +!!$ +!!$ Parallel Sparse BLAS v2.0 +!!$ (C) Copyright 2006 Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari University of Rome Tor Vergata +!!$ +!!$ Redistribution and use in source and binary forms, with or without +!!$ modification, are permitted provided that the following conditions +!!$ are met: +!!$ 1. Redistributions of source code must retain the above copyright +!!$ notice, this list of conditions and the following disclaimer. +!!$ 2. Redistributions in binary form must reproduce the above copyright +!!$ notice, this list of conditions, and the following disclaimer in the +!!$ documentation and/or other materials provided with the distribution. +!!$ 3. The name of the PSBLAS group or the names of its contributors may +!!$ not be used to endorse or promote products derived from this +!!$ software without specific written permission. +!!$ +!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +!!$ POSSIBILITY OF SUCH DAMAGE. +!!$ +!!$ + +subroutine zasr(n,x,dir) + use psb_serial_mod + use zacmp_mod + implicit none + ! + ! Quicksort on lexicographic comparison of complex numbers. + ! Adapted from a number of sources, including Don Knuth's TAOCP. + ! + ! .. Scalar Arguments .. + integer, intent(in) :: n, dir + complex(kind(1.d0)) :: x(n) + ! .. + ! .. Local Scalars .. + complex(kind(1.d0)) :: xx, xk, piv, xt + integer i, j, ilx, iux, istp, lpiv + integer n1, n2 + + integer, parameter :: maxstack=64,nparms=3,ithrs=16 + integer :: istack(nparms,maxstack) + ! .. + + ! + ! small inputs will only get through insertion sort. + ! + select case(dir) + + case(psb_alsort_up_) + + if (n > ithrs) then + ! + ! Init stack pointer + ! + istp = 1 + istack(1,istp) = 1 + istack(2,istp) = n + + do + if (istp <= 0) exit + ilx = istack(1,istp) + iux = istack(2,istp) + istp = istp - 1 + !$$$ write(0,*) 'Debug 1: ',ilx,iux + ! + ! Choose a pivot with median-of-three heuristics, leave it + ! in the LPIV location + ! + i = ilx + j = iux + lpiv = (i+j)/2 + piv = x(lpiv) + if (piv < x(i)) then + xt = x(i) + x(i) = x(lpiv) + x(lpiv) = xt + piv = x(lpiv) + endif + if (piv > x(j)) then + xt = x(j) + x(j) = x(lpiv) + x(lpiv) = xt + piv = x(lpiv) + endif + if (piv < x(i)) then + xt = x(i) + x(i) = x(lpiv) + x(lpiv) = xt + piv = x(lpiv) + endif + ! + ! now piv is correct; place it into first location + + xt = x(i) + x(i) = x(lpiv) + x(lpiv) = xt + + i = ilx - 1 + j = iux + 1 + + outer_up: do + in_up1: do + i = i + 1 + xk = x(i) + if (xk >= piv) exit in_up1 + end do in_up1 + ! + ! Ensure finite termination for next loop + ! + xt = xk + x(i) = piv + in_up2:do + j = j - 1 + xk = x(j) + if (xk <= piv) exit in_up2 + end do in_up2 + x(i) = xt + + if (j > i) then + xt = x(i) + x(i) = x(j) + x(j) = xt + else + exit outer_up + end if + end do outer_up + if (i == ilx) then + if (x(i) /= piv) then + write(0,*) 'Should never ever get here????!!!!' + stop + endif + i = i + 1 + endif + + n1 = (i-1)-ilx+1 + n2 = iux-(i)+1 + if (n1 > n2) then + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call izasr_up(n1,x(ilx:i-1)) + endif + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call izasr_up(n2,x(i:iux)) + endif + else + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call izasr_up(n2,x(i:iux)) + endif + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call izasr_up(n1,x(ilx:i-1)) + endif + endif + enddo + else + call izasr_up(n,x) + endif + + case(psb_alsort_down_) + + + if (n > ithrs) then + ! + ! Init stack pointer + ! + istp = 1 + istack(1,istp) = 1 + istack(2,istp) = n + + do + if (istp <= 0) exit + ilx = istack(1,istp) + iux = istack(2,istp) + istp = istp - 1 + !$$$ write(0,*) 'Debug 1: ',ilx,iux + ! + ! Choose a pivot with median-of-three heuristics, leave it + ! in the LPIV location + ! + i = ilx + j = iux + lpiv = (i+j)/2 + piv = x(lpiv) + if (piv > x(i)) then + xt = x(i) + x(i) = x(lpiv) + x(lpiv) = xt + piv = x(lpiv) + endif + if (piv < x(j)) then + xt = x(j) + x(j) = x(lpiv) + x(lpiv) = xt + piv = x(lpiv) + endif + if (piv > x(i)) then + xt = x(i) + x(i) = x(lpiv) + x(lpiv) = xt + piv = x(lpiv) + endif + ! + ! now piv is correct; place it into first location + + xt = x(i) + x(i) = x(lpiv) + x(lpiv) = xt + + i = ilx - 1 + j = iux + 1 + + outer_dw: do + in_dw1: do + i = i + 1 + xk = x(i) + if (xk <= piv) exit in_dw1 + end do in_dw1 + ! + ! Ensure finite termination for next loop + ! + xt = xk + x(i) = piv + in_dw2:do + j = j - 1 + xk = x(j) + if (xk >= piv) exit in_dw2 + end do in_dw2 + x(i) = xt + + if (j > i) then + xt = x(i) + x(i) = x(j) + x(j) = xt + else + exit outer_dw + end if + end do outer_dw + if (i == ilx) then + if (x(i) /= piv) then + write(0,*) 'Should never ever get here????!!!!' + stop + endif + i = i + 1 + endif + + n1 = (i-1)-ilx+1 + n2 = iux-(i)+1 + if (n1 > n2) then + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call izasr_dw(n1,x(ilx:i-1)) + endif + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call izasr_dw(n2,x(i:iux)) + endif + else + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call izasr_dw(n2,x(i:iux)) + endif + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call izasr_dw(n1,x(ilx:i-1)) + endif + endif + enddo + else + call izasr_dw(n,x) + endif + + case default + write(0,*) 'isr error !',dir + end select + + + return + +contains + + subroutine izasr_up(n,x) + use zacmp_mod + implicit none + integer :: n + complex(kind(1.d0)) :: x(n) + integer :: i,j + complex(kind(1.d0)) :: xx + + do j=n-1,1,-1 + if (x(j+1) < x(j)) then + xx = x(j) + i=j+1 + do + x(i-1) = x(i) + i = i+1 + if (i>n) exit + if (x(i) >= xx) exit + end do + x(i-1) = xx + endif + enddo + end subroutine izasr_up + + subroutine izasr_dw(n,x) + use zacmp_mod + implicit none + integer :: n + complex(kind(1.d0)) :: x(n) + integer :: i,j + complex(kind(1.d0)) :: xx + + do j=n-1,1,-1 + if (x(j+1) > x(j)) then + xx = x(j) + i=j+1 + do + x(i-1) = x(i) + i = i+1 + if (i>n) exit + if (x(i) <= xx) exit + end do + x(i-1) = xx + endif + enddo + end subroutine izasr_dw + +end subroutine zasr diff --git a/base/serial/aux/zasrx.f90 b/base/serial/aux/zasrx.f90 new file mode 100644 index 000000000..9d6fde036 --- /dev/null +++ b/base/serial/aux/zasrx.f90 @@ -0,0 +1,413 @@ +!!$ +!!$ Parallel Sparse BLAS v2.0 +!!$ (C) Copyright 2006 Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari University of Rome Tor Vergata +!!$ +!!$ Redistribution and use in source and binary forms, with or without +!!$ modification, are permitted provided that the following conditions +!!$ are met: +!!$ 1. Redistributions of source code must retain the above copyright +!!$ notice, this list of conditions and the following disclaimer. +!!$ 2. Redistributions in binary form must reproduce the above copyright +!!$ notice, this list of conditions, and the following disclaimer in the +!!$ documentation and/or other materials provided with the distribution. +!!$ 3. The name of the PSBLAS group or the names of its contributors may +!!$ not be used to endorse or promote products derived from this +!!$ software without specific written permission. +!!$ +!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +!!$ POSSIBILITY OF SUCH DAMAGE. +!!$ +!!$ +subroutine zasrx(n,x,indx,dir,flag) + use psb_serial_mod + use zacmp_mod + implicit none + ! + ! Quicksort with indices into original positions. + ! Adapted from a number of sources, including Don Knuth's TAOCP. + ! + ! .. Scalar Arguments .. + integer, intent(in) :: n, dir, flag + complex(kind(1.d0)) :: x(n) + integer :: indx(n) + ! .. + ! .. Local Scalars .. + complex(kind(1.d0)) :: xx, piv, xk, xt + integer i, j, ii, ilx, iux, istp, lpiv + integer ixt, n1, n2 + + integer, parameter :: maxstack=64,nparms=3,ithrs=16 + integer :: istack(nparms,maxstack) + ! .. + + select case(flag) + case(psb_sort_ovw_idx_) + do i=1, n + indx(i) = i + enddo + case(psb_sort_keep_idx_) + ! do nothing + case default + write(0,*) 'Error in isrx: invalid flag',flag + end select + ! + + ! + ! small inputs will only get through insertion sort. + ! + select case(dir) + + case(psb_alsort_up_) + + if (n > ithrs) then + ! + ! Init stack pointer + ! + istp = 1 + istack(1,istp) = 1 + istack(2,istp) = n + + do + if (istp <= 0) exit + ilx = istack(1,istp) + iux = istack(2,istp) + istp = istp - 1 + !$$$ write(0,*) 'Debug 1: ',ilx,iux + ! + ! Choose a pivot with median-of-three heuristics, leave it + ! in the LPIV location + ! + i = ilx + j = iux + lpiv = (i+j)/2 + piv = x(lpiv) + if (piv < x(i)) then + xt = x(i) + ixt = indx(i) + x(i) = x(lpiv) + indx(i) = indx(lpiv) + x(lpiv) = xt + indx(lpiv) = ixt + piv = x(lpiv) + endif + if (piv > x(j)) then + xt = x(j) + ixt = indx(j) + x(j) = x(lpiv) + indx(j) = indx(lpiv) + x(lpiv) = xt + indx(lpiv) = ixt + piv = x(lpiv) + endif + if (piv < x(i)) then + xt = x(i) + ixt = indx(i) + x(i) = x(lpiv) + indx(i) = indx(lpiv) + x(lpiv) = xt + indx(lpiv) = ixt + piv = x(lpiv) + endif + ! + ! now piv is correct; place it into first location + xt = x(i) + ixt = indx(i) + x(i) = x(lpiv) + indx(i) = indx(lpiv) + x(lpiv) = xt + indx(lpiv) = ixt + piv = x(lpiv) + + i = ilx - 1 + j = iux + 1 + + outer_up: do + in_up1: do + i = i + 1 + xk = x(i) + if (xk >= piv) exit in_up1 + end do in_up1 + ! + ! Ensure finite termination for next loop + ! + xt = xk + x(i) = piv + in_up2:do + j = j - 1 + xk = x(j) + if (xk <= piv) exit in_up2 + end do in_up2 + x(i) = xt + + if (j > i) then + xt = x(i) + ixt = indx(i) + x(i) = x(j) + indx(i) = indx(j) + x(j) = xt + indx(j) = ixt + else + exit outer_up + end if + end do outer_up + if (i == ilx) then + if (x(i) /= piv) then + write(0,*) 'Should never ever get here????!!!!' + stop + endif + i = i + 1 + endif + + n1 = (i-1)-ilx+1 + n2 = iux-(i)+1 + if (n1 > n2) then + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call izasrx_up(n1,x(ilx:i-1),indx(ilx:i-1)) + endif + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call izasrx_up(n2,x(i:iux),indx(i:iux)) + endif + else + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call izasrx_up(n2,x(i:iux),indx(i:iux)) + endif + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call izasrx_up(n1,x(ilx:i-1),indx(ilx:i-1)) + endif + endif + enddo + else + call izasrx_up(n,x,indx) + endif + + case(psb_alsort_down_) + + + + if (n > ithrs) then + ! + ! Init stack pointer + ! + istp = 1 + istack(1,istp) = 1 + istack(2,istp) = n + + do + if (istp <= 0) exit + ilx = istack(1,istp) + iux = istack(2,istp) + istp = istp - 1 + !$$$ write(0,*) 'Debug 1: ',ilx,iux + ! + ! Choose a pivot with median-of-three heuristics, leave it + ! in the LPIV location + ! + i = ilx + j = iux + lpiv = (i+j)/2 + piv = x(lpiv) + if (piv > x(i)) then + xt = x(i) + ixt = indx(i) + x(i) = x(lpiv) + indx(i) = indx(lpiv) + x(lpiv) = xt + indx(lpiv) = ixt + piv = x(lpiv) + endif + if (piv < x(j)) then + xt = x(j) + ixt = indx(j) + x(j) = x(lpiv) + indx(j) = indx(lpiv) + x(lpiv) = xt + indx(lpiv) = ixt + piv = x(lpiv) + endif + if (piv > x(i)) then + xt = x(i) + ixt = indx(i) + x(i) = x(lpiv) + indx(i) = indx(lpiv) + x(lpiv) = xt + indx(lpiv) = ixt + piv = x(lpiv) + endif + ! + ! now piv is correct; place it into first location + xt = x(i) + ixt = indx(i) + x(i) = x(lpiv) + indx(i) = indx(lpiv) + x(lpiv) = xt + indx(lpiv) = ixt + piv = x(lpiv) + + i = ilx - 1 + j = iux + 1 + + outer_dw: do + in_dw1: do + i = i + 1 + xk = x(i) + if (xk <= piv) exit in_dw1 + end do in_dw1 + ! + ! Ensure finite termination for next loop + ! + xt = xk + x(i) = piv + in_dw2:do + j = j - 1 + xk = x(j) + if (xk >= piv) exit in_dw2 + end do in_dw2 + x(i) = xt + + if (j > i) then + xt = x(i) + ixt = indx(i) + x(i) = x(j) + indx(i) = indx(j) + x(j) = xt + indx(j) = ixt + else + exit outer_dw + end if + end do outer_dw + if (i == ilx) then + if (x(i) /= piv) then + write(0,*) 'Should never ever get here????!!!!' + stop + endif + i = i + 1 + endif + + n1 = (i-1)-ilx+1 + n2 = iux-(i)+1 + if (n1 > n2) then + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call izasrx_dw(n1,x(ilx:i-1),indx(ilx:i-1)) + endif + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call izasrx_dw(n2,x(i:iux),indx(i:iux)) + endif + else + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call izasrx_dw(n2,x(i:iux),indx(i:iux)) + endif + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call izasrx_dw(n1,x(ilx:i-1),indx(ilx:i-1)) + endif + endif + enddo + else + call izasrx_dw(n,x,indx) + endif + + case default + write(0,*) 'isrx error dir ',dir + end select + + + return + +contains + + subroutine izasrx_up(n,x,indx) + use zacmp_mod + implicit none + integer :: n + complex(kind(1.d0)) :: x(n) + integer :: indx(n) + integer :: i,j,ix + complex(kind(1.d0)) :: xx + + do j=n-1,1,-1 + if (x(j+1) < x(j)) then + xx = x(j) + ix = indx(j) + i=j+1 + do + x(i-1) = x(i) + indx(i-1) = indx(i) + i = i+1 + if (i>n) exit + if (x(i) >= xx) exit + end do + x(i-1) = xx + indx(i-1) = ix + endif + enddo + end subroutine izasrx_up + + subroutine izasrx_dw(n,x,indx) + use zacmp_mod + implicit none + integer :: n + complex(kind(1.d0)) :: x(n) + integer :: indx(n) + integer :: i,j,ix + complex(kind(1.d0)) :: xx + + do j=n-1,1,-1 + if (x(j+1) > x(j)) then + xx = x(j) + ix = indx(j) + i=j+1 + do + x(i-1) = x(i) + indx(i-1) = indx(i) + i = i+1 + if (i>n) exit + if (x(i) <= xx) exit + end do + x(i-1) = xx + indx(i-1) = ix + endif + enddo + end subroutine izasrx_dw + +end subroutine zasrx diff --git a/base/serial/aux/zlcmp_mod.f90 b/base/serial/aux/zlcmp_mod.f90 new file mode 100644 index 000000000..299cdec58 --- /dev/null +++ b/base/serial/aux/zlcmp_mod.f90 @@ -0,0 +1,44 @@ +module zlcmp_mod + interface operator(<) + module procedure zllt + end interface + interface operator(<=) + module procedure zlle + end interface + interface operator(>) + module procedure zlgt + end interface + interface operator(>=) + module procedure zlge + end interface + +contains + + function zllt(a,b) + complex(kind(1.d0)), intent(in) :: a,b + logical :: zllt + + zllt = (real(a)real(b)).or.((real(a)==real(b)).and.(aimag(a)>aimag(b))) + end function zlgt + function zlge(a,b) + complex(kind(1.d0)), intent(in) :: a,b + logical :: zlge + + zlge = (real(a)>real(b)).or.((real(a)==real(b)).and.(aimag(a)>=aimag(b))) + end function zlge + +end module zlcmp_mod + diff --git a/base/serial/aux/zlsr.f90 b/base/serial/aux/zlsr.f90 new file mode 100644 index 000000000..0fe182e3a --- /dev/null +++ b/base/serial/aux/zlsr.f90 @@ -0,0 +1,362 @@ +!!$ +!!$ Parallel Sparse BLAS v2.0 +!!$ (C) Copyright 2006 Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari University of Rome Tor Vergata +!!$ +!!$ Redistribution and use in source and binary forms, with or without +!!$ modification, are permitted provided that the following conditions +!!$ are met: +!!$ 1. Redistributions of source code must retain the above copyright +!!$ notice, this list of conditions and the following disclaimer. +!!$ 2. Redistributions in binary form must reproduce the above copyright +!!$ notice, this list of conditions, and the following disclaimer in the +!!$ documentation and/or other materials provided with the distribution. +!!$ 3. The name of the PSBLAS group or the names of its contributors may +!!$ not be used to endorse or promote products derived from this +!!$ software without specific written permission. +!!$ +!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +!!$ POSSIBILITY OF SUCH DAMAGE. +!!$ +!!$ + +subroutine zlsr(n,x,dir) + use psb_serial_mod + use zlcmp_mod + implicit none + ! + ! Quicksort on lexicographic comparison of complex numbers. + ! Adapted from a number of sources, including Don Knuth's TAOCP. + ! + ! .. Scalar Arguments .. + integer, intent(in) :: n, dir + complex(kind(1.d0)) :: x(n) + ! .. + ! .. Local Scalars .. + complex(kind(1.d0)) :: xx, xk, piv, xt + integer i, j, ilx, iux, istp, lpiv + integer n1, n2 + + integer, parameter :: maxstack=64,nparms=3,ithrs=16 + integer :: istack(nparms,maxstack) + ! .. + + ! + ! small inputs will only get through insertion sort. + ! + select case(dir) + + case(psb_lsort_up_) + + if (n > ithrs) then + ! + ! Init stack pointer + ! + istp = 1 + istack(1,istp) = 1 + istack(2,istp) = n + + do + if (istp <= 0) exit + ilx = istack(1,istp) + iux = istack(2,istp) + istp = istp - 1 + !$$$ write(0,*) 'Debug 1: ',ilx,iux + ! + ! Choose a pivot with median-of-three heuristics, leave it + ! in the LPIV location + ! + i = ilx + j = iux + lpiv = (i+j)/2 + piv = x(lpiv) + if (piv < x(i)) then + xt = x(i) + x(i) = x(lpiv) + x(lpiv) = xt + piv = x(lpiv) + endif + if (piv > x(j)) then + xt = x(j) + x(j) = x(lpiv) + x(lpiv) = xt + piv = x(lpiv) + endif + if (piv < x(i)) then + xt = x(i) + x(i) = x(lpiv) + x(lpiv) = xt + piv = x(lpiv) + endif + ! + ! now piv is correct; place it into first location + + xt = x(i) + x(i) = x(lpiv) + x(lpiv) = xt + + i = ilx - 1 + j = iux + 1 + + outer_up: do + in_up1: do + i = i + 1 + xk = x(i) + if (xk >= piv) exit in_up1 + end do in_up1 + ! + ! Ensure finite termination for next loop + ! + xt = xk + x(i) = piv + in_up2:do + j = j - 1 + xk = x(j) + if (xk <= piv) exit in_up2 + end do in_up2 + x(i) = xt + + if (j > i) then + xt = x(i) + x(i) = x(j) + x(j) = xt + else + exit outer_up + end if + end do outer_up + if (i == ilx) then + if (x(i) /= piv) then + write(0,*) 'Should never ever get here????!!!!' + stop + endif + i = i + 1 + endif + + n1 = (i-1)-ilx+1 + n2 = iux-(i)+1 + if (n1 > n2) then + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call izlsr_up(n1,x(ilx:i-1)) + endif + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call izlsr_up(n2,x(i:iux)) + endif + else + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call izlsr_up(n2,x(i:iux)) + endif + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call izlsr_up(n1,x(ilx:i-1)) + endif + endif + enddo + else + call izlsr_up(n,x) + endif + + case(psb_lsort_down_) + + + if (n > ithrs) then + ! + ! Init stack pointer + ! + istp = 1 + istack(1,istp) = 1 + istack(2,istp) = n + + do + if (istp <= 0) exit + ilx = istack(1,istp) + iux = istack(2,istp) + istp = istp - 1 + !$$$ write(0,*) 'Debug 1: ',ilx,iux + ! + ! Choose a pivot with median-of-three heuristics, leave it + ! in the LPIV location + ! + i = ilx + j = iux + lpiv = (i+j)/2 + piv = x(lpiv) + if (piv > x(i)) then + xt = x(i) + x(i) = x(lpiv) + x(lpiv) = xt + piv = x(lpiv) + endif + if (piv < x(j)) then + xt = x(j) + x(j) = x(lpiv) + x(lpiv) = xt + piv = x(lpiv) + endif + if (piv > x(i)) then + xt = x(i) + x(i) = x(lpiv) + x(lpiv) = xt + piv = x(lpiv) + endif + ! + ! now piv is correct; place it into first location + + xt = x(i) + x(i) = x(lpiv) + x(lpiv) = xt + + i = ilx - 1 + j = iux + 1 + + outer_dw: do + in_dw1: do + i = i + 1 + xk = x(i) + if (xk <= piv) exit in_dw1 + end do in_dw1 + ! + ! Ensure finite termination for next loop + ! + xt = xk + x(i) = piv + in_dw2:do + j = j - 1 + xk = x(j) + if (xk >= piv) exit in_dw2 + end do in_dw2 + x(i) = xt + + if (j > i) then + xt = x(i) + x(i) = x(j) + x(j) = xt + else + exit outer_dw + end if + end do outer_dw + if (i == ilx) then + if (x(i) /= piv) then + write(0,*) 'Should never ever get here????!!!!' + stop + endif + i = i + 1 + endif + + n1 = (i-1)-ilx+1 + n2 = iux-(i)+1 + if (n1 > n2) then + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call izlsr_dw(n1,x(ilx:i-1)) + endif + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call izlsr_dw(n2,x(i:iux)) + endif + else + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call izlsr_dw(n2,x(i:iux)) + endif + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call izlsr_dw(n1,x(ilx:i-1)) + endif + endif + enddo + else + call izlsr_dw(n,x) + endif + + case default + write(0,*) 'isr error !',dir + end select + + + return + +contains + + subroutine izlsr_up(n,x) + use zlcmp_mod + implicit none + integer :: n + complex(kind(1.d0)) :: x(n) + integer :: i,j + complex(kind(1.d0)) :: xx + + do j=n-1,1,-1 + if (x(j+1) < x(j)) then + xx = x(j) + i=j+1 + do + x(i-1) = x(i) + i = i+1 + if (i>n) exit + if (x(i) >= xx) exit + end do + x(i-1) = xx + endif + enddo + end subroutine izlsr_up + + subroutine izlsr_dw(n,x) + use zlcmp_mod + implicit none + integer :: n + complex(kind(1.d0)) :: x(n) + integer :: i,j + complex(kind(1.d0)) :: xx + + do j=n-1,1,-1 + if (x(j+1) > x(j)) then + xx = x(j) + i=j+1 + do + x(i-1) = x(i) + i = i+1 + if (i>n) exit + if (x(i) <= xx) exit + end do + x(i-1) = xx + endif + enddo + end subroutine izlsr_dw + +end subroutine zlsr diff --git a/base/serial/aux/zlsrx.f90 b/base/serial/aux/zlsrx.f90 new file mode 100644 index 000000000..ef6467d0f --- /dev/null +++ b/base/serial/aux/zlsrx.f90 @@ -0,0 +1,413 @@ +!!$ +!!$ Parallel Sparse BLAS v2.0 +!!$ (C) Copyright 2006 Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari University of Rome Tor Vergata +!!$ +!!$ Redistribution and use in source and binary forms, with or without +!!$ modification, are permitted provided that the following conditions +!!$ are met: +!!$ 1. Redistributions of source code must retain the above copyright +!!$ notice, this list of conditions and the following disclaimer. +!!$ 2. Redistributions in binary form must reproduce the above copyright +!!$ notice, this list of conditions, and the following disclaimer in the +!!$ documentation and/or other materials provided with the distribution. +!!$ 3. The name of the PSBLAS group or the names of its contributors may +!!$ not be used to endorse or promote products derived from this +!!$ software without specific written permission. +!!$ +!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +!!$ POSSIBILITY OF SUCH DAMAGE. +!!$ +!!$ +subroutine zlsrx(n,x,indx,dir,flag) + use psb_serial_mod + use zlcmp_mod + implicit none + ! + ! Quicksort with indices into original positions. + ! Adapted from a number of sources, including Don Knuth's TAOCP. + ! + ! .. Scalar Arguments .. + integer, intent(in) :: n, dir, flag + complex(kind(1.d0)) :: x(n) + integer :: indx(n) + ! .. + ! .. Local Scalars .. + complex(kind(1.d0)) :: xx, piv, xk, xt + integer i, j, ii, ilx, iux, istp, lpiv + integer ixt, n1, n2 + + integer, parameter :: maxstack=64,nparms=3,ithrs=16 + integer :: istack(nparms,maxstack) + ! .. + + select case(flag) + case(psb_sort_ovw_idx_) + do i=1, n + indx(i) = i + enddo + case(psb_sort_keep_idx_) + ! do nothing + case default + write(0,*) 'Error in isrx: invalid flag',flag + end select + ! + + ! + ! small inputs will only get through insertion sort. + ! + select case(dir) + + case(psb_lsort_up_) + + if (n > ithrs) then + ! + ! Init stack pointer + ! + istp = 1 + istack(1,istp) = 1 + istack(2,istp) = n + + do + if (istp <= 0) exit + ilx = istack(1,istp) + iux = istack(2,istp) + istp = istp - 1 + !$$$ write(0,*) 'Debug 1: ',ilx,iux + ! + ! Choose a pivot with median-of-three heuristics, leave it + ! in the LPIV location + ! + i = ilx + j = iux + lpiv = (i+j)/2 + piv = x(lpiv) + if (piv < x(i)) then + xt = x(i) + ixt = indx(i) + x(i) = x(lpiv) + indx(i) = indx(lpiv) + x(lpiv) = xt + indx(lpiv) = ixt + piv = x(lpiv) + endif + if (piv > x(j)) then + xt = x(j) + ixt = indx(j) + x(j) = x(lpiv) + indx(j) = indx(lpiv) + x(lpiv) = xt + indx(lpiv) = ixt + piv = x(lpiv) + endif + if (piv < x(i)) then + xt = x(i) + ixt = indx(i) + x(i) = x(lpiv) + indx(i) = indx(lpiv) + x(lpiv) = xt + indx(lpiv) = ixt + piv = x(lpiv) + endif + ! + ! now piv is correct; place it into first location + xt = x(i) + ixt = indx(i) + x(i) = x(lpiv) + indx(i) = indx(lpiv) + x(lpiv) = xt + indx(lpiv) = ixt + piv = x(lpiv) + + i = ilx - 1 + j = iux + 1 + + outer_up: do + in_up1: do + i = i + 1 + xk = x(i) + if (xk >= piv) exit in_up1 + end do in_up1 + ! + ! Ensure finite termination for next loop + ! + xt = xk + x(i) = piv + in_up2:do + j = j - 1 + xk = x(j) + if (xk <= piv) exit in_up2 + end do in_up2 + x(i) = xt + + if (j > i) then + xt = x(i) + ixt = indx(i) + x(i) = x(j) + indx(i) = indx(j) + x(j) = xt + indx(j) = ixt + else + exit outer_up + end if + end do outer_up + if (i == ilx) then + if (x(i) /= piv) then + write(0,*) 'Should never ever get here????!!!!' + stop + endif + i = i + 1 + endif + + n1 = (i-1)-ilx+1 + n2 = iux-(i)+1 + if (n1 > n2) then + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call izlsrx_up(n1,x(ilx:i-1),indx(ilx:i-1)) + endif + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call izlsrx_up(n2,x(i:iux),indx(i:iux)) + endif + else + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call izlsrx_up(n2,x(i:iux),indx(i:iux)) + endif + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call izlsrx_up(n1,x(ilx:i-1),indx(ilx:i-1)) + endif + endif + enddo + else + call izlsrx_up(n,x,indx) + endif + + case(psb_lsort_down_) + + + + if (n > ithrs) then + ! + ! Init stack pointer + ! + istp = 1 + istack(1,istp) = 1 + istack(2,istp) = n + + do + if (istp <= 0) exit + ilx = istack(1,istp) + iux = istack(2,istp) + istp = istp - 1 + !$$$ write(0,*) 'Debug 1: ',ilx,iux + ! + ! Choose a pivot with median-of-three heuristics, leave it + ! in the LPIV location + ! + i = ilx + j = iux + lpiv = (i+j)/2 + piv = x(lpiv) + if (piv > x(i)) then + xt = x(i) + ixt = indx(i) + x(i) = x(lpiv) + indx(i) = indx(lpiv) + x(lpiv) = xt + indx(lpiv) = ixt + piv = x(lpiv) + endif + if (piv < x(j)) then + xt = x(j) + ixt = indx(j) + x(j) = x(lpiv) + indx(j) = indx(lpiv) + x(lpiv) = xt + indx(lpiv) = ixt + piv = x(lpiv) + endif + if (piv > x(i)) then + xt = x(i) + ixt = indx(i) + x(i) = x(lpiv) + indx(i) = indx(lpiv) + x(lpiv) = xt + indx(lpiv) = ixt + piv = x(lpiv) + endif + ! + ! now piv is correct; place it into first location + xt = x(i) + ixt = indx(i) + x(i) = x(lpiv) + indx(i) = indx(lpiv) + x(lpiv) = xt + indx(lpiv) = ixt + piv = x(lpiv) + + i = ilx - 1 + j = iux + 1 + + outer_dw: do + in_dw1: do + i = i + 1 + xk = x(i) + if (xk <= piv) exit in_dw1 + end do in_dw1 + ! + ! Ensure finite termination for next loop + ! + xt = xk + x(i) = piv + in_dw2:do + j = j - 1 + xk = x(j) + if (xk >= piv) exit in_dw2 + end do in_dw2 + x(i) = xt + + if (j > i) then + xt = x(i) + ixt = indx(i) + x(i) = x(j) + indx(i) = indx(j) + x(j) = xt + indx(j) = ixt + else + exit outer_dw + end if + end do outer_dw + if (i == ilx) then + if (x(i) /= piv) then + write(0,*) 'Should never ever get here????!!!!' + stop + endif + i = i + 1 + endif + + n1 = (i-1)-ilx+1 + n2 = iux-(i)+1 + if (n1 > n2) then + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call izlsrx_dw(n1,x(ilx:i-1),indx(ilx:i-1)) + endif + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call izlsrx_dw(n2,x(i:iux),indx(i:iux)) + endif + else + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call izlsrx_dw(n2,x(i:iux),indx(i:iux)) + endif + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call izlsrx_dw(n1,x(ilx:i-1),indx(ilx:i-1)) + endif + endif + enddo + else + call izlsrx_dw(n,x,indx) + endif + + case default + write(0,*) 'isrx error dir ',dir + end select + + + return + +contains + + subroutine izlsrx_up(n,x,indx) + use zlcmp_mod + implicit none + integer :: n + complex(kind(1.d0)) :: x(n) + integer :: indx(n) + integer :: i,j,ix + complex(kind(1.d0)) :: xx + + do j=n-1,1,-1 + if (x(j+1) < x(j)) then + xx = x(j) + ix = indx(j) + i=j+1 + do + x(i-1) = x(i) + indx(i-1) = indx(i) + i = i+1 + if (i>n) exit + if (x(i) >= xx) exit + end do + x(i-1) = xx + indx(i-1) = ix + endif + enddo + end subroutine izlsrx_up + + subroutine izlsrx_dw(n,x,indx) + use zlcmp_mod + implicit none + integer :: n + complex(kind(1.d0)) :: x(n) + integer :: indx(n) + integer :: i,j,ix + complex(kind(1.d0)) :: xx + + do j=n-1,1,-1 + if (x(j+1) > x(j)) then + xx = x(j) + ix = indx(j) + i=j+1 + do + x(i-1) = x(i) + indx(i-1) = indx(i) + i = i+1 + if (i>n) exit + if (x(i) <= xx) exit + end do + x(i-1) = xx + indx(i-1) = ix + endif + enddo + end subroutine izlsrx_dw + +end subroutine zlsrx diff --git a/base/serial/dp/dcoco.f b/base/serial/dp/dcoco.f index b1eddbf09..69517f735 100644 --- a/base/serial/dp/dcoco.f +++ b/base/serial/dp/dcoco.f @@ -36,6 +36,7 @@ c use psb_const_mod use psb_spmat_type + use psb_string_mod implicit none c .. scalar arguments .. @@ -74,8 +75,8 @@ c call psb_getifield(check_flag,psb_dupl_,infon,psb_ifasize_,ierror) - if (trans.eq.'N') then - scale = (unitd.eq.'L') ! meaningless + if (toupper(trans).eq.'N') then + scale = (toupper(unitd).eq.'L') ! meaningless p1(1) = 0 p2(1) = 0 @@ -114,7 +115,7 @@ c goto 9999 end if - if (descra(1:1).eq.'G') then + if (toupper(descra(1:1)).eq.'G') then c c sort COO data structure c @@ -245,26 +246,29 @@ c ... add the duplicated element ... if (debug) write(*,*)'done rebuild COO',infon(1) - else if (descra(1:1).eq.'S' .and. descra(2:2).eq.'U') then + else if (toupper(descra(1:1)).eq.'S' .and. + + toupper(descra(2:2)).eq.'U') then ierror = 3021 call fcpsb_errpush(ierror,name,int_val) goto 9999 - else if (descra(1:1).eq.'T' .and. descra(2:2).eq.'U') then + else if (toupper(descra(1:1)).eq.'T' .and. + + toupper(descra(2:2)).eq.'U') then ierror = 3021 call fcpsb_errpush(ierror,name,int_val) goto 9999 - else if (descra(1:1).eq.'T' .and. descra(2:2).eq.'L') then + else if (toupper(descra(1:1)).eq.'T' .and. + + toupper(descra(2:2)).eq.'L') then ierror = 3021 call fcpsb_errpush(ierror,name,int_val) goto 9999 end if c - else if (trans.ne.'N') then + else if (toupper(trans).ne.'N') then c c to do c diff --git a/base/serial/dp/dcocr.f b/base/serial/dp/dcocr.f index 1d07f5876..bf2a92a71 100644 --- a/base/serial/dp/dcocr.f +++ b/base/serial/dp/dcocr.f @@ -37,6 +37,7 @@ C use psb_const_mod use psb_spmat_type + use psb_string_mod IMPLICIT NONE C @@ -51,18 +52,19 @@ C .. Array Arguments .. * INFON(*), P1(*), P2(*) CHARACTER DESCRA*11, DESCRN*11 C .. Local Scalars .. - INTEGER NNZ, K, ROW, I, J, NZL, IRET - integer ipx, ip1, ip2, CHECK_FLAG, err_act - INTEGER ELEM, ELEM_CSR - LOGICAL SCALE - INTEGER MAX_NNZERO + integer nnz, k, row, i, j, nzl, iret + integer ipx, ip1, ip2, check_flag, err_act + integer elem, elem_csr,regen_flag + logical scale + integer max_nnzero logical debug parameter (debug=.false.) -c .. Local Arrays .. - CHARACTER*20 NAME - INTEGER INT_VAL(5) + integer, allocatable :: itmp(:) +c .. local arrays .. + character*20 name + integer int_val(5) -C +c C ...Common variables... C .. External Subroutines .. @@ -75,14 +77,15 @@ C CALL FCPSB_ERRACTIONSAVE(ERR_ACT) call psb_getifield(check_flag,psb_dupl_,infon,psb_ifasize_,ierror) + call psb_getifield(regen_flag,psb_upd_,infon,psb_ifasize_,ierror) - IF ((TRANS.EQ.'N').or.(TRANS.EQ.'n')) THEN + IF (toupper(TRANS).EQ.'N') THEN - SCALE = (UNITD.EQ.'L') ! meaningless + SCALE = (toupper(UNITD).EQ.'L') ! meaningless P1(1) = 0 P2(1) = 0 - NNZ = INFO(1) + nnz = info(1) if (debug) then write(0,*) 'On entry to DCOCR: NNZ LAUX ', + nnz,laux,larn,lian1,lian2 @@ -117,25 +120,35 @@ C GOTO 9999 END IF - IF (DESCRA(1:1).EQ.'G') THEN + allocate(itmp(nnz),stat=iret) + if (iret /= 0) then + call fcpsb_errpush(4010,name,int_val) + goto 9999 + end if + + do k=1, nnz + arn(k) = ar(k) + ian1(k) = ja(k) + itmp(k) = ia(k) + enddo + ! Mark as unavailable by default. + infon(psb_upd_pnt_) = 0 + + + IF (toupper(descra(1:1)).EQ.'G') THEN C C Sort COO data structure C if (debug) write(0,*)'First sort',nnz -c$$$ if (debug) then -c$$$ do k=1,nnz -c$$$ write(*,*) k,ia(k),ja(k),ar(k) -c$$$ enddo -c$$$ endif c$$$ write(0,*) 'DCOCR Sizes ',lian2,((m+1)+nnz+psb_ireg_flgs_+1), c$$$ + m+1,nnz,psb_ireg_flgs_, c$$$ + laux,2*(2+nnz) - if ((lian2.ge.((m+1)+nnz+psb_ireg_flgs_+1)) + if ((regen_flag==psb_upd_perm_).and. + + (lian2.ge.((m+1)+nnz+psb_ireg_flgs_+1)) + .and.(laux.ge.2*(2+nnz))) then C C Prepare for smart regeneration c - ipx = nnz+3 do i=1, nnz aux(ipx+i-1) = i @@ -149,182 +162,167 @@ c ian2(ip1+psb_nnz_) = 0 ian2(ip1+psb_ichk_) = nnz+check_flag -c$$$ write(0,*)'DCOCR Check: ',ip2,ian2(ip1+psb_iflag_), -c$$$ + ian2(ip1+psb_nnzt_), ian2(ip1+psb_nnz_), -c$$$ + ian2(ip1+psb_ichk_) - -c$$$ + ip1,ip2,nnz,ian2(ip1+nnzt_) - if (debug) write(0,*) 'Build check :',ian2(ip1+psb_nnzt_) C .... Order with key IA ... - CALL MSORT_UP(NNZ,IA,AUX,IRET) - IF (IRET.EQ.0) CALL REORDVN3(NNZ,AR,IA,JA,AUX(IPX),AUX) + call msort_up(nnz,itmp,aux,iret) + if (iret.eq.0) call reordvn3(nnz,arn,itmp,ian1,aux(ipx),aux) if (debug) then do i=1, nnz-1 - if (ia(i).gt.ia(i+1)) then - write(0,*) 'Sorting error:',i,ia(i),ia(i+1) + if (itmp(i).gt.itmp(i+1)) then + write(0,*) 'Sorting error:',i,itmp(i),itmp(i+1) endif enddo - write(0,*) 'nnz :',m,nnz,ia(nnz),ja(nnz) + write(0,*) 'nnz :',m,nnz,itmp(nnz),ian1(nnz) endif -C .... Order with key IA2N ... +C .... Order with key JA ... I = 1 J = I -c$$$ DO WHILE (I.LE.NNZ) -c$$$ DO WHILE ((IA(J).EQ.IA(I)).AND. -c$$$ + (J.LE.NNZ)) - DO - if (I>NNZ) exit - DO + do + if (i>nnz) exit + do if (j>nnz) exit - if (ia(j) /= ia(i)) exit - J = J+1 - ENDDO - NZL = J - I - CALL MSORT_UP(NZL,JA(I),AUX,IRET) - IF (IRET.EQ.0) CALL REORDVN3(NZL,AR(I),IA(I),JA(I), - + AUX(IPX+I-1),AUX) - I = J - ENDDO + if (itmp(j) /= itmp(i)) exit + j = j+1 + enddo + nzl = j - i + call msort_up(nzl,ian1(i),aux,iret) + if (iret.eq.0) call reordvn3(nzl,arn(i),itmp(i),ian1(i), + + aux(ipx+i-1),aux) + i = j + enddo -C ... Construct CSR Representation... - ELEM = 1 - ELEM_CSR = 1 -C ... Insert first element ... - DO ROW = 1, IA(1) - IAN2(ROW) = 1 - ENDDO +c ... Construct CSR Representation... + elem = 1 + elem_csr = 1 +c ... Insert first element ... + do row = 1, itmp(1) + ian2(row) = 1 + enddo if (debug) write(0,*)'Rebuild CSR',ia(1),elem_csr - IAN1(ELEM_CSR) = JA(ELEM) - ARN(ELEM_CSR) = AR(ELEM) + ian1(elem_csr) = ian1(elem) + arn(elem_csr) = arn(elem) ian2(ip2+aux(ipx+elem-1)-1) = elem_csr - ELEM = ELEM+1 - ELEM_CSR = ELEM_CSR+1 -C ... Insert remaining element ... - DO ROW = IA(1), M -c$$$ if (debug) write(*,*)'CSR Loop:',row,m,elem_csr -c$$$ DO WHILE ((IA(ELEM).EQ.ROW).AND.(ELEM.LE.NNZ)) - DO + elem = elem+1 + elem_csr = elem_csr+1 +c ... insert remaining element ... + do row = itmp(1), m + do if (elem > nnz) exit - if (ia(elem) /= row) exit - IF (IA(ELEM).NE.IA(ELEM-1)) THEN -C ... Insert first element of a row ... - IAN1(ELEM_CSR) = JA(ELEM) - ARN(ELEM_CSR) = AR(ELEM) + if (itmp(elem) /= row) exit + if (itmp(elem).ne.itmp(elem-1)) then +c ... insert first element of a row ... + ian1(elem_csr) = ian1(elem) + arn(elem_csr) = arn(elem) ian2(ip2+aux(ipx+elem-1)-1) = elem_csr - ELEM_CSR = ELEM_CSR+1 - ELSE IF (JA(ELEM).NE.JA(ELEM-1)) THEN -C ... Insert other element of row ... - IAN1(ELEM_CSR) = JA(ELEM) - ARN(ELEM_CSR) = AR(ELEM) + elem_csr = elem_csr+1 + else if (ian1(elem).ne.ian1(elem-1)) then +c ... insert other element of row ... + ian1(elem_csr) = ian1(elem) + arn(elem_csr) = arn(elem) ian2(ip2+aux(ipx+elem-1)-1) = elem_csr - ELEM_CSR = ELEM_CSR+1 - ELSE - IF (CHECK_FLAG.EQ.psb_dupl_err_) THEN -C ... Error, there are duplicated elements ... - IERROR = 130 - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - ELSE IF (CHECK_FLAG.EQ.psb_dupl_ovwrt_) THEN -C ... Insert only the last duplicated element ... - ARN(ELEM_CSR-1) = AR(ELEM) + elem_csr = elem_csr+1 + else + if (check_flag.eq.psb_dupl_err_) then +c ... error, there are duplicated elements ... + ierror = 130 + call fcpsb_errpush(ierror,name,int_val) + goto 9999 + else if (check_flag.eq.psb_dupl_ovwrt_) then +c ... insert only the last duplicated element ... + arn(elem_csr-1) = arn(elem) ian2(ip2+aux(ipx+elem-1)-1) = elem_csr-1 - if (debug) write(0,*) 'Duplicated overwrite perm ', + if (debug) write(0,*) 'duplicated overwrite perm ', + elem_csr-1,elem - ELSE IF (CHECK_FLAG.EQ.psb_dupl_add_) THEN -C ... Sum the duplicated element ... - ARN(ELEM_CSR-1) = ARN(ELEM_CSR-1) + AR(ELEM) + else if (check_flag.eq.psb_dupl_add_) then +c ... sum the duplicated element ... + arn(elem_csr-1) = arn(elem_csr-1) + arn(elem) ian2(ip2+aux(ipx+elem-1)-1) = elem_csr-1 - if (debug) write(0,*) 'Duplicated add perm ', + if (debug) write(0,*) 'duplicated add perm ', + elem_csr-1,elem - END IF - ENDIF - ELEM = ELEM + 1 - ENDDO - IAN2(ROW+1) = ELEM_CSR - ENDDO + end if + endif + elem = elem + 1 + enddo + ian2(row+1) = elem_csr + enddo - ELSE -c$$$ write(0,*) 'Going for ELSE !!!?' + else C .... Order with key IA ... - CALL MSORT_UP(NNZ,IA,AUX,IRET) - IF (IRET.EQ.0) CALL REORDVN(NNZ,AR,IA,JA,AUX) -C .... Order with key IA2N ... - I = 1 - J = I -c$$$ DO WHILE (I.LE.NNZ) -c$$$ DO WHILE ((IA(J).EQ.IA(I)).AND. -c$$$ + (J.LE.NNZ)) - DO - if (I>NNZ) exit - DO + + call msort_up(nnz,itmp,aux,iret) + if (iret.eq.0) call reordvn(nnz,arn,itmp,ian1,aux) +C .... Order with key JA ... + i = 1 + j = i + do + if (i>nnz) exit + do if (j>nnz) exit - if (ia(j) /= ia(i)) exit - J = J+1 - ENDDO - NZL = J - I - CALL MSORT_UP(NZL,JA(I),AUX,IRET) - IF (IRET.EQ.0) CALL REORDVN(NZL,AR(I),IA(I),JA(I),AUX) - I = J - ENDDO + if (itmp(j) /= itmp(i)) exit + j = j+1 + enddo + nzl = j - i + call msort_up(nzl,ian1(i),aux,iret) + if (iret.eq.0) + + call reordvn(nzl,arn(i),itmp(i),ian1(i),aux) + i = j + enddo C ... Construct CSR Representation... - ELEM = 1 - ELEM_CSR = 1 + elem = 1 + elem_csr = 1 C ... Insert first element ... - DO ROW = 1, IA(1) - IAN2(ROW) = 1 - ENDDO + do row = 1, itmp(1) + ian2(row) = 1 + enddo if (debug) write(0,*)'Rebuild CSR',ia(1),elem_csr - IAN1(ELEM_CSR) = JA(ELEM) - ARN(ELEM_CSR) = AR(ELEM) - ELEM = ELEM+1 - ELEM_CSR = ELEM_CSR+1 + ian1(elem_csr) = ian1(elem) + arn(elem_csr) = arn(elem) + elem = elem+1 + elem_csr = elem_csr+1 C ... Insert remaining element ... - DO ROW = IA(1), M -c$$$ if (debug) write(*,*)'CSR Loop:',row,m,elem_csr -c$$$ DO WHILE ((IA(ELEM).EQ.ROW).AND.(ELEM.LE.NNZ)) - DO + do row = itmp(1), m + do if (elem > nnz) exit - if (ia(elem) /= row) exit - IF (IA(ELEM).NE.IA(ELEM-1)) THEN -C ... Insert first element of a row ... - IAN1(ELEM_CSR) = JA(ELEM) - ARN(ELEM_CSR) = AR(ELEM) - ELEM_CSR = ELEM_CSR+1 - ELSE IF (JA(ELEM).NE.JA(ELEM-1)) THEN + if (itmp(elem) /= row) exit + if (itmp(elem).ne.itmp(elem-1)) then +c ... insert first element of a row ... + ian1(elem_csr) = ian1(elem) + arn(elem_csr) = arn(elem) + elem_csr = elem_csr+1 + else if (ian1(elem).ne.ian1(elem-1)) then C ... Insert other element of row ... - IAN1(ELEM_CSR) = JA(ELEM) - ARN(ELEM_CSR) = AR(ELEM) - ELEM_CSR = ELEM_CSR+1 - ELSE - IF (CHECK_FLAG.EQ.psb_dupl_err_) THEN -C ... Error, there are duplicated elements ... - IERROR = 130 - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - ELSE IF (CHECK_FLAG.EQ.psb_dupl_ovwrt_) THEN -C ... Insert only the last duplicated element ... - ARN(ELEM_CSR-1) = AR(ELEM) + ian1(elem_csr) = ian1(elem) + arn(elem_csr) = arn(elem) + elem_csr = elem_csr+1 + else + if (check_flag.eq.psb_dupl_err_) then +c ... error, there are duplicated elements ... + ierror = 130 + call fcpsb_errpush(ierror,name,int_val) + goto 9999 + else if (check_flag.eq.psb_dupl_ovwrt_) then +c ... insert only the last duplicated element ... + arn(elem_csr-1) = arn(elem) if (debug) write(0,*) 'Duplicated overwrite srch', + elem_csr-1,elem - ELSE IF (CHECK_FLAG.EQ.psb_dupl_add_) THEN -C ... Sum the duplicated element ... - ARN(ELEM_CSR-1) = ARN(ELEM_CSR-1) + AR(ELEM) + else if (check_flag.eq.psb_dupl_add_) then +c ... sum the duplicated element ... + arn(elem_csr-1) = arn(elem_csr-1) + arn(elem) if (debug) write(0,*) 'Duplicated add srch', + elem_csr-1,elem - END IF - ENDIF - ELEM = ELEM + 1 - ENDDO - IAN2(ROW+1) = ELEM_CSR - ENDDO - ENDIF + end if + endif + elem = elem + 1 + enddo + ian2(row+1) = elem_csr + enddo + endif if (debug) write(0,*)'Done Rebuild CSR', + ian2(m+1),ia(elem) @@ -334,200 +332,162 @@ c$$$ write(0,*) 'Overflow check :',ia(i),ja(i),ar(i) c$$$ enddo c$$$ endif - ELSE IF (DESCRA(1:1).EQ.'S' .AND. DESCRA(2:2).EQ.'U') THEN + ELSE IF (toupper(DESCRA(1:1)).EQ.'S' .AND. + + toupper(DESCRA(2:2)).EQ.'U') THEN - DO 20 K = 1, M - P2(K) = K - 20 CONTINUE + do 20 k = 1, m + p2(k) = k + 20 continue - ELSE IF (DESCRA(1:1).EQ.'T' .AND. DESCRA(2:2).EQ.'U') THEN + else if (toupper(DESCRA(1:1)).EQ.'T' .AND. + + toupper(DESCRA(2:2)).EQ.'U') THEN + + + call msort_up(nnz,itmp,aux,iret) + if (iret.eq.0) call reordvn(nnz,arn,itmp,ian1,aux) +C .... Order with key JA ... + i = 1 + j = i + do + if (i>nnz) exit + do + if (j>nnz) exit + if (itmp(j) /= itmp(i)) exit + j = j+1 + enddo + nzl = j - i + call msort_up(nzl,ian1(i),aux,iret) + if (iret.eq.0) + + call reordvn(nzl,arn(i),itmp(i),ian1(i),aux) + i = j + enddo -C .... Order with key IA ... - CALL MSORT_UP(NNZ,IA,AUX,IRET) - IF (IRET.EQ.0) CALL REORDVN(NNZ,AR,IA,JA,AUX) -C .... Order with key IA2N ... - I = 1 - J = I -c$$$ DO WHILE (I.LE.NNZ) -c$$$ DO WHILE ((IA(J).EQ.IA(I)).AND. -c$$$ + (J.LE.NNZ)) - DO - if (I>NNZ) exit - DO - if (j>nnz) exit - if (ia(j) /= ia(i)) exit - J = J+1 - ENDDO - NZL = J - I - CALL MSORT_UP(NZL,JA(I),AUX,IRET) - IF (IRET.EQ.0) CALL REORDVN(NZL,AR(I),IA(I),JA(I),AUX) - I = J - ENDDO C ... Construct CSR Representation... - ELEM = 1 - ELEM_CSR = 1 + elem = 1 + elem_csr = 1 C ... Insert first element ... - DO ROW = 1, IA(1) - IAN2(ROW) = 1 - ENDDO - if (debug) write(0,*)'Rebuild CSR',ia(1),elem_csr - IF(JA(ELEM).GT.IA(ELEM)) THEN - IAN1(ELEM_CSR) = JA(ELEM) - ARN(ELEM_CSR) = AR(ELEM) - ELEM_CSR = ELEM_CSR+1 - ENDIF - - ELEM = ELEM+1 - + do row = 1, itmp(1) + ian2(row) = 1 + enddo + if (debug) write(0,*)'Rebuild CSR',ia(1),elem_csr + ian1(elem_csr) = ian1(elem) + arn(elem_csr) = arn(elem) + elem = elem+1 + elem_csr = elem_csr+1 C ... Insert remaining element ... - DO ROW = IA(1), M -c$$$ if (debug) write(*,*)'CSR Loop:',row,m,elem_csr -c$$$ DO WHILE ((IA(ELEM).EQ.ROW).AND.(ELEM.LE.NNZ)) - DO - if (elem > nnz) exit - if (ia(elem) /= row) exit - IF (IA(ELEM).NE.IA(ELEM-1)) THEN -C ... Insert first element of a row ... - IF(JA(ELEM).GT.IA(ELEM)) THEN - IAN1(ELEM_CSR) = JA(ELEM) - ARN(ELEM_CSR) = AR(ELEM) - ELEM_CSR = ELEM_CSR+1 - ENDIF - ELSE IF (JA(ELEM).NE.JA(ELEM-1)) THEN -C ... Insert other element of row ... - IF(JA(ELEM).GT.IA(ELEM)) THEN - IAN1(ELEM_CSR) = JA(ELEM) - ARN(ELEM_CSR) = AR(ELEM) - ELEM_CSR = ELEM_CSR+1 - ENDIF - ELSE - IF (CHECK_FLAG.EQ.psb_dupl_err_) THEN -C ... Error, there are duplicated elements ... - IERROR = 130 - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - ELSE IF (CHECK_FLAG.EQ.psb_dupl_ovwrt_) THEN -C ... Insert only the last duplicated element ... - IF(JA(ELEM).GT.IA(ELEM)) THEN - ARN(ELEM_CSR-1) = AR(ELEM) - ENDIF - if (debug) write(0,*) 'Duplicated overwrite', - + elem_csr-1,elem - ELSE IF (CHECK_FLAG.EQ.psb_dupl_add_) THEN -C ... Sum the duplicated element ... - IF(JA(ELEM).GT.IA(ELEM)) THEN - ARN(ELEM_CSR-1) = ARN(ELEM_CSR-1) + AR(ELEM) - ENDIF - if (debug) write(0,*) 'Duplicated add', - + elem_csr-1,elem - END IF - ENDIF - ELEM = ELEM + 1 - ENDDO - IAN2(ROW+1) = ELEM_CSR - ENDDO - - - if (debug) write(0,*)'Done Rebuild CSR', - + ian2(m+1),ia(elem) - if (debug) then - do i=ian2(m+1), nnz - write(0,*) 'Overflow check :',ia(i),ja(i),ar(i) + do row = itmp(1), m + do + if (elem > nnz) exit + if (itmp(elem) /= row) exit + if (itmp(elem).ne.itmp(elem-1)) then +c ... insert first element of a row ... + ian1(elem_csr) = ian1(elem) + arn(elem_csr) = arn(elem) + elem_csr = elem_csr+1 + else if (ian1(elem).ne.ian1(elem-1)) then +C ... Insert other element of row ... + ian1(elem_csr) = ian1(elem) + arn(elem_csr) = arn(elem) + elem_csr = elem_csr+1 + else + if (check_flag.eq.psb_dupl_err_) then +c ... error, there are duplicated elements ... + ierror = 130 + call fcpsb_errpush(ierror,name,int_val) + goto 9999 + else if (check_flag.eq.psb_dupl_ovwrt_) then +c ... insert only the last duplicated element ... + arn(elem_csr-1) = arn(elem) + if (debug) write(0,*) 'Duplicated overwrite srch', + + elem_csr-1,elem + else if (check_flag.eq.psb_dupl_add_) then +c ... sum the duplicated element ... + arn(elem_csr-1) = arn(elem_csr-1) + arn(elem) + if (debug) write(0,*) 'Duplicated add srch', + + elem_csr-1,elem + end if + endif + elem = elem + 1 + enddo + ian2(row+1) = elem_csr enddo - endif - - - ELSE IF (DESCRA(1:1).EQ.'T' .AND. DESCRA(2:2).EQ.'L') THEN + else if (toupper(descra(1:1)).EQ.'T' .AND. + + toupper(DESCRA(2:2)).EQ.'L') THEN + + call msort_up(nnz,itmp,aux,iret) + if (iret.eq.0) call reordvn(nnz,arn,itmp,ian1,aux) +C .... Order with key JA ... + i = 1 + j = i + do + if (i>nnz) exit + do + if (j>nnz) exit + if (itmp(j) /= itmp(i)) exit + j = j+1 + enddo + nzl = j - i + call msort_up(nzl,ian1(i),aux,iret) + if (iret.eq.0) + + call reordvn(nzl,arn(i),itmp(i),ian1(i),aux) + i = j + enddo + -C .... Order with key IA ... - CALL MSORT_UP(NNZ,IA,AUX,IRET) - IF (IRET.EQ.0) CALL REORDVN(NNZ,AR,IA,JA,AUX) -C .... Order with key IA2N ... - I = 1 - J = I -c$$$ DO WHILE (I.LE.NNZ) -c$$$ DO WHILE ((IA(J).EQ.IA(I)).AND. -c$$$ + (J.LE.NNZ)) - DO - if (I>NNZ) exit - DO - if (j>nnz) exit - if (ia(j) /= ia(i)) exit - J = J+1 - ENDDO - NZL = J - I - CALL MSORT_UP(NZL,JA(I),AUX,IRET) - IF (IRET.EQ.0) CALL REORDVN(NZL,AR(I),IA(I),JA(I),AUX) - I = J - ENDDO C ... Construct CSR Representation... - ELEM = 1 - ELEM_CSR = 1 + elem = 1 + elem_csr = 1 C ... Insert first element ... - DO ROW = 1, IA(1) - IAN2(ROW) = 1 - ENDDO - if (debug) write(0,*)'Rebuild CSR',ia(1),elem_csr - IF(JA(ELEM).LT.IA(ELEM)) THEN - IAN1(ELEM_CSR) = JA(ELEM) - ARN(ELEM_CSR) = AR(ELEM) - ELEM_CSR = ELEM_CSR+1 - ENDIF - ELEM = ELEM+1 + do row = 1, itmp(1) + ian2(row) = 1 + enddo + if (debug) write(0,*)'Rebuild CSR',ia(1),elem_csr + ian1(elem_csr) = ian1(elem) + arn(elem_csr) = arn(elem) + elem = elem+1 + elem_csr = elem_csr+1 +C ... Insert remaining element ... + do row = itmp(1), m + do + if (elem > nnz) exit + if (itmp(elem) /= row) exit + if (itmp(elem).ne.itmp(elem-1)) then +c ... insert first element of a row ... + ian1(elem_csr) = ian1(elem) + arn(elem_csr) = arn(elem) + elem_csr = elem_csr+1 + else if (ian1(elem).ne.ian1(elem-1)) then +C ... Insert other element of row ... + ian1(elem_csr) = ian1(elem) + arn(elem_csr) = arn(elem) + elem_csr = elem_csr+1 + else + if (check_flag.eq.psb_dupl_err_) then +c ... error, there are duplicated elements ... + ierror = 130 + call fcpsb_errpush(ierror,name,int_val) + goto 9999 + else if (check_flag.eq.psb_dupl_ovwrt_) then +c ... insert only the last duplicated element ... + arn(elem_csr-1) = arn(elem) + if (debug) write(0,*) 'Duplicated overwrite srch', + + elem_csr-1,elem + else if (check_flag.eq.psb_dupl_add_) then +c ... sum the duplicated element ... + arn(elem_csr-1) = arn(elem_csr-1) + arn(elem) + if (debug) write(0,*) 'Duplicated add srch', + + elem_csr-1,elem + end if + endif + elem = elem + 1 + enddo + ian2(row+1) = elem_csr + enddo -C ... Insert remaining element ... - DO ROW = IA(1), M -c$$$ if (debug) write(*,*)'CSR Loop:',row,m,elem_csr -c$$$ DO WHILE ((IA(ELEM).EQ.ROW).AND.(ELEM.LE.NNZ)) - DO - if (elem > nnz) exit - if (ia(elem) /= row) exit - IF (IA(ELEM).NE.IA(ELEM-1)) THEN -C ... Insert first element of a row ... - IF(JA(ELEM).LT.IA(ELEM)) THEN - IAN1(ELEM_CSR) = JA(ELEM) - ARN(ELEM_CSR) = AR(ELEM) - ELEM_CSR = ELEM_CSR+1 - ENDIF - ELSE IF (JA(ELEM).NE.JA(ELEM-1)) THEN -C ... Insert other element of row ... - IF(JA(ELEM).LT.IA(ELEM)) THEN - IAN1(ELEM_CSR) = JA(ELEM) - ARN(ELEM_CSR) = AR(ELEM) - ELEM_CSR = ELEM_CSR+1 - ENDIF - ELSE - IF (CHECK_FLAG.EQ.psb_dupl_err_) THEN -C ... Error, there are duplicated elements ... - IERROR = 130 - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - ELSE IF (CHECK_FLAG.EQ.psb_dupl_ovwrt_) THEN -C ... Insert only the last duplicated element ... - IF(JA(ELEM).LT.IA(ELEM)) THEN - ARN(ELEM_CSR-1) = AR(ELEM) - ENDIF - if (debug) write(0,*) 'Duplicated overwrite', - + elem_csr-1,elem - ELSE IF (CHECK_FLAG.EQ.psb_dupl_add_) THEN -C ... Sum the duplicated element ... - IF(JA(ELEM).LT.IA(ELEM)) THEN - ARN(ELEM_CSR-1) = ARN(ELEM_CSR-1) + AR(ELEM) - ENDIF - if (debug) write(0,*) 'Duplicated add', - + elem_csr-1,elem - END IF - ENDIF - ELEM = ELEM + 1 - ENDDO - IAN2(ROW+1) = ELEM_CSR - ENDDO - - if (debug) write(0,*)'Done Rebuild CSR', + ian2(m+1),ia(elem) if (debug) then @@ -537,29 +497,29 @@ C ... Sum the duplicated element ... endif - END IF -C - ELSE IF (TRANS.NE.'N') THEN -C -C TO DO -C - IERROR = 3021 - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 + end if +c + else if (toupper(TRANS).NE.'N') then +c +c to do +c + ierror = 3021 + call fcpsb_errpush(ierror,name,int_val) + goto 9999 - END IF - INFON(1)=ELEM_CSR-1 + end if + infon(1)=elem_csr-1 - CALL FCPSB_ERRACTIONRESTORE(ERR_ACT) - RETURN + call fcpsb_erractionrestore(err_act) + return - 9999 CONTINUE - CALL FCPSB_ERRACTIONRESTORE(ERR_ACT) + 9999 continue + call fcpsb_erractionrestore(err_act) - IF ( ERR_ACT .NE. 0 ) THEN - CALL FCPSB_SERROR() - RETURN - ENDIF + if ( err_act .ne. 0 ) then + call fcpsb_serror() + return + endif - RETURN - END + return + end diff --git a/base/serial/dp/dcrco.f b/base/serial/dp/dcrco.f index a5566e682..dc8c0c56d 100644 --- a/base/serial/dp/dcrco.f +++ b/base/serial/dp/dcrco.f @@ -34,6 +34,7 @@ C use psb_const_mod use psb_spmat_type + use psb_string_mod IMPLICIT NONE C @@ -63,8 +64,8 @@ C IERROR = 0 CALL FCPSB_ERRACTIONSAVE(ERR_ACT) - IF (TRANS.EQ.'N') THEN - SCALE = (UNITD.EQ.'L') ! meaningless + IF (toupper(TRANS).EQ.'N') THEN + SCALE = (toupper(UNITD).EQ.'L') ! meaningless IP1(1) = 0 IP2(1) = 0 NNZ = IA2(M+1)-1 @@ -92,7 +93,7 @@ C GOTO 9999 END IF - IF (DESCRA(1:1).EQ.'G') THEN + IF (toupper(DESCRA(1:1)).EQ.'G') THEN C ... Construct COO Representation... ELEM = 0 @@ -106,19 +107,27 @@ C ... Construct COO Representation... ENDDO INFON(psb_nnz_) = elem if (debug) write(0,*) 'CRCO endloop',m,elem - ELSE IF (DESCRA(1:1).EQ.'S' .AND. DESCRA(2:2).EQ.'U') THEN + ELSE IF (toupper(DESCRA(1:1)).EQ.'S' .AND. + + toupper(DESCRA(2:2)).EQ.'U') THEN DO 20 K = 1, M IP2(K) = K 20 CONTINUE + ierror = 3021 + call fcpsb_errpush(ierror,name,int_val) + goto 9999 c$$$ CALL DVSSG(M,IA1,IA2,IP2,IAN2(PNG),IP1,IP2,AUX(IWLEN), c$$$ * AUX(IWORK1)) c$$$ CALL DVSMR(M,AR,IA1,IA2,IAN2(PNG),AUX(IWLEN),IP1,IP2, c$$$ * IAN2(PIA),IAN2(PJA),IAN1,ARN,AUX(IWORK1), c$$$ * AUX(IWORK2),NJA,IER,SCALE) C - ELSE IF (DESCRA(1:1).EQ.'T' .AND. DESCRA(2:2).EQ.'U') THEN + ELSE IF (toupper(DESCRA(1:1)).EQ.'T' .AND. + + toupper(DESCRA(2:2)).EQ.'U') THEN + ierror = 3021 + call fcpsb_errpush(ierror,name,int_val) + goto 9999 c$$$ CALL DVTFG('U',M,IA1,IA2,IAN2(PNG),IP1,IP2,AUX(IWLEN), c$$$c * AUX(IWORK1),AUX(IWORK2),IAN1(M+1)) @@ -127,23 +136,36 @@ c$$$ CALL DVTMR(M,AR,IA1,IA2,ISTROW,IAN2(PNG),AUX(IWLEN),IP1,IP2, c$$$ * IAN2(PIA),IAN2(PJA),IAN1,ARN,NJA,IER,SCALE) C - ELSE IF (DESCRA(1:1).EQ.'T' .AND. DESCRA(2:2).EQ.'L') THEN + ELSE IF (toupper(DESCRA(1:1)).EQ.'T' .AND. + + toupper(DESCRA(2:2)).EQ.'L') THEN + ierror = 3021 + call fcpsb_errpush(ierror,name,int_val) + goto 9999 c$$$ CALL DVTFG('L',M,IA1,IA2,IAN2(PNG),IP1,IP2,AUX(IWLEN), c$$$c * AUX(IWORK1),AUX(IWORK2),IAN1(M+1)) c$$$ * AUX(IWORK1),IAN1(1),IAN1(M+5)) c$$$ CALL DVTMR(M,AR,IA1,IA2,ISTROW,IAN2(PNG),AUX(IWLEN),IP1,IP2, c$$$ * IAN2(PIA),IAN2(PJA),IAN1,ARN,NJA,IER,SCALE) + else + ierror = 3021 + call fcpsb_errpush(ierror,name,int_val) + goto 9999 END IF C - ELSE IF (TRANS.NE.'N') THEN + ELSE IF (toupper(TRANS).NE.'N') THEN C C TO DO C IERROR = 3021 CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) GOTO 9999 + else + ierror = 3021 + call fcpsb_errpush(ierror,name,int_val) + goto 9999 + END IF diff --git a/base/serial/dp/dcrcr.f b/base/serial/dp/dcrcr.f index f0343516b..d62851728 100644 --- a/base/serial/dp/dcrcr.f +++ b/base/serial/dp/dcrcr.f @@ -163,6 +163,7 @@ C SUBROUTINE DCRCR(TRANS,M,N,UNITD,D,DESCRA,A,IA1,IA2,INFOA,IP1, * DESCRN,AN,IAN1,IAN2,INFON,IP2,LAN,LIAN1,LIAN2, * WORK,LWORK,IERROR) + use psb_string_mod IMPLICIT NONE C C .. Scalar Arguments .. @@ -177,6 +178,7 @@ C .. Local Scalars .. INTEGER I, J, ERR_ACT LOGICAL EXIT c .. Local Arrays .. + character idescra*11 CHARACTER*20 NAME INTEGER INT_VAL(5) @@ -192,11 +194,12 @@ C C C Check for argument errors C - IF(((DESCRA(1:1) .EQ. 'S' .OR. DESCRA(1:1) .EQ. 'H' .OR. - & DESCRA(1:1) .EQ. 'A') .AND. (UNITD .NE. 'B')) .OR. - & (.NOT.((DESCRA(3:3).EQ.'N').OR.(DESCRA(3:3).EQ.'L').OR. - + (DESCRA(3:3).EQ.'U'))) .OR. - + TRANS.NE.'N') THEN + idescra=toupper(descra) + IF(((idescra(1:1) .EQ. 'S' .OR. idescra(1:1) .EQ. 'H' .OR. + & idescra(1:1) .EQ. 'A') .AND. (toupper(unitd) .NE. 'B')) .OR. + & (.NOT.((idescra(3:3).EQ.'N').OR.(idescra(3:3).EQ.'L').OR. + + (idescra(3:3).EQ.'U'))) .OR. + + toupper(TRANS).NE.'N') THEN IERROR = 20 ENDIF IF(LAN.LT.(IA2(M+1)-1)) THEN @@ -223,8 +226,8 @@ C IERROR = 23 ENDIF ENDIF - IF ((DESCRA(1:1) .EQ. 'S' .OR. DESCRA(1:1) .EQ. 'H' .OR. - & DESCRA(1:1) .EQ. 'A') .AND. (UNITD .EQ. 'B')) THEN + IF ((idescra(1:1) .EQ. 'S' .OR. idescra(1:1) .EQ. 'H' .OR. + & idescra(1:1) .EQ. 'A') .AND. (toupper(UNITD) .EQ. 'B')) THEN IF (LWORK.LT.M) THEN IF (LWORK.LE.0) THEN EXIT=.TRUE. @@ -250,7 +253,7 @@ C C C Set DESCRN, IP1, IP2 C - DESCRN(1:3) = DESCRA(1:3) + DESCRN(1:3) = idescra(1:3) IP1(1)=0 IP2(1)=0 @@ -260,8 +263,8 @@ C DO 20 I = 1, M+1 IAN2(I) = IA2(I) 20 CONTINUE - IF ((DESCRA(1:1) .EQ. 'S' .OR. DESCRA(1:1) .EQ. 'H' .OR. - & DESCRA(1:1) .EQ. 'A') .AND. (UNITD .EQ. 'B')) THEN + IF ((idescra(1:1) .EQ. 'S' .OR. idescra(1:1) .EQ. 'H' .OR. + & idescra(1:1) .EQ. 'A') .AND. (toupper(UNITD) .EQ. 'B')) THEN DO 30 I = 1, M WORK(I) = DSQRT(D(I)) 30 CONTINUE @@ -271,21 +274,21 @@ C IAN1(J) = IA1(J) 50 CONTINUE 40 CONTINUE - ELSE IF (UNITD .EQ. 'L') THEN + ELSE IF (toupper(UNITD) .EQ. 'L') THEN DO 60 I = 1, M DO 70 J = IA2(I), IA2(I+1)-1 AN(J) = D(I) * A(J) IAN1(J) = IA1(J) 70 CONTINUE 60 CONTINUE - ELSE IF (UNITD .EQ. 'R') THEN + ELSE IF (toupper(UNITD) .EQ. 'R') THEN DO 80 I = 1, M DO 90 J = IA2(I), IA2(I+1)-1 AN(J) = A(J) * D(IA1(J)) IAN1(J) = IA1(J) 90 CONTINUE 80 CONTINUE - ELSE IF (UNITD .EQ. 'U') THEN + ELSE IF (toupper(UNITD) .EQ. 'U') THEN DO 100 J = 1, IA2(M+1)-1 AN(J) = A(J) IAN1(J) = IA1(J) diff --git a/base/serial/dp/dcrjd.f b/base/serial/dp/dcrjd.f index aedeadfa6..e185f079b 100644 --- a/base/serial/dp/dcrjd.f +++ b/base/serial/dp/dcrjd.f @@ -61,6 +61,7 @@ C IAN2,INFON, IP1, IP2 C use psb_const_mod use psb_spmat_type + use psb_string_mod IMPLICIT NONE C @@ -69,9 +70,9 @@ C .. Scalar Arguments .. * SIZE_REQ, IERROR CHARACTER TRANS,UNITD C .. Array Arguments .. - DOUBLE PRECISION AR(*), ARN(*), D(*), AUX(LAUX) - INTEGER IA1(*), IA2(*), INFO(*), IAN1(*), IAN2(*), - * INFON(*), IP1(*), IP2(*) + DOUBLE PRECISION AR(*), ARN(LARN), D(*), AUX(LAUX) + INTEGER IA1(*), IA2(*), INFO(*), IAN1(LIAN1), + + IAN2(LIAN2), INFON(*), IP1(*), IP2(*) CHARACTER DESCRA*11, DESCRN*11 C .. Local Scalars .. INTEGER IOFF, ISTROW, NJA, NZ, PIA, @@ -103,10 +104,10 @@ C GOTO 9999 ENDIF - IF (TRANS.EQ.'N') THEN + IF (toupper(TRANS).EQ.'N') THEN C NJA = 3*M - SCALE = (UNITD.EQ.'L') ! meaningless + SCALE = (toupper(UNITD).EQ.'L') ! meaningless IOFF = 5 C C SET THE VALUES OF POINTERS TO VECTOR IAN2 AND AUX @@ -115,7 +116,7 @@ C PIA = PNG + 1 PJA = PIA + 3*(M+2) - IF (DESCRA(1:1).EQ.'G') THEN + IF (toupper(DESCRA(1:1)).EQ.'G') THEN C C CHECK ON DIMENSION OF IAN2 AND AUX @@ -169,10 +170,11 @@ C ENDIF LJA = LIAN2-PJA - CALL DGINDEX(M,IAN2(PNG),AR,IA1,IA2,ARN,IAN1,IAN2(PIA), - + IAN2(PJA), INFON, LARN,LIAN1, - + LJA,IP1, AUX, LAUX*2, SIZE_REQ,IERROR) - + CALL DGINDEX(M,IAN2(PNG),AR,IA1,IA2,info, + + ARN,IAN1,IAN2(PIA), IAN2(PJA), INFON, + + LARN,LIAN1, LJA,IP1, + + AUX, LAUX*2, SIZE_REQ,IERROR) + IF (IERROR.NE.0) THEN CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) GOTO 9999 @@ -182,7 +184,8 @@ C DESCRN(2:2) = 'U' DESCRN(3:3) = 'N' - ELSE IF (DESCRA(1:1).EQ.'S' .AND. DESCRA(2:2).EQ.'U') THEN + ELSE IF (toupper(DESCRA(1:1)).EQ.'S' .AND. + + toupper(DESCRA(2:2)).EQ.'U') THEN C ISTROW = 1 NZ = 2*(IA2(M+1)-1) - M @@ -218,13 +221,13 @@ c$$$ CALL DVSMR(M,AR,IA1,IA2,IAN2(PNG),AUX(IWLEN),IP1,IP2, c$$$ * IAN2(PIA),IAN2(PJA),IAN1,ARN,AUX(IWORK1), c$$$ * AUX(IWORK2),NJA,IER,SCALE) C - ELSE IF (DESCRA(1:1).EQ.'T') THEN + ELSE IF (toupper(DESCRA(1:1)).EQ.'T') THEN C C Only unit diagonal so far for triangular matrices. C - IF (DESCRA(3:3).NE.'U') THEN + IF (toupper(DESCRA(3:3)).NE.'U') THEN IERROR=3022 CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) GOTO 9999 @@ -273,8 +276,7 @@ c$$$ write(0,*) "error 2",ierrv(1) ENDIF DESCRN(1:1) = 'T' - DESCRN(2:2) = DESCRA(2:2) - DESCRN(3:3) = DESCRA(3:3) + DESCRN(2:3) = toupper(DESCRA(2:3)) END IF C @@ -288,7 +290,7 @@ C LIAN2 = 3*M + 10 LAUX2 = 4*M + 2 C - ELSE IF (TRANS.NE.'N') THEN + ELSE IF (toupper(TRANS).NE.'N') THEN C C TO BE DONE C diff --git a/base/serial/dp/dcsrp1.f b/base/serial/dp/dcsrp1.f index 3bb9f58a0..8fcc0b2f1 100644 --- a/base/serial/dp/dcsrp1.f +++ b/base/serial/dp/dcsrp1.f @@ -118,6 +118,7 @@ C + P,WORK,IWORK,LWORK,IERROR) use psb_const_mod use psb_spmat_type + use psb_string_mod IMPLICIT NONE C .. Scalar Arguments .. INTEGER LWORK,M, N, IERROR @@ -140,14 +141,14 @@ C IERROR = 0 CALL FCPSB_ERRACTIONSAVE(ERR_ACT) - IF(TRANS.EQ.'N') THEN + IF(toupper(TRANS).EQ.'N') THEN DO 30 I=1,M DO 10 J=IA(I),IA(I+1)-1 JA(J) = P(JA(J)) 10 CONTINUE 30 CONTINUE WORK(1) = 0.D0 - ELSE IF(TRANS.EQ.'T') THEN + ELSE IF(toupper(TRANS).EQ.'T') THEN C C LWORK refers here to INTEGER IWORK (alias for WORK) C diff --git a/base/serial/dp/dcsrrp.f b/base/serial/dp/dcsrrp.f index e6b3b3d3e..5ac1e8e0f 100644 --- a/base/serial/dp/dcsrrp.f +++ b/base/serial/dp/dcsrrp.f @@ -121,6 +121,7 @@ C C SUBROUTINE DCSRRP(TRANS,M,N,DESCRA,JA,IA, + P,WORK,LWORK,IERROR) + use psb_string_mod IMPLICIT NONE C .. Scalar Arguments .. INTEGER LWORK, M, N, IERROR @@ -143,7 +144,8 @@ C IERROR = 0 CALL FCPSB_ERRACTIONSAVE(ERR_ACT) - IF (DESCRA(1:1).EQ.'S' .OR. DESCRA(1:1).EQ.'T') THEN + IF (toupper(DESCRA(1:1)).EQ.'S' .OR. + + toupper(DESCRA(1:1)).EQ.'T') THEN IERROR=3023 CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) GOTO 9999 diff --git a/base/serial/dp/dgind_tri.f b/base/serial/dp/dgind_tri.f index 3589f87bd..d5983dc22 100644 --- a/base/serial/dp/dgind_tri.f +++ b/base/serial/dp/dgind_tri.f @@ -29,7 +29,7 @@ C POSSIBILITY OF SUCH DAMAGE. C C SUBROUTINE DGIND_TRI(M,N_BLOCKS,A,IA1,IA2,ARN,KA,IA,JA, - + LARN,LKA,LJA,IPERM,WORK, LWORK, IERROR) + + LARN,LKA,LJA,IPERM,WORK, LWORK, IERROR) use psb_const_mod IMPLICIT NONE @@ -42,11 +42,11 @@ C ... Array arguments ... DOUBLE PRECISION A(*), ARN(*), WORK(*) INTEGER IA1(*), IA2(*), KA(*), - + IA(3,*), IPERM(M), JA(*) + + IA(3,*), IPERM(M), JA(*) C .... Local scalars ... INTEGER I, J, BLOCK, ROW, COL, POINT_AR, POINT_JA, - + DIM_BLOCK, LIMIT, ERR_ACT + + DIM_BLOCK, LIMIT, ERR_ACT LOGICAL CSR c .. Local Arrays .. CHARACTER*20 NAME @@ -61,161 +61,161 @@ c .. Local Arrays .. IERROR = 0 IF ((LARN.LT.POINT_AR).OR.(LKA.LT.POINT_AR)) THEN - IERROR = 60 - INT_VAL(1) = 10 - INT_VAL(2) = POINT_AR - INT_VAL(3) = LARN - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 + IERROR = 60 + INT_VAL(1) = 10 + INT_VAL(2) = POINT_AR + INT_VAL(3) = LARN + CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) + GOTO 9999 ENDIF C .... Invert Permutation Matrix... IF (IPERM(1).NE.0) THEN - DO I = 1, M - WORK(IPERM(I)) = I - ENDDO + DO I = 1, M + WORK(IPERM(I)) = I + ENDDO ENDIF DO BLOCK = 1, N_BLOCKS - COL = 1 - DIM_BLOCK = IA(1,BLOCK+1)-IA(1,BLOCK) - LIMIT = INT(DIM_BLOCK*PSB_PERCENT_) - POINT_JA = POINT_JA+1 - IF (LJA.LT.POINT_JA) THEN - IERROR = 60 - INT_VAL(1) = 12 - INT_VAL(2) = POINT_JA - INT_VAL(3) = LJA - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - ENDIF - - IA(2,BLOCK) = POINT_JA - JA(POINT_JA) = POINT_AR - CSR = .FALSE. - - IF (DIM_BLOCK.NE.0) THEN + COL = 1 + DIM_BLOCK = IA(1,BLOCK+1)-IA(1,BLOCK) + LIMIT = INT(DIM_BLOCK*PSB_PERCENT_) + POINT_JA = POINT_JA+1 + IF (LJA.LT.POINT_JA) THEN + IERROR = 60 + INT_VAL(1) = 12 + INT_VAL(2) = POINT_JA + INT_VAL(3) = LJA + CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) + GOTO 9999 + ENDIF + + IA(2,BLOCK) = POINT_JA + JA(POINT_JA) = POINT_AR + CSR = .FALSE. + + IF (DIM_BLOCK.NE.0) THEN C ... If current block is not empty ... C ... For each Column belonging to Block ... - DO WHILE(.TRUE.) + DO WHILE(.TRUE.) C ... For each row belonging to the block BLOCK ... - DO I = IA(1,BLOCK), IA(1,BLOCK+1)-1 - IF (IPERM(1).EQ.0) THEN - ROW = I - ELSE - ROW = WORK(I) - ENDIF - + DO I = IA(1,BLOCK), IA(1,BLOCK+1)-1 + IF (IPERM(1).EQ.0) THEN + ROW = I + ELSE + ROW = WORK(I) + ENDIF + C ... If the current row is too short ... - IF (IA2(ROW)+COL-1.GE.IA2(ROW+1)) THEN + IF (IA2(ROW)+COL-1.GE.IA2(ROW+1)) THEN C ... Switch to CSR representation ... - IF (I.LE.IA(1,BLOCK)+LIMIT) THEN - CSR=.TRUE. - POINT_AR = POINT_AR - I + IA(1,BLOCK) - GOTO 998 - ELSE - ARN(POINT_AR) = 0.D0 + IF (I.LE.IA(1,BLOCK)+LIMIT) THEN + CSR=.TRUE. + POINT_AR = POINT_AR - I + IA(1,BLOCK) + GOTO 998 + ELSE + ARN(POINT_AR) = 0.D0 C C The following statement assumes that we never get here with POINT_AR=1 C - KA (POINT_AR) = KA(POINT_AR-1) - - POINT_AR = POINT_AR+1 - IF ((LARN.LT.POINT_AR).OR.(LKA.LT.POINT_AR)) - + THEN - IERROR = 60 - INT_VAL(1) = 10 - INT_VAL(2) = POINT_AR - INT_VAL(3) = LARN - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - ENDIF - ENDIF - ELSE - ARN(POINT_AR) = A(IA2(ROW)+COL-1) - KA (POINT_AR) = IPERM(IA1(IA2(ROW)+COL-1)) - - POINT_AR = POINT_AR+1 - IF ((LARN.LT.POINT_AR).OR.(LKA.LT.POINT_AR)) THEN - IERROR = 60 - INT_VAL(1) = 10 - INT_VAL(2) = POINT_AR - INT_VAL(3) = LARN - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - ENDIF + KA (POINT_AR) = KA(POINT_AR-1) + + POINT_AR = POINT_AR+1 + IF ((LARN.LT.POINT_AR).OR.(LKA.LT.POINT_AR)) + + THEN + IERROR = 60 + INT_VAL(1) = 10 + INT_VAL(2) = POINT_AR + INT_VAL(3) = LARN + CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) + GOTO 9999 ENDIF - ENDDO + ENDIF + ELSE + ARN(POINT_AR) = A(IA2(ROW)+COL-1) + KA (POINT_AR) = IPERM(IA1(IA2(ROW)+COL-1)) - IF (CSR) GOTO 998 - - IF (LJA.LT.POINT_JA+COL) THEN + POINT_AR = POINT_AR+1 + IF ((LARN.LT.POINT_AR).OR.(LKA.LT.POINT_AR)) THEN IERROR = 60 - INT_VAL(1) = 12 - INT_VAL(2) = POINT_JA - INT_VAL(3) = LJA + INT_VAL(1) = 10 + INT_VAL(2) = POINT_AR + INT_VAL(3) = LARN CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) GOTO 9999 - ENDIF - - JA(POINT_JA+COL) = POINT_AR - COL = COL+1 + ENDIF + ENDIF ENDDO - 998 CONTINUE - ENDIF + IF (CSR) GOTO 998 - POINT_JA = POINT_JA+COL-1 - - IF (LJA.LT.POINT_JA) THEN + IF (LJA.LT.POINT_JA+COL) THEN + IERROR = 60 + INT_VAL(1) = 12 + INT_VAL(2) = POINT_JA + INT_VAL(3) = LJA + CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) + GOTO 9999 + ENDIF + + JA(POINT_JA+COL) = POINT_AR + COL = COL+1 + ENDDO + 998 CONTINUE + + ENDIF + + POINT_JA = POINT_JA+COL-1 + + IF (LJA.LT.POINT_JA) THEN + IERROR = 60 + INT_VAL(1) = 12 + INT_VAL(2) = POINT_JA + INT_VAL(3) = LJA + CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) + GOTO 9999 + ENDIF + + IA(3,BLOCK) = POINT_JA + +C ... Start CSR Format ... + +C ... For each row belonging to the block BLOCK ... + DO I = IA(1,BLOCK), IA(1,BLOCK+1)-1 + IF (IPERM(1).EQ.0) THEN + ROW = I + ELSE + ROW = WORK(I) + ENDIF + +C ... For each nnzero elements belonging to current row ... + DO J = IA2(ROW)+COL-1, IA2(ROW+1)-1 + ARN(POINT_AR) = A(J) + KA (POINT_AR) = IPERM(IA1(J)) + + POINT_AR = POINT_AR+1 + IF ((LARN.LT.POINT_AR).OR.(LKA.LT.POINT_AR)) THEN + IERROR = 60 + INT_VAL(1) = 10 + INT_VAL(2) = POINT_AR + INT_VAL(3) = LARN + CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) + GOTO 9999 + ENDIF + ENDDO + + POINT_JA = POINT_JA+1 + IF (LJA.LT.POINT_JA) THEN IERROR = 60 INT_VAL(1) = 12 INT_VAL(2) = POINT_JA INT_VAL(3) = LJA CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) GOTO 9999 - ENDIF - - IA(3,BLOCK) = POINT_JA - -C ... Start CSR Format ... - -C ... For each row belonging to the block BLOCK ... - DO I = IA(1,BLOCK), IA(1,BLOCK+1)-1 - IF (IPERM(1).EQ.0) THEN - ROW = I - ELSE - ROW = WORK(I) - ENDIF - -C ... For each nnzero elements belonging to current row ... - DO J = IA2(ROW)+COL-1, IA2(ROW+1)-1 - ARN(POINT_AR) = A(J) - KA (POINT_AR) = IPERM(IA1(J)) - - POINT_AR = POINT_AR+1 - IF ((LARN.LT.POINT_AR).OR.(LKA.LT.POINT_AR)) THEN - IERROR = 60 - INT_VAL(1) = 10 - INT_VAL(2) = POINT_AR - INT_VAL(3) = LARN - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - ENDIF - ENDDO - - POINT_JA = POINT_JA+1 - IF (LJA.LT.POINT_JA) THEN - IERROR = 60 - INT_VAL(1) = 12 - INT_VAL(2) = POINT_JA - INT_VAL(3) = LJA - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - ENDIF - - JA(POINT_JA) = POINT_AR - ENDDO + ENDIF + + JA(POINT_JA) = POINT_AR + ENDDO ENDDO IA(2,N_BLOCKS+1) = POINT_JA @@ -227,8 +227,8 @@ C ... For each nnzero elements belonging to current row ... CALL FCPSB_ERRACTIONRESTORE(ERR_ACT) IF ( ERR_ACT .NE. 0 ) THEN - CALL FCPSB_SERROR() - RETURN + CALL FCPSB_SERROR() + RETURN ENDIF RETURN diff --git a/base/serial/dp/dgindex.f b/base/serial/dp/dgindex.f index 0d1f1b48e..f56b8b17f 100644 --- a/base/serial/dp/dgindex.f +++ b/base/serial/dp/dgindex.f @@ -28,8 +28,8 @@ C ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE C POSSIBILITY OF SUCH DAMAGE. C C - SUBROUTINE DGINDEX(M,N_BLOCKS,A,IA1,IA2,ARN,KA,IA,JA, INFON, - + LARN,LKA,LJA,IPERM,WORK, LWORK, SIZE_REQ, IERROR) + SUBROUTINE DGINDEX(M,N_BLOCKS,A,IA1,IA2,infoa,ARN,KA,IA,JA, INFON, + + LARN,LKA,LJA,IPERM,WORK, LWORK, SIZE_REQ, IERROR) use psb_const_mod use psb_spmat_type @@ -37,18 +37,18 @@ C C ... Scalar arguments ... INTEGER M, LWORK,N_BLOCKS,LARN,LKA,LJA, - + SIZE_REQ,IERROR + + SIZE_REQ,IERROR C ... Array arguments ... - DOUBLE PRECISION A(*), ARN(*) - INTEGER IA1(*), IA2(*), KA(*), - + IA(3,*), IPERM(*), JA(*), WORK(*),INFON(*) + DOUBLE PRECISION A(*), ARN(LARN) + INTEGER IA1(*), IA2(*), KA(LKA), + + IA(3,*), IPERM(*), JA(LJA), WORK(*),INFON(*), infoa(*) C .... Local scalars ... INTEGER I, J, BLOCK, ROW, COL, POINT_AR, POINT_JA, IP1, - + IP2, IPX, NNZ, DIM_BLOCK, LIMIT, IPW,COUNT, IPC,CHECK_FLAG, - + ERR_ACT + + IP2, IPX, NNZ, DIM_BLOCK, LIMIT, IPW,COUNT, IPC,CHECK_FLAG, + + ERR_ACT, ix, regen_flag LOGICAL CSR c .. Local Arrays .. CHARACTER*20 NAME @@ -60,373 +60,390 @@ c .. Local Arrays .. POINT_AR = 1 POINT_JA = 0 - call psb_getifield(check_flag,psb_dupl_,infon,psb_ifasize_,ierror) + call psb_getifield(regen_flag,psb_upd_,infon,psb_ifasize_,ierror) IF ((LARN.LT.POINT_AR).OR.(LKA.LT.POINT_AR)) THEN - IERROR = 60 - INT_VAL(1) = 11 - INT_VAL(2) = POINT_AR - INT_VAL(3) = LARN - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 + IERROR = 60 + INT_VAL(1) = 11 + INT_VAL(2) = POINT_AR + INT_VAL(3) = LARN + CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) + GOTO 9999 ENDIF - NNZ = IA2(M + 1) - 1 - COUNT = 0 + NNZ = IA2(M + 1) - 1 + COUNT = 0 C .... Invert Permutation Matrix... IF (IPERM(1).NE.0) THEN - DO I = 1, M - WORK(IPERM(I)) = I - ENDDO + DO I = 1, M + WORK(IPERM(I)) = I + ENDDO ENDIF - IF ( (LKA .GE.( SIZE_REQ )) - + .AND. (LWORK .GE. (M + NNZ+2))) THEN + size_Req=0 + + IF ( (regen_flag == psb_upd_perm_) + + .AND. (LWORK .GE. (M + NNZ+2))) THEN C C Prepare for smart regeneration C - IPW = M + 2 - IP1 = (LKA-PSB_IREG_FLGS_-2)/2 - IP2 = IP1+PSB_IREG_FLGS_ - IPC = IP2 + NNZ + 1 - KA(IP1 + PSB_IPC_) = IPC - KA(IP1+PSB_IP2_) = IP2 - INFON(PSB_UPD_PNT_) = IP1 - KA(IP1+PSB_IFLAG_) = CHECK_FLAG - KA(IP1+PSB_NNZT_) = NNZ - KA(IP1+PSB_NNZ_) = 0 - KA(IP1+PSB_ICHK_) = NNZ+CHECK_FLAG - I = M+2 - IPX = IA2(I+PSB_IP2_) + IPW = M + 2 + IP1 = (LKA-PSB_IREG_FLGS_-2)/2 + IP2 = IP1+PSB_IREG_FLGS_ + IPC = IP2 + NNZ + 1 + KA(IP1 + PSB_IPC_) = IPC + KA(IP1+PSB_IP2_) = IP2 + INFON(PSB_UPD_PNT_) = IP1 + KA(IP1+PSB_IFLAG_) = CHECK_FLAG + KA(IP1+PSB_NNZT_) = NNZ + KA(IP1+PSB_NNZ_) = 0 + KA(IP1+PSB_ICHK_) = NNZ+CHECK_FLAG + if (infoa(psb_upd_pnt_) > 0) then + I = infoa(psb_upd_pnt_) + IPX = IA2(I+PSB_IP2_) C Invert permutation for smart regeneration - - DO I = 1, NNZ + + DO I = 1, NNZ WORK(IPW + IA2(IPX + I -1) - 1) = I - ENDDO - + ENDDO + else + ! No permutation available before, set identity. + DO I = 1, NNZ + WORK(IPW + I - 1) = I + ENDDO + endif C Construct JAD matrix... - DO BLOCK = 1, N_BLOCKS - COL = 1 - DIM_BLOCK = IA(1,BLOCK+1)-IA(1,BLOCK) + DO BLOCK = 1, N_BLOCKS + COL = 1 + DIM_BLOCK = IA(1,BLOCK+1)-IA(1,BLOCK) c$$$ write(0,*) 'DGINDEX: BLOCK LOOP ',block,n_blocks,dim_block - if (dim_block .gt. PSB_MAXJDROWS_) then - write(0,*) 'Wrong value for dim_block',block, - + IA(1,BLOCK+1),IA(1,BLOCK) - return - endif - LIMIT = INT(DIM_BLOCK*PSB_PERCENT_) - POINT_JA = POINT_JA+1 - IF (LJA.LT.POINT_JA) THEN - IERROR = 60 - INT_VAL(1) = 13 - INT_VAL(2) = POINT_JA - INT_VAL(3) = LJA - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - ENDIF - - IA(2,BLOCK) = POINT_JA - JA(POINT_JA) = POINT_AR - CSR = .FALSE. - - IF (DIM_BLOCK.NE.0) THEN + if (dim_block .gt. PSB_MAXJDROWS_) then + write(0,*) 'Wrong value for dim_block',block, + + IA(1,BLOCK+1),IA(1,BLOCK) + return + endif + LIMIT = INT(DIM_BLOCK*PSB_PERCENT_) + POINT_JA = POINT_JA+1 + IF (LJA.LT.POINT_JA) THEN + IERROR = 60 + INT_VAL(1) = 13 + INT_VAL(2) = POINT_JA + INT_VAL(3) = LJA + CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) + GOTO 9999 + ENDIF + + IA(2,BLOCK) = POINT_JA + JA(POINT_JA) = POINT_AR + CSR = .FALSE. + + IF (DIM_BLOCK.NE.0) THEN C ... If current block is not empty ... C ... For each Column belonging to Block ... - DO WHILE(.TRUE.) + DO WHILE(.TRUE.) C ... For each row belonging to the block BLOCK ... - DO I = IA(1,BLOCK), IA(1,BLOCK+1)-1 - IF (IPERM(1).EQ.0) THEN - ROW = I - ELSE - ROW = WORK(I) - ENDIF - + DO I = IA(1,BLOCK), IA(1,BLOCK+1)-1 + IF (IPERM(1).EQ.0) THEN + ROW = I + ELSE + ROW = WORK(I) + ENDIF + C ... If the current row is too short ... - IF (IA2(ROW)+COL-1.GE.IA2(ROW+1)) THEN + IF (IA2(ROW)+COL-1.GE.IA2(ROW+1)) THEN C ... Switch to CSR representation ... - IF (I.LE.IA(1,BLOCK)+LIMIT) THEN - CSR=.TRUE. - POINT_AR = POINT_AR - I + IA(1,BLOCK) - GOTO 998 - ELSE + IF (I.LE.IA(1,BLOCK)+LIMIT) THEN + CSR=.TRUE. + POINT_AR = POINT_AR - I + IA(1,BLOCK) + GOTO 998 + ELSE - COUNT = COUNT + 1 - ARN(POINT_AR) = 0.D0 - KA(POINT_AR) = KA(POINT_AR-1) - IF(POINT_AR.LT.IP1) THEN - KA(IPC + COUNT -1) = POINT_AR - ENDIF + COUNT = COUNT + 1 + ARN(POINT_AR) = 0.D0 + KA(POINT_AR) = KA(POINT_AR-1) + IF(POINT_AR.LT.IP1) THEN + KA(IPC + COUNT -1) = POINT_AR + ENDIF C C The following statement assumes that we never get here with POINT_AR=1 C - POINT_AR = POINT_AR+1 - IF ((LARN.LT.POINT_AR).OR.(LKA.LT.POINT_AR)) - + THEN - IERROR = 60 - INT_VAL(1) = 11 - INT_VAL(2) = POINT_AR - INT_VAL(3) = LARN - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - ENDIF - ENDIF - ELSE - ARN(POINT_AR) = A(IA2(ROW)+COL-1) - KA(POINT_AR) = IA1(IA2(ROW)+COL-1) - IF(POINT_AR.LT.IP1) THEN - KA(IP2 + WORK(IPW + - + IA2(ROW) +COL -1-1)-1) = POINT_AR - ENDIF - - POINT_AR = POINT_AR+1 - IF ((LARN.LT.POINT_AR).OR.(LKA.LT.POINT_AR)) - + THEN - IERROR = 60 - INT_VAL(1) = 11 - INT_VAL(2) = POINT_AR - INT_VAL(3) = LARN - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - ENDIF - ENDIF - ENDDO - - IF (CSR) GOTO 998 - - IF (LJA.LT.POINT_JA+COL) THEN - IERROR = 60 - INT_VAL(1) = 13 - INT_VAL(2) = POINT_JA - INT_VAL(3) = LJA - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 + POINT_AR = POINT_AR+1 + IF ((LARN.LT.POINT_AR).OR.(LKA.LT.POINT_AR)) + + THEN + IERROR = 60 + INT_VAL(1) = 11 + INT_VAL(2) = POINT_AR + INT_VAL(3) = LARN + CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) + GOTO 9999 + ENDIF ENDIF - IF(IERROR.EQ.0) THEN - JA(POINT_JA+COL) = POINT_AR + ELSE + ARN(POINT_AR) = A(IA2(ROW)+COL-1) + KA(POINT_AR) = IA1(IA2(ROW)+COL-1) + IF(POINT_AR.LT.IP1) THEN + KA(IP2 + WORK(IPW + + + IA2(ROW) +COL -1-1)-1) = POINT_AR ENDIF - COL = COL+1 - ENDDO - - ENDIF - 998 CONTINUE - - POINT_JA = POINT_JA+COL-1 - - IF (LJA.LT.POINT_JA) THEN - IERROR = 60 - INT_VAL(1) = 13 - INT_VAL(2) = POINT_JA - INT_VAL(3) = LJA - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - ENDIF - - IA(3,BLOCK) = POINT_JA + + POINT_AR = POINT_AR+1 + IF ((LARN.LT.POINT_AR).OR.(LKA.LT.POINT_AR)) + + THEN + IERROR = 60 + INT_VAL(1) = 11 + INT_VAL(2) = POINT_AR + INT_VAL(3) = LARN + CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) + GOTO 9999 + ENDIF + ENDIF + ENDDO + + IF (CSR) GOTO 998 + + IF (LJA.LT.POINT_JA+COL) THEN + IERROR = 60 + INT_VAL(1) = 13 + INT_VAL(2) = POINT_JA + INT_VAL(3) = LJA + CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) + GOTO 9999 + ENDIF + IF(IERROR.EQ.0) THEN + JA(POINT_JA+COL) = POINT_AR + ENDIF + COL = COL+1 + ENDDO + ENDIF + 998 CONTINUE + + POINT_JA = POINT_JA+COL-1 + + IF (LJA.LT.POINT_JA) THEN + IERROR = 60 + INT_VAL(1) = 13 + INT_VAL(2) = POINT_JA + INT_VAL(3) = LJA + CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) + GOTO 9999 + ENDIF + + IA(3,BLOCK) = POINT_JA + C ... Start CSR Format ... - + C ... For each row belonging to the block BLOCK ... - DO I = IA(1,BLOCK), IA(1,BLOCK+1)-1 - IF (IPERM(1).EQ.0) THEN - ROW = I - ELSE - ROW = WORK(I) - ENDIF - + DO I = IA(1,BLOCK), IA(1,BLOCK+1)-1 + IF (IPERM(1).EQ.0) THEN + ROW = I + ELSE + ROW = WORK(I) + ENDIF + C ... For each nnzero elements belonging to current row ... - DO J = IA2(ROW)+COL-1, IA2(ROW+1)-1 - - ARN(POINT_AR) = A(J) - KA (POINT_AR) = IA1(J) - IF (POINT_AR.LT.IP1) THEN - KA(IP2 + WORK(IPW + J-1)-1) = POINT_AR - ENDIF + DO J = IA2(ROW)+COL-1, IA2(ROW+1)-1 + + ARN(POINT_AR) = A(J) + KA (POINT_AR) = IA1(J) + IF (POINT_AR.LT.IP1) THEN + KA(IP2 + WORK(IPW + J-1)-1) = POINT_AR + ENDIF - POINT_AR = POINT_AR+1 - IF ((LARN.LT.POINT_AR).OR.(LKA.LT.POINT_AR)) THEN - IERROR = 60 - INT_VAL(1) = 11 - INT_VAL(2) = POINT_AR - INT_VAL(3) = LARN - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - ENDIF - ENDDO - - POINT_JA = POINT_JA+1 - IF (LJA.LT.POINT_JA) THEN - IERROR = 60 - INT_VAL(1) = 13 - INT_VAL(2) = POINT_JA - INT_VAL(3) = LJA - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - ENDIF - JA(POINT_JA) = POINT_AR + POINT_AR = POINT_AR+1 + IF ((LARN.LT.POINT_AR).OR.(LKA.LT.POINT_AR)) THEN + IERROR = 60 + INT_VAL(1) = 11 + INT_VAL(2) = POINT_AR + INT_VAL(3) = LARN + CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) + GOTO 9999 + ENDIF ENDDO - ENDDO - - - ELSE -c$$$ c write(*,*)'inizio a ciclare sui blocchi' - DO BLOCK = 1, N_BLOCKS - COL = 1 - DIM_BLOCK = IA(1,BLOCK+1)-IA(1,BLOCK) - LIMIT = INT(DIM_BLOCK*PSB_PERCENT_) + POINT_JA = POINT_JA+1 IF (LJA.LT.POINT_JA) THEN - IERROR = 60 - INT_VAL(1) = 13 - INT_VAL(2) = POINT_JA - INT_VAL(3) = LJA - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 + IERROR = 60 + INT_VAL(1) = 13 + INT_VAL(2) = POINT_JA + INT_VAL(3) = LJA + CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) + GOTO 9999 ENDIF - - IA(2,BLOCK) = POINT_JA JA(POINT_JA) = POINT_AR - CSR = .FALSE. - - IF (DIM_BLOCK.NE.0) THEN + ENDDO + ENDDO + + IA(2,N_BLOCKS+1) = POINT_JA + KA(IP1 + PSB_ZERO_) = COUNT + + IF (POINT_AR.GE.IP1) THEN + SIZE_REQ=NNZ+COUNT + ELSE + SIZE_REQ=0 + ENDIF + + ELSE +c$$$ c write(*,*)'inizio a ciclare sui blocchi' + IP1 = LKA - PSB_ZERO_ + + DO BLOCK = 1, N_BLOCKS + COL = 1 + DIM_BLOCK = IA(1,BLOCK+1)-IA(1,BLOCK) + LIMIT = INT(DIM_BLOCK*PSB_PERCENT_) + POINT_JA = POINT_JA+1 + IF (LJA.LT.POINT_JA) THEN + IERROR = 60 + INT_VAL(1) = 13 + INT_VAL(2) = POINT_JA + INT_VAL(3) = LJA + CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) + GOTO 9999 + ENDIF + + IA(2,BLOCK) = POINT_JA + JA(POINT_JA) = POINT_AR + CSR = .FALSE. + + IF (DIM_BLOCK.NE.0) THEN C ... If current block is not empty ... C ... For each Column belonging to Block ... - DO WHILE(.TRUE.) + DO WHILE(.TRUE.) C ... For each row belonging to the block BLOCK ... - DO I = IA(1,BLOCK), IA(1,BLOCK+1)-1 - IF (IPERM(1).EQ.0) THEN - ROW = I - ELSE - ROW = WORK(I) - ENDIF - + DO I = IA(1,BLOCK), IA(1,BLOCK+1)-1 + IF (IPERM(1).EQ.0) THEN + ROW = I + ELSE + ROW = WORK(I) + ENDIF + C ... If the current row is too short ... - IF (IA2(ROW)+COL-1.GE.IA2(ROW+1)) THEN + IF (IA2(ROW)+COL-1.GE.IA2(ROW+1)) THEN C ... Switch to CSR representation ... - IF (I.LE.IA(1,BLOCK)+LIMIT) THEN - CSR=.TRUE. - POINT_AR = POINT_AR - I + IA(1,BLOCK) - GOTO 999 - ELSE - COUNT= COUNT+1 - ARN(POINT_AR) = 0.D0 - KA (POINT_AR) = KA(POINT_AR-1) + IF (I.LE.IA(1,BLOCK)+LIMIT) THEN + CSR=.TRUE. + POINT_AR = POINT_AR - I + IA(1,BLOCK) + GOTO 999 + ELSE + COUNT= COUNT+1 + ARN(POINT_AR) = 0.D0 + KA (POINT_AR) = KA(POINT_AR-1) C C The following statement assumes that we never get here with POINT_AR=1 C - POINT_AR = POINT_AR+1 - IF ((LARN.LT.POINT_AR).OR.(LKA.LT.POINT_AR)) - + THEN - IERROR = 60 - INT_VAL(1) = 11 - INT_VAL(2) = POINT_AR - INT_VAL(3) = LARN - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - ENDIF - ENDIF - ELSE - ARN(POINT_AR) = A(IA2(ROW)+COL-1) - KA (POINT_AR) = IA1(IA2(ROW)+COL-1) - POINT_AR = POINT_AR+1 - IF ((LARN.LT.POINT_AR).OR.(LKA.LT.POINT_AR)) - + THEN - IERROR = 60 - INT_VAL(1) = 11 - INT_VAL(2) = POINT_AR - INT_VAL(3) = LARN - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - ENDIF - ENDIF - ENDDO - - IF (CSR) GOTO 999 - - IF (LJA.LT.POINT_JA+COL) THEN - IERROR = 60 - INT_VAL(1) = 13 - INT_VAL(2) = POINT_JA - INT_VAL(3) = LJA - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 + POINT_AR = POINT_AR+1 + IF ((LARN.LT.POINT_AR).OR.(LKA.LT.POINT_AR)) + + THEN + IERROR = 60 + INT_VAL(1) = 11 + INT_VAL(2) = POINT_AR + INT_VAL(3) = LARN + CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) + GOTO 9999 + ENDIF ENDIF - - JA(POINT_JA+COL) = POINT_AR - COL = COL+1 - ENDDO - - ENDIF - 999 CONTINUE - - POINT_JA = POINT_JA+COL-1 - - IF (LJA.LT.POINT_JA) THEN - IERROR = 60 - INT_VAL(1) = 13 - INT_VAL(2) = POINT_JA - INT_VAL(3) = LJA - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - ENDIF - - IA(3,BLOCK) = POINT_JA + ELSE + ARN(POINT_AR) = A(IA2(ROW)+COL-1) + KA (POINT_AR) = IA1(IA2(ROW)+COL-1) + POINT_AR = POINT_AR+1 + IF ((LARN.LT.POINT_AR).OR.(LKA.LT.POINT_AR)) + + THEN + IERROR = 60 + INT_VAL(1) = 11 + INT_VAL(2) = POINT_AR + INT_VAL(3) = LARN + CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) + GOTO 9999 + ENDIF + ENDIF + ENDDO + + IF (CSR) GOTO 999 + + IF (LJA.LT.POINT_JA+COL) THEN + IERROR = 60 + INT_VAL(1) = 13 + INT_VAL(2) = POINT_JA + INT_VAL(3) = LJA + CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) + GOTO 9999 + ENDIF + + JA(POINT_JA+COL) = POINT_AR + COL = COL+1 + ENDDO + ENDIF + 999 CONTINUE + + POINT_JA = POINT_JA+COL-1 + + IF (LJA.LT.POINT_JA) THEN + IERROR = 60 + INT_VAL(1) = 13 + INT_VAL(2) = POINT_JA + INT_VAL(3) = LJA + CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) + GOTO 9999 + ENDIF + + IA(3,BLOCK) = POINT_JA + C ... Start CSR Format ... - + C ... For each row belonging to the block BLOCK ... - DO I = IA(1,BLOCK), IA(1,BLOCK+1)-1 - IF (IPERM(1).EQ.0) THEN - ROW = I - ELSE - ROW = WORK(I) - ENDIF - + DO I = IA(1,BLOCK), IA(1,BLOCK+1)-1 + IF (IPERM(1).EQ.0) THEN + ROW = I + ELSE + ROW = WORK(I) + ENDIF + C ... For each nnzero elements belonging to current row ... - DO J = IA2(ROW)+COL-1, IA2(ROW+1)-1 - ARN(POINT_AR) = A(J) - KA (POINT_AR) = IA1(J) - POINT_AR = POINT_AR+1 - IF ((LARN.LT.POINT_AR).OR.(LKA.LT.POINT_AR)) THEN - IERROR = 60 - INT_VAL(1) = 11 - INT_VAL(2) = POINT_AR - INT_VAL(3) = LARN - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - ENDIF - ENDDO - - POINT_JA = POINT_JA+1 - IF (LJA.LT.POINT_JA) THEN - IERROR = 60 - INT_VAL(1) = 13 - INT_VAL(2) = POINT_JA - INT_VAL(3) = LJA - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - ENDIF - JA(POINT_JA) = POINT_AR + DO J = IA2(ROW)+COL-1, IA2(ROW+1)-1 + ARN(POINT_AR) = A(J) + KA (POINT_AR) = IA1(J) + POINT_AR = POINT_AR+1 + IF ((LARN.LT.POINT_AR).OR.(LKA.LT.POINT_AR)) THEN + IERROR = 60 + INT_VAL(1) = 11 + INT_VAL(2) = POINT_AR + INT_VAL(3) = LARN + CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) + GOTO 9999 + ENDIF ENDDO - ENDDO - - - - + + POINT_JA = POINT_JA+1 + IF (LJA.LT.POINT_JA) THEN + IERROR = 60 + INT_VAL(1) = 13 + INT_VAL(2) = POINT_JA + INT_VAL(3) = LJA + CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) + GOTO 9999 + ENDIF + JA(POINT_JA) = POINT_AR + ENDDO + ENDDO + + + + IA(2,N_BLOCKS+1) = POINT_JA + + IF (POINT_AR.GE.lka) THEN + SIZE_REQ=NNZ+COUNT + ELSE + SIZE_REQ=0 + ENDIF ENDIF - IA(2,N_BLOCKS+1) = POINT_JA - KA(IP1 + PSB_ZERO_) = COUNT - IF(POINT_AR.GE.IP1) THEN - SIZE_REQ=NNZ+COUNT - ELSE - SIZE_REQ=0 - ENDIF infon(1)=point_ar-1 CALL FCPSB_ERRACTIONRESTORE(ERR_ACT) @@ -436,8 +453,8 @@ C ... For each nnzero elements belonging to current row ... CALL FCPSB_ERRACTIONRESTORE(ERR_ACT) IF ( ERR_ACT .NE. 0 ) THEN - CALL FCPSB_SERROR() - RETURN + CALL FCPSB_SERROR() + RETURN ENDIF RETURN diff --git a/base/serial/dp/djadrp.f b/base/serial/dp/djadrp.f index 4a874824d..eb2a17182 100644 --- a/base/serial/dp/djadrp.f +++ b/base/serial/dp/djadrp.f @@ -116,6 +116,7 @@ C C SUBROUTINE DJADRP(TRANS,M,N,DESCRA,JA,IA, + P,WORK,LWORK,IERROR) + use psb_string_mod IMPLICIT NONE C .. Scalar Arguments .. INTEGER LWORK, M, N, IERROR @@ -146,7 +147,7 @@ C PIA = PNG + 1 PJA = PIA + 3*(IA(PNG)+1) - IF (DESCRA(1:1).EQ.'G') THEN + IF (toupper(DESCRA(1:1)).EQ.'G') THEN CALL DJADRP1(TRANS,M,N,DESCRA,IA(PNG), + JA,IA(PIA),IA(PJA),P,WORK,LWORK*2) ELSE diff --git a/base/serial/dp/djadrp1.f b/base/serial/dp/djadrp1.f index 81b155d9a..50d06d6f9 100644 --- a/base/serial/dp/djadrp1.f +++ b/base/serial/dp/djadrp1.f @@ -102,6 +102,7 @@ C C SUBROUTINE DJADRP1(TRANS,M,N,DESCRA,NG,KA,IA,JA, + P,IWORK,LWORK,IERROR) + use psb_string_mod IMPLICIT NONE C .. Scalar Arguments .. INTEGER LWORK,M, N, NG, IERROR @@ -125,7 +126,7 @@ C IERROR = 0 CALL FCPSB_ERRACTIONSAVE(ERR_ACT) - IF(TRANS.EQ.'N') THEN + IF(toupper(TRANS).EQ.'N') THEN IF (DEBUG) WRITE(0,*)'DJADRP1:',NG DO IPG = 1, NG DO K = IA(2,IPG), IA(3,IPG)-1 @@ -143,7 +144,7 @@ C Permute CSR ENDDO IWORK(1) = 0 - ELSE IF(TRANS.EQ.'T') THEN + ELSE IF(toupper(TRANS).EQ.'T') THEN C C LWORK refers here to INTEGER IWORK (alias for WORK) C diff --git a/base/serial/dp/djdcox.f b/base/serial/dp/djdcox.f index 317b3bc2f..dcfaf5e9d 100755 --- a/base/serial/dp/djdcox.f +++ b/base/serial/dp/djdcox.f @@ -33,10 +33,11 @@ C C Covert matrix from JAD format to COO Format C SUBROUTINE DJDCOX(TRANS,M,N,DESCRA,AR,IA,JA,KA,NG,IPERM,INFO, - * IP1,DESCRN,ARN,IA1N,IA2N,INFON,IP2,LARN,LIA1N, - * LIA2N,AUX,LAUX,IERROR) + * IP1,DESCRN,ARN,IA1N,IA2N,INFON,IP2,LARN,LIA1N, + * LIA2N,AUX,LAUX,IERROR) use psb_const_mod + use psb_string_mod IMPLICIT NONE C @@ -47,11 +48,11 @@ C .. Array Arguments .. DOUBLE PRECISION AR(*), ARN(*) INTEGER AUX(0:LAUX/2-1),IPERM(*) INTEGER IA(3,*), JA(*), KA(*), INFO(*), IA1N(*), - * IA2N(*), INFON(*), IP1(*), IP2(*) + * IA2N(*), INFON(*), IP1(*), IP2(*) CHARACTER DESCRA*11, DESCRN*11 C .. Local Scalars .. INTEGER IPX, IPG, NNZ, K, ROW, - * I, J, NZL, IRET, ERR_ACT + * I, J, NZL, IRET, ERR_ACT LOGICAL SCALE logical debug parameter (debug=.false.) @@ -66,110 +67,115 @@ C IERROR = 0 CALL FCPSB_ERRACTIONSAVE(ERR_ACT) - IF (TRANS.EQ.'N') THEN + IF (toupper(TRANS).EQ.'N') THEN C SCALE = (UNITD.EQ.'L') ! meaningless - IP1(1) = 0 - IP2(1) = 0 - - IF (IPERM(1).NE.0) THEN - DO I = 1, M - AUX(IPERM(I)) = I - ENDDO - ENDIF - - NNZ = JA(IA(2,NG+1)-1 +1)-1 - - if (debug) then - write(0,*) 'On entry to DJDCOX: NNZ LAUX ', - + nnz,laux,larn,lia1n,lia2n - endif - IF (LAUX.LT.NNZ+2) THEN - IERROR = 60 - INT_VAL(1) = 23 - INT_VAL(2) = NNZ+2 - INT_VAL(3) = LAUX - ELSE IF (LARN.LT.NNZ) THEN - IERROR = 60 - INT_VAL(1) = 19 - INT_VAL(2) = NNZ+2 - INT_VAL(3) = LAUX - ELSE IF (LIA1N.LT.NNZ) THEN - IERROR = 60 - INT_VAL(1) = 20 - INT_VAL(2) = NNZ+2 - INT_VAL(3) = LAUX - ELSE IF (LIA2N.LT.NNZ) THEN - IERROR = 60 - INT_VAL(1) = 21 - INT_VAL(2) = NNZ+2 - INT_VAL(3) = LAUX - ENDIF - - IF (DESCRA(1:1).EQ.'G') THEN - - DO 200 IPG = 1, NG - DO 50 K = IA(2,IPG), IA(3,IPG)-1 - IPX = IA(1,IPG) - DO 40 I = JA(K), JA(K+1) - 1 - ARN(I) = AR(I) - IA1N(I) = AUX(IPX) - IA2N(I) = KA(I) - IPX = IPX + 1 - 40 CONTINUE - 50 CONTINUE - - IPX = IA(1,IPG) - DO 70 K = IA(3,IPG), IA(2,IPG+1)-1 - DO 60 I = JA(K), JA(K+1) - 1 - ARN(I) = AR(I) - IA1N(I) = AUX(IPX) - IA2N(I) = KA(I) - 60 CONTINUE - IPX = IPX + 1 - 70 CONTINUE - 200 CONTINUE - - + IP1(1) = 0 + IP2(1) = 0 + + IF (IPERM(1).NE.0) THEN + DO I = 1, M + AUX(IPERM(I)) = I + ENDDO + ENDIF + + NNZ = JA(IA(2,NG+1)-1 +1)-1 + + if (debug) then + write(0,*) 'On entry to DJDCOX: NNZ LAUX ', + + nnz,laux,larn,lia1n,lia2n + endif + IF (LAUX.LT.NNZ+2) THEN + IERROR = 60 + INT_VAL(1) = 23 + INT_VAL(2) = NNZ+2 + INT_VAL(3) = LAUX + ELSE IF (LARN.LT.NNZ) THEN + IERROR = 60 + INT_VAL(1) = 19 + INT_VAL(2) = NNZ+2 + INT_VAL(3) = LAUX + ELSE IF (LIA1N.LT.NNZ) THEN + IERROR = 60 + INT_VAL(1) = 20 + INT_VAL(2) = NNZ+2 + INT_VAL(3) = LAUX + ELSE IF (LIA2N.LT.NNZ) THEN + IERROR = 60 + INT_VAL(1) = 21 + INT_VAL(2) = NNZ+2 + INT_VAL(3) = LAUX + ENDIF + + IF (toupper(DESCRA(1:1)).EQ.'G') THEN + + DO 200 IPG = 1, NG + DO 50 K = IA(2,IPG), IA(3,IPG)-1 + IPX = IA(1,IPG) + DO 40 I = JA(K), JA(K+1) - 1 + ARN(I) = AR(I) + IA1N(I) = AUX(IPX) + IA2N(I) = KA(I) + IPX = IPX + 1 + 40 CONTINUE + 50 CONTINUE + IPX = IA(1,IPG) + DO 70 K = IA(3,IPG), IA(2,IPG+1)-1 + DO 60 I = JA(K), JA(K+1) - 1 + ARN(I) = AR(I) + IA1N(I) = AUX(IPX) + IA2N(I) = KA(I) + 60 CONTINUE + IPX = IPX + 1 + 70 CONTINUE + 200 CONTINUE + + + C .... Order with key IA1N.... - CALL MSORT_UP(NNZ,IA1N,AUX,IRET) - IF (IRET.EQ.0) CALL REORDVN(NNZ,ARN,IA1N,IA2N,AUX) - + CALL MSORT_UP(NNZ,IA1N,AUX,IRET) + IF (IRET.EQ.0) CALL REORDVN(NNZ,ARN,IA1N,IA2N,AUX) + C .... Order with key IA2N ... - I = 1 - J = I - DO WHILE (I.LE.NNZ) - DO WHILE ((IA1N(J).EQ.IA1N(I)).AND. - + (J.LE.NNZ)) - J = J+1 - ENDDO - NZL = J - I - CALL MSORT_UP(NZL,IA2N(I),AUX,IRET) - IF (IRET.EQ.0) CALL REORDVN(NZL,ARN(I),IA1N(I),IA2N(I), - + AUX) - I = J + I = 1 + J = I + DO WHILE (I.LE.NNZ) + DO WHILE ((IA1N(J).EQ.IA1N(I)).AND. + + (J.LE.NNZ)) + J = J+1 ENDDO - INFON(1)=nnz - - ELSE IF (DESCRA(1:1).EQ.'S' .AND. DESCRA(2:2).EQ.'U') THEN - - DO 20 K = 1, M - IP2(K) = K - 20 CONTINUE - - ELSE IF (DESCRA(1:1).EQ.'T' .AND. DESCRA(2:2).EQ.'U') THEN - - ELSE IF (DESCRA(1:1).EQ.'T' .AND. DESCRA(2:2).EQ.'L') THEN - - END IF + NZL = J - I + CALL MSORT_UP(NZL,IA2N(I),AUX,IRET) + IF (IRET.EQ.0) CALL REORDVN(NZL,ARN(I),IA1N(I),IA2N(I), + + AUX) + I = J + ENDDO + INFON(1)=nnz + + ELSE IF (toupper(DESCRA(1:1)).EQ.'S' .AND. + + toupper(DESCRA(2:2)).EQ.'U') THEN + + DO 20 K = 1, M + IP2(K) = K + 20 CONTINUE + +c$$$ ELSE IF (DESCRA(1:1).EQ.'T' .AND. DESCRA(2:2).EQ.'U') THEN +c$$$ +c$$$ ELSE IF (DESCRA(1:1).EQ.'T' .AND. DESCRA(2:2).EQ.'L') THEN + else + IERROR = 3021 + CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) + GOTO 9999 + + END IF C - ELSE IF (TRANS.NE.'N') THEN + ELSE IF (toupper(TRANS).NE.'N') THEN C C TO DO C - IERROR = 3021 - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 + IERROR = 3021 + CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) + GOTO 9999 END IF @@ -181,8 +187,8 @@ C CALL FCPSB_ERRACTIONRESTORE(ERR_ACT) IF ( ERR_ACT .NE. 0 ) THEN - CALL FCPSB_SERROR() - RETURN + CALL FCPSB_SERROR() + RETURN ENDIF RETURN diff --git a/base/serial/dp/dvtfg.f b/base/serial/dp/dvtfg.f index 0e1165a37..c8dbf1022 100644 --- a/base/serial/dp/dvtfg.f +++ b/base/serial/dp/dvtfg.f @@ -32,13 +32,15 @@ C C Compute level numbers for the triangular matrix. C SUBROUTINE DVTFG (UPLO,M,JA,IA,NG,IPA,IPAT,KLEN,IWORK1,IWORK2, - * IWORK3) + * IWORK3) + use psb_string_mod + implicit none C .. Scalar Arguments .. INTEGER M, NG CHARACTER UPLO C .. Array Arguments .. INTEGER IA(*), IPA(*), IPAT(*), IWORK3(*), JA(*), - * KLEN(*), IWORK2(*), IWORK1(*) + * KLEN(*), IWORK2(*), IWORK1(*) C .. Local Scalars .. INTEGER I, J, L, L0, L1, LEV, NP, iret C .. Intrinsic Functions .. @@ -56,11 +58,11 @@ C C THE MATRIX HASN'T ELEMENTS C THE OUTPUT PERMUTATIONS ARE POSED TO THE IDENTITY MATRIX C - DO 20 I = 1, M - IPA(I) = I - IPAT(I) = I - KLEN(I) = 0 - 20 CONTINUE + DO 20 I = 1, M + IPA(I) = I + IPAT(I) = I + KLEN(I) = 0 + 20 CONTINUE ELSE C C COMPUTE LEVEL NUMBER FOR EACH ROWS @@ -68,31 +70,31 @@ C C IWORK1: AUXILIARY VECTOR WHICH CONTAINS C LEVEL NUMBERS OF EACH ROW C - DO 40 I = 1, M - IWORK1(I) = 0 - IWORK3(I) = 0 - 40 CONTINUE - IF (UPLO.EQ.'L') THEN + DO 40 I = 1, M + IWORK1(I) = 0 + IWORK3(I) = 0 + 40 CONTINUE + IF (toupper(UPLO).EQ.'L') THEN C C LOWER TRIANGULAR SPARSE MATRIX C - DO 80 I = 1, M - IWORK1(I) = 1 - DO 60 J = IA(I), IA(I+1) - 1 - IWORK1(I) = MAX(IWORK1(I),IWORK1(JA(J))+1) - 60 CONTINUE - 80 CONTINUE - ELSE IF (UPLO.EQ.'U') THEN + DO 80 I = 1, M + IWORK1(I) = 1 + DO 60 J = IA(I), IA(I+1) - 1 + IWORK1(I) = MAX(IWORK1(I),IWORK1(JA(J))+1) + 60 CONTINUE + 80 CONTINUE + ELSE IF (toupper(UPLO).EQ.'U') THEN C C UPPER TRIANGULAR SPARSE MATRIX C - DO 120 I = M, 1, -1 - IWORK1(I) = 1 - DO 100 J = IA(I), IA(I+1) - 1 - IWORK1(I) = MAX(IWORK1(I),IWORK1(JA(J))+1) - 100 CONTINUE - 120 CONTINUE - END IF + DO 120 I = M, 1, -1 + IWORK1(I) = 1 + DO 100 J = IA(I), IA(I+1) - 1 + IWORK1(I) = MAX(IWORK1(I),IWORK1(JA(J))+1) + 100 CONTINUE + 120 CONTINUE + END IF C C COUNT NUMBER OF ROWS IN EACH EQUIVALENCE GROUPS C @@ -101,44 +103,44 @@ C C IWORK3: AUXILIARY VECTOR WHICH CONTAINS C THE NUMBER OF ROWS FOR EACH GROUPS C - DO 140 I = 1, M - IWORK3(IWORK1(I)) = IWORK3(IWORK1(I)) + 1 - 140 CONTINUE + DO 140 I = 1, M + IWORK3(IWORK1(I)) = IWORK3(IWORK1(I)) + 1 + 140 CONTINUE C C SET UP IWORK2: C IWORK2(I) POINTS TO THE BEGINNING OF I-TH GROUP C - IWORK2(1) = 1 - DO 160 I = 2, M + 1 - IWORK2(I) = IWORK3(I-1) + IWORK2(I-1) - IF (IWORK2(I).EQ.M+1) THEN - NG = I - 1 - GO TO 180 - END IF - 160 CONTINUE - 180 CONTINUE + IWORK2(1) = 1 + DO 160 I = 2, M + 1 + IWORK2(I) = IWORK3(I-1) + IWORK2(I-1) + IF (IWORK2(I).EQ.M+1) THEN + NG = I - 1 + GO TO 180 + END IF + 160 CONTINUE + 180 CONTINUE C C NG : TOTAL NUMBER OF LEVELS C IWORK3: VECTOR CONTAINING THE NUMBER OF THE ROWS SORTED BY C EQUIVALENCE GROUPS. C - DO 200 I = 1, M - IWORK3(IWORK2(IWORK1(I))) = I - IWORK2(IWORK1(I)) = IWORK2(IWORK1(I)) + 1 - 200 CONTINUE + DO 200 I = 1, M + IWORK3(IWORK2(IWORK1(I))) = I + IWORK2(IWORK1(I)) = IWORK2(IWORK1(I)) + 1 + 200 CONTINUE C C REGENERATE IWORK2: POINTER INTO IWORK3 FOR EQUIVALENCE GROUPS C - DO 220 I = NG + 1, 2, -1 - IWORK2(I) = IWORK2(I-1) - 220 CONTINUE - IWORK2(1) = 1 + DO 220 I = NG + 1, 2, -1 + IWORK2(I) = IWORK2(I-1) + 220 CONTINUE + IWORK2(1) = 1 C C IWORK1: ROWS LENGTH IN NEW ORDERING C - DO 240 L = 1, M - IWORK1(L) = IA(IWORK3(L)) - IA(IWORK3(L)+1) - 240 CONTINUE + DO 240 L = 1, M + IWORK1(L) = IA(IWORK3(L)) - IA(IWORK3(L)+1) + 240 CONTINUE C C SORT ROWS BY DECREASING NUMBER OF NONZERO ELEMENTS. C @@ -146,49 +148,49 @@ C IPA: VECTOR OF NUMBER OF ROWS SORTED BY EQUIVALENCE C GROUPS AND BY ROW LENGTH C IPAT: AUXILIARY VECTOR NEED TO THE SORTER ROUTINES C - L1 = IWORK2(2) - IWORK2(1) - DO 260 L = 1, L1 - IPA(L) = IWORK3(L) - 260 CONTINUE - if (debug) write(0,*) 'DVTFG: Group ',1,':',(ipa(l),l=1,l1) - DO 360 LEV = 2, NG + L1 = IWORK2(2) - IWORK2(1) + DO 260 L = 1, L1 + IPA(L) = IWORK3(L) + 260 CONTINUE + if (debug) write(0,*) 'DVTFG: Group ',1,':',(ipa(l),l=1,l1) + DO 360 LEV = 2, NG C C LOOP ON GROUPS C L1: LENGTH OF CURRENT GROUP C L0: POINTER TO IPA TO THE FIRST LOCATIONS RESERVED C FOR CURRENT GROUP C - L1 = IWORK2(LEV+1) - IWORK2(LEV) - L0 = IWORK2(LEV) - 1 - CALL MSORT_UP(L1,IWORK1(IWORK2(LEV)),IPAT,IRET) - IF (IRET.EQ.0) THEN - NP = IPAT(1) - DO 280 L = 1, L1 - IPA(L0+L) = IWORK3(L0+NP) - NP = IPAT(1+NP) - 280 CONTINUE - ELSE + L1 = IWORK2(LEV+1) - IWORK2(LEV) + L0 = IWORK2(LEV) - 1 + CALL MSORT_UP(L1,IWORK1(IWORK2(LEV)),IPAT,IRET) + IF (IRET.EQ.0) THEN + NP = IPAT(1) + DO 280 L = 1, L1 + IPA(L0+L) = IWORK3(L0+NP) + NP = IPAT(1+NP) + 280 CONTINUE + ELSE C C VECTOR ALREADY SORTED. NO CHANGE IS NEED C - DO 320 L = 1, L1 - IPA(L0+L) = IWORK3(L0+L) - 320 CONTINUE - ENDIF - if (debug) write(0,*) 'DVTFG: Group ',lev, - + ':',(ipa(l0+l),l=1,l1) - 360 CONTINUE + DO 320 L = 1, L1 + IPA(L0+L) = IWORK3(L0+L) + 320 CONTINUE + ENDIF + if (debug) write(0,*) 'DVTFG: Group ',lev, + + ':',(ipa(l0+l),l=1,l1) + 360 CONTINUE C C IPAT = IPA-1 C - DO 380 I = 1, M - IPAT(IPA(I)) = I - 380 CONTINUE + DO 380 I = 1, M + IPAT(IPA(I)) = I + 380 CONTINUE C DO 400 I = 1, NG C KLEN(I) = IWORK2(I+1) - IWORK2(I) - DO 400 I = 1, NG+1 - KLEN(I) = IWORK2(I) - 400 CONTINUE + DO 400 I = 1, NG+1 + KLEN(I) = IWORK2(I) + 400 CONTINUE END IF RETURN END diff --git a/base/serial/dp/zcoco.f b/base/serial/dp/zcoco.f index 81c7e58bf..77c501e91 100644 --- a/base/serial/dp/zcoco.f +++ b/base/serial/dp/zcoco.f @@ -36,6 +36,7 @@ c use psb_const_mod use psb_spmat_type + use psb_string_mod implicit none c .. scalar arguments .. @@ -73,8 +74,8 @@ c call fcpsb_erractionsave(err_act) call psb_getifield(check_flag,psb_dupl_,infon,psb_ifasize_,ierror) - if (trans.eq.'N') then - scale = (unitd.eq.'L') ! meaningless + if (toupper(trans).eq.'N') then + scale = (toupper(unitd).eq.'L') ! meaningless p1(1) = 0 p2(1) = 0 @@ -113,7 +114,7 @@ c goto 9999 end if - if (descra(1:1).eq.'G') then + if (toupper(descra(1:1)).eq.'G') then c c sort COO data structure c @@ -245,26 +246,29 @@ c ... sum the duplicated element ... if (debug) write(*,*)'done rebuild COO',infon(1) - else if (descra(1:1).eq.'S' .and. descra(2:2).eq.'U') then + else if (toupper(descra(1:1)).eq.'S' .and. + + toupper(descra(2:2)).eq.'U') then do 20 k = 1, m p2(k) = k 20 continue - else if (descra(1:1).eq.'T' .and. descra(2:2).eq.'U') then + else if (toupper(descra(1:1)).eq.'T' .and. + + toupper(descra(2:2)).eq.'U') then ierror = 3021 call fcpsb_errpush(ierror,name,int_val) goto 9999 - else if (descra(1:1).eq.'T' .and. descra(2:2).eq.'L') then + else if (toupper(descra(1:1)).eq.'T' .and. + + toupper(descra(2:2)).eq.'L') then ierror = 3021 call fcpsb_errpush(ierror,name,int_val) goto 9999 end if c - else if (trans.ne.'N') then + else if (toupper(trans).ne.'N') then c c to do c diff --git a/base/serial/dp/zcocr.f b/base/serial/dp/zcocr.f index 90f127334..6230b3bcb 100644 --- a/base/serial/dp/zcocr.f +++ b/base/serial/dp/zcocr.f @@ -37,6 +37,7 @@ C use psb_const_mod use psb_spmat_type + use psb_string_mod IMPLICIT NONE C @@ -51,16 +52,17 @@ C .. Array Arguments .. * INFON(*), P1(*), P2(*) CHARACTER DESCRA*11, DESCRN*11 C .. Local Scalars .. - INTEGER NNZ, K, ROW, I, J, NZL, IRET - integer ipx, ip1, ip2, CHECK_FLAG, err_act - INTEGER ELEM, ELEM_CSR - LOGICAL SCALE - INTEGER MAX_NNZERO + integer nnz, k, row, i, j, nzl, iret + integer ipx, ip1, ip2, check_flag, err_act + integer elem, elem_csr,regen_flag + logical scale + integer max_nnzero logical debug parameter (debug=.false.) -c .. Local Arrays .. - CHARACTER*20 NAME - INTEGER INT_VAL(5) + integer, allocatable :: itmp(:) +c .. local arrays .. + character*20 name + integer int_val(5) C C ...Common variables... @@ -75,14 +77,15 @@ C CALL FCPSB_ERRACTIONSAVE(ERR_ACT) call psb_getifield(check_flag,psb_dupl_,infon,psb_ifasize_,ierror) + call psb_getifield(regen_flag,psb_upd_,infon,psb_ifasize_,ierror) - IF ((TRANS.EQ.'N').or.(TRANS.EQ.'n')) THEN + IF (toupper(TRANS).EQ.'N') THEN - SCALE = (UNITD.EQ.'L') ! meaningless + SCALE = (toupper(UNITD).EQ.'L') ! meaningless P1(1) = 0 P2(1) = 0 - NNZ = INFO(1) + nnz = info(1) if (debug) then write(0,*) 'On entry to ZCOCR: NNZ LAUX ', + nnz,laux,larn,lian1,lian2 @@ -95,18 +98,18 @@ C ELSE IF (LARN.LT.NNZ) THEN IERROR = 60 INT_VAL(1) = 18 - INT_VAL(2) = NNZ+2 - INT_VAL(3) = LAUX + INT_VAL(2) = NNZ + INT_VAL(3) = LARN ELSE IF (LIAN1.LT.NNZ) THEN IERROR = 60 INT_VAL(1) = 19 - INT_VAL(2) = NNZ+2 - INT_VAL(3) = LAUX + INT_VAL(2) = NNZ + INT_VAL(3) = LIAN1 ELSE IF (LIAN2.LT.M+1) THEN IERROR = 60 INT_VAL(1) = 20 - INT_VAL(2) = NNZ+2 - INT_VAL(3) = LAUX + INT_VAL(2) = M+1 + INT_VAL(3) = LIAN2 ENDIF C @@ -117,25 +120,32 @@ C GOTO 9999 END IF - IF (DESCRA(1:1).EQ.'G') THEN + allocate(itmp(nnz),stat=iret) + if (iret /= 0) then + call fcpsb_errpush(4010,name,int_val) + goto 9999 + end if + + do k=1, nnz + arn(k) = ar(k) + ian1(k) = ja(k) + itmp(k) = ia(k) + enddo + + IF (toupper(descra(1:1)).EQ.'G') THEN C C Sort COO data structure C if (debug) write(0,*)'First sort',nnz -c$$$ if (debug) then -c$$$ do k=1,nnz -c$$$ write(*,*) k,ia(k),ja(k),ar(k) -c$$$ enddo -c$$$ endif c$$$ write(0,*) 'ZCOCR Sizes ',lian2,((m+1)+nnz+psb_ireg_flgs_+1), c$$$ + m+1,nnz,psb_ireg_flgs_, c$$$ + laux,2*(2+nnz) - if ((lian2.ge.((m+1)+nnz+psb_ireg_flgs_+1)) + if ((regen_flag==psb_upd_perm_).and. + + (lian2.ge.((m+1)+nnz+psb_ireg_flgs_+1)) + .and.(laux.ge.2*(2+nnz))) then C C Prepare for smart regeneration c - ipx = nnz+3 do i=1, nnz aux(ipx+i-1) = i @@ -157,371 +167,331 @@ c$$$ + ip1,ip2,nnz,ian2(ip1+nnzt_) if (debug) write(0,*) 'Build check :',ian2(ip1+psb_nnzt_) C .... Order with key IA ... - CALL MSORT_UP(NNZ,IA,AUX,IRET) - IF (IRET.EQ.0) CALL ZREORDVN3(NNZ,AR,IA,JA,AUX(IPX),AUX) + call msort_up(nnz,itmp,aux,iret) + if (iret.eq.0) + + call zreordvn3(nnz,arn,itmp,ian1,aux(ipx),aux) if (debug) then do i=1, nnz-1 - if (ia(i).gt.ia(i+1)) then - write(0,*) 'Sorting error:',i,ia(i),ia(i+1) + if (itmp(i).gt.itmp(i+1)) then + write(0,*) 'Sorting error:',i,itmp(i),itmp(i+1) endif enddo - write(0,*) 'nnz :',m,nnz,ia(nnz),ja(nnz) + write(0,*) 'nnz :',m,nnz,itmp(nnz),ian1(nnz) endif -C .... Order with key IA2N ... +C .... Order with key JA ... I = 1 J = I -c$$$ DO WHILE (I.LE.NNZ) -c$$$ DO WHILE ((IA(J).EQ.IA(I)).AND. -c$$$ + (J.LE.NNZ)) - DO - if (I>NNZ) exit - DO + do + if (i>nnz) exit + do if (j>nnz) exit - if (ia(j) /= ia(i)) exit - J = J+1 - ENDDO - NZL = J - I - CALL MSORT_UP(NZL,JA(I),AUX,IRET) - IF (IRET.EQ.0) CALL ZREORDVN3(NZL,AR(I),IA(I),JA(I), - + AUX(IPX+I-1),AUX) - I = J - ENDDO + if (itmp(j) /= itmp(i)) exit + j = j+1 + enddo + nzl = j - i + call msort_up(nzl,ian1(i),aux,iret) + if (iret.eq.0) call zreordvn3(nzl,arn(i),itmp(i),ian1(i), + + aux(ipx+i-1),aux) + i = j + enddo -C ... Construct CSR Representation... - ELEM = 1 - ELEM_CSR = 1 -C ... Insert first element ... - DO ROW = 1, IA(1) - IAN2(ROW) = 1 - ENDDO +c ... Construct CSR Representation... + elem = 1 + elem_csr = 1 +c ... Insert first element ... + do row = 1, itmp(1) + ian2(row) = 1 + enddo if (debug) write(0,*)'Rebuild CSR',ia(1),elem_csr - IAN1(ELEM_CSR) = JA(ELEM) - ARN(ELEM_CSR) = AR(ELEM) + ian1(elem_csr) = ian1(elem) + arn(elem_csr) = arn(elem) ian2(ip2+aux(ipx+elem-1)-1) = elem_csr - ELEM = ELEM+1 - ELEM_CSR = ELEM_CSR+1 -C ... Insert remaining element ... - DO ROW = IA(1), M -c$$$ if (debug) write(*,*)'CSR Loop:',row,m,elem_csr -c$$$ DO WHILE ((IA(ELEM).EQ.ROW).AND.(ELEM.LE.NNZ)) - DO + elem = elem+1 + elem_csr = elem_csr+1 +c ... insert remaining element ... + do row = itmp(1), m + do if (elem > nnz) exit - if (ia(elem) /= row) exit - IF (IA(ELEM).NE.IA(ELEM-1)) THEN -C ... Insert first element of a row ... - IAN1(ELEM_CSR) = JA(ELEM) - ARN(ELEM_CSR) = AR(ELEM) + if (itmp(elem) /= row) exit + if (itmp(elem).ne.itmp(elem-1)) then +c ... insert first element of a row ... + ian1(elem_csr) = ian1(elem) + arn(elem_csr) = arn(elem) ian2(ip2+aux(ipx+elem-1)-1) = elem_csr - ELEM_CSR = ELEM_CSR+1 - ELSE IF (JA(ELEM).NE.JA(ELEM-1)) THEN -C ... Insert other element of row ... - IAN1(ELEM_CSR) = JA(ELEM) - ARN(ELEM_CSR) = AR(ELEM) + elem_csr = elem_csr+1 + else if (ian1(elem).ne.ian1(elem-1)) then +c ... insert other element of row ... + ian1(elem_csr) = ian1(elem) + arn(elem_csr) = arn(elem) ian2(ip2+aux(ipx+elem-1)-1) = elem_csr - ELEM_CSR = ELEM_CSR+1 - ELSE - IF (CHECK_FLAG.EQ.psb_dupl_err_) THEN -C ... Error, there are duplicated elements ... - IERROR = 130 - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - ELSE IF (CHECK_FLAG.EQ.psb_dupl_ovwrt_) THEN -C ... Insert only the last duplicated element ... - ARN(ELEM_CSR-1) = AR(ELEM) + elem_csr = elem_csr+1 + else + if (check_flag.eq.psb_dupl_err_) then +c ... error, there are duplicated elements ... + ierror = 130 + call fcpsb_errpush(ierror,name,int_val) + goto 9999 + else if (check_flag.eq.psb_dupl_ovwrt_) then +c ... insert only the last duplicated element ... + arn(elem_csr-1) = arn(elem) ian2(ip2+aux(ipx+elem-1)-1) = elem_csr-1 - ELSE IF (CHECK_FLAG.EQ.psb_dupl_add_) THEN -C ... Sum the duplicated element ... - ARN(ELEM_CSR-1) = ARN(ELEM_CSR-1) + AR(ELEM) + if (debug) write(0,*) 'duplicated overwrite perm ', + + elem_csr-1,elem + else if (check_flag.eq.psb_dupl_add_) then +c ... sum the duplicated element ... + arn(elem_csr-1) = arn(elem_csr-1) + arn(elem) ian2(ip2+aux(ipx+elem-1)-1) = elem_csr-1 - END IF - ENDIF - ELEM = ELEM + 1 - ENDDO - IAN2(ROW+1) = ELEM_CSR - ENDDO - ELSE -c$$$ write(0,*) 'Going for ELSE !!!?' + if (debug) write(0,*) 'duplicated add perm ', + + elem_csr-1,elem + end if + endif + elem = elem + 1 + enddo + ian2(row+1) = elem_csr + enddo + + + else C .... Order with key IA ... - CALL MSORT_UP(NNZ,IA,AUX,IRET) - IF (IRET.EQ.0) CALL ZREORDVN(NNZ,AR,IA,JA,AUX) -C .... Order with key IA2N ... - I = 1 - J = I -c$$$ DO WHILE (I.LE.NNZ) -c$$$ DO WHILE ((IA(J).EQ.IA(I)).AND. -c$$$ + (J.LE.NNZ)) - DO - if (I>NNZ) exit - DO + + call msort_up(nnz,itmp,aux,iret) + if (iret.eq.0) call zreordvn(nnz,arn,itmp,ian1,aux) +C .... Order with key JA ... + i = 1 + j = i + do + if (i>nnz) exit + do if (j>nnz) exit - if (ia(j) /= ia(i)) exit - J = J+1 - ENDDO - NZL = J - I - CALL MSORT_UP(NZL,JA(I),AUX,IRET) - IF (IRET.EQ.0) CALL ZREORDVN(NZL,AR(I),IA(I),JA(I),AUX) - I = J - ENDDO + if (itmp(j) /= itmp(i)) exit + j = j+1 + enddo + nzl = j - i + call msort_up(nzl,ian1(i),aux,iret) + if (iret.eq.0) + + call zreordvn(nzl,arn(i),itmp(i),ian1(i),aux) + i = j + enddo C ... Construct CSR Representation... - ELEM = 1 - ELEM_CSR = 1 + elem = 1 + elem_csr = 1 C ... Insert first element ... - DO ROW = 1, IA(1) - IAN2(ROW) = 1 - ENDDO + do row = 1, itmp(1) + ian2(row) = 1 + enddo if (debug) write(0,*)'Rebuild CSR',ia(1),elem_csr - IAN1(ELEM_CSR) = JA(ELEM) - ARN(ELEM_CSR) = AR(ELEM) - ELEM = ELEM+1 - ELEM_CSR = ELEM_CSR+1 + ian1(elem_csr) = ian1(elem) + arn(elem_csr) = arn(elem) + elem = elem+1 + elem_csr = elem_csr+1 C ... Insert remaining element ... - DO ROW = IA(1), M -c$$$ if (debug) write(*,*)'CSR Loop:',row,m,elem_csr -c$$$ DO WHILE ((IA(ELEM).EQ.ROW).AND.(ELEM.LE.NNZ)) - DO + do row = itmp(1), m + do if (elem > nnz) exit - if (ia(elem) /= row) exit - IF (IA(ELEM).NE.IA(ELEM-1)) THEN -C ... Insert first element of a row ... - IAN1(ELEM_CSR) = JA(ELEM) - ARN(ELEM_CSR) = AR(ELEM) - ELEM_CSR = ELEM_CSR+1 - ELSE IF (JA(ELEM).NE.JA(ELEM-1)) THEN + if (itmp(elem) /= row) exit + if (itmp(elem).ne.itmp(elem-1)) then +c ... insert first element of a row ... + ian1(elem_csr) = ian1(elem) + arn(elem_csr) = arn(elem) + elem_csr = elem_csr+1 + else if (ian1(elem).ne.ian1(elem-1)) then C ... Insert other element of row ... - IAN1(ELEM_CSR) = JA(ELEM) - ARN(ELEM_CSR) = AR(ELEM) - ELEM_CSR = ELEM_CSR+1 - ELSE - IF (CHECK_FLAG.EQ.psb_dupl_err_) THEN -C ... Error, there are duplicated elements ... - IERROR = 130 - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - ELSE IF (CHECK_FLAG.EQ.psb_dupl_ovwrt_) THEN -C ... Insert only the last duplicated element ... - ARN(ELEM_CSR-1) = AR(ELEM) - if (debug) write(0,*) 'Duplicated overwrite', + ian1(elem_csr) = ian1(elem) + arn(elem_csr) = arn(elem) + elem_csr = elem_csr+1 + else + if (check_flag.eq.psb_dupl_err_) then +c ... error, there are duplicated elements ... + ierror = 130 + call fcpsb_errpush(ierror,name,int_val) + goto 9999 + else if (check_flag.eq.psb_dupl_ovwrt_) then +c ... insert only the last duplicated element ... + arn(elem_csr-1) = arn(elem) + if (debug) write(0,*) 'Duplicated overwrite srch', + elem_csr-1,elem - ELSE IF (CHECK_FLAG.EQ.psb_dupl_add_) THEN -C ... Sum the duplicated element ... - ARN(ELEM_CSR-1) = ARN(ELEM_CSR-1) + AR(ELEM) - if (debug) write(0,*) 'Duplicated add', + else if (check_flag.eq.psb_dupl_add_) then +c ... sum the duplicated element ... + arn(elem_csr-1) = arn(elem_csr-1) + arn(elem) + if (debug) write(0,*) 'Duplicated add srch', + elem_csr-1,elem - END IF - ENDIF - ELEM = ELEM + 1 - ENDDO - IAN2(ROW+1) = ELEM_CSR - ENDDO - ENDIF + end if + endif + elem = elem + 1 + enddo + ian2(row+1) = elem_csr + enddo + endif if (debug) write(0,*)'Done Rebuild CSR', + ian2(m+1),ia(elem) - if (debug) then - do i=ian2(m+1), nnz - write(0,*) 'Overflow check :',ia(i),ja(i),ar(i) - enddo - endif +c$$$ if (debug) then +c$$$ do i=ian2(m+1), nnz +c$$$ write(0,*) 'Overflow check :',ia(i),ja(i),ar(i) +c$$$ enddo +c$$$ endif - ELSE IF (DESCRA(1:1).EQ.'S' .AND. DESCRA(2:2).EQ.'U') THEN + ELSE IF (toupper(DESCRA(1:1)).EQ.'S' .AND. + + toupper(DESCRA(2:2)).EQ.'U') THEN - DO 20 K = 1, M - P2(K) = K - 20 CONTINUE + do 20 k = 1, m + p2(k) = k + 20 continue - ELSE IF (DESCRA(1:1).EQ.'T' .AND. DESCRA(2:2).EQ.'U') THEN + else if (toupper(DESCRA(1:1)).EQ.'T' .AND. + + toupper(DESCRA(2:2)).EQ.'U') THEN + + + call msort_up(nnz,itmp,aux,iret) + if (iret.eq.0) call zreordvn(nnz,arn,itmp,ian1,aux) +C .... Order with key JA ... + i = 1 + j = i + do + if (i>nnz) exit + do + if (j>nnz) exit + if (itmp(j) /= itmp(i)) exit + j = j+1 + enddo + nzl = j - i + call msort_up(nzl,ian1(i),aux,iret) + if (iret.eq.0) + + call zreordvn(nzl,arn(i),itmp(i),ian1(i),aux) + i = j + enddo -C .... Order with key IA ... - CALL MSORT_UP(NNZ,IA,AUX,IRET) - IF (IRET.EQ.0) CALL ZREORDVN(NNZ,AR,IA,JA,AUX) -C .... Order with key IA2N ... - I = 1 - J = I -c$$$ DO WHILE (I.LE.NNZ) -c$$$ DO WHILE ((IA(J).EQ.IA(I)).AND. -c$$$ + (J.LE.NNZ)) - DO - if (I>NNZ) exit - DO - if (j>nnz) exit - if (ia(j) /= ia(i)) exit - J = J+1 - ENDDO - NZL = J - I - CALL MSORT_UP(NZL,JA(I),AUX,IRET) - IF (IRET.EQ.0) CALL ZREORDVN(NZL,AR(I),IA(I),JA(I),AUX) - I = J - ENDDO C ... Construct CSR Representation... - ELEM = 1 - ELEM_CSR = 1 + elem = 1 + elem_csr = 1 C ... Insert first element ... - DO ROW = 1, IA(1) - IAN2(ROW) = 1 - ENDDO - if (debug) write(0,*)'Rebuild CSR',ia(1),elem_csr - IF(JA(ELEM).GT.IA(ELEM)) THEN - IAN1(ELEM_CSR) = JA(ELEM) - ARN(ELEM_CSR) = AR(ELEM) - ELEM_CSR = ELEM_CSR+1 - ENDIF - - ELEM = ELEM+1 - + do row = 1, itmp(1) + ian2(row) = 1 + enddo + if (debug) write(0,*)'Rebuild CSR',ia(1),elem_csr + ian1(elem_csr) = ian1(elem) + arn(elem_csr) = arn(elem) + elem = elem+1 + elem_csr = elem_csr+1 C ... Insert remaining element ... - DO ROW = IA(1), M -c$$$ if (debug) write(*,*)'CSR Loop:',row,m,elem_csr -c$$$ DO WHILE ((IA(ELEM).EQ.ROW).AND.(ELEM.LE.NNZ)) - DO - if (elem > nnz) exit - if (ia(elem) /= row) exit - IF (IA(ELEM).NE.IA(ELEM-1)) THEN -C ... Insert first element of a row ... - IF(JA(ELEM).GT.IA(ELEM)) THEN - IAN1(ELEM_CSR) = JA(ELEM) - ARN(ELEM_CSR) = AR(ELEM) - ELEM_CSR = ELEM_CSR+1 - ENDIF - ELSE IF (JA(ELEM).NE.JA(ELEM-1)) THEN -C ... Insert other element of row ... - IF(JA(ELEM).GT.IA(ELEM)) THEN - IAN1(ELEM_CSR) = JA(ELEM) - ARN(ELEM_CSR) = AR(ELEM) - ELEM_CSR = ELEM_CSR+1 - ENDIF - ELSE - IF (CHECK_FLAG.EQ.psb_dupl_err_) THEN -C ... Error, there are duplicated elements ... - IERROR = 130 - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - ELSE IF (CHECK_FLAG.EQ.psb_dupl_ovwrt_) THEN -C ... Insert only the last duplicated element ... - IF(JA(ELEM).GT.IA(ELEM)) THEN - ARN(ELEM_CSR-1) = AR(ELEM) - ENDIF - if (debug) write(0,*) 'Duplicated overwrite', - + elem_csr-1,elem - ELSE IF (CHECK_FLAG.EQ.psb_dupl_add_) THEN -C ... Sum the duplicated element ... - IF(JA(ELEM).GT.IA(ELEM)) THEN - ARN(ELEM_CSR-1) = ARN(ELEM_CSR-1) + AR(ELEM) - ENDIF - if (debug) write(0,*) 'Duplicated add', - + elem_csr-1,elem - END IF - ENDIF - ELEM = ELEM + 1 - ENDDO - IAN2(ROW+1) = ELEM_CSR - ENDDO - - - if (debug) write(0,*)'Done Rebuild CSR', - + ian2(m+1),ia(elem) - if (debug) then - do i=ian2(m+1), nnz - write(0,*) 'Overflow check :',ia(i),ja(i),ar(i) + do row = itmp(1), m + do + if (elem > nnz) exit + if (itmp(elem) /= row) exit + if (itmp(elem).ne.itmp(elem-1)) then +c ... insert first element of a row ... + ian1(elem_csr) = ian1(elem) + arn(elem_csr) = arn(elem) + elem_csr = elem_csr+1 + else if (ian1(elem).ne.ian1(elem-1)) then +C ... Insert other element of row ... + ian1(elem_csr) = ian1(elem) + arn(elem_csr) = arn(elem) + elem_csr = elem_csr+1 + else + if (check_flag.eq.psb_dupl_err_) then +c ... error, there are duplicated elements ... + ierror = 130 + call fcpsb_errpush(ierror,name,int_val) + goto 9999 + else if (check_flag.eq.psb_dupl_ovwrt_) then +c ... insert only the last duplicated element ... + arn(elem_csr-1) = arn(elem) + if (debug) write(0,*) 'Duplicated overwrite srch', + + elem_csr-1,elem + else if (check_flag.eq.psb_dupl_add_) then +c ... sum the duplicated element ... + arn(elem_csr-1) = arn(elem_csr-1) + arn(elem) + if (debug) write(0,*) 'Duplicated add srch', + + elem_csr-1,elem + end if + endif + elem = elem + 1 + enddo + ian2(row+1) = elem_csr enddo - endif - - - ELSE IF (DESCRA(1:1).EQ.'T' .AND. DESCRA(2:2).EQ.'L') THEN + else if (toupper(descra(1:1)).EQ.'T' .AND. + + toupper(DESCRA(2:2)).EQ.'L') THEN + + call msort_up(nnz,itmp,aux,iret) + if (iret.eq.0) call zreordvn(nnz,arn,itmp,ian1,aux) +C .... Order with key JA ... + i = 1 + j = i + do + if (i>nnz) exit + do + if (j>nnz) exit + if (itmp(j) /= itmp(i)) exit + j = j+1 + enddo + nzl = j - i + call msort_up(nzl,ian1(i),aux,iret) + if (iret.eq.0) + + call zreordvn(nzl,arn(i),itmp(i),ian1(i),aux) + i = j + enddo + -C .... Order with key IA ... - CALL MSORT_UP(NNZ,IA,AUX,IRET) - IF (IRET.EQ.0) CALL ZREORDVN(NNZ,AR,IA,JA,AUX) -C .... Order with key IA2N ... - I = 1 - J = I -c$$$ DO WHILE (I.LE.NNZ) -c$$$ DO WHILE ((IA(J).EQ.IA(I)).AND. -c$$$ + (J.LE.NNZ)) - DO - if (I>NNZ) exit - DO - if (j>nnz) exit - if (ia(j) /= ia(i)) exit - J = J+1 - ENDDO - NZL = J - I - CALL MSORT_UP(NZL,JA(I),AUX,IRET) - IF (IRET.EQ.0) CALL ZREORDVN(NZL,AR(I),IA(I),JA(I),AUX) - I = J - ENDDO C ... Construct CSR Representation... - ELEM = 1 - ELEM_CSR = 1 + elem = 1 + elem_csr = 1 C ... Insert first element ... - DO ROW = 1, IA(1) - IAN2(ROW) = 1 - ENDDO - if (debug) write(0,*)'Rebuild CSR',ia(1),elem_csr - IF(JA(ELEM).LT.IA(ELEM)) THEN - IAN1(ELEM_CSR) = JA(ELEM) - ARN(ELEM_CSR) = AR(ELEM) - ELEM_CSR = ELEM_CSR+1 - ENDIF - ELEM = ELEM+1 + do row = 1, itmp(1) + ian2(row) = 1 + enddo + if (debug) write(0,*)'Rebuild CSR',ia(1),elem_csr + ian1(elem_csr) = ian1(elem) + arn(elem_csr) = arn(elem) + elem = elem+1 + elem_csr = elem_csr+1 +C ... Insert remaining element ... + do row = itmp(1), m + do + if (elem > nnz) exit + if (itmp(elem) /= row) exit + if (itmp(elem).ne.itmp(elem-1)) then +c ... insert first element of a row ... + ian1(elem_csr) = ian1(elem) + arn(elem_csr) = arn(elem) + elem_csr = elem_csr+1 + else if (ian1(elem).ne.ian1(elem-1)) then +C ... Insert other element of row ... + ian1(elem_csr) = ian1(elem) + arn(elem_csr) = arn(elem) + elem_csr = elem_csr+1 + else + if (check_flag.eq.psb_dupl_err_) then +c ... error, there are duplicated elements ... + ierror = 130 + call fcpsb_errpush(ierror,name,int_val) + goto 9999 + else if (check_flag.eq.psb_dupl_ovwrt_) then +c ... insert only the last duplicated element ... + arn(elem_csr-1) = arn(elem) + if (debug) write(0,*) 'Duplicated overwrite srch', + + elem_csr-1,elem + else if (check_flag.eq.psb_dupl_add_) then +c ... sum the duplicated element ... + arn(elem_csr-1) = arn(elem_csr-1) + arn(elem) + if (debug) write(0,*) 'Duplicated add srch', + + elem_csr-1,elem + end if + endif + elem = elem + 1 + enddo + ian2(row+1) = elem_csr + enddo -C ... Insert remaining element ... - DO ROW = IA(1), M -c$$$ if (debug) write(*,*)'CSR Loop:',row,m,elem_csr -c$$$ DO WHILE ((IA(ELEM).EQ.ROW).AND.(ELEM.LE.NNZ)) - DO - if (elem > nnz) exit - if (ia(elem) /= row) exit - IF (IA(ELEM).NE.IA(ELEM-1)) THEN -C ... Insert first element of a row ... - IF(JA(ELEM).LT.IA(ELEM)) THEN - IAN1(ELEM_CSR) = JA(ELEM) - ARN(ELEM_CSR) = AR(ELEM) - ELEM_CSR = ELEM_CSR+1 - ENDIF - ELSE IF (JA(ELEM).NE.JA(ELEM-1)) THEN -C ... Insert other element of row ... - IF(JA(ELEM).LT.IA(ELEM)) THEN - IAN1(ELEM_CSR) = JA(ELEM) - ARN(ELEM_CSR) = AR(ELEM) - ELEM_CSR = ELEM_CSR+1 - ENDIF - ELSE - IF (CHECK_FLAG.EQ.psb_dupl_err_) THEN -C ... Error, there are duplicated elements ... - IERROR = 130 - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - ELSE IF (CHECK_FLAG.EQ.psb_dupl_ovwrt_) THEN -C ... Insert only the last duplicated element ... - IF(JA(ELEM).LT.IA(ELEM)) THEN - ARN(ELEM_CSR-1) = AR(ELEM) - ENDIF - if (debug) write(0,*) 'Duplicated overwrite', - + elem_csr-1,elem - ELSE IF (CHECK_FLAG.EQ.psb_dupl_add_) THEN -C ... Sum the duplicated element ... - IF(JA(ELEM).LT.IA(ELEM)) THEN - ARN(ELEM_CSR-1) = ARN(ELEM_CSR-1) + AR(ELEM) - ENDIF - if (debug) write(0,*) 'Duplicated add', - + elem_csr-1,elem - END IF - ENDIF - ELEM = ELEM + 1 - ENDDO - IAN2(ROW+1) = ELEM_CSR - ENDDO - - if (debug) write(0,*)'Done Rebuild CSR', + ian2(m+1),ia(elem) if (debug) then @@ -531,29 +501,29 @@ C ... Sum the duplicated element ... endif - END IF -C - ELSE IF (TRANS.NE.'N') THEN -C -C TO DO -C - IERROR = 3021 - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 + end if +c + else if (toupper(TRANS).NE.'N') then +c +c to do +c + ierror = 3021 + call fcpsb_errpush(ierror,name,int_val) + goto 9999 - END IF - INFON(1)=ELEM_CSR-1 + end if + infon(1)=elem_csr-1 - CALL FCPSB_ERRACTIONRESTORE(ERR_ACT) - RETURN + call fcpsb_erractionrestore(err_act) + return - 9999 CONTINUE - CALL FCPSB_ERRACTIONRESTORE(ERR_ACT) + 9999 continue + call fcpsb_erractionrestore(err_act) - IF ( ERR_ACT .NE. 0 ) THEN - CALL FCPSB_SERROR() - RETURN - ENDIF + if ( err_act .ne. 0 ) then + call fcpsb_serror() + return + endif - RETURN - END + return + end diff --git a/base/serial/dp/zcrco.f b/base/serial/dp/zcrco.f index b1d49a3d0..483724d82 100644 --- a/base/serial/dp/zcrco.f +++ b/base/serial/dp/zcrco.f @@ -34,6 +34,7 @@ C use psb_const_mod use psb_spmat_type + use psb_string_mod IMPLICIT NONE C @@ -63,8 +64,8 @@ C IERROR = 0 CALL FCPSB_ERRACTIONSAVE(ERR_ACT) - IF (TRANS.EQ.'N') THEN - SCALE = (UNITD.EQ.'L') ! meaningless + IF (toupper(TRANS).EQ.'N') THEN + SCALE = (toupper(UNITD).EQ.'L') ! meaningless IP1(1) = 0 IP2(1) = 0 NNZ = IA2(M+1)-1 @@ -90,7 +91,7 @@ C GOTO 9999 END IF - IF (DESCRA(1:1).EQ.'G') THEN + IF (toupper(DESCRA(1:1)).EQ.'G') THEN C ... Construct COO Representation... ELEM = 1 @@ -103,7 +104,8 @@ C ... Construct COO Representation... ENDDO ENDDO INFON(psb_nnz_) = IA2(M+1)-1 - ELSE IF (DESCRA(1:1).EQ.'S' .AND. DESCRA(2:2).EQ.'U') THEN + ELSE IF (toupper(DESCRA(1:1)).EQ.'S' .AND. + + toupper(DESCRA(2:2)).EQ.'U') THEN DO 20 K = 1, M IP2(K) = K @@ -113,14 +115,16 @@ C ... Construct COO Representation... call fcpsb_errpush(ierror,name,int_val) goto 9999 C - ELSE IF (DESCRA(1:1).EQ.'T' .AND. DESCRA(2:2).EQ.'U') THEN + ELSE IF (toupper(DESCRA(1:1)).EQ.'T' .AND. + + toupper(DESCRA(2:2)).EQ.'U') THEN C ierror = 3021 call fcpsb_errpush(ierror,name,int_val) goto 9999 - ELSE IF (DESCRA(1:1).EQ.'T' .AND. DESCRA(2:2).EQ.'L') THEN + ELSE IF (toupper(DESCRA(1:1)).EQ.'T' .AND. + + toupper(DESCRA(2:2)).EQ.'L') THEN ierror = 3021 call fcpsb_errpush(ierror,name,int_val) @@ -128,7 +132,7 @@ C END IF C - ELSE IF (TRANS.NE.'N') THEN + ELSE IF (toupper(TRANS).NE.'N') THEN C C TO DO C diff --git a/base/serial/dp/zcrcr.f b/base/serial/dp/zcrcr.f index f1c17192c..3ac0f729d 100644 --- a/base/serial/dp/zcrcr.f +++ b/base/serial/dp/zcrcr.f @@ -161,8 +161,9 @@ C IERROR > 0 error C C SUBROUTINE ZCRCR(TRANS,M,N,UNITD,D,DESCRA,A,IA1,IA2,INFOA,IP1, - * DESCRN,AN,IAN1,IAN2,INFON,IP2,LAN,LIAN1,LIAN2, - * WORK,LWORK,IERROR) + * DESCRN,AN,IAN1,IAN2,INFON,IP2,LAN,LIAN1,LIAN2, + * WORK,LWORK,IERROR) + use psb_string_mod IMPLICIT NONE C C .. Scalar Arguments .. @@ -171,12 +172,13 @@ C .. Scalar Arguments .. C .. Array Arguments .. complex(kind(1.d0)) A(*), AN(*), D(*), WORK(LWORK) INTEGER IA1(*), IA2(*), IAN1(*), IAN2(*), IP1(*), IP2(*), - * INFOA(*), INFON(*) + * INFOA(*), INFON(*) CHARACTER DESCRA*11, DESCRN*11 C .. Local Scalars .. INTEGER I, J, ERR_ACT LOGICAL EXIT c .. Local Arrays .. + character idescra*11 CHARACTER*20 NAME INTEGER INT_VAL(5) @@ -192,65 +194,66 @@ C C C Check for argument errors C - IF(((DESCRA(1:1) .EQ. 'S' .OR. DESCRA(1:1) .EQ. 'H' .OR. - & DESCRA(1:1) .EQ. 'A') .AND. (UNITD .NE. 'B')) .OR. - & (.NOT.((DESCRA(3:3).EQ.'N').OR.(DESCRA(3:3).EQ.'L').OR. - + (DESCRA(3:3).EQ.'U'))) .OR. - + TRANS.NE.'N') THEN - IERROR = 20 + idescra=toupper(descra) + IF(((IDESCRA(1:1) .EQ. 'S' .OR. IDESCRA(1:1) .EQ. 'H' .OR. + & IDESCRA(1:1) .EQ. 'A') .AND. (toupper(UNITD) .NE. 'B')) .OR. + & (.NOT.((IDESCRA(3:3).EQ.'N').OR.(IDESCRA(3:3).EQ.'L').OR. + + (IDESCRA(3:3).EQ.'U'))) .OR. + + toupper(TRANS).NE.'N') THEN + IERROR = 20 ENDIF IF(LAN.LT.(IA2(M+1)-1)) THEN - IF (LAN.LE.0) THEN - EXIT=.TRUE. - AN(1) = DBLE(IA2(M+1)-1) - ELSE - IERROR = 21 - ENDIF + IF (LAN.LE.0) THEN + EXIT=.TRUE. + AN(1) = DBLE(IA2(M+1)-1) + ELSE + IERROR = 21 + ENDIF ENDIF IF(LIAN1.LT.(IA2(M+1)-1)) THEN - IF (LAN.LE.0) THEN - EXIT=.TRUE. - IAN1(1) = IA2(M+1)-1 - ELSE - IERROR = 22 - ENDIF + IF (LAN.LE.0) THEN + EXIT=.TRUE. + IAN1(1) = IA2(M+1)-1 + ELSE + IERROR = 22 + ENDIF ENDIF IF(LIAN2.LT.(M+1)) THEN - IF (LAN.LE.0) THEN - EXIT=.TRUE. - IAN2(1) = M+1 - ELSE - IERROR = 23 - ENDIF + IF (LAN.LE.0) THEN + EXIT=.TRUE. + IAN2(1) = M+1 + ELSE + IERROR = 23 + ENDIF ENDIF - IF ((DESCRA(1:1) .EQ. 'S' .OR. DESCRA(1:1) .EQ. 'H' .OR. - & DESCRA(1:1) .EQ. 'A') .AND. (UNITD .EQ. 'B')) THEN - IF (LWORK.LT.M) THEN - IF (LWORK.LE.0) THEN - EXIT=.TRUE. - ELSE - IERROR = 25 - ENDIF - WORK(1) = DBLE(M) - ENDIF + IF ((IDESCRA(1:1) .EQ. 'S' .OR. IDESCRA(1:1) .EQ. 'H' .OR. + & IDESCRA(1:1) .EQ. 'A') .AND. (toupper(UNITD) .EQ. 'B')) THEN + IF (LWORK.LT.M) THEN + IF (LWORK.LE.0) THEN + EXIT=.TRUE. + ELSE + IERROR = 25 + ENDIF + WORK(1) = DBLE(M) + ENDIF ELSE - IF (LWORK.LT.0) THEN - WORK(1) = 0.D0 - ENDIF + IF (LWORK.LT.0) THEN + WORK(1) = 0.D0 + ENDIF ENDIF C C Error handling C - IF(IERROR.NE.0) THEN - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - END IF + IF(IERROR.NE.0) THEN + CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) + GOTO 9999 + END IF IF (EXIT) goto 9998 C C Set DESCRN, IP1, IP2 C - DESCRN(1:3) = DESCRA(1:3) + DESCRN(1:3) = IDESCRA(1:3) IP1(1)=0 IP2(1)=0 @@ -258,38 +261,38 @@ C C Compute output matrix C DO 20 I = 1, M+1 - IAN2(I) = IA2(I) + IAN2(I) = IA2(I) 20 CONTINUE - IF ((DESCRA(1:1) .EQ. 'S' .OR. DESCRA(1:1) .EQ. 'H' .OR. - & DESCRA(1:1) .EQ. 'A') .AND. (UNITD .EQ. 'B')) THEN - DO 30 I = 1, M - WORK(I) = DBLE(DSQRT(ABS(D(I)))) - 30 CONTINUE - DO 40 I = 1, M - DO 50 J = IA2(I), IA2(I+1)-1 - AN(J) = WORK(I) * A(J) * WORK(IA1(J)) - IAN1(J) = IA1(J) - 50 CONTINUE - 40 CONTINUE - ELSE IF (UNITD .EQ. 'L') THEN - DO 60 I = 1, M - DO 70 J = IA2(I), IA2(I+1)-1 - AN(J) = D(I) * A(J) - IAN1(J) = IA1(J) - 70 CONTINUE - 60 CONTINUE - ELSE IF (UNITD .EQ. 'R') THEN - DO 80 I = 1, M - DO 90 J = IA2(I), IA2(I+1)-1 - AN(J) = A(J) * D(IA1(J)) - IAN1(J) = IA1(J) - 90 CONTINUE - 80 CONTINUE - ELSE IF (UNITD .EQ. 'U') THEN - DO 100 J = 1, IA2(M+1)-1 - AN(J) = A(J) + IF ((IDESCRA(1:1) .EQ. 'S' .OR. IDESCRA(1:1) .EQ. 'H' .OR. + & IDESCRA(1:1) .EQ. 'A') .AND. (toupper(UNITD) .EQ. 'B')) THEN + DO 30 I = 1, M + WORK(I) = DBLE(DSQRT(ABS(D(I)))) + 30 CONTINUE + DO 40 I = 1, M + DO 50 J = IA2(I), IA2(I+1)-1 + AN(J) = WORK(I) * A(J) * WORK(IA1(J)) + IAN1(J) = IA1(J) + 50 CONTINUE + 40 CONTINUE + ELSE IF (toupper(UNITD) .EQ. 'L') THEN + DO 60 I = 1, M + DO 70 J = IA2(I), IA2(I+1)-1 + AN(J) = D(I) * A(J) + IAN1(J) = IA1(J) + 70 CONTINUE + 60 CONTINUE + ELSE IF (toupper(UNITD) .EQ. 'R') THEN + DO 80 I = 1, M + DO 90 J = IA2(I), IA2(I+1)-1 + AN(J) = A(J) * D(IA1(J)) IAN1(J) = IA1(J) - 100 CONTINUE + 90 CONTINUE + 80 CONTINUE + ELSE IF (toupper(UNITD) .EQ. 'U') THEN + DO 100 J = 1, IA2(M+1)-1 + AN(J) = A(J) + IAN1(J) = IA1(J) + 100 CONTINUE ENDIF 9998 CONTINUE @@ -300,8 +303,8 @@ C CALL FCPSB_ERRACTIONRESTORE(ERR_ACT) IF ( ERR_ACT .NE. 0 ) THEN - CALL FCPSB_SERROR() - RETURN + CALL FCPSB_SERROR() + RETURN ENDIF RETURN diff --git a/base/serial/dp/zcrjd.f b/base/serial/dp/zcrjd.f index 735eb7f7f..cfc23775e 100644 --- a/base/serial/dp/zcrjd.f +++ b/base/serial/dp/zcrjd.f @@ -61,6 +61,7 @@ C IAN2,INFON, IP1, IP2 C use psb_const_mod use psb_spmat_type + use psb_string_mod IMPLICIT NONE C @@ -103,10 +104,10 @@ C GOTO 9999 ENDIF - IF (TRANS.EQ.'N') THEN + IF (toupper(TRANS).EQ.'N') THEN C NJA = 3*M - SCALE = (UNITD.EQ.'L') ! meaningless + SCALE = (toupper(UNITD).EQ.'L') ! meaningless IOFF = 5 C C SET THE VALUES OF POINTERS TO VECTOR IAN2 AND AUX @@ -115,7 +116,7 @@ C PIA = PNG + 1 PJA = PIA + 3*(M+2) - IF (DESCRA(1:1).EQ.'G') THEN + IF (toupper(DESCRA(1:1)).EQ.'G') THEN C C CHECK ON DIMENSION OF IAN2 AND AUX @@ -169,10 +170,11 @@ C ENDIF LJA = LIAN2-PJA - CALL ZGINDEX(M,IAN2(PNG),AR,IA1,IA2,ARN,IAN1,IAN2(PIA), - + IAN2(PJA), INFON, LARN,LIAN1, - + LJA,IP1, AUX, LAUX*2, SIZE_REQ,IERROR) - + CALL ZGINDEX(M,IAN2(PNG),AR,IA1,IA2,info, + + ARN,IAN1,IAN2(PIA), IAN2(PJA), INFON, + + LARN,LIAN1, LJA,IP1, + + AUX, LAUX*2, SIZE_REQ,IERROR) + IF (IERROR.NE.0) THEN CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) GOTO 9999 @@ -182,7 +184,8 @@ C DESCRN(2:2) = 'U' DESCRN(3:3) = 'N' - ELSE IF (DESCRA(1:1).EQ.'S' .AND. DESCRA(2:2).EQ.'U') THEN + ELSE IF (toupper(DESCRA(1:1)).EQ.'S' .AND. + + toupper(DESCRA(2:2)).EQ.'U') THEN C ISTROW = 1 NZ = 2*(IA2(M+1)-1) - M @@ -218,13 +221,13 @@ c$$$ CALL DVSMR(M,AR,IA1,IA2,IAN2(PNG),AUX(IWLEN),IP1,IP2, c$$$ * IAN2(PIA),IAN2(PJA),IAN1,ARN,AUX(IWORK1), c$$$ * AUX(IWORK2),NJA,IER,SCALE) C - ELSE IF (DESCRA(1:1).EQ.'T') THEN + ELSE IF (toupper(DESCRA(1:1)).EQ.'T') THEN C C Only unit diagonal so far for triangular matrices. C - IF (DESCRA(3:3).NE.'U') THEN + IF (toupper(DESCRA(3:3)).NE.'U') THEN IERROR=3022 CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) GOTO 9999 @@ -273,8 +276,7 @@ c$$$ write(0,*) "error 2",ierrv(1) ENDIF DESCRN(1:1) = 'T' - DESCRN(2:2) = DESCRA(2:2) - DESCRN(3:3) = DESCRA(3:3) + DESCRN(2:3) = toupper(DESCRA(2:3)) END IF C @@ -288,7 +290,7 @@ C LIAN2 = 3*M + 10 LAUX2 = 4*M + 2 C - ELSE IF (TRANS.NE.'N') THEN + ELSE IF (toupper(TRANS).NE.'N') THEN C C TO BE DONE C diff --git a/base/serial/dp/zgindex.f b/base/serial/dp/zgindex.f index 9f49d5e8a..d7bd6e5b5 100644 --- a/base/serial/dp/zgindex.f +++ b/base/serial/dp/zgindex.f @@ -28,7 +28,7 @@ C ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE C POSSIBILITY OF SUCH DAMAGE. C C - SUBROUTINE ZGINDEX(M,N_BLOCKS,A,IA1,IA2,ARN,KA,IA,JA, INFON, + SUBROUTINE ZGINDEX(M,N_BLOCKS,A,IA1,IA2,infoa,ARN,KA,IA,JA, INFON, + LARN,LKA,LJA,IPERM,WORK, LWORK, SIZE_REQ, IERROR) use psb_const_mod @@ -43,12 +43,12 @@ C ... Array arguments ... complex(kind(1.d0)) A(*), ARN(*) INTEGER IA1(*), IA2(*), KA(*), - + IA(3,*), IPERM(*), JA(*), WORK(*),INFON(*) + + IA(3,*), IPERM(*), JA(*), WORK(*),INFON(*), infoa(*) C .... Local scalars ... INTEGER I, J, BLOCK, ROW, COL, POINT_AR, POINT_JA, IP1, + IP2, IPX, NNZ, DIM_BLOCK, LIMIT, IPW,COUNT, IPC,CHECK_FLAG, - + ERR_ACT + + ERR_ACT, ix, regen_flag LOGICAL CSR c .. Local Arrays .. CHARACTER*20 NAME @@ -61,6 +61,8 @@ c .. Local Arrays .. POINT_AR = 1 POINT_JA = 0 call psb_getifield(check_flag,psb_dupl_,infon,psb_ifasize_,ierror) + call psb_getifield(regen_flag,psb_upd_,infon,psb_ifasize_,ierror) + IF ((LARN.LT.POINT_AR).OR.(LKA.LT.POINT_AR)) THEN IERROR = 60 @@ -71,8 +73,8 @@ c .. Local Arrays .. GOTO 9999 ENDIF - NNZ = IA2(M + 1) - 1 - COUNT = 0 + NNZ = IA2(M + 1) - 1 + COUNT = 0 C .... Invert Permutation Matrix... IF (IPERM(1).NE.0) THEN @@ -81,7 +83,9 @@ C .... Invert Permutation Matrix... ENDDO ENDIF - IF ( (LKA .GE.( SIZE_REQ )) + size_Req=0 + + IF ( (regen_flag == psb_upd_perm_) + .AND. (LWORK .GE. (M + NNZ+2))) THEN C C Prepare for smart regeneration @@ -98,19 +102,25 @@ C KA(IP1+PSB_NNZT_) = NNZ KA(IP1+PSB_NNZ_) = 0 KA(IP1+PSB_ICHK_) = NNZ+CHECK_FLAG - I = M+2 - IPX = IA2(I+PSB_IP2_) + if (infoa(psb_upd_pnt_) > 0) then + I = infoa(psb_upd_pnt_) + IPX = IA2(I+PSB_IP2_) C Invert permutation for smart regeneration - - DO I = 1, NNZ - WORK(IPW + IA2(IPX + I -1) - 1) = I - ENDDO - + + DO I = 1, NNZ + WORK(IPW + IA2(IPX + I -1) - 1) = I + ENDDO + else + ! No permutation available before, set identity. + DO I = 1, NNZ + WORK(IPW + I - 1) = I + ENDDO + endif C Construct JAD matrix... DO BLOCK = 1, N_BLOCKS - COL = 1 + COL = 1 DIM_BLOCK = IA(1,BLOCK+1)-IA(1,BLOCK) c$$$ write(0,*) 'ZGINDEX: BLOCK LOOP ',block,n_blocks,dim_block if (dim_block .gt. PSB_MAXJDROWS_) then @@ -270,9 +280,19 @@ C ... For each nnzero elements belonging to current row ... ENDDO ENDDO + IA(2,N_BLOCKS+1) = POINT_JA + KA(IP1 + PSB_ZERO_) = COUNT + + IF (POINT_AR.GE.IP1) THEN + SIZE_REQ=NNZ+COUNT + ELSE + SIZE_REQ=0 + ENDIF ELSE c$$$ c write(*,*)'inizio a ciclare sui blocchi' + IP1 = LKA - PSB_ZERO_ + DO BLOCK = 1, N_BLOCKS COL = 1 DIM_BLOCK = IA(1,BLOCK+1)-IA(1,BLOCK) @@ -415,16 +435,15 @@ C ... For each nnzero elements belonging to current row ... + IA(2,N_BLOCKS+1) = POINT_JA + IF (POINT_AR.GE.lka) THEN + SIZE_REQ=NNZ+COUNT + ELSE + SIZE_REQ=0 + ENDIF ENDIF - IA(2,N_BLOCKS+1) = POINT_JA - KA(IP1 + PSB_ZERO_) = COUNT - IF(POINT_AR.GE.IP1) THEN - SIZE_REQ=NNZ+COUNT - ELSE - SIZE_REQ=0 - ENDIF infon(1)=point_ar-1 CALL FCPSB_ERRACTIONRESTORE(ERR_ACT) diff --git a/base/serial/psb_cest.f90 b/base/serial/psb_cest.f90 index efce9e15a..e518fcb8f 100644 --- a/base/serial/psb_cest.f90 +++ b/base/serial/psb_cest.f90 @@ -28,19 +28,20 @@ !!$ POSSIBILITY OF SUCH DAMAGE. !!$ !!$ -subroutine psb_cest(afmt, m,n,nnz, lia1, lia2, lar, iup, info) +subroutine psb_cest(afmt,m,n,nnz, lia1, lia2, lar, iup,info) use psb_error_mod use psb_const_mod use psb_string_mod use psb_spmat_type + implicit none ! .. scalar arguments .. integer, intent(in) :: m,n,nnz,iup integer, intent(out) :: lia1, lia2, lar, info + character(len=*), intent(inout) :: afmt ! .. array arguments.. - character(len=5) :: afmt integer :: int_val(5), err_act character(len=20) :: name @@ -50,18 +51,20 @@ subroutine psb_cest(afmt, m,n,nnz, lia1, lia2, lar, iup, info) if (afmt == '???') then afmt = psb_fidef_ endif + + afmt = toupper(afmt) select case(iup) case (psb_upd_perm_) - if (toupper(afmt) == 'JAD') then - lia1 = 2*(nnz + nnz/5) +1000 - lia2 = 2*(nnz + nnz/5) +1000 +m - lar = nnz + nnz/5 - else if (toupper(afmt) == 'COO') then + if (afmt == 'JAD') then + lia1 = 2*(nnz) + 1000 + lia2 = (3*nnz)/2 + 1000 + m + lar = (3*nnz)/2 + else if (afmt == 'COO') then lia1 = nnz lia2 = 2*nnz + 1000 lar = nnz - else if(toupper(afmt) == 'CSR') then + else if(afmt == 'CSR') then lia1 = nnz lia2 = 2*nnz + 1000 + m + 1 lar = nnz @@ -71,17 +74,17 @@ subroutine psb_cest(afmt, m,n,nnz, lia1, lia2, lar, iup, info) goto 9999 endif - case (psb_upd_dflt_, psb_upd_srch_) + case (psb_upd_srch_) - if (toupper(afmt) == 'JAD') then - lia1 = nnz + nnz/5 - lia2 = nnz + nnz/5 - lar = nnz + nnz/5 - else if (toupper(afmt) == 'COO') then + if (afmt == 'JAD') then + lia1 = (3*nnz)/2 + lia2 = (3*nnz)/2 + lar = (3*nnz)/2 + else if (afmt == 'COO') then lia1 = nnz lia2 = nnz lar = nnz - else if(toupper(afmt) == 'CSR') then + else if(afmt == 'CSR') then lia1 = nnz lia2 = max(nnz,m+1) lar = nnz diff --git a/base/serial/psb_dcoins.f90 b/base/serial/psb_dcoins.f90 index 319e247fe..055401398 100644 --- a/base/serial/psb_dcoins.f90 +++ b/base/serial/psb_dcoins.f90 @@ -38,7 +38,7 @@ subroutine psb_dcoins(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl,rebuild) use psb_realloc_mod use psb_string_mod use psb_error_mod - use psb_serial_mod, only : psb_csdp + use psb_serial_mod, psb_protect_name => psb_dcoins use psb_update_mod implicit none @@ -156,8 +156,12 @@ subroutine psb_dcoins(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl,rebuild) case (psb_upd_perm_) ip1 = psb_sp_getifld(psb_upd_pnt_,a,info) nzl = psb_sp_getifld(psb_del_bnd_,a,info) - nza = a%ia2(ip1+psb_nnz_) - + select case(ufida) + case ('JAD') + nza = a%ia1(ip1+psb_nnz_) + case default + nza = a%ia2(ip1+psb_nnz_) + end select call psb_inner_upd(nz,ia,ja,val,nza,a%aspk,size(a%aspk),& & imin,imax,jmin,jmax,nzl,info,gtl,ng) @@ -172,11 +176,17 @@ subroutine psb_dcoins(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl,rebuild) write(0,*) 'PSB_COINS: update discarded items ' end if end if - a%ia2(ip1+psb_nnz_) = nza + + select case(ufida) + case ('JAD') + a%ia1(ip1+psb_nnz_) = nza + case default + a%ia2(ip1+psb_nnz_) = nza + end select if (debug) write(0,*) 'From COINS(UPD) : NZA:',nza - case (psb_upd_dflt_, psb_upd_srch_) + case (psb_upd_srch_) call psb_srch_upd(nz,ia,ja,val,nza,a,& & imin,imax,jmin,jmax,nzl,info,gtl,ng) @@ -187,8 +197,7 @@ subroutine psb_dcoins(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl,rebuild) & 'COINS: Going through rebuild_ fingers crossed!' irst = info call psb_nullify_sp(tmp) - tmp%fida='COO' - call psb_csdp(a,tmp,info) + call psb_spcnv(a,tmp,info,afmt='coo') if(info /= izero) then info=4010 ch_err='psb_csdp' @@ -349,7 +358,7 @@ subroutine psb_dcoins(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl,rebuild) if (debug) write(0,*) 'From COINS(UPD) : NZA:',nza - case (psb_upd_dflt_, psb_upd_srch_) + case (psb_upd_srch_) call psb_srch_upd(nz,ia,ja,val,nza,a,& & imin,imax,jmin,jmax,nzl,info) @@ -360,8 +369,7 @@ subroutine psb_dcoins(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl,rebuild) & 'COINS: Going through rebuild_ fingers crossed!' irst = info call psb_nullify_sp(tmp) - tmp%fida='COO' - call psb_csdp(a,tmp,info) + call psb_spcnv(a,tmp,info,afmt='coo') call psb_sp_setifld(psb_spmat_bld_,psb_state_,tmp,info) if (debug) then write(0,*) 'COINS Rebuild: size',tmp%infoa(psb_nnz_) ,irst @@ -429,7 +437,6 @@ subroutine psb_dcoins(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl,rebuild) endif - return call psb_erractionrestore(err_act) return diff --git a/base/serial/psb_dcsdp.f90 b/base/serial/psb_dcsdp.f90 deleted file mode 100644 index 6200af3f8..000000000 --- a/base/serial/psb_dcsdp.f90 +++ /dev/null @@ -1,515 +0,0 @@ -!!$ -!!$ Parallel Sparse BLAS v2.0 -!!$ (C) Copyright 2006 Salvatore Filippone University of Rome Tor Vergata -!!$ Alfredo Buttari University of Rome Tor Vergata -!!$ -!!$ Redistribution and use in source and binary forms, with or without -!!$ modification, are permitted provided that the following conditions -!!$ are met: -!!$ 1. Redistributions of source code must retain the above copyright -!!$ notice, this list of conditions and the following disclaimer. -!!$ 2. Redistributions in binary form must reproduce the above copyright -!!$ notice, this list of conditions, and the following disclaimer in the -!!$ documentation and/or other materials provided with the distribution. -!!$ 3. The name of the PSBLAS group or the names of its contributors may -!!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. -!!$ -!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -!!$ POSSIBILITY OF SUCH DAMAGE. -!!$ -!!$ -! File: psb_dcsdp.f90 -! -! Subroutine: psb_dcsdp -! This subroutine performs the assembly of -! the local part of a sparse distributed matrix -! -! Parameters: -! a - type(). The input matrix to be assembled. -! b - type(). The assembled output matrix. -! info - integer. Eventually returns an error code. -! ifc - integer(optional). ??? -! check - character(optional). ??? -! trans - character(optional). ??? -! unitd - character(optional). ??? -! -subroutine psb_dcsdp(a, b,info,ifc,check,trans,unitd,upd,dupl) - use psb_const_mod - use psb_error_mod - use psb_spmat_type - use psb_string_mod - use psb_serial_mod, psb_protect_name => psb_dcsdp - implicit none - !....Parameters... - Type(psb_dspmat_type), intent(in) :: A - Type(psb_dspmat_type), intent(inout) :: B - Integer, intent(out) :: info - Integer, intent(in), optional :: ifc,upd,dupl - character, intent(in), optional :: check,trans,unitd - - !...Locals... - real(kind(1.d0)) :: d(1) - real(kind(1.d0)), allocatable :: work(:) - type(psb_dspmat_type) :: temp_a - Integer :: nzr, ntry, ifc_, ia1_size,& - & ia2_size, aspk_size,size_req,n_row,n_col,upd_,dupl_ - integer :: ip1, ip2, nnz, iflag, ichk, nnzt,& - & ipc, i, count, err_act, i1, i2, ia - character :: check_,trans_,unitd_ - Integer, Parameter :: maxtry=8 - logical, parameter :: debug=.false. - character(len=20) :: name, ch_err - - name='psb_csdp' - info = 0 - call psb_erractionsave(err_act) - - ntry=0 - if (present(ifc)) then - ifc_ = max(1,ifc) - else - ifc_ = 1 - endif - if (present(check)) then - check_ = toupper(check) - else - check_ = 'N' - endif - if (present(trans)) then - trans_ = toupper(trans) - else - trans_ = 'N' - endif - if (present(unitd)) then - unitd_ = toupper(unitd) - else - unitd_ = 'U' - endif - - - if (check_=='R') then - allocate(work(max(size(a%aspk),size(b%aspk))+1000),stat=info) - else - allocate(work(max(size(a%ia1),size(a%ia2))+max(a%m,b%m)+1000),stat=info) - endif - - if (info /= 0) then - info=2040 - call psb_errpush(info,name) - goto 9999 - end if - if (ifc_<1) then - write(0,*) 'csdp90 Error: invalid ifc ',ifc_ - info = -4 - call psb_errpush(info,name) - goto 9999 - endif - - if((check_=='Y').or.(check_=='C')) then - if(toupper(a%fida(1:3))=='CSR') then - call dcsrck(trans,a%m,a%k,a%descra,a%aspk,a%ia1,a%ia2,work,size(work),info) - if(info /= 0) then - info=4010 - ch_err='dcsrck' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - - else - write(0,'("Check not yet suported for the ",a3," storage format")')a%fida(1:3) - end if - - end if - - if (check_/='R') then - - if (present(upd)) then - call psb_sp_setifld(upd,psb_upd_,b,info) - end if - if (present(dupl)) then - call psb_sp_setifld(dupl,psb_dupl_,b,info) - end if - - upd_ = psb_sp_getifld(psb_upd_,b,info) - select case(upd_) - case(psb_upd_dflt_,psb_upd_srch_,psb_upd_perm_) - ! Legal value, do nothing - case default - ! Fix bad value - upd_ = psb_upd_dflt_ - call psb_sp_setifld(upd_,psb_upd_,b,info) - end select - dupl_ = psb_sp_getifld(psb_dupl_,b,info) - select case(dupl_) - case(psb_dupl_ovwrt_,psb_dupl_add_,psb_dupl_err_) - ! Legal value, do nothing - case default - ! Fix bad value - dupl_ = psb_dupl_def_ - call psb_sp_setifld(dupl_,psb_dupl_,b,info) - end select - - ! ...matrix conversion... - b%m=a%m - b%k=a%k - size_req = psb_sp_get_nnzeros(a) - if (debug) write(0,*) 'DCSDP : size_req 1:',size_req - ! - - n_row=b%m - n_col=b%k - call psb_cest(b%fida, n_row,n_col,size_req,& - & ia1_size, ia2_size, aspk_size, upd_,info) - - if (info /= psb_no_err_) then - info=4010 - ch_err='psb_cest' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - endif - if (.not.allocated(b%aspk).or.& - &.not.allocated(b%ia1).or.& - &.not.allocated(b%ia2).or.& - &.not.allocated(b%pl).or.& - &.not.allocated(b%pr)) then - call psb_sp_reall(b,ia1_size,ia2_size,aspk_size,info) - else if ((size(b%aspk) < aspk_size) .or.& - &(size(b%ia1) < ia1_size) .or.& - &(size(b%ia2) < ia2_size) .or.& - &(size(b%pl) < b%m) .or.& - &(size(b%pr) < b%k )) then - call psb_sp_reall(b,ia1_size,ia2_size,aspk_size,info) - endif - - if (info /= psb_no_err_) then - info=4010 - ch_err='psb_sp_reall' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - endif - - b%pl(:) = 0 - b%pr(:) = 0 - - b%descra = a%descra - - select case (toupper(a%fida(1:3))) - - case ('CSR') - - select case (toupper(b%fida(1:3))) - - case ('CSR') - - call dcrcr(trans_, a%m, a%k, unitd_, d, a%descra, a%aspk,& - & a%ia1, a%ia2, a%infoa, b%pl, b%descra, b%aspk, b%ia1,& - & b%ia2, b%infoa, b%pr, size(b%aspk), size(b%ia1),& - & size(b%ia2), work, size(work), info) - - - if (info/=0) then - info=4010 - ch_err='dcrcr' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - - case ('JAD') - - !...converting to JAD - !...output matrix may not be big enough - do - - call dcrjd(trans_, a%m, a%k, unitd_, d, a%descra, a%aspk,& - & a%ia1, a%ia2, a%infoa, b%pl, b%descra, b%aspk, b%ia1,& - & b%ia2, b%infoa, b%pr, size(b%aspk), size(b%ia1),& - & size(b%ia2), work, size(work), nzr, info) - if (info /= 0) then - call psb_errpush(4010,name,a_err='dcrjd') - goto 9999 - endif - - ntry = ntry + 1 - if (debug) then - write(0,*) 'On out from dcrjad ',nzr,info - end if - if (nzr == 0) exit - if (ntry > maxtry ) then - write(0,*) 'Tried reallocating for DCRJAD for ',maxtry,': giving up now.' - info=2040 - call psb_errpush(info,name) - goto 9999 - endif - - call psb_sp_reall(b,nzr,info,ifc=ifc_) - if (info /= 0) then - info=2040 - call psb_errpush(info,name) - goto 9999 - endif - - end do - - if (info/=0) then - call psb_errpush(info,name) - goto 9999 - end if - - case ('COO') - if (debug) write(0,*) 'Calling CRCO ',a%descra - call dcrco(trans_, a%m, a%k, unitd_, d, a%descra, a%aspk,& - & a%ia1, a%ia2, a%infoa, b%pl, b%descra, b%aspk, b%ia1,& - & b%ia2, b%infoa, b%pr, size(b%aspk), size(b%ia1),& - & size(b%ia2), work, size(work), info) - - if (info/=0) then - call psb_errpush(4010,name,a_err='dcrco') - goto 9999 - end if - case default - info=4010 - call psb_errpush(info,name) - goto 9999 - - end select - - case ('COO','COI') - - select case (toupper(b%fida(1:3))) - - case ('CSR') - - call dcocr(trans_, a%m, a%k, unitd_, d, a%descra, a%aspk,& - & a%ia2, a%ia1, a%infoa, b%pl, b%descra, b%aspk, b%ia1,& - & b%ia2, b%infoa, b%pr, size(b%aspk), size(b%ia1),& - & size(b%ia2), work, 2*size(work), info) - - if (info/=0) then - call psb_errpush(4010,name,a_err='dcocr') - goto 9999 - end if - - case ('JAD') - - call psb_sp_all(temp_a, size(b%ia1),size(b%ia2),size(b%aspk),info) - if (info /= 0) then - info=2040 - call psb_errpush(info,name) - goto 9999 - endif - temp_a%m = a%m - temp_a%k = a%k - - !...Dirty trick: converting to CSR and then to JAD - - call dcocr(trans_, a%m, a%k, unitd_, d, a%descra, a%aspk,& - & a%ia2, a%ia1, a%infoa, temp_a%pl, temp_a%descra, & - & temp_a%aspk, temp_a%ia1, temp_a%ia2, temp_a%infoa, temp_a%pr, & - & size(temp_a%aspk), size(temp_a%ia1),& - & size(temp_a%ia2), work, 2*size(work), info) - - if (info/=0) then - call psb_errpush(4010,name,a_err='dcocr') - goto 9999 - end if - - do - call dcrjd(trans_, temp_a%m, temp_a%k, unitd_, d, temp_a%descra, & - & temp_a%aspk, temp_a%ia1, temp_a%ia2, temp_a%infoa, & - & b%pl, b%descra, b%aspk, b%ia1, b%ia2, b%infoa, b%pr, & - & size(b%aspk), size(b%ia1),& - & size(b%ia2), work, size(work), nzr, info) - if (info/=0) then - call psb_errpush(4010,name,a_err='dcrjd') - goto 9999 - end if - - ntry = ntry + 1 - if (debug) then - write(0,*) 'On out from dcrjad ',nzr,info - end if - if (nzr == 0) exit - if (ntry > maxtry ) then - write(0,*) 'Tried reallocating for DCRJAD for ',maxtry,& - & ': giving up now.' - info=2040 - call psb_errpush(info,name) - goto 9999 - endif - - call psb_sp_reall(b,nzr,info,ifc=ifc_) - if (info /= 0) then - info=2040 - call psb_errpush(info,name) - goto 9999 - endif - - end do - - case ('COO') - - call dcoco(trans_, a%m, a%k, unitd_, d, a%descra, a%aspk,& - & a%ia1, a%ia2, a%infoa, b%pl, b%descra, b%aspk, b%ia1,& - & b%ia2, b%infoa, b%pr, size(b%aspk), size(b%ia1),& - & size(b%ia2), work, 2*size(work), info) - if (info/=0) then - call psb_errpush(4010,name,a_err='dcoco') - goto 9999 - end if - - case default - info=4010 - call psb_errpush(info,name) - goto 9999 - end select - - case default - info=4010 - call psb_errpush(info,name) - goto 9999 - - end select - - if (psb_sp_getifld(psb_upd_,b,info) /= psb_upd_perm_) & - & call psb_sp_trim(b,info) - - else if (check_=='R') then - - !...Regenerating matrix - - if (psb_sp_getifld(psb_state_,b,info) /= psb_spmat_upd_) then - info = 8888 - call psb_errpush(info,name) - goto 9999 - endif - - ! - ! dupl_ and upd_ fields should not be changed. - ! - select case(psb_sp_getifld(psb_upd_,b,info)) - - case(psb_upd_perm_) - if (debug) write(0,*) 'Regeneration with psb_upd_perm_' - if (toupper(b%fida(1:3))/='JAD') then - ip1 = psb_sp_getifld(psb_upd_pnt_,b,info) - ip2 = b%ia2(ip1+psb_ip2_) - nnz = b%ia2(ip1+psb_nnz_) - iflag = b%ia2(ip1+psb_iflag_) - ichk = b%ia2(ip1+psb_ichk_) - nnzt = b%ia2(ip1+psb_nnzt_) - if (debug) write(*,*) 'Regeneration start: ',& - & b%infoa(psb_upd_),psb_upd_perm_,nnz,nnzt ,iflag,info - - if ((ichk/=nnzt+iflag).or.(nnz/=nnzt)) then - info = 8889 - write(*,*) 'Regeneration start error: ',& - & b%infoa(psb_upd_),psb_upd_perm_,nnz,nnzt ,iflag,ichk - call psb_errpush(info,name) - goto 9999 - endif - do i= 1, nnz - work(i) = 0.d0 - enddo - select case(iflag) - case(psb_dupl_ovwrt_,psb_dupl_err_) - do i=1, nnz - work(b%ia2(ip2+i-1)) = b%aspk(i) - enddo - case(psb_dupl_add_) - do i=1, nnz - work(b%ia2(ip2+i-1)) = b%aspk(i) + work(b%ia2(ip2+i-1)) - enddo - case default - info = 8887 - call psb_errpush(info,name) - goto 9999 - end select - - do i=1, nnz - b%aspk(i) = work(i) - enddo - - else if (toupper(b%fida(1:3)) == 'JAD') then - - - ip1 = psb_sp_getifld(psb_upd_pnt_,b,info) - ip2 = b%ia1(ip1+psb_ip2_) - count = b%ia1(ip1+psb_zero_) - ipc = b%ia1(ip1+psb_ipc_) - nnz = b%ia1(ip1+psb_nnz_) - iflag = b%ia1(ip1+psb_iflag_) - ichk = b%ia1(ip1+psb_ichk_) - nnzt = b%ia1(ip1+psb_nnzt_) - if (debug) write(*,*) 'Regeneration start: ',& - & b%infoa(psb_upd_),psb_upd_perm_,nnz,nnzt,count, & - & iflag,info - - if ((ichk/=nnzt+iflag).or.(nnz/=nnzt)) then - info = 10 - write(*,*) 'Regeneration start error: ',& - & b%infoa(psb_upd_),psb_upd_perm_,nnz,nnzt ,iflag,ichk - call psb_errpush(info,name) - goto 9999 - endif - - do i= 1, nnz+count - work(i) = 0.d0 - enddo - select case(iflag) - case(psb_dupl_ovwrt_,psb_dupl_err_) - do i=1, nnz - work(b%ia1(ip2+i-1)) = b%aspk(i) - enddo - case(psb_dupl_add_) - do i=1, nnz - work(b%ia1(ip2+i-1)) = b%aspk(i) + work(b%ia1(ip2+i-1)) - enddo - case default - info = 8887 - call psb_errpush(info,name) - goto 9999 - end select - - do i=1, nnz+count - b%aspk(i) = work(i) - enddo - do i=1, count - b%aspk(b%ia1(ipc+i-1)) = 0.d0 - end do - endif - - case(psb_upd_dflt_,psb_upd_srch_) - ! Nothing to be done here. - if (debug) write(0,*) 'Going through on regeneration with psb_upd_srch_' - case default - ! Wrong value - info = 8888 - call psb_errpush(info,name) - goto 9999 - - end select - end if - call psb_sp_setifld(psb_spmat_asb_,psb_state_,b,info) - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - if (err_act.eq.psb_act_abort_) then - call psb_error() - return - end if - return - -end subroutine psb_dcsdp diff --git a/base/serial/psb_dfixcoo.f90 b/base/serial/psb_dfixcoo.f90 index a0488f241..653fbe85b 100644 --- a/base/serial/psb_dfixcoo.f90 +++ b/base/serial/psb_dfixcoo.f90 @@ -32,10 +32,12 @@ ! Subroutine: ! Parameters: -Subroutine psb_dfixcoo(A,INFO,idir) +subroutine psb_dfixcoo(a,info,idir) use psb_spmat_type use psb_const_mod use psb_string_mod + use psb_serial_mod, psb_protect_name => psb_dfixcoo + use psb_error_mod implicit none !....Parameters... @@ -45,11 +47,14 @@ Subroutine psb_dfixcoo(A,INFO,idir) integer, allocatable :: iaux(:) !locals - Integer :: nza, nzl,iret,idir_ - integer :: i,j, irw, icl + Integer :: nza, nzl,iret,idir_, dupl_ + integer :: i,j, irw, icl, err_act logical, parameter :: debug=.false. + character(len=20) :: name = 'psb_fixcoo' info = 0 + call psb_erractionsave(err_act) + if(debug) write(0,*)'fixcoo: ',size(a%ia1),size(a%ia2) if (toupper(a%fida) /= 'COO') then write(0,*) 'Fixcoo Invalid input ',a%fida @@ -62,9 +67,11 @@ Subroutine psb_dfixcoo(A,INFO,idir) idir_ = 0 endif - nza = a%infoa(psb_nnz_) + nza = psb_sp_getifld(psb_nnz_,a,info) if (nza < 2) return + dupl_ = psb_sp_getifld(psb_dupl_,a,info) + allocate(iaux(nza+2),stat=info) if (info /= 0) return @@ -92,22 +99,61 @@ Subroutine psb_dfixcoo(A,INFO,idir) irw = a%ia1(i) icl = a%ia2(i) j = 1 - do - j = j + 1 - if (j > nza) exit - if ((a%ia1(j) == irw).and.(a%ia2(j) == icl)) then - a%aspk(i) = a%aspk(i) + a%aspk(j) - else - i = i+1 - a%aspk(i) = a%aspk(j) - a%ia1(i) = a%ia1(j) - a%ia2(i) = a%ia2(j) - irw = a%ia1(i) - icl = a%ia2(i) - endif - enddo - a%infoa(psb_nnz_) = i - a%infoa(psb_srtd_) = psb_isrtdcoo_ + + select case(dupl_) + case(psb_dupl_ovwrt_) + + do + j = j + 1 + if (j > nza) exit + if ((a%ia1(j) == irw).and.(a%ia2(j) == icl)) then + a%aspk(i) = a%aspk(j) + else + i = i+1 + a%aspk(i) = a%aspk(j) + a%ia1(i) = a%ia1(j) + a%ia2(i) = a%ia2(j) + irw = a%ia1(i) + icl = a%ia2(i) + endif + enddo + + case(psb_dupl_add_) + + do + j = j + 1 + if (j > nza) exit + if ((a%ia1(j) == irw).and.(a%ia2(j) == icl)) then + a%aspk(i) = a%aspk(i) + a%aspk(j) + else + i = i+1 + a%aspk(i) = a%aspk(j) + a%ia1(i) = a%ia1(j) + a%ia2(i) = a%ia2(j) + irw = a%ia1(i) + icl = a%ia2(i) + endif + enddo + + case(psb_dupl_err_) + do + j = j + 1 + if (j > nza) exit + if ((a%ia1(j) == irw).and.(a%ia2(j) == icl)) then + call psb_errpush(130,name) + goto 9999 + else + i = i+1 + a%aspk(i) = a%aspk(j) + a%ia1(i) = a%ia1(j) + a%ia2(i) = a%ia2(j) + irw = a%ia1(i) + icl = a%ia2(i) + endif + enddo + + end select + if(debug) write(0,*)'FIXCOO: end second loop' @@ -133,28 +179,79 @@ Subroutine psb_dfixcoo(A,INFO,idir) irw = a%ia1(i) icl = a%ia2(i) j = 1 - do - j = j + 1 - if (j > nza) exit - if ((a%ia1(j) == irw).and.(a%ia2(j) == icl)) then - a%aspk(i) = a%aspk(i) + a%aspk(j) - else - i = i+1 - a%aspk(i) = a%aspk(j) - a%ia1(i) = a%ia1(j) - a%ia2(i) = a%ia2(j) - irw = a%ia1(i) - icl = a%ia2(i) - endif - enddo - a%infoa(psb_nnz_) = i - a%infoa(psb_srtd_) = psb_isrtdcoo_ + + select case(dupl_) + case(psb_dupl_ovwrt_) + do + j = j + 1 + if (j > nza) exit + if ((a%ia1(j) == irw).and.(a%ia2(j) == icl)) then + a%aspk(i) = a%aspk(j) + else + i = i+1 + a%aspk(i) = a%aspk(j) + a%ia1(i) = a%ia1(j) + a%ia2(i) = a%ia2(j) + irw = a%ia1(i) + icl = a%ia2(i) + endif + enddo + + case(psb_dupl_add_) + do + j = j + 1 + if (j > nza) exit + if ((a%ia1(j) == irw).and.(a%ia2(j) == icl)) then + a%aspk(i) = a%aspk(i) + a%aspk(j) + else + i = i+1 + a%aspk(i) = a%aspk(j) + a%ia1(i) = a%ia1(j) + a%ia2(i) = a%ia2(j) + irw = a%ia1(i) + icl = a%ia2(i) + endif + enddo + + case(psb_dupl_err_) + do + j = j + 1 + if (j > nza) exit + if ((a%ia1(j) == irw).and.(a%ia2(j) == icl)) then + call psb_errpush(130,name) + goto 9999 + else + i = i+1 + a%aspk(i) = a%aspk(j) + a%ia1(i) = a%ia1(j) + a%ia2(i) = a%ia2(j) + irw = a%ia1(i) + icl = a%ia2(i) + endif + enddo + end select if(debug) write(0,*)'FIXCOO: end second loop' case default write(0,*) 'Fixcoo: unknown direction ',idir_ end select - a%infoa(psb_upd_) = psb_upd_srch_ + + call psb_sp_setifld(psb_isrtdcoo_,psb_srtd_,a,info) + call psb_sp_setifld(i,psb_nnz_,a,info) + call psb_sp_setifld(psb_spmat_asb_,psb_state_,a,info) + call psb_sp_setifld(psb_upd_srch_,psb_upd_,a,info) + deallocate(iaux) + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act.eq.psb_act_abort_) then + call psb_error() + return + end if return + end Subroutine psb_dfixcoo diff --git a/base/serial/psb_dipcoo2csc.f90 b/base/serial/psb_dipcoo2csc.f90 index 34e96f432..2ddb1ccd7 100644 --- a/base/serial/psb_dipcoo2csc.f90 +++ b/base/serial/psb_dipcoo2csc.f90 @@ -35,7 +35,7 @@ subroutine psb_dipcoo2csc(a,info,clshr) use psb_spmat_type use psb_const_mod - use psb_serial_mod, only : psb_fixcoo + use psb_serial_mod, psb_protect_name => psb_dipcoo2csc use psb_error_mod use psb_string_mod use psb_realloc_mod diff --git a/base/serial/psb_dipcoo2csr.f90 b/base/serial/psb_dipcoo2csr.f90 index 50fbea8e3..f596b2710 100644 --- a/base/serial/psb_dipcoo2csr.f90 +++ b/base/serial/psb_dipcoo2csr.f90 @@ -36,7 +36,7 @@ subroutine psb_dipcoo2csr(a,info,rwshr) use psb_spmat_type use psb_const_mod use psb_realloc_mod - use psb_serial_mod, only : psb_fixcoo + use psb_serial_mod, psb_protect_name => psb_dipcoo2csr use psb_error_mod use psb_string_mod implicit none diff --git a/base/serial/psb_dipcsr2coo.f90 b/base/serial/psb_dipcsr2coo.f90 index c71571ced..792a96220 100644 --- a/base/serial/psb_dipcsr2coo.f90 +++ b/base/serial/psb_dipcsr2coo.f90 @@ -38,6 +38,7 @@ Subroutine psb_dipcsr2coo(a,info) use psb_error_mod use psb_string_mod use psb_realloc_mod + use psb_serial_mod, psb_protect_name => psb_dipcsr2coo implicit none !....Parameters... @@ -86,6 +87,7 @@ Subroutine psb_dipcsr2coo(a,info) a%infoa(psb_upd_) = psb_upd_srch_ deallocate(itemp) + call psb_fixcoo(a,info) call psb_erractionrestore(err_act) return diff --git a/base/serial/psb_dnumbmm.f90 b/base/serial/psb_dnumbmm.f90 index a71abee0f..fb7f261e4 100644 --- a/base/serial/psb_dnumbmm.f90 +++ b/base/serial/psb_dnumbmm.f90 @@ -71,6 +71,7 @@ subroutine psb_dnumbmm(a,b,c) write(0,*) 'Error ',info,' from inner numbmm' end if end if + call psb_sp_setifld(psb_spmat_asb_,psb_state_,c,info) deallocate(temp) return diff --git a/base/serial/psb_drwextd.f90 b/base/serial/psb_drwextd.f90 index 21b434377..05a1e5a8b 100644 --- a/base/serial/psb_drwextd.f90 +++ b/base/serial/psb_drwextd.f90 @@ -41,6 +41,7 @@ subroutine psb_drwextd(nr,a,info,b,rowscale) use psb_spmat_type use psb_error_mod use psb_string_mod + use psb_serial_mod, psb_protect_name => psb_drwextd implicit none ! Extend matrix A up to NR rows with empty ones (i.e.: all zeroes) @@ -66,11 +67,11 @@ subroutine psb_drwextd(nr,a,info,b,rowscale) if (nr > a%m) then if (toupper(a%fida) == 'CSR') then - call psb_realloc(nr+1,a%ia2,info) + call psb_ensure_size(nr+1,a%ia2,info) if (present(b)) then nzb = psb_sp_get_nnzeros(b) - call psb_realloc(size(a%ia1)+nzb,a%ia1,info) - call psb_realloc(size(a%aspk)+nzb,a%aspk,info) + call psb_ensure_size(size(a%ia1)+nzb,a%ia1,info) + call psb_ensure_size(size(a%aspk)+nzb,a%aspk,info) if (toupper(b%fida)=='CSR') then do i=1, min(nr-a%m,b%m) diff --git a/base/serial/psb_dspclip.f90 b/base/serial/psb_dspclip.f90 index 192988e35..331ebd4bf 100644 --- a/base/serial/psb_dspclip.f90 +++ b/base/serial/psb_dspclip.f90 @@ -109,7 +109,7 @@ subroutine psb_dspclip(a,b,info,imin,imax,jmin,jmax,rscale,cscale) call psb_sp_all(mb,kb,b,sizeb,info) b%fida = 'COO' b%descra = a%descra - nzb = 0 + nzb = 0 do i=imin_, imax_, irbk nrt = min(irbk,imax_-i+1) ifst = i diff --git a/base/serial/psb_dspcnv.f90 b/base/serial/psb_dspcnv.f90 new file mode 100644 index 000000000..d60360b3e --- /dev/null +++ b/base/serial/psb_dspcnv.f90 @@ -0,0 +1,553 @@ +!!$ +!!$ Parallel Sparse BLAS v2.0 +!!$ (C) Copyright 2006 Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari University of Rome Tor Vergata +!!$ +!!$ Redistribution and use in source and binary forms, with or without +!!$ modification, are permitted provided that the following conditions +!!$ are met: +!!$ 1. Redistributions of source code must retain the above copyright +!!$ notice, this list of conditions and the following disclaimer. +!!$ 2. Redistributions in binary form must reproduce the above copyright +!!$ notice, this list of conditions, and the following disclaimer in the +!!$ documentation and/or other materials provided with the distribution. +!!$ 3. The name of the PSBLAS group or the names of its contributors may +!!$ not be used to endorse or promote products derived from this +!!$ software without specific written permission. +!!$ +!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +!!$ POSSIBILITY OF SUCH DAMAGE. +!!$ +!!$ +! File: psb_dcsdp.f90 +! +! Subroutine: psb_dcsdp +! This subroutine performs the assembly of +! the local part of a sparse distributed matrix +! +! Parameters: +! a - type(). The input matrix to be assembled. +! b - type(). The assembled output matrix. +! info - integer. Eventually returns an error code. +! ifc - integer(optional). ??? +! check - character(optional). ??? +! trans - character(optional). ??? +! unitd - character(optional). ??? +! +subroutine psb_dspcnv2(a, b,info,afmt,upd,dupl) + use psb_const_mod + use psb_error_mod + use psb_spmat_type + use psb_string_mod + use psb_serial_mod, psb_protect_name => psb_dspcnv2 + implicit none + !....Parameters... + Type(psb_dspmat_type), intent(in) :: A + Type(psb_dspmat_type), intent(out) :: B + Integer, intent(out) :: info + Integer, intent(in), optional :: upd,dupl + character(len=*), optional, intent(in) :: afmt + + !...Locals... + real(kind(1.d0)) :: d(1) + real(kind(1.d0)), allocatable :: work(:) + type(psb_dspmat_type) :: temp_a + Integer :: nzr, ntry, ifc_, ia1_size,& + & ia2_size, aspk_size,size_req,n_row,n_col,upd_,dupl_ + integer :: ip1, ip2, nnz, iflag, ichk, nnzt,& + & ipc, i, count, err_act, i1, i2, ia + character :: check_,trans_,unitd_ + character(len=5) :: afmt_ + Integer, Parameter :: maxtry=8 + logical, parameter :: debug=.false. + character(len=20) :: name, ch_err + + name='psb_spcnv' + info = 0 + call psb_erractionsave(err_act) + + ntry=0 + + ifc_ = 2 + + + check_ = 'N' + trans_ = 'N' + unitd_ = 'U' + allocate(work(max(size(a%ia1),size(a%ia2))+max(a%m,b%m)+1000),stat=info) + + if (info /= 0) then + info=2040 + call psb_errpush(info,name) + goto 9999 + end if + + + if (present(upd)) then + call psb_sp_setifld(upd,psb_upd_,b,info) + end if + if (present(dupl)) then + call psb_sp_setifld(dupl,psb_dupl_,b,info) + end if + if (present(afmt)) then + afmt_ = afmt + else + afmt_ = psb_fidef_ + end if + + upd_ = psb_sp_getifld(psb_upd_,b,info) + select case(upd_) + case(psb_upd_srch_,psb_upd_perm_) + ! Legal value, do nothing + case default + ! Fix bad value + upd_ = psb_upd_dflt_ + call psb_sp_setifld(upd_,psb_upd_,b,info) + end select + + dupl_ = psb_sp_getifld(psb_dupl_,b,info) + select case(dupl_) + case(psb_dupl_ovwrt_,psb_dupl_add_,psb_dupl_err_) + ! Legal value, do nothing + case default + ! Fix bad value + dupl_ = psb_dupl_def_ + call psb_sp_setifld(dupl_,psb_dupl_,b,info) + end select + + ! ...matrix conversion... + b%m=a%m + b%k=a%k + b%fida=afmt_ + size_req = psb_sp_get_nnzeros(a) + if (debug) write(0,*) 'DCSDP : size_req 1:',size_req + ! + n_row=b%m + n_col=b%k + call psb_cest(afmt_,n_row,n_col,size_req,& + & ia1_size, ia2_size, aspk_size, upd_,info) + b%fida=afmt_ + + if (info /= psb_no_err_) then + info=4010 + ch_err='psb_cest' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + endif + if (.not.allocated(b%aspk).or.& + &.not.allocated(b%ia1).or.& + &.not.allocated(b%ia2).or.& + &.not.allocated(b%pl).or.& + &.not.allocated(b%pr)) then + call psb_sp_reall(b,ia1_size,ia2_size,aspk_size,info) + else if ((size(b%aspk) < aspk_size) .or.& + &(size(b%ia1) < ia1_size) .or.& + &(size(b%ia2) < ia2_size) .or.& + &(size(b%pl) < b%m) .or.& + &(size(b%pr) < b%k )) then + call psb_sp_reall(b,ia1_size,ia2_size,aspk_size,info) + endif + + if (info /= psb_no_err_) then + info=4010 + ch_err='psb_sp_reall' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + endif + + b%pl(:) = 0 + b%pr(:) = 0 + + b%descra = a%descra + + select case (tolower(a%fida)) + + case ('csr') + + select case (tolower(b%fida)) + + case ('csr') + + call dcrcr(trans_, a%m, a%k, unitd_, d, a%descra, a%aspk,& + & a%ia1, a%ia2, a%infoa, b%pl, b%descra, b%aspk, b%ia1,& + & b%ia2, b%infoa, b%pr, size(b%aspk), size(b%ia1),& + & size(b%ia2), work, size(work), info) + + + if (info/=0) then + info=4010 + ch_err='dcrcr' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + case ('jad') + + !...converting to JAD + !...output matrix may not be big enough + do + + call dcrjd(trans_, a%m, a%k, unitd_, d, a%descra, a%aspk,& + & a%ia1, a%ia2, a%infoa, b%pl, b%descra, b%aspk, b%ia1,& + & b%ia2, b%infoa, b%pr, size(b%aspk), size(b%ia1),& + & size(b%ia2), work, size(work), nzr, info) + if (info /= 0) then + call psb_errpush(4010,name,a_err='dcrjd') + goto 9999 + endif + + ntry = ntry + 1 + if (debug) then + write(0,*) 'On out from dcrjad ',nzr,info + end if + if (nzr == 0) exit + if (ntry > maxtry ) then + write(0,*) 'Tried reallocating for DCRJAD for ',maxtry,': giving up now.' + info=2040 + call psb_errpush(info,name) + goto 9999 + endif + call psb_cest(afmt_,n_row,n_col,nzr,& + & ia1_size, ia2_size, aspk_size, upd_,info) + call psb_sp_reall(b,ia1_size,ia2_size,aspk_size,info) + if (info /= 0) then + info=2040 + call psb_errpush(info,name) + goto 9999 + endif + + end do + + if (info/=0) then + call psb_errpush(info,name) + goto 9999 + end if + + case ('coo') + if (debug) write(0,*) 'Calling CRCO ',a%descra + call dcrco(trans_, a%m, a%k, unitd_, d, a%descra, a%aspk,& + & a%ia1, a%ia2, a%infoa, b%pl, b%descra, b%aspk, b%ia1,& + & b%ia2, b%infoa, b%pr, size(b%aspk), size(b%ia1),& + & size(b%ia2), work, size(work), info) + + if (info/=0) then + call psb_errpush(4010,name,a_err='dcrco') + goto 9999 + end if + case default + info=4010 + call psb_errpush(info,name) + goto 9999 + + end select + + case ('coo','coi') + + select case (tolower(b%fida)) + + case ('csr') + + call dcocr(trans_, a%m, a%k, unitd_, d, a%descra, a%aspk,& + & a%ia2, a%ia1, a%infoa, b%pl, b%descra, b%aspk, b%ia1,& + & b%ia2, b%infoa, b%pr, size(b%aspk), size(b%ia1),& + & size(b%ia2), work, 2*size(work), info) + + if (info/=0) then + call psb_errpush(4010,name,a_err='dcocr') + goto 9999 + end if + + case ('jad') + + call psb_sp_all(temp_a, size(b%ia1),size(b%ia2),size(b%aspk),info) + if (info /= 0) then + info=2040 + call psb_errpush(info,name) + goto 9999 + endif + temp_a%m = a%m + temp_a%k = a%k + temp_a%infoa=b%infoa + !...Dirty trick: converting to CSR and then to JAD + + call dcocr(trans_, a%m, a%k, unitd_, d, a%descra, a%aspk,& + & a%ia2, a%ia1, a%infoa, temp_a%pl, temp_a%descra, & + & temp_a%aspk, temp_a%ia1, temp_a%ia2, temp_a%infoa, temp_a%pr, & + & size(temp_a%aspk), size(temp_a%ia1),& + & size(temp_a%ia2), work, 2*size(work), info) + + if (info/=0) then + call psb_errpush(4010,name,a_err='dcocr') + goto 9999 + end if + + do + call dcrjd(trans_, temp_a%m, temp_a%k, unitd_, d, temp_a%descra, & + & temp_a%aspk, temp_a%ia1, temp_a%ia2, temp_a%infoa, & + & b%pl, b%descra, b%aspk, b%ia1, b%ia2, b%infoa, b%pr, & + & size(b%aspk), size(b%ia1),& + & size(b%ia2), work, size(work), nzr, info) + if (info/=0) then + call psb_errpush(4010,name,a_err='dcrjd') + goto 9999 + end if + + ntry = ntry + 1 + if (debug) then + write(0,*) 'On out from dcrjad ',nzr,info + end if + if (nzr == 0) exit + if (ntry > maxtry ) then + write(0,*) 'Tried reallocating for DCRJAD for ',maxtry,& + & ': giving up now.' + info=2040 + call psb_errpush(info,name) + goto 9999 + endif + + call psb_sp_reall(b,nzr,info,ifc=ifc_) + if (info /= 0) then + info=2040 + call psb_errpush(info,name) + goto 9999 + endif + + end do + + case ('coo') + + call dcoco(trans_, a%m, a%k, unitd_, d, a%descra, a%aspk,& + & a%ia1, a%ia2, a%infoa, b%pl, b%descra, b%aspk, b%ia1,& + & b%ia2, b%infoa, b%pr, size(b%aspk), size(b%ia1),& + & size(b%ia2), work, 2*size(work), info) + if (info/=0) then + call psb_errpush(4010,name,a_err='dcoco') + goto 9999 + end if + + case default + info=4010 + call psb_errpush(info,name) + goto 9999 + end select + + case default + info=4010 + call psb_errpush(info,name) + goto 9999 + + end select + + if (psb_sp_getifld(psb_upd_,b,info) /= psb_upd_perm_) & + & call psb_sp_trim(b,info) + + + call psb_sp_setifld(psb_spmat_asb_,psb_state_,b,info) + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act.eq.psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_dspcnv2 + + +subroutine psb_dspcnv1(a, info, afmt, upd, dupl) + + use psb_spmat_type + use psb_regen_mod + use psb_serial_mod, psb_protect_name => psb_dspcnv1 + use psb_const_mod + use psi_mod + use psb_error_mod + use psb_string_mod + !use psb_penv_mod + + implicit none + + + !...Parameters.... + type(psb_dspmat_type), intent (inout) :: a + integer, intent(out) :: info + integer,optional, intent(in) :: dupl, upd + character(len=*), optional, intent(in) :: afmt + + integer :: int_err(5) + type(psb_dspmat_type) :: atemp + integer :: np,me,n_col,iout, err_act + integer :: spstate + integer :: upd_, dupl_ + integer :: ictxt,n_row + logical, parameter :: debug=.false., debugwrt=.false. + character(len=20) :: name, ch_err + + info = 0 + int_err(1)=0 + name = 'psb_spcnv' + call psb_erractionsave(err_act) + + if (present(upd)) then + call psb_sp_setifld(upd,psb_upd_,a,info) + end if + if (present(dupl)) then + call psb_sp_setifld(dupl,psb_dupl_,a,info) + end if + + upd_ = psb_sp_getifld(psb_upd_,a,info) + select case(upd_) + case(psb_upd_srch_,psb_upd_perm_) + ! Legal value, do nothing + case default + ! Fix bad value + upd_ = psb_upd_dflt_ + call psb_sp_setifld(upd_,psb_upd_,a,info) + end select + + dupl_ = psb_sp_getifld(psb_dupl_,a,info) + select case(dupl_) + case(psb_dupl_ovwrt_,psb_dupl_add_,psb_dupl_err_) + ! Legal value, do nothing + case default + ! Fix bad value + dupl_ = psb_dupl_def_ + call psb_sp_setifld(dupl_,psb_dupl_,a,info) + end select + + + spstate = psb_sp_getifld(psb_state_,a,info) + if (info /= 0) then + goto 9999 + endif + if (debug) write(0,*) 'Sparse matrix state:',spstate,psb_spmat_bld_,psb_spmat_upd_ + if (spstate /= psb_spmat_upd_) then + ! Should we first figure out if we can do it in place? + if (debug) write(0,*) 'Update:',upd_,psb_upd_srch_,psb_upd_perm_ + if (upd_ == psb_upd_srch_) then + if (present(afmt)) then + select case (tolower(a%fida)) + case('coo') + select case(tolower(afmt)) + case('coo') + call psb_fixcoo(a,info) + goto 9998 + case('csr') + call psb_ipcoo2csr(a,info) + goto 9998 + case('csc') + call psb_ipcoo2csc(a,info) + goto 9998 + end select + case('csr') + select case(tolower(afmt)) + case('coo') + call psb_ipcsr2coo(a,info) + goto 9998 + end select + end select + end if + end if + + call psb_sp_clone(a,atemp,info) + if(info /= psb_no_err_) then + info=4010 + ch_err='psb_sp_clone' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + ! convert to user requested format after the temp copy + end if + + if (debugwrt) then + iout = 30+me + open(iout) + call psb_csprt(iout,atemp,head='Input mat') + close(iout) + endif + + ! Do the real conversion into the requested storage format + ! result is put in A + call psb_spcnv(atemp,a,info,afmt=afmt,upd=upd,dupl=dupl) + + IF (debug) WRITE (*, *) me,' ASB: From SPCNV',info,' ',A%FIDA + if (info /= psb_no_err_) then + info=4010 + ch_err='psb_csdp' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + endif + + if (debugwrt) then + iout = 60+me + open(iout) + call psb_csprt(iout,a,head='Output mat') + close(iout) + endif + + call psb_sp_free(atemp,info) + + else if (spstate == psb_spmat_upd_) then + ! + ! Second case: we come from an update loop. + ! + select case(tolower(a%fida)) + case('csr') + call csr_regen(a,info) + case ('coo','coi') + call coo_regen(a,info) + case('jad') + call jad_regen(a,info) + case default + info=136 + ch_err=a%fida + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end select + + + ! check on error retuned by dcsdp + if (info /= psb_no_err_) then + info = 4010 + ch_err='xx_regen' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + else + + info = 600 + call psb_errpush(info,name) + goto 9999 + if (debug) write(0,*) 'Sparse matrix state:',spstate,psb_spmat_bld_,psb_spmat_upd_ + + endif + +9998 continue + + call psb_sp_setifld(psb_spmat_asb_,psb_state_,a,info) + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act.eq.psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_dspcnv1 diff --git a/base/serial/psb_dspgetrow.f90 b/base/serial/psb_dspgetrow.f90 index b5fd42dc9..2c970d828 100644 --- a/base/serial/psb_dspgetrow.f90 +++ b/base/serial/psb_dspgetrow.f90 @@ -87,21 +87,19 @@ subroutine psb_dspgetrow(irw,a,nz,ia,ja,val,info,iren,lrw,append,nzin) nzin_ = 0 endif - if (toupper(a%fida) == 'CSR') then - call csr_getrow(irw_,a,nz,ia,ja,val,nzin_,append_,lrw_,info,iren) - - else if (toupper(a%fida) == 'COO') then - call coo_getrow(irw_,a,nz,ia,ja,val,nzin_,append_,lrw_,info,iren) - - else if (toupper(a%fida) == 'JAD') then - call jad_getrow(irw_,a,nz,ia,ja,val,nzin_,append_,lrw_,info,iren) - - else - info=136 - ch_err=a%fida(1:3) - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if + select case (tolower(a%fida)) + case ('csr') + call csr_getrow(irw_,a,nz,ia,ja,val,nzin_,append_,lrw_,info,iren) + case ('coo') + call coo_getrow(irw_,a,nz,ia,ja,val,nzin_,append_,lrw_,info,iren) + case ('jad') + call jad_getrow(irw_,a,nz,ia,ja,val,nzin_,append_,lrw_,info,iren) + case default + info=136 + ch_err=a%fida(1:3) + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end select if (info /= 0) goto 9999 !!$ call psb_erractionrestore(err_act) diff --git a/base/serial/psb_dsymbmm.f90 b/base/serial/psb_dsymbmm.f90 index 869a777fa..8b5b35f34 100644 --- a/base/serial/psb_dsymbmm.f90 +++ b/base/serial/psb_dsymbmm.f90 @@ -93,6 +93,7 @@ subroutine psb_dsymbmm(a,b,c,info) c%k=b%k c%fida='CSR' c%descra='GUN' + deallocate(itemp) call psb_erractionrestore(err_act) return diff --git a/base/serial/psb_dtransp.f90 b/base/serial/psb_dtransp.f90 index c5ac8b0a8..bd0f1dd9d 100644 --- a/base/serial/psb_dtransp.f90 +++ b/base/serial/psb_dtransp.f90 @@ -36,10 +36,11 @@ subroutine psb_dtransp(a,b,c,fmt) use psb_spmat_type use psb_tools_mod use psb_string_mod - use psb_serial_mod, only : psb_ipcoo2csr, psb_ipcsr2coo, psb_fixcoo, psb_csdp + use psb_serial_mod, psb_protect_name => psb_dtransp implicit none - type(psb_dspmat_type) :: a,b + type(psb_dspmat_type), intent(inout) :: a + type(psb_dspmat_type), intent(out) :: b integer, optional :: c character(len=*), optional :: fmt @@ -59,55 +60,21 @@ subroutine psb_dtransp(a,b,c,fmt) fmt_='CSR' endif - if (.true.) then - if (allocated(b%aspk)) call psb_sp_free(b,info) - b%fida = 'COO' - b%descra = 'GUN' - call psb_csdp(a,b,info) -!!$ write(0,*) 'Check from CSDP',b%m,b%k,b%fida,b%descra,b%infoa(psb_nnz_) - if (info /= 0) then - write(0,*) 'transp: info from CSDP ',info - return - end if - else - if (allocated(b%aspk)) call psb_sp_free(b,info) - call psb_sp_clone(a,b,info) - - if (b%fida=='CSR') then - call psb_ipcsr2coo(b,info) - else if (b%fida=='COO') then - ! do nothing - else - write(0,*) 'Unimplemented case in TRANSP ' - endif -!!$ write(0,*) 'Check from CLONE',b%m,b%k,b%fida,b%descra,b%infoa(psb_nnz_) - endif -!!$ nz = b%infoa(nnz_) -!!$ write(0,*) 'TRANSP CHECKS:',a%m,a%k,& -!!$ &minval(b%ia1(1:nz)),maxval(b%ia1(1:nz)),& -!!$ &minval(b%ia2(1:nz)),maxval(b%ia2(1:nz)) + call psb_nullify_sp(b) + + call psb_spcnv(a,b,info,afmt='coo') + + if (info /= 0) then + write(0,*) 'transp: info from CSDP ',info + return + end if call psb_transfer(b%ia1,itmp,info) call psb_transfer(b%ia2,b%ia1,info) call psb_transfer(itmp,b%ia2,info) b%m = a%k b%k = a%m -!!$ write(0,*) 'Calling IPCOO2CSR from transp90 ',b%m,b%k - if (fmt_=='CSR') then - call psb_ipcoo2csr(b,info) - b%fida='CSR' - else if (fmt_=='COO') then - call psb_fixcoo(b,info) - b%fida='COO' - else - call psb_nullify_sp(tmp) - call psb_sp_clone(b,tmp,info) - b%fida=fmt_ - call psb_csdp(tmp,b,info) - !!!!!! ADD HERE ERRPUSH!!! - call psb_sp_free(tmp,info) - - endif + call psb_spcnv(b,info,afmt=fmt_) return end subroutine psb_dtransp diff --git a/base/serial/psb_regen_mod.f90 b/base/serial/psb_regen_mod.f90 new file mode 100644 index 000000000..a843f6881 --- /dev/null +++ b/base/serial/psb_regen_mod.f90 @@ -0,0 +1,613 @@ +module psb_regen_mod + + interface csr_regen + module procedure csr_dsp_regen, csr_zsp_regen + end interface + interface coo_regen + module procedure coo_dsp_regen, coo_zsp_regen + end interface + interface jad_regen + module procedure jad_dsp_regen, jad_zsp_regen + end interface + +contains + + subroutine csr_dsp_regen(a,info) + + use psb_spmat_type + use psb_const_mod + use psb_error_mod + implicit none + + type(psb_dspmat_type), intent(inout) :: a + integer :: info + + integer :: i,j, k, ip1,ip2,nnz,iflag,ichk,nnzt + real(kind(1.d0)), allocatable :: work(:) + integer :: err_act + character(len=20) :: name, ch_err + logical, parameter :: debug=.false. + + name='psb_spcnv' + info = 0 + call psb_erractionsave(err_act) + + + ! + ! dupl_ and upd_ fields should not be changed. + ! + select case(psb_sp_getifld(psb_upd_,a,info)) + + case(psb_upd_perm_) + + allocate(work(size(a%aspk)+1000),stat=info) + if (info /= 0) then + info=2040 + call psb_errpush(info,name) + goto 9999 + end if + + if (debug) write(0,*) 'Regeneration with psb_upd_perm_' + ip1 = psb_sp_getifld(psb_upd_pnt_,a,info) + ip2 = a%ia2(ip1+psb_ip2_) + nnz = a%ia2(ip1+psb_nnz_) + iflag = a%ia2(ip1+psb_iflag_) + ichk = a%ia2(ip1+psb_ichk_) + nnzt = a%ia2(ip1+psb_nnzt_) + if (debug) write(*,*) 'Regeneration start: ',& + & a%infoa(psb_upd_),psb_upd_perm_,nnz,nnzt ,iflag,info + + if ((ichk/=nnzt+iflag).or.(nnz/=nnzt)) then + info = 8889 + write(*,*) 'Regeneration start error: ',& + & a%infoa(psb_upd_),psb_upd_perm_,nnz,nnzt ,iflag,ichk + call psb_errpush(info,name) + goto 9999 + endif + do i= 1, nnz + work(i) = dzero + enddo + select case(iflag) + case(psb_dupl_ovwrt_,psb_dupl_err_) + do i=1, nnz + work(a%ia2(ip2+i-1)) = a%aspk(i) + enddo + case(psb_dupl_add_) + do i=1, nnz + work(a%ia2(ip2+i-1)) = a%aspk(i) + work(a%ia2(ip2+i-1)) + enddo + case default + info = 8887 + call psb_errpush(info,name) + goto 9999 + end select + + do i=1, nnz + a%aspk(i) = work(i) + enddo + + + case(psb_upd_srch_) + ! Nothing to be done here. + if (debug) write(0,*) 'Going through on regeneration with psb_upd_srch_' + case default + ! Wrong value + info = 8888 + call psb_errpush(info,name) + goto 9999 + + end select + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act.eq.psb_act_abort_) then + call psb_error() + return + end if + return + + end subroutine csr_dsp_regen + + subroutine coo_dsp_regen(a,info) + + use psb_spmat_type + use psb_const_mod + use psb_error_mod + implicit none + + type(psb_dspmat_type), intent(inout) :: a + integer :: info + + integer :: i,j, k, ip1,ip2,nnz,iflag,ichk,nnzt + real(kind(1.d0)), allocatable :: work(:) + integer :: err_act + character(len=20) :: name, ch_err + logical, parameter :: debug=.false. + + name='psb_spcnv' + info = 0 + call psb_erractionsave(err_act) + + + ! + ! dupl_ and upd_ fields should not be changed. + ! + select case(psb_sp_getifld(psb_upd_,a,info)) + + case(psb_upd_perm_) + + allocate(work(size(a%aspk)+1000),stat=info) + if (info /= 0) then + info=2040 + call psb_errpush(info,name) + goto 9999 + end if + + if (debug) write(0,*) 'Regeneration with psb_upd_perm_' + ip1 = psb_sp_getifld(psb_upd_pnt_,a,info) + ip2 = a%ia2(ip1+psb_ip2_) + nnz = a%ia2(ip1+psb_nnz_) + iflag = a%ia2(ip1+psb_iflag_) + ichk = a%ia2(ip1+psb_ichk_) + nnzt = a%ia2(ip1+psb_nnzt_) + if (debug) write(*,*) 'Regeneration start: ',& + & a%infoa(psb_upd_),psb_upd_perm_,nnz,nnzt ,iflag,info + + if ((ichk/=nnzt+iflag).or.(nnz/=nnzt)) then + info = 8889 + write(*,*) 'Regeneration start error: ',& + & a%infoa(psb_upd_),psb_upd_perm_,nnz,nnzt ,iflag,ichk + call psb_errpush(info,name) + goto 9999 + endif + do i= 1, nnz + work(i) = dzero + enddo + select case(iflag) + case(psb_dupl_ovwrt_,psb_dupl_err_) + do i=1, nnz + work(a%ia2(ip2+i-1)) = a%aspk(i) + enddo + case(psb_dupl_add_) + do i=1, nnz + work(a%ia2(ip2+i-1)) = a%aspk(i) + work(a%ia2(ip2+i-1)) + enddo + case default + info = 8887 + call psb_errpush(info,name) + goto 9999 + end select + + do i=1, nnz + a%aspk(i) = work(i) + enddo + + + case(psb_upd_srch_) + ! Nothing to be done here. + if (debug) write(0,*) 'Going through on regeneration with psb_upd_srch_' + case default + ! Wrong value + info = 8888 + call psb_errpush(info,name) + goto 9999 + + end select + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act.eq.psb_act_abort_) then + call psb_error() + return + end if + return + + end subroutine coo_dsp_regen + + subroutine jad_dsp_regen(a,info) + + use psb_spmat_type + use psb_const_mod + use psb_error_mod + implicit none + + type(psb_dspmat_type), intent(inout) :: a + integer :: info + + integer :: i,j, k, ip1,ip2,nnz,iflag,ichk,nnzt + real(kind(1.d0)), allocatable :: work(:) + integer :: err_act + character(len=20) :: name, ch_err + logical, parameter :: debug=.false. + + name='psb_spcnv' + info = 0 + call psb_erractionsave(err_act) + + + ! + ! dupl_ and upd_ fields should not be changed. + ! + select case(psb_sp_getifld(psb_upd_,a,info)) + + case(psb_upd_perm_) + + allocate(work(size(a%aspk)+1000),stat=info) + if (info /= 0) then + info=2040 + call psb_errpush(info,name) + goto 9999 + end if + + if (debug) write(0,*) 'Regeneration with psb_upd_perm_' + ip1 = psb_sp_getifld(psb_upd_pnt_,a,info) + ip2 = a%ia1(ip1+psb_ip2_) + nnz = a%ia1(ip1+psb_nnz_) + iflag = a%ia1(ip1+psb_iflag_) + ichk = a%ia1(ip1+psb_ichk_) + nnzt = a%ia1(ip1+psb_nnzt_) + if (debug) write(*,*) 'Regeneration start: ',& + & a%infoa(psb_upd_),psb_upd_perm_,nnz,nnzt ,iflag,info + + if ((ichk/=nnzt+iflag).or.(nnz/=nnzt)) then + info = 8889 + write(*,*) 'Regeneration start error: ',& + & a%infoa(psb_upd_),psb_upd_perm_,nnz,nnzt ,iflag,ichk + call psb_errpush(info,name) + goto 9999 + endif + do i= 1, nnz + work(i) = dzero + enddo + select case(iflag) + case(psb_dupl_ovwrt_,psb_dupl_err_) + do i=1, nnz + work(a%ia1(ip2+i-1)) = a%aspk(i) + enddo + case(psb_dupl_add_) + do i=1, nnz + work(a%ia1(ip2+i-1)) = a%aspk(i) + work(a%ia1(ip2+i-1)) + enddo + case default + info = 8887 + call psb_errpush(info,name) + goto 9999 + end select + + do i=1, nnz + a%aspk(i) = work(i) + enddo + + + case(psb_upd_srch_) + ! Nothing to be done here. + if (debug) write(0,*) 'Going through on regeneration with psb_upd_srch_' + case default + ! Wrong value + info = 8888 + call psb_errpush(info,name) + goto 9999 + + end select + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act.eq.psb_act_abort_) then + call psb_error() + return + end if + return + + end subroutine jad_dsp_regen + + + + subroutine csr_zsp_regen(a,info) + + use psb_spmat_type + use psb_const_mod + use psb_error_mod + implicit none + + type(psb_zspmat_type), intent(inout) :: a + integer :: info + + integer :: i,j, k, ip1,ip2,nnz,iflag,ichk,nnzt + complex(kind(1.d0)), allocatable :: work(:) + integer :: err_act + character(len=20) :: name, ch_err + logical, parameter :: debug=.false. + + name='psb_spcnv' + info = 0 + call psb_erractionsave(err_act) + + + ! + ! dupl_ and upd_ fields should not be changed. + ! + select case(psb_sp_getifld(psb_upd_,a,info)) + + case(psb_upd_perm_) + + allocate(work(size(a%aspk)+1000),stat=info) + if (info /= 0) then + info=2040 + call psb_errpush(info,name) + goto 9999 + end if + + if (debug) write(0,*) 'Regeneration with psb_upd_perm_' + ip1 = psb_sp_getifld(psb_upd_pnt_,a,info) + ip2 = a%ia2(ip1+psb_ip2_) + nnz = a%ia2(ip1+psb_nnz_) + iflag = a%ia2(ip1+psb_iflag_) + ichk = a%ia2(ip1+psb_ichk_) + nnzt = a%ia2(ip1+psb_nnzt_) + if (debug) write(*,*) 'Regeneration start: ',& + & a%infoa(psb_upd_),psb_upd_perm_,nnz,nnzt ,iflag,info + + if ((ichk/=nnzt+iflag).or.(nnz/=nnzt)) then + info = 8889 + write(*,*) 'Regeneration start error: ',& + & a%infoa(psb_upd_),psb_upd_perm_,nnz,nnzt ,iflag,ichk + call psb_errpush(info,name) + goto 9999 + endif + do i= 1, nnz + work(i) = zzero + enddo + select case(iflag) + case(psb_dupl_ovwrt_,psb_dupl_err_) + do i=1, nnz + work(a%ia2(ip2+i-1)) = a%aspk(i) + enddo + case(psb_dupl_add_) + do i=1, nnz + work(a%ia2(ip2+i-1)) = a%aspk(i) + work(a%ia2(ip2+i-1)) + enddo + case default + info = 8887 + call psb_errpush(info,name) + goto 9999 + end select + + do i=1, nnz + a%aspk(i) = work(i) + enddo + + + case(psb_upd_srch_) + ! Nothing to be done here. + if (debug) write(0,*) 'Going through on regeneration with psb_upd_srch_' + case default + ! Wrong value + info = 8888 + call psb_errpush(info,name) + goto 9999 + + end select + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act.eq.psb_act_abort_) then + call psb_error() + return + end if + return + + end subroutine csr_zsp_regen + + subroutine coo_zsp_regen(a,info) + + use psb_spmat_type + use psb_const_mod + use psb_error_mod + implicit none + + type(psb_zspmat_type), intent(inout) :: a + integer :: info + + integer :: i,j, k, ip1,ip2,nnz,iflag,ichk,nnzt + complex(kind(1.d0)), allocatable :: work(:) + integer :: err_act + character(len=20) :: name, ch_err + logical, parameter :: debug=.false. + + name='psb_spcnv' + info = 0 + call psb_erractionsave(err_act) + + + ! + ! dupl_ and upd_ fields should not be changed. + ! + select case(psb_sp_getifld(psb_upd_,a,info)) + + case(psb_upd_perm_) + + allocate(work(size(a%aspk)+1000),stat=info) + if (info /= 0) then + info=2040 + call psb_errpush(info,name) + goto 9999 + end if + + if (debug) write(0,*) 'Regeneration with psb_upd_perm_' + ip1 = psb_sp_getifld(psb_upd_pnt_,a,info) + ip2 = a%ia2(ip1+psb_ip2_) + nnz = a%ia2(ip1+psb_nnz_) + iflag = a%ia2(ip1+psb_iflag_) + ichk = a%ia2(ip1+psb_ichk_) + nnzt = a%ia2(ip1+psb_nnzt_) + if (debug) write(*,*) 'Regeneration start: ',& + & a%infoa(psb_upd_),psb_upd_perm_,nnz,nnzt ,iflag,info + + if ((ichk/=nnzt+iflag).or.(nnz/=nnzt)) then + info = 8889 + write(*,*) 'Regeneration start error: ',& + & a%infoa(psb_upd_),psb_upd_perm_,nnz,nnzt ,iflag,ichk + call psb_errpush(info,name) + goto 9999 + endif + do i= 1, nnz + work(i) = zzero + enddo + select case(iflag) + case(psb_dupl_ovwrt_,psb_dupl_err_) + do i=1, nnz + work(a%ia2(ip2+i-1)) = a%aspk(i) + enddo + case(psb_dupl_add_) + do i=1, nnz + work(a%ia2(ip2+i-1)) = a%aspk(i) + work(a%ia2(ip2+i-1)) + enddo + case default + info = 8887 + call psb_errpush(info,name) + goto 9999 + end select + + do i=1, nnz + a%aspk(i) = work(i) + enddo + + + case(psb_upd_srch_) + ! Nothing to be done here. + if (debug) write(0,*) 'Going through on regeneration with psb_upd_srch_' + case default + ! Wrong value + info = 8888 + call psb_errpush(info,name) + goto 9999 + + end select + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act.eq.psb_act_abort_) then + call psb_error() + return + end if + return + + end subroutine coo_zsp_regen + + subroutine jad_zsp_regen(a,info) + + use psb_spmat_type + use psb_const_mod + use psb_error_mod + implicit none + + type(psb_zspmat_type), intent(inout) :: a + integer :: info + + integer :: i,j, k, ip1,ip2,nnz,iflag,ichk,nnzt + complex(kind(1.d0)), allocatable :: work(:) + integer :: err_act + character(len=20) :: name, ch_err + logical, parameter :: debug=.false. + + name='psb_spcnv' + info = 0 + call psb_erractionsave(err_act) + + + ! + ! dupl_ and upd_ fields should not be changed. + ! + select case(psb_sp_getifld(psb_upd_,a,info)) + + case(psb_upd_perm_) + + allocate(work(size(a%aspk)+1000),stat=info) + if (info /= 0) then + info=2040 + call psb_errpush(info,name) + goto 9999 + end if + + if (debug) write(0,*) 'Regeneration with psb_upd_perm_' + ip1 = psb_sp_getifld(psb_upd_pnt_,a,info) + ip2 = a%ia1(ip1+psb_ip2_) + nnz = a%ia1(ip1+psb_nnz_) + iflag = a%ia1(ip1+psb_iflag_) + ichk = a%ia1(ip1+psb_ichk_) + nnzt = a%ia1(ip1+psb_nnzt_) + if (debug) write(*,*) 'Regeneration start: ',& + & a%infoa(psb_upd_),psb_upd_perm_,nnz,nnzt ,iflag,info + + if ((ichk/=nnzt+iflag).or.(nnz/=nnzt)) then + info = 8889 + write(*,*) 'Regeneration start error: ',& + & a%infoa(psb_upd_),psb_upd_perm_,nnz,nnzt ,iflag,ichk + call psb_errpush(info,name) + goto 9999 + endif + do i= 1, nnz + work(i) = zzero + enddo + select case(iflag) + case(psb_dupl_ovwrt_,psb_dupl_err_) + do i=1, nnz + work(a%ia1(ip2+i-1)) = a%aspk(i) + enddo + case(psb_dupl_add_) + do i=1, nnz + work(a%ia1(ip2+i-1)) = a%aspk(i) + work(a%ia1(ip2+i-1)) + enddo + case default + info = 8887 + call psb_errpush(info,name) + goto 9999 + end select + + do i=1, nnz + a%aspk(i) = work(i) + enddo + + + case(psb_upd_srch_) + ! Nothing to be done here. + if (debug) write(0,*) 'Going through on regeneration with psb_upd_srch_' + case default + ! Wrong value + info = 8888 + call psb_errpush(info,name) + goto 9999 + + end select + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act.eq.psb_act_abort_) then + call psb_error() + return + end if + return + + end subroutine jad_zsp_regen + + + +end module psb_regen_mod diff --git a/base/serial/psb_update_mod.f90 b/base/serial/psb_update_mod.f90 index 52f1454b3..b8067aa0b 100644 --- a/base/serial/psb_update_mod.f90 +++ b/base/serial/psb_update_mod.f90 @@ -30,12 +30,6 @@ !!$ module psb_update_mod - - use psb_spmat_type - use psb_const_mod - use psb_realloc_mod - use psb_string_mod - interface psb_srch_upd module procedure psb_d_srch_upd, psb_z_srch_upd end interface @@ -48,11 +42,21 @@ module psb_update_mod module procedure d_csr_srch_upd, z_csr_srch_upd end interface + interface jad_srch_upd + module procedure d_jad_srch_upd, z_jad_srch_upd + end interface + contains subroutine psb_d_srch_upd(nz,ia,ja,val,nza,a,& & imin,imax,jmin,jmax,nzl,info,gtl,ng) + + use psb_spmat_type + use psb_const_mod + use psb_realloc_mod + use psb_string_mod + use psb_serial_mod implicit none type(psb_dspmat_type), intent(inout) :: a @@ -62,7 +66,7 @@ contains real(kind(1.d0)), intent(in) :: val(*) integer, intent(out) :: info integer, intent(in), optional :: ng,gtl(*) - + info = 0 if (present(gtl)) then @@ -70,44 +74,34 @@ contains info = -1 return endif - - select case(toupper(a%fida)) - case ('CSR') -!!$ write(0,*) 'Calling csr_srch_upd' - call csr_srch_upd(nz,ia,ja,val,nza,a,& - & imin,imax,jmin,jmax,nzl,info,gtl,ng) -!!$ write(0,*) 'From csr_srch_upd:',info - case ('COO') - call coo_srch_upd(nz,ia,ja,val,nza,a,& - & imin,imax,jmin,jmax,nzl,info,gtl,ng) - - case default - - info = -9 - - end select - else - select case(toupper(a%fida)) - case ('CSR') -!!$ write(0,*) 'Calling csr_srch_upd' - call csr_srch_upd(nz,ia,ja,val,nza,a,& - & imin,imax,jmin,jmax,nzl,info) -!!$ write(0,*) 'From csr_srch_upd:',info - case ('COO') - call coo_srch_upd(nz,ia,ja,val,nza,a,& - & imin,imax,jmin,jmax,nzl,info) - - case default - - info = -9 - - end select end if + select case(tolower(a%fida)) + case ('csr') + call csr_srch_upd(nz,ia,ja,val,nza,a,& + & imin,imax,jmin,jmax,nzl,info,gtl,ng) + case ('coo') + call coo_srch_upd(nz,ia,ja,val,nza,a,& + & imin,imax,jmin,jmax,nzl,info,gtl,ng) + case ('jad') + call jad_srch_upd(nz,ia,ja,val,nza,a,& + & imin,imax,jmin,jmax,nzl,info,gtl,ng) + + case default + + info = -9 + + end select end subroutine psb_d_srch_upd subroutine psb_z_srch_upd(nz,ia,ja,val,nza,a,& & imin,imax,jmin,jmax,nzl,info,gtl,ng) + + use psb_spmat_type + use psb_const_mod + use psb_realloc_mod + use psb_string_mod + use psb_serial_mod implicit none type(psb_zspmat_type), intent(inout) :: a @@ -117,7 +111,7 @@ contains complex(kind(1.d0)), intent(in) :: val(*) integer, intent(out) :: info integer, intent(in), optional :: ng,gtl(*) - + info = 0 if (present(gtl)) then @@ -125,7 +119,7 @@ contains info = -1 return endif - + select case(toupper(a%fida)) case ('CSR') !!$ write(0,*) 'Calling csr_srch_upd' @@ -135,11 +129,11 @@ contains case ('COO') call coo_srch_upd(nz,ia,ja,val,nza,a,& & imin,imax,jmin,jmax,nzl,info,gtl,ng) - + case default - + info = -9 - + end select else select case(toupper(a%fida)) @@ -151,11 +145,11 @@ contains case ('COO') call coo_srch_upd(nz,ia,ja,val,nza,a,& & imin,imax,jmin,jmax,nzl,info) - + case default - + info = -9 - + end select end if @@ -164,6 +158,12 @@ contains subroutine d_csr_srch_upd(nz,ia,ja,val,nza,a,& & imin,imax,jmin,jmax,nzl,info,gtl,ng) + + use psb_spmat_type + use psb_const_mod + use psb_realloc_mod + use psb_string_mod + use psb_serial_mod implicit none type(psb_dspmat_type), intent(inout) :: a @@ -387,6 +387,12 @@ contains subroutine d_coo_srch_upd(nz,ia,ja,val,nza,a,& & imin,imax,jmin,jmax,nzl,info,gtl,ng) + + use psb_spmat_type + use psb_const_mod + use psb_realloc_mod + use psb_string_mod + use psb_serial_mod implicit none type(psb_dspmat_type), intent(inout) :: a @@ -583,9 +589,252 @@ contains end subroutine d_coo_srch_upd + subroutine d_jad_srch_upd(nz,ia,ja,val,nza,a,imin,imax,jmin,jmax,nzl,info,gtl,ng) + + use psb_spmat_type + use psb_const_mod + use psb_realloc_mod + use psb_string_mod + use psb_serial_mod + + implicit none + + type(psb_dspmat_type), intent(inout), target :: a + integer, intent(in) :: nz, imin,imax,jmin,jmax,nzl + integer, intent(in) :: ia(*),ja(*) + integer, intent(inout) :: nza + real(kind(1.d0)), intent(in) :: val(*) + integer, intent(out) :: info + integer, intent(in), optional :: ng,gtl(*) + + integer, pointer :: ia1(:), ia2(:), ia3(:),& + & ja_(:), ka_(:) + integer, allocatable :: indices(:), blks(:), rows(:) + integer :: png, pia, pja, ipx, blk, rb, row, k_pt, npg, col, ngr, nzin_,& + & i,j,k,nr,dupl, ii, ir, ic + + info = 0 + dupl = psb_sp_getifld(psb_dupl_,a,info) + + png = a%ia2(1) ! points to the number of blocks + pia = a%ia2(2) ! points to the beginning of ia(3,png) + pja = a%ia2(3) ! points to the beginning of ja(:) + + ngr = a%ia2(png) ! the number of blocks + ja_ => a%ia2(pja:) ! the array containing the pointers to ka and aspk + ka_ => a%ia1(:) ! the array containing the column indices + ia1 => a%ia2(pia:pja-1:3) ! the array containing the first row index + ! of each block + ia2 => a%ia2(pia+1:pja-1:3) ! the array containing a pointer to the pos. + ! in ja to the first jad column + ia3 => a%ia2(pia+2:pja-1:3) ! the array containing a pointer to the pos. + ! in ja to the first csr column + + + if (a%pl(1) /= 0) then + + if (present(gtl)) then + if (.not.present(ng)) then + info = -1 + return + endif + + + allocate(rows(nz),stat=info) + if (info /= 0) then + info = -4010 + return + endif + j=0 + do i=1,nz + ir = ia(i) + if ((ir >=1).and.(ir<=ng)) then + ir = gtl(ir) + j = j + 1 + rows(j) = ir + endif + enddo + call psb_msort_unique(rows(1:j),nr) + allocate(indices(nr),blks(nr),stat=info) + if (info /= 0) then + info = -4010 + return + endif + + do i=1,nr + indices(i)=a%pl(rows(i)) + j=0 + blkfnd_gtl: do + j=j+1 + if(ia1(j).eq.indices(i)) then + blks(i)=j + ipx = ia1(j) ! the first row index of the block + rb = indices(i)-ipx ! the row offset within the block + row = ia3(j)+rb + exit blkfnd_gtl + else if(ia1(j).gt.indices(i)) then + blks(i)=j-1 + ipx = ia1(j-1) ! the first row index of the block + rb = indices(i)-ipx ! the row offset within the block + row = ia3(j-1)+rb + exit blkfnd_gtl + end if + end do blkfnd_gtl + end do + + + ! cycle over elements + update_gtl: do ii=1,nz + ir = ia(ii) + ic = ja(ii) + if ((ir >=1).and.(ir<=ng).and.(ic>=1).and.(ic<=ng)) then + ir = gtl(ir) + if ((ir > 0).and.(ir <= a%m)) then + ic = gtl(ic) + call ibsrch(i,ir,nr,rows) + + ! find which block the row belongs to + blk = blks(i) + + ! extract first part of the row from the jad block + ipx = ia1(blk) ! the first row index of the block + k_pt= ia2(blk) ! the pointer to the beginning of a column in ja + rb = indices(i)-ipx ! the row offset within the block + npg = ja_(k_pt+1)-ja_(k_pt) ! the number of rows in the block + + do col = ia2(blk), ia3(blk)-1 + if (ic == ka_(ja_(col)+rb)) then + select case(dupl) + case(psb_dupl_ovwrt_,psb_dupl_err_) + a%aspk(ja_(col)+rb) = val(ii) + case(psb_dupl_add_) + a%aspk(ja_(col)+rb) = a%aspk(ja_(col)+rb) + val(ii) + end select + cycle update_gtl + endif + end do + + ! extract second part of the row from the csr tail just in case + row=ia3(blk)+rb + do j=ja_(row), ja_(row+1)-1 + if (ic == ka_(j)) then + select case(dupl) + case(psb_dupl_ovwrt_,psb_dupl_err_) + a%aspk(j) = val(ii) + case(psb_dupl_add_) + a%aspk(j) = a%aspk(j) + val(ii) + end select + cycle update_gtl + endif + end do + end if + end if + end do update_gtl + + else + + allocate(rows(nz),stat=info) + if (info /= 0) then + info = -4010 + return + endif + j=0 + do i=1,nz + ir = ia(i) + if ((ir >=1).and.(ir<=a%m)) then + j = j + 1 + rows(j) = ir + endif + enddo + call psb_msort_unique(rows(1:j),nr) + allocate(indices(nr),blks(nr),stat=info) + if (info /= 0) then + info = -4010 + return + endif + + do i=1,nr + indices(i)=a%pl(rows(i)) + j=0 + blkfnd: do + j=j+1 + if(ia1(j).eq.indices(i)) then + blks(i)=j + ipx = ia1(j) ! the first row index of the block + rb = indices(i)-ipx ! the row offset within the block + row = ia3(j)+rb + exit blkfnd + else if(ia1(j).gt.indices(i)) then + blks(i)=j-1 + ipx = ia1(j-1) ! the first row index of the block + rb = indices(i)-ipx ! the row offset within the block + row = ia3(j-1)+rb + exit blkfnd + end if + end do blkfnd + end do + + + ! cycle over elements + update: do ii=1,nz + ir = ia(ii) + ic = ja(ii) + if ((ir >=1).and.(ir<=a%m).and.(ic>=1).and.(ic<=a%k)) then + call ibsrch(i,ir,nr,rows) + ! find which block the row belongs to + blk = blks(i) + + ! extract first part of the row from the jad block + ipx = ia1(blk) ! the first row index of the block + k_pt= ia2(blk) ! the pointer to the beginning of a column in ja + rb = indices(i)-ipx ! the row offset within the block + npg = ja_(k_pt+1)-ja_(k_pt) ! the number of rows in the block + + do col = ia2(blk), ia3(blk)-1 + if (ic == ka_(ja_(col)+rb)) then + select case(dupl) + case(psb_dupl_ovwrt_,psb_dupl_err_) + a%aspk(ja_(col)+rb) = val(ii) + case(psb_dupl_add_) + a%aspk(ja_(col)+rb) = a%aspk(ja_(col)+rb) + val(ii) + end select + cycle update + endif + end do + + ! extract second part of the row from the csr tail just in case + row=ia3(blk)+rb + do j=ja_(row), ja_(row+1)-1 + if (ic == ka_(j)) then + select case(dupl) + case(psb_dupl_ovwrt_,psb_dupl_err_) + a%aspk(j) = val(ii) + case(psb_dupl_add_) + a%aspk(j) = a%aspk(j) + val(ii) + end select + cycle update + endif + end do + end if + end do update + + end if + else + ! There might be some problems + info=134 + end if + + end subroutine d_jad_srch_upd + subroutine z_csr_srch_upd(nz,ia,ja,val,nza,a,& & imin,imax,jmin,jmax,nzl,info,gtl,ng) + + use psb_spmat_type + use psb_const_mod + use psb_realloc_mod + use psb_string_mod + use psb_serial_mod implicit none type(psb_zspmat_type), intent(inout) :: a @@ -801,6 +1050,12 @@ contains subroutine z_coo_srch_upd(nz,ia,ja,val,nza,a,& & imin,imax,jmin,jmax,nzl,info,gtl,ng) + + use psb_spmat_type + use psb_const_mod + use psb_realloc_mod + use psb_string_mod + use psb_serial_mod implicit none type(psb_zspmat_type), intent(inout) :: a @@ -813,7 +1068,7 @@ contains integer :: i,ir,ic, ilr, ilc, ip, & & i1,i2,nc,lb,ub,m,nnz,dupl,isrt logical, parameter :: debug=.false. - + info = 0 dupl = psb_sp_getifld(psb_dupl_,a,info) @@ -997,5 +1252,245 @@ contains end subroutine z_coo_srch_upd + + + subroutine z_jad_srch_upd(nz,ia,ja,val,nza,a,imin,imax,jmin,jmax,nzl,info,gtl,ng) + + use psb_spmat_type + use psb_const_mod + use psb_realloc_mod + use psb_string_mod + use psb_serial_mod + + implicit none + + type(psb_zspmat_type), intent(inout), target :: a + integer, intent(in) :: nz, imin,imax,jmin,jmax,nzl + integer, intent(in) :: ia(*),ja(*) + integer, intent(inout) :: nza + complex(kind(1.d0)), intent(in) :: val(*) + integer, intent(out) :: info + integer, intent(in), optional :: ng,gtl(*) + + integer, pointer :: ia1(:), ia2(:), ia3(:),& + & ja_(:), ka_(:) + integer, allocatable :: indices(:), blks(:), rows(:) + integer :: png, pia, pja, ipx, blk, rb, row, k_pt, npg, col, ngr, nzin_,& + & i,j,k,nr,dupl, ii, ir, ic + + info = 0 + dupl = psb_sp_getifld(psb_dupl_,a,info) + + png = a%ia2(1) ! points to the number of blocks + pia = a%ia2(2) ! points to the beginning of ia(3,png) + pja = a%ia2(3) ! points to the beginning of ja(:) + + ngr = a%ia2(png) ! the number of blocks + ja_ => a%ia2(pja:) ! the array containing the pointers to ka and aspk + ka_ => a%ia1(:) ! the array containing the column indices + ia1 => a%ia2(pia:pja-1:3) ! the array containing the first row index + ! of each block + ia2 => a%ia2(pia+1:pja-1:3) ! the array containing a pointer to the pos. + ! in ja to the first jad column + ia3 => a%ia2(pia+2:pja-1:3) ! the array containing a pointer to the pos. + ! in ja to the first csr column + + + if (a%pl(1) /= 0) then + + if (present(gtl)) then + if (.not.present(ng)) then + info = -1 + return + endif + + + allocate(rows(nz),stat=info) + if (info /= 0) then + info = -4010 + return + endif + j=0 + do i=1,nz + ir = ia(i) + if ((ir >=1).and.(ir<=ng)) then + ir = gtl(ir) + j = j + 1 + rows(j) = ir + endif + enddo + call psb_msort_unique(rows(1:j),nr) + allocate(indices(nr),blks(nr),stat=info) + if (info /= 0) then + info = -4010 + return + endif + + do i=1,nr + indices(i)=a%pl(rows(i)) + j=0 + blkfnd_gtl: do + j=j+1 + if(ia1(j).eq.indices(i)) then + blks(i)=j + ipx = ia1(j) ! the first row index of the block + rb = indices(i)-ipx ! the row offset within the block + row = ia3(j)+rb + exit blkfnd_gtl + else if(ia1(j).gt.indices(i)) then + blks(i)=j-1 + ipx = ia1(j-1) ! the first row index of the block + rb = indices(i)-ipx ! the row offset within the block + row = ia3(j-1)+rb + exit blkfnd_gtl + end if + end do blkfnd_gtl + end do + + + ! cycle over elements + update_gtl: do ii=1,nz + ir = ia(ii) + ic = ja(ii) + if ((ir >=1).and.(ir<=ng).and.(ic>=1).and.(ic<=ng)) then + ir = gtl(ir) + if ((ir > 0).and.(ir <= a%m)) then + ic = gtl(ic) + call ibsrch(i,ir,nr,rows) + + ! find which block the row belongs to + blk = blks(i) + + ! extract first part of the row from the jad block + ipx = ia1(blk) ! the first row index of the block + k_pt= ia2(blk) ! the pointer to the beginning of a column in ja + rb = indices(i)-ipx ! the row offset within the block + npg = ja_(k_pt+1)-ja_(k_pt) ! the number of rows in the block + + do col = ia2(blk), ia3(blk)-1 + if (ic == ka_(ja_(col)+rb)) then + select case(dupl) + case(psb_dupl_ovwrt_,psb_dupl_err_) + a%aspk(ja_(col)+rb) = val(ii) + case(psb_dupl_add_) + a%aspk(ja_(col)+rb) = a%aspk(ja_(col)+rb) + val(ii) + end select + cycle update_gtl + endif + end do + + ! extract second part of the row from the csr tail just in case + row=ia3(blk)+rb + do j=ja_(row), ja_(row+1)-1 + if (ic == ka_(j)) then + select case(dupl) + case(psb_dupl_ovwrt_,psb_dupl_err_) + a%aspk(j) = val(ii) + case(psb_dupl_add_) + a%aspk(j) = a%aspk(j) + val(ii) + end select + cycle update_gtl + endif + end do + end if + end if + end do update_gtl + + else + + allocate(rows(nz),stat=info) + if (info /= 0) then + info = -4010 + return + endif + j=0 + do i=1,nz + ir = ia(i) + if ((ir >=1).and.(ir<=a%m)) then + j = j + 1 + rows(j) = ir + endif + enddo + call psb_msort_unique(rows(1:j),nr) + allocate(indices(nr),blks(nr),stat=info) + if (info /= 0) then + info = -4010 + return + endif + + do i=1,nr + indices(i)=a%pl(rows(i)) + j=0 + blkfnd: do + j=j+1 + if(ia1(j).eq.indices(i)) then + blks(i)=j + ipx = ia1(j) ! the first row index of the block + rb = indices(i)-ipx ! the row offset within the block + row = ia3(j)+rb + exit blkfnd + else if(ia1(j).gt.indices(i)) then + blks(i)=j-1 + ipx = ia1(j-1) ! the first row index of the block + rb = indices(i)-ipx ! the row offset within the block + row = ia3(j-1)+rb + exit blkfnd + end if + end do blkfnd + end do + + + ! cycle over elements + update: do ii=1,nz + ir = ia(ii) + ic = ja(ii) + if ((ir >=1).and.(ir<=a%m).and.(ic>=1).and.(ic<=a%k)) then + call ibsrch(i,ir,nr,rows) + ! find which block the row belongs to + blk = blks(i) + + ! extract first part of the row from the jad block + ipx = ia1(blk) ! the first row index of the block + k_pt= ia2(blk) ! the pointer to the beginning of a column in ja + rb = indices(i)-ipx ! the row offset within the block + npg = ja_(k_pt+1)-ja_(k_pt) ! the number of rows in the block + + do col = ia2(blk), ia3(blk)-1 + if (ic == ka_(ja_(col)+rb)) then + select case(dupl) + case(psb_dupl_ovwrt_,psb_dupl_err_) + a%aspk(ja_(col)+rb) = val(ii) + case(psb_dupl_add_) + a%aspk(ja_(col)+rb) = a%aspk(ja_(col)+rb) + val(ii) + end select + cycle update + endif + end do + + ! extract second part of the row from the csr tail just in case + row=ia3(blk)+rb + do j=ja_(row), ja_(row+1)-1 + if (ic == ka_(j)) then + select case(dupl) + case(psb_dupl_ovwrt_,psb_dupl_err_) + a%aspk(j) = val(ii) + case(psb_dupl_add_) + a%aspk(j) = a%aspk(j) + val(ii) + end select + cycle update + endif + end do + end if + end do update + + end if + else + ! There might be some problems + info=134 + end if + + end subroutine z_jad_srch_upd + + end module psb_update_mod diff --git a/base/serial/psb_zcoins.f90 b/base/serial/psb_zcoins.f90 index 5069a79f0..c67fe25fd 100644 --- a/base/serial/psb_zcoins.f90 +++ b/base/serial/psb_zcoins.f90 @@ -38,7 +38,7 @@ subroutine psb_zcoins(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl,rebuild) use psb_realloc_mod use psb_string_mod use psb_error_mod - use psb_serial_mod, only : psb_sp_info, psb_csdp + use psb_serial_mod, psb_protect_name => psb_zcoins use psb_update_mod implicit none @@ -156,8 +156,12 @@ subroutine psb_zcoins(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl,rebuild) case (psb_upd_perm_) ip1 = psb_sp_getifld(psb_upd_pnt_,a,info) nzl = psb_sp_getifld(psb_del_bnd_,a,info) - nza = a%ia2(ip1+psb_nnz_) - + select case(ufida) + case ('JAD') + nza = a%ia1(ip1+psb_nnz_) + case default + nza = a%ia2(ip1+psb_nnz_) + end select call psb_inner_upd(nz,ia,ja,val,nza,a%aspk,size(a%aspk),& & imin,imax,jmin,jmax,nzl,info,gtl,ng) @@ -172,11 +176,17 @@ subroutine psb_zcoins(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl,rebuild) write(0,*) 'PSB_COINS: update discarded items ' end if end if - a%ia2(ip1+psb_nnz_) = nza + + select case(ufida) + case ('JAD') + a%ia1(ip1+psb_nnz_) = nza + case default + a%ia2(ip1+psb_nnz_) = nza + end select if (debug) write(0,*) 'From COINS(UPD) : NZA:',nza - case (psb_upd_dflt_, psb_upd_srch_) + case (psb_upd_srch_) call psb_srch_upd(nz,ia,ja,val,nza,a,& & imin,imax,jmin,jmax,nzl,info,gtl,ng) @@ -187,8 +197,7 @@ subroutine psb_zcoins(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl,rebuild) & 'COINS: Going through rebuild_ fingers crossed!' irst = info call psb_nullify_sp(tmp) - tmp%fida='COO' - call psb_csdp(a,tmp,info) + call psb_spcnv(a,tmp,info,afmt='coo') if(info /= izero) then info=4010 ch_err='psb_csdp' @@ -349,7 +358,7 @@ subroutine psb_zcoins(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl,rebuild) if (debug) write(0,*) 'From COINS(UPD) : NZA:',nza - case (psb_upd_dflt_, psb_upd_srch_) + case (psb_upd_srch_) call psb_srch_upd(nz,ia,ja,val,nza,a,& & imin,imax,jmin,jmax,nzl,info) @@ -360,8 +369,7 @@ subroutine psb_zcoins(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl,rebuild) & 'COINS: Going through rebuild_ fingers crossed!' irst = info call psb_nullify_sp(tmp) - tmp%fida='COO' - call psb_csdp(a,tmp,info) + call psb_spcnv(a,tmp,info,afmt='coo') call psb_sp_setifld(psb_spmat_bld_,psb_state_,tmp,info) if (debug) then write(0,*) 'COINS Rebuild: size',tmp%infoa(psb_nnz_) ,irst @@ -429,8 +437,6 @@ subroutine psb_zcoins(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl,rebuild) endif - return - call psb_erractionrestore(err_act) return diff --git a/base/serial/psb_zcsdp.f90 b/base/serial/psb_zcsdp.f90 deleted file mode 100644 index 6a8d28df9..000000000 --- a/base/serial/psb_zcsdp.f90 +++ /dev/null @@ -1,516 +0,0 @@ -!!$ -!!$ Parallel Sparse BLAS v2.0 -!!$ (C) Copyright 2006 Salvatore Filippone University of Rome Tor Vergata -!!$ Alfredo Buttari University of Rome Tor Vergata -!!$ -!!$ Redistribution and use in source and binary forms, with or without -!!$ modification, are permitted provided that the following conditions -!!$ are met: -!!$ 1. Redistributions of source code must retain the above copyright -!!$ notice, this list of conditions and the following disclaimer. -!!$ 2. Redistributions in binary form must reproduce the above copyright -!!$ notice, this list of conditions, and the following disclaimer in the -!!$ documentation and/or other materials provided with the distribution. -!!$ 3. The name of the PSBLAS group or the names of its contributors may -!!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. -!!$ -!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -!!$ POSSIBILITY OF SUCH DAMAGE. -!!$ -!!$ -! File: psb_zcsdp.f90 -! -! Subroutine: psb_zcsdp -! This subroutine performs the assembly of -! the local part of a sparse distributed matrix -! -! Parameters: -! a - type(). The input matrix to be assembled. -! b - type(). The assembled output matrix. -! info - integer. Eventually returns an error code. -! ifc - integer(optional). ??? -! check - character(optional). ??? -! trans - character(optional). ??? -! unitd - character(optional). ??? -! -subroutine psb_zcsdp(a, b,info,ifc,check,trans,unitd,upd,dupl) - use psb_const_mod - use psb_error_mod - use psb_spmat_type - use psb_string_mod - use psb_serial_mod, psb_protect_name => psb_zcsdp - implicit none - !....Parameters... - Type(psb_zspmat_type), intent(in) :: A - Type(psb_zspmat_type), intent(inout) :: B - Integer, intent(out) :: info - Integer, intent(in), optional :: ifc,upd,dupl - character, intent(in), optional :: check,trans,unitd - - !...Locals... - complex(kind(1.d0)) :: d(1) - complex(kind(1.d0)), allocatable :: work(:) - type(psb_zspmat_type) :: temp_a - Integer :: nzr, ntry, ifc_, ia1_size,& - & ia2_size, aspk_size,size_req,n_row,n_col,upd_,dupl_ - integer :: ip1, ip2, nnz, iflag, ichk, nnzt,& - & ipc, i, count, err_act, i1, i2, ia - character :: check_,trans_,unitd_ - Integer, Parameter :: maxtry=8 - logical, parameter :: debug=.false. - character(len=20) :: name, ch_err - - name='psb_csdp' - info = 0 - call psb_erractionsave(err_act) - - ntry=0 - if (present(ifc)) then - ifc_ = max(1,ifc) - else - ifc_ = 1 - endif - if (present(check)) then - check_ = toupper(check) - else - check_ = 'N' - endif - if (present(trans)) then - trans_ = toupper(trans) - else - trans_ = 'N' - endif - if (present(unitd)) then - unitd_ = toupper(unitd) - else - unitd_ = 'U' - endif - - - if (check_=='R') then - allocate(work(max(size(a%aspk),size(b%aspk))+1000),stat=info) - else - allocate(work(max(size(a%ia1),size(a%ia2))+max(a%m,b%m)+1000),stat=info) - endif - - if (info /= 0) then - info=2040 - call psb_errpush(info,name) - goto 9999 - end if - if (ifc_<1) then - write(0,*) 'csdp90 Error: invalid ifc ',ifc_ - info = -4 - call psb_errpush(info,name) - goto 9999 - endif - - if((check_=='Y').or.(check_=='C')) then - if(toupper(a%fida(1:3))=='CSR') then - call zcsrck(trans,a%m,a%k,a%descra,a%aspk,a%ia1,a%ia2,work,size(work),info) - if(info /= 0) then - info=4010 - ch_err='dcsrck' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - - else - write(0,'("Check not yet suported for the ",a3," storage format")')a%fida(1:3) - end if - - end if - - if (check_/='R') then - - if (present(upd)) then - call psb_sp_setifld(upd,psb_upd_,b,info) - end if - if (present(dupl)) then - call psb_sp_setifld(dupl,psb_dupl_,b,info) - end if - - upd_ = psb_sp_getifld(psb_upd_,b,info) - select case(upd_) - case(psb_upd_dflt_,psb_upd_srch_,psb_upd_perm_) - ! Legal value, do nothing - case default - ! Fix bad value - upd_ = psb_upd_dflt_ - call psb_sp_setifld(upd_,psb_upd_,b,info) - end select - dupl_ = psb_sp_getifld(psb_dupl_,b,info) - select case(dupl_) - case(psb_dupl_ovwrt_,psb_dupl_add_,psb_dupl_err_) - ! Legal value, do nothing - case default - ! Fix bad value - dupl_ = psb_dupl_def_ - call psb_sp_setifld(dupl_,psb_dupl_,b,info) - end select - - ! ...matrix conversion... - b%m=a%m - b%k=a%k - size_req = psb_sp_get_nnzeros(a) - if (debug) write(0,*) 'DCSDP : size_req 1:',size_req - ! - - n_row=b%m - n_col=b%k - call psb_cest(b%fida, n_row,n_col,size_req,& - & ia1_size, ia2_size, aspk_size, upd_,info) - - if (info /= psb_no_err_) then - info=4010 - ch_err='psb_cest' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - endif - if (.not.allocated(b%aspk).or.& - &.not.allocated(b%ia1).or.& - &.not.allocated(b%ia2).or.& - &.not.allocated(b%pl).or.& - &.not.allocated(b%pr)) then - call psb_sp_reall(b,ia1_size,ia2_size,aspk_size,info) - else if ((size(b%aspk) < aspk_size) .or.& - &(size(b%ia1) < ia1_size) .or.& - &(size(b%ia2) < ia2_size) .or.& - &(size(b%pl) < b%m) .or.& - &(size(b%pr) < b%k )) then - call psb_sp_reall(b,ia1_size,ia2_size,aspk_size,info) - endif - - if (info /= psb_no_err_) then - info=4010 - ch_err='psb_sp_reall' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - endif - - b%pl(:) = 0 - b%pr(:) = 0 - - b%descra = a%descra - - select case (toupper(a%fida(1:3))) - - case ('CSR') - - select case (toupper(b%fida(1:3))) - - case ('CSR') - - - call zcrcr(trans_, a%m, a%k, unitd_, d, a%descra, a%aspk,& - & a%ia1, a%ia2, a%infoa, b%pl, b%descra, b%aspk, b%ia1,& - & b%ia2, b%infoa, b%pr, size(b%aspk), size(b%ia1),& - & size(b%ia2), work, size(work), info) - - - if (info/=0) then - info=4010 - ch_err='dcrcr' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - - case ('JAD') - - !...converting to JAD - !...output matrix may not be big enough - do - - call zcrjd(trans_, a%m, a%k, unitd_, d, a%descra, a%aspk,& - & a%ia1, a%ia2, a%infoa, b%pl, b%descra, b%aspk, b%ia1,& - & b%ia2, b%infoa, b%pr, size(b%aspk), size(b%ia1),& - & size(b%ia2), work, size(work), nzr, info) - if (info /= 0) then - call psb_errpush(4010,name,a_err='dcrjd') - goto 9999 - endif - - ntry = ntry + 1 - if (debug) then - write(0,*) 'On out from dcrjad ',nzr,info - end if - if (nzr == 0) exit - if (ntry > maxtry ) then - write(0,*) 'Tried reallocating for DCRJAD for ',maxtry,': giving up now.' - info=2040 - call psb_errpush(info,name) - goto 9999 - endif - - call psb_sp_reall(b,nzr,info,ifc=ifc_) - if (info /= 0) then - info=2040 - call psb_errpush(info,name) - goto 9999 - endif - - end do - - if (info/=0) then - call psb_errpush(info,name) - goto 9999 - end if - - case ('COO') - - call zcrco(trans_, a%m, a%k, unitd_, d, a%descra, a%aspk,& - & a%ia1, a%ia2, a%infoa, b%pl, b%descra, b%aspk, b%ia1,& - & b%ia2, b%infoa, b%pr, size(b%aspk), size(b%ia1),& - & size(b%ia2), work, size(work), info) - - if (info/=0) then - call psb_errpush(4010,name,a_err='dcrco') - goto 9999 - end if - case default - info=4010 - call psb_errpush(info,name) - goto 9999 - - end select - - case ('COO','COI') - - select case (toupper(b%fida(1:3))) - - case ('CSR') - - call zcocr(trans_, a%m, a%k, unitd_, d, a%descra, a%aspk,& - & a%ia2, a%ia1, a%infoa, b%pl, b%descra, b%aspk, b%ia1,& - & b%ia2, b%infoa, b%pr, size(b%aspk), size(b%ia1),& - & size(b%ia2), work, 2*size(work), info) - - if (info/=0) then - call psb_errpush(4010,name,a_err='dcocr') - goto 9999 - end if - - case ('JAD') - - call psb_sp_all(temp_a, size(b%ia1),size(b%ia2),size(b%aspk),info) - if (info /= 0) then - info=2040 - call psb_errpush(info,name) - goto 9999 - endif - temp_a%m = a%m - temp_a%k = a%k - - !...Dirty trick: converting to CSR and then to JAD - - call zcocr(trans_, a%m, a%k, unitd_, d, a%descra, a%aspk,& - & a%ia2, a%ia1, a%infoa, temp_a%pl, temp_a%descra, & - & temp_a%aspk, temp_a%ia1, temp_a%ia2, temp_a%infoa, temp_a%pr, & - & size(temp_a%aspk), size(temp_a%ia1),& - & size(temp_a%ia2), work, 2*size(work), info) - - if (info/=0) then - call psb_errpush(4010,name,a_err='dcocr') - goto 9999 - end if - - do - call zcrjd(trans_, temp_a%m, temp_a%k, unitd_, d, temp_a%descra, & - & temp_a%aspk, temp_a%ia1, temp_a%ia2, temp_a%infoa, & - & b%pl, b%descra, b%aspk, b%ia1, b%ia2, b%infoa, b%pr, & - & size(b%aspk), size(b%ia1),& - & size(b%ia2), work, size(work), nzr, info) - if (info/=0) then - call psb_errpush(4010,name,a_err='dcrjd') - goto 9999 - end if - - ntry = ntry + 1 - if (debug) then - write(0,*) 'On out from dcrjad ',nzr,info - end if - if (nzr == 0) exit - if (ntry > maxtry ) then - write(0,*) 'Tried reallocating for DCRJAD for ',maxtry,& - & ': giving up now.' - info=2040 - call psb_errpush(info,name) - goto 9999 - endif - - call psb_sp_reall(b,nzr,info,ifc=ifc_) - if (info /= 0) then - info=2040 - call psb_errpush(info,name) - goto 9999 - endif - - end do - - case ('COO') - - call zcoco(trans_, a%m, a%k, unitd_, d, a%descra, a%aspk,& - & a%ia1, a%ia2, a%infoa, b%pl, b%descra, b%aspk, b%ia1,& - & b%ia2, b%infoa, b%pr, size(b%aspk), size(b%ia1),& - & size(b%ia2), work, 2*size(work), info) - if (info/=0) then - call psb_errpush(4010,name,a_err='dcoco') - goto 9999 - end if - - case default - info=4010 - call psb_errpush(info,name) - goto 9999 - end select - - case default - info=4010 - call psb_errpush(info,name) - goto 9999 - - end select - - - if (psb_sp_getifld(psb_upd_,b,info) /= psb_upd_perm_) & - & call psb_sp_trim(b,info) - - else if (check_=='R') then - !...Regenerating matrix - - if (psb_sp_getifld(psb_state_,b,info) /= psb_spmat_upd_) then - info = 8888 - call psb_errpush(info,name) - goto 9999 - endif - - ! - ! dupl_ and upd_ fields should not be changed. - ! - select case(psb_sp_getifld(psb_upd_,b,info)) - - case(psb_upd_perm_) - if (debug) write(0,*) 'Regeneration with psb_upd_perm_' - if (toupper(b%fida(1:3))/='JAD') then - ip1 = psb_sp_getifld(psb_upd_pnt_,b,info) - ip2 = b%ia2(ip1+psb_ip2_) - nnz = b%ia2(ip1+psb_nnz_) - iflag = b%ia2(ip1+psb_iflag_) - ichk = b%ia2(ip1+psb_ichk_) - nnzt = b%ia2(ip1+psb_nnzt_) - if (debug) write(*,*) 'Regeneration start: ',& - & b%infoa(psb_upd_),psb_upd_perm_,nnz,nnzt ,iflag,info - - if ((ichk/=nnzt+iflag).or.(nnz/=nnzt)) then - info = 8889 - write(*,*) 'Regeneration start error: ',& - & b%infoa(psb_upd_),psb_upd_perm_,nnz,nnzt ,iflag,ichk - call psb_errpush(info,name) - goto 9999 - endif - do i= 1, nnz - work(i) = 0.d0 - enddo - select case(iflag) - case(psb_dupl_ovwrt_,psb_dupl_err_) - do i=1, nnz - work(b%ia2(ip2+i-1)) = b%aspk(i) - enddo - case(psb_dupl_add_) - do i=1, nnz - work(b%ia2(ip2+i-1)) = b%aspk(i) + work(b%ia2(ip2+i-1)) - enddo - case default - info = 8887 - call psb_errpush(info,name) - goto 9999 - end select - - do i=1, nnz - b%aspk(i) = work(i) - enddo - - else if (toupper(b%fida(1:3)) == 'JAD') then - - - ip1 = psb_sp_getifld(psb_upd_pnt_,b,info) - ip2 = b%ia1(ip1+psb_ip2_) - count = b%ia1(ip1+psb_zero_) - ipc = b%ia1(ip1+psb_ipc_) - nnz = b%ia1(ip1+psb_nnz_) - iflag = b%ia1(ip1+psb_iflag_) - ichk = b%ia1(ip1+psb_ichk_) - nnzt = b%ia1(ip1+psb_nnzt_) - if (debug) write(*,*) 'Regeneration start: ',& - & b%infoa(psb_upd_),psb_upd_perm_,nnz,nnzt,count, & - & iflag,info - - if ((ichk/=nnzt+iflag).or.(nnz/=nnzt)) then - info = 10 - write(*,*) 'Regeneration start error: ',& - & b%infoa(psb_upd_),psb_upd_perm_,nnz,nnzt ,iflag,ichk - call psb_errpush(info,name) - goto 9999 - endif - - do i= 1, nnz+count - work(i) = 0.d0 - enddo - select case(iflag) - case(psb_dupl_ovwrt_,psb_dupl_err_) - do i=1, nnz - work(b%ia1(ip2+i-1)) = b%aspk(i) - enddo - case(psb_dupl_add_) - do i=1, nnz - work(b%ia1(ip2+i-1)) = b%aspk(i) + work(b%ia1(ip2+i-1)) - enddo - case default - info = 8887 - call psb_errpush(info,name) - goto 9999 - end select - - do i=1, nnz+count - b%aspk(i) = work(i) - enddo - do i=1, count - b%aspk(b%ia1(ipc+i-1)) = 0.d0 - end do - endif - - case(psb_upd_dflt_,psb_upd_srch_) - ! Nothing to be done here. - if (debug) write(0,*) 'Going through on regeneration with psb_upd_srch_' - case default - ! Wrong value - info = 8888 - call psb_errpush(info,name) - goto 9999 - - end select - end if - call psb_sp_setifld(psb_spmat_asb_,psb_state_,b,info) - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - if (err_act.eq.psb_act_abort_) then - call psb_error() - return - end if - return - -end subroutine psb_zcsdp diff --git a/base/serial/psb_zfixcoo.f90 b/base/serial/psb_zfixcoo.f90 index 95a765181..88ffdc2f7 100644 --- a/base/serial/psb_zfixcoo.f90 +++ b/base/serial/psb_zfixcoo.f90 @@ -32,10 +32,12 @@ ! Subroutine: ! Parameters: -Subroutine psb_zfixcoo(A,INFO,idir) +Subroutine psb_zfixcoo(a,info,idir) use psb_spmat_type use psb_const_mod use psb_string_mod + use psb_serial_mod, psb_protect_name => psb_zfixcoo + use psb_error_mod implicit none !....Parameters... @@ -45,11 +47,14 @@ Subroutine psb_zfixcoo(A,INFO,idir) integer, allocatable :: iaux(:) !locals - Integer :: nza, nzl,iret,idir_ - integer :: i,j, irw, icl + Integer :: nza, nzl,iret,idir_, dupl_ + integer :: i,j, irw, icl, err_act logical, parameter :: debug=.false. + character(len=20) :: name = 'psb_fixcoo' info = 0 + call psb_erractionsave(err_act) + if(debug) write(0,*)'fixcoo: ',size(a%ia1),size(a%ia2) if (toupper(a%fida) /= 'COO') then write(0,*) 'Fixcoo Invalid input ',a%fida @@ -62,9 +67,11 @@ Subroutine psb_zfixcoo(A,INFO,idir) idir_ = 0 endif - nza = a%infoa(psb_nnz_) + nza = psb_sp_getifld(psb_nnz_,a,info) if (nza < 2) return + dupl_ = psb_sp_getifld(psb_dupl_,a,info) + allocate(iaux(nza+2),stat=info) if (info /= 0) return @@ -92,22 +99,61 @@ Subroutine psb_zfixcoo(A,INFO,idir) irw = a%ia1(i) icl = a%ia2(i) j = 1 - do - j = j + 1 - if (j > nza) exit - if ((a%ia1(j) == irw).and.(a%ia2(j) == icl)) then - a%aspk(i) = a%aspk(i) + a%aspk(j) - else - i = i+1 - a%aspk(i) = a%aspk(j) - a%ia1(i) = a%ia1(j) - a%ia2(i) = a%ia2(j) - irw = a%ia1(i) - icl = a%ia2(i) - endif - enddo - a%infoa(psb_nnz_) = i - a%infoa(psb_srtd_) = psb_isrtdcoo_ + + select case(dupl_) + case(psb_dupl_ovwrt_) + + do + j = j + 1 + if (j > nza) exit + if ((a%ia1(j) == irw).and.(a%ia2(j) == icl)) then + a%aspk(i) = a%aspk(j) + else + i = i+1 + a%aspk(i) = a%aspk(j) + a%ia1(i) = a%ia1(j) + a%ia2(i) = a%ia2(j) + irw = a%ia1(i) + icl = a%ia2(i) + endif + enddo + + case(psb_dupl_add_) + + do + j = j + 1 + if (j > nza) exit + if ((a%ia1(j) == irw).and.(a%ia2(j) == icl)) then + a%aspk(i) = a%aspk(i) + a%aspk(j) + else + i = i+1 + a%aspk(i) = a%aspk(j) + a%ia1(i) = a%ia1(j) + a%ia2(i) = a%ia2(j) + irw = a%ia1(i) + icl = a%ia2(i) + endif + enddo + + case(psb_dupl_err_) + do + j = j + 1 + if (j > nza) exit + if ((a%ia1(j) == irw).and.(a%ia2(j) == icl)) then + call psb_errpush(130,name) + goto 9999 + else + i = i+1 + a%aspk(i) = a%aspk(j) + a%ia1(i) = a%ia1(j) + a%ia2(i) = a%ia2(j) + irw = a%ia1(i) + icl = a%ia2(i) + endif + enddo + + end select + if(debug) write(0,*)'FIXCOO: end second loop' @@ -133,29 +179,79 @@ Subroutine psb_zfixcoo(A,INFO,idir) irw = a%ia1(i) icl = a%ia2(i) j = 1 - do - j = j + 1 - if (j > nza) exit - if ((a%ia1(j) == irw).and.(a%ia2(j) == icl)) then - a%aspk(i) = a%aspk(i) + a%aspk(j) - else - i = i+1 - a%aspk(i) = a%aspk(j) - a%ia1(i) = a%ia1(j) - a%ia2(i) = a%ia2(j) - irw = a%ia1(i) - icl = a%ia2(i) - endif - enddo - a%infoa(psb_nnz_) = i - a%infoa(psb_srtd_) = psb_isrtdcoo_ + + select case(dupl_) + case(psb_dupl_ovwrt_) + do + j = j + 1 + if (j > nza) exit + if ((a%ia1(j) == irw).and.(a%ia2(j) == icl)) then + a%aspk(i) = a%aspk(j) + else + i = i+1 + a%aspk(i) = a%aspk(j) + a%ia1(i) = a%ia1(j) + a%ia2(i) = a%ia2(j) + irw = a%ia1(i) + icl = a%ia2(i) + endif + enddo + + case(psb_dupl_add_) + do + j = j + 1 + if (j > nza) exit + if ((a%ia1(j) == irw).and.(a%ia2(j) == icl)) then + a%aspk(i) = a%aspk(i) + a%aspk(j) + else + i = i+1 + a%aspk(i) = a%aspk(j) + a%ia1(i) = a%ia1(j) + a%ia2(i) = a%ia2(j) + irw = a%ia1(i) + icl = a%ia2(i) + endif + enddo + + case(psb_dupl_err_) + do + j = j + 1 + if (j > nza) exit + if ((a%ia1(j) == irw).and.(a%ia2(j) == icl)) then + call psb_errpush(130,name) + goto 9999 + else + i = i+1 + a%aspk(i) = a%aspk(j) + a%ia1(i) = a%ia1(j) + a%ia2(i) = a%ia2(j) + irw = a%ia1(i) + icl = a%ia2(i) + endif + enddo + end select if(debug) write(0,*)'FIXCOO: end second loop' case default write(0,*) 'Fixcoo: unknown direction ',idir_ end select - a%infoa(psb_upd_) = psb_upd_srch_ + + call psb_sp_setifld(psb_isrtdcoo_,psb_srtd_,a,info) + call psb_sp_setifld(i,psb_nnz_,a,info) + call psb_sp_setifld(psb_spmat_asb_,psb_state_,a,info) + call psb_sp_setifld(psb_upd_srch_,psb_upd_,a,info) deallocate(iaux) + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act.eq.psb_act_abort_) then + call psb_error() + return + end if return + end Subroutine psb_zfixcoo diff --git a/base/serial/psb_zipcoo2csc.f90 b/base/serial/psb_zipcoo2csc.f90 index 05cd9a437..60f25e32d 100644 --- a/base/serial/psb_zipcoo2csc.f90 +++ b/base/serial/psb_zipcoo2csc.f90 @@ -35,7 +35,7 @@ subroutine psb_zipcoo2csc(a,info,clshr) use psb_spmat_type use psb_const_mod - use psb_serial_mod, only : psb_fixcoo + use psb_serial_mod, psb_protect_name => psb_zipcoo2csc use psb_error_mod use psb_string_mod use psb_realloc_mod @@ -49,7 +49,7 @@ subroutine psb_zipcoo2csc(a,info,clshr) integer, allocatable :: iaux(:), itemp(:) !locals logical :: clshr_ - Integer :: nza, i,j,irw, idl,err_act,nc,icl + Integer :: nza, nr, i,j, idl,err_act,nc,icl Integer, Parameter :: maxtry=8 logical, parameter :: debug=.false. character(len=20) :: name @@ -107,7 +107,6 @@ subroutine psb_zipcoo2csc(a,info,clshr) if (clshr_) then - j = 1 i = 1 icl = itemp(j) diff --git a/base/serial/psb_zipcsr2coo.f90 b/base/serial/psb_zipcsr2coo.f90 index 32d4a6af6..c8e5d3f20 100644 --- a/base/serial/psb_zipcsr2coo.f90 +++ b/base/serial/psb_zipcsr2coo.f90 @@ -38,6 +38,7 @@ Subroutine psb_zipcsr2coo(a,info) use psb_error_mod use psb_string_mod use psb_realloc_mod + use psb_serial_mod, psb_protect_name => psb_zipcsr2coo implicit none !....Parameters... @@ -86,6 +87,7 @@ Subroutine psb_zipcsr2coo(a,info) a%infoa(psb_upd_) = psb_upd_srch_ deallocate(itemp) + call psb_fixcoo(a,info) call psb_erractionrestore(err_act) return diff --git a/base/serial/psb_zspcnv.f90 b/base/serial/psb_zspcnv.f90 new file mode 100644 index 000000000..6cf6f462d --- /dev/null +++ b/base/serial/psb_zspcnv.f90 @@ -0,0 +1,553 @@ +!!$ +!!$ Parallel Sparse BLAS v2.0 +!!$ (C) Copyright 2006 Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari University of Rome Tor Vergata +!!$ +!!$ Redistribution and use in source and binary forms, with or without +!!$ modification, are permitted provided that the following conditions +!!$ are met: +!!$ 1. Redistributions of source code must retain the above copyright +!!$ notice, this list of conditions and the following disclaimer. +!!$ 2. Redistributions in binary form must reproduce the above copyright +!!$ notice, this list of conditions, and the following disclaimer in the +!!$ documentation and/or other materials provided with the distribution. +!!$ 3. The name of the PSBLAS group or the names of its contributors may +!!$ not be used to endorse or promote products derived from this +!!$ software without specific written permission. +!!$ +!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +!!$ POSSIBILITY OF SUCH DAMAGE. +!!$ +!!$ +! File: psb_dcsdp.f90 +! +! Subroutine: psb_dcsdp +! This subroutine performs the assembly of +! the local part of a sparse distributed matrix +! +! Parameters: +! a - type(). The input matrix to be assembled. +! b - type(). The assembled output matrix. +! info - integer. Eventually returns an error code. +! ifc - integer(optional). ??? +! check - character(optional). ??? +! trans - character(optional). ??? +! unitd - character(optional). ??? +! +subroutine psb_zspcnv2(a, b,info,afmt,upd,dupl) + use psb_const_mod + use psb_error_mod + use psb_spmat_type + use psb_string_mod + use psb_serial_mod, psb_protect_name => psb_zspcnv2 + implicit none + !....Parameters... + Type(psb_zspmat_type), intent(in) :: A + Type(psb_zspmat_type), intent(out) :: B + Integer, intent(out) :: info + Integer, intent(in), optional :: upd,dupl + character(len=*), optional, intent(in) :: afmt + + !...Locals... + complex(kind(1.d0)) :: d(1) + complex(kind(1.d0)), allocatable :: work(:) + type(psb_zspmat_type) :: temp_a + Integer :: nzr, ntry, ifc_, ia1_size,& + & ia2_size, aspk_size,size_req,n_row,n_col,upd_,dupl_ + integer :: ip1, ip2, nnz, iflag, ichk, nnzt,& + & ipc, i, count, err_act, i1, i2, ia + character :: check_,trans_,unitd_ + character(len=5) :: afmt_ + Integer, Parameter :: maxtry=8 + logical, parameter :: debug=.false. + character(len=20) :: name, ch_err + + name='psb_spcnv' + info = 0 + call psb_erractionsave(err_act) + + ntry=0 + + ifc_ = 2 + + + check_ = 'N' + trans_ = 'N' + unitd_ = 'U' + allocate(work(max(size(a%ia1),size(a%ia2))+max(a%m,b%m)+1000),stat=info) + + if (info /= 0) then + info=2040 + call psb_errpush(info,name) + goto 9999 + end if + + + if (present(upd)) then + call psb_sp_setifld(upd,psb_upd_,b,info) + end if + if (present(dupl)) then + call psb_sp_setifld(dupl,psb_dupl_,b,info) + end if + if (present(afmt)) then + afmt_ = afmt + else + afmt_ = psb_fidef_ + end if + + upd_ = psb_sp_getifld(psb_upd_,b,info) + select case(upd_) + case(psb_upd_srch_,psb_upd_perm_) + ! Legal value, do nothing + case default + ! Fix bad value + upd_ = psb_upd_dflt_ + call psb_sp_setifld(upd_,psb_upd_,b,info) + end select + + dupl_ = psb_sp_getifld(psb_dupl_,b,info) + select case(dupl_) + case(psb_dupl_ovwrt_,psb_dupl_add_,psb_dupl_err_) + ! Legal value, do nothing + case default + ! Fix bad value + dupl_ = psb_dupl_def_ + call psb_sp_setifld(dupl_,psb_dupl_,b,info) + end select + + ! ...matrix conversion... + b%m=a%m + b%k=a%k + b%fida=afmt_ + size_req = psb_sp_get_nnzeros(a) + if (debug) write(0,*) 'DCSDP : size_req 1:',size_req + ! + n_row=b%m + n_col=b%k + call psb_cest(afmt_,n_row,n_col,size_req,& + & ia1_size, ia2_size, aspk_size, upd_,info) + b%fida=afmt_ + + if (info /= psb_no_err_) then + info=4010 + ch_err='psb_cest' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + endif + if (.not.allocated(b%aspk).or.& + &.not.allocated(b%ia1).or.& + &.not.allocated(b%ia2).or.& + &.not.allocated(b%pl).or.& + &.not.allocated(b%pr)) then + call psb_sp_reall(b,ia1_size,ia2_size,aspk_size,info) + else if ((size(b%aspk) < aspk_size) .or.& + &(size(b%ia1) < ia1_size) .or.& + &(size(b%ia2) < ia2_size) .or.& + &(size(b%pl) < b%m) .or.& + &(size(b%pr) < b%k )) then + call psb_sp_reall(b,ia1_size,ia2_size,aspk_size,info) + endif + + if (info /= psb_no_err_) then + info=4010 + ch_err='psb_sp_reall' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + endif + + b%pl(:) = 0 + b%pr(:) = 0 + + b%descra = a%descra + + select case (tolower(a%fida)) + + case ('csr') + + select case (tolower(b%fida)) + + case ('csr') + + call zcrcr(trans_, a%m, a%k, unitd_, d, a%descra, a%aspk,& + & a%ia1, a%ia2, a%infoa, b%pl, b%descra, b%aspk, b%ia1,& + & b%ia2, b%infoa, b%pr, size(b%aspk), size(b%ia1),& + & size(b%ia2), work, size(work), info) + + + if (info/=0) then + info=4010 + ch_err='dcrcr' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + case ('jad') + + !...converting to JAD + !...output matrix may not be big enough + do + + call zcrjd(trans_, a%m, a%k, unitd_, d, a%descra, a%aspk,& + & a%ia1, a%ia2, a%infoa, b%pl, b%descra, b%aspk, b%ia1,& + & b%ia2, b%infoa, b%pr, size(b%aspk), size(b%ia1),& + & size(b%ia2), work, size(work), nzr, info) + if (info /= 0) then + call psb_errpush(4010,name,a_err='dcrjd') + goto 9999 + endif + + ntry = ntry + 1 + if (debug) then + write(0,*) 'On out from dcrjad ',nzr,info + end if + if (nzr == 0) exit + if (ntry > maxtry ) then + write(0,*) 'Tried reallocating for DCRJAD for ',maxtry,': giving up now.' + info=2040 + call psb_errpush(info,name) + goto 9999 + endif + call psb_cest(afmt_,n_row,n_col,nzr,& + & ia1_size, ia2_size, aspk_size, upd_,info) + call psb_sp_reall(b,ia1_size,ia2_size,aspk_size,info) + if (info /= 0) then + info=2040 + call psb_errpush(info,name) + goto 9999 + endif + + end do + + if (info/=0) then + call psb_errpush(info,name) + goto 9999 + end if + + case ('coo') + if (debug) write(0,*) 'Calling CRCO ',a%descra + call zcrco(trans_, a%m, a%k, unitd_, d, a%descra, a%aspk,& + & a%ia1, a%ia2, a%infoa, b%pl, b%descra, b%aspk, b%ia1,& + & b%ia2, b%infoa, b%pr, size(b%aspk), size(b%ia1),& + & size(b%ia2), work, size(work), info) + + if (info/=0) then + call psb_errpush(4010,name,a_err='dcrco') + goto 9999 + end if + case default + info=4010 + call psb_errpush(info,name) + goto 9999 + + end select + + case ('coo','coi') + + select case (tolower(b%fida)) + + case ('csr') + + call zcocr(trans_, a%m, a%k, unitd_, d, a%descra, a%aspk,& + & a%ia2, a%ia1, a%infoa, b%pl, b%descra, b%aspk, b%ia1,& + & b%ia2, b%infoa, b%pr, size(b%aspk), size(b%ia1),& + & size(b%ia2), work, 2*size(work), info) + + if (info/=0) then + call psb_errpush(4010,name,a_err='dcocr') + goto 9999 + end if + + case ('jad') + + call psb_sp_all(temp_a, size(b%ia1),size(b%ia2),size(b%aspk),info) + if (info /= 0) then + info=2040 + call psb_errpush(info,name) + goto 9999 + endif + temp_a%m = a%m + temp_a%k = a%k + temp_a%infoa=b%infoa + !...Dirty trick: converting to CSR and then to JAD + + call zcocr(trans_, a%m, a%k, unitd_, d, a%descra, a%aspk,& + & a%ia2, a%ia1, a%infoa, temp_a%pl, temp_a%descra, & + & temp_a%aspk, temp_a%ia1, temp_a%ia2, temp_a%infoa, temp_a%pr, & + & size(temp_a%aspk), size(temp_a%ia1),& + & size(temp_a%ia2), work, 2*size(work), info) + + if (info/=0) then + call psb_errpush(4010,name,a_err='dcocr') + goto 9999 + end if + + do + call zcrjd(trans_, temp_a%m, temp_a%k, unitd_, d, temp_a%descra, & + & temp_a%aspk, temp_a%ia1, temp_a%ia2, temp_a%infoa, & + & b%pl, b%descra, b%aspk, b%ia1, b%ia2, b%infoa, b%pr, & + & size(b%aspk), size(b%ia1),& + & size(b%ia2), work, size(work), nzr, info) + if (info/=0) then + call psb_errpush(4010,name,a_err='dcrjd') + goto 9999 + end if + + ntry = ntry + 1 + if (debug) then + write(0,*) 'On out from dcrjad ',nzr,info + end if + if (nzr == 0) exit + if (ntry > maxtry ) then + write(0,*) 'Tried reallocating for DCRJAD for ',maxtry,& + & ': giving up now.' + info=2040 + call psb_errpush(info,name) + goto 9999 + endif + + call psb_sp_reall(b,nzr,info,ifc=ifc_) + if (info /= 0) then + info=2040 + call psb_errpush(info,name) + goto 9999 + endif + + end do + + case ('coo') + + call zcoco(trans_, a%m, a%k, unitd_, d, a%descra, a%aspk,& + & a%ia1, a%ia2, a%infoa, b%pl, b%descra, b%aspk, b%ia1,& + & b%ia2, b%infoa, b%pr, size(b%aspk), size(b%ia1),& + & size(b%ia2), work, 2*size(work), info) + if (info/=0) then + call psb_errpush(4010,name,a_err='dcoco') + goto 9999 + end if + + case default + info=4010 + call psb_errpush(info,name) + goto 9999 + end select + + case default + info=4010 + call psb_errpush(info,name) + goto 9999 + + end select + + if (psb_sp_getifld(psb_upd_,b,info) /= psb_upd_perm_) & + & call psb_sp_trim(b,info) + + + call psb_sp_setifld(psb_spmat_asb_,psb_state_,b,info) + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act.eq.psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_zspcnv2 + + +subroutine psb_zspcnv1(a, info, afmt, upd, dupl) + + use psb_spmat_type + use psb_regen_mod + use psb_serial_mod, psb_protect_name => psb_zspcnv1 + use psb_const_mod + use psi_mod + use psb_error_mod + use psb_string_mod + !use psb_penv_mod + + implicit none + + + !...Parameters.... + type(psb_zspmat_type), intent (inout) :: a + integer, intent(out) :: info + integer,optional, intent(in) :: dupl, upd + character(len=*), optional, intent(in) :: afmt + + integer :: int_err(5) + type(psb_zspmat_type) :: atemp + integer :: np,me,n_col,iout, err_act + integer :: spstate + integer :: upd_, dupl_ + integer :: ictxt,n_row + logical, parameter :: debug=.false., debugwrt=.false. + character(len=20) :: name, ch_err + + info = 0 + int_err(1)=0 + name = 'psb_spcnv' + call psb_erractionsave(err_act) + + if (present(upd)) then + call psb_sp_setifld(upd,psb_upd_,a,info) + end if + if (present(dupl)) then + call psb_sp_setifld(dupl,psb_dupl_,a,info) + end if + + upd_ = psb_sp_getifld(psb_upd_,a,info) + select case(upd_) + case(psb_upd_srch_,psb_upd_perm_) + ! Legal value, do nothing + case default + ! Fix bad value + upd_ = psb_upd_dflt_ + call psb_sp_setifld(upd_,psb_upd_,a,info) + end select + + dupl_ = psb_sp_getifld(psb_dupl_,a,info) + select case(dupl_) + case(psb_dupl_ovwrt_,psb_dupl_add_,psb_dupl_err_) + ! Legal value, do nothing + case default + ! Fix bad value + dupl_ = psb_dupl_def_ + call psb_sp_setifld(dupl_,psb_dupl_,a,info) + end select + + + spstate = psb_sp_getifld(psb_state_,a,info) + if (info /= 0) then + goto 9999 + endif + if (debug) write(0,*) 'Sparse matrix state:',spstate,psb_spmat_bld_,psb_spmat_upd_ + if (spstate /= psb_spmat_upd_) then + ! Should we first figure out if we can do it in place? + if (debug) write(0,*) 'Update:',upd_,psb_upd_srch_,psb_upd_perm_ + if (upd_ == psb_upd_srch_) then + if (present(afmt)) then + select case (tolower(a%fida)) + case('coo') + select case(tolower(afmt)) + case('coo') + call psb_fixcoo(a,info) + goto 9998 + case('csr') + call psb_ipcoo2csr(a,info) + goto 9998 + case('csc') + call psb_ipcoo2csc(a,info) + goto 9998 + end select + case('csr') + select case(tolower(afmt)) + case('coo') + call psb_ipcsr2coo(a,info) + goto 9998 + end select + end select + end if + end if + + call psb_sp_clone(a,atemp,info) + if(info /= psb_no_err_) then + info=4010 + ch_err='psb_sp_clone' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + ! convert to user requested format after the temp copy + end if + + if (debugwrt) then + iout = 30+me + open(iout) + call psb_csprt(iout,atemp,head='Input mat') + close(iout) + endif + + ! Do the real conversion into the requested storage format + ! result is put in A + call psb_spcnv(atemp,a,info,afmt=afmt,upd=upd,dupl=dupl) + + IF (debug) WRITE (*, *) me,' ASB: From SPCNV',info,' ',A%FIDA + if (info /= psb_no_err_) then + info=4010 + ch_err='psb_csdp' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + endif + + if (debugwrt) then + iout = 60+me + open(iout) + call psb_csprt(iout,a,head='Output mat') + close(iout) + endif + + call psb_sp_free(atemp,info) + + else if (spstate == psb_spmat_upd_) then + ! + ! Second case: we come from an update loop. + ! + select case(tolower(a%fida)) + case('csr') + call csr_regen(a,info) + case ('coo','coi') + call coo_regen(a,info) + case('jad') + call jad_regen(a,info) + case default + info=136 + ch_err=a%fida + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end select + + + ! check on error retuned by dcsdp + if (info /= psb_no_err_) then + info = 4010 + ch_err='xx_regen' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + else + + info = 600 + call psb_errpush(info,name) + goto 9999 + if (debug) write(0,*) 'Sparse matrix state:',spstate,psb_spmat_bld_,psb_spmat_upd_ + + endif + +9998 continue + + call psb_sp_setifld(psb_spmat_asb_,psb_state_,a,info) + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act.eq.psb_act_abort_) then + call psb_error() + return + end if + return + +end subroutine psb_zspcnv1 diff --git a/base/serial/psb_zspgetrow.f90 b/base/serial/psb_zspgetrow.f90 index 1a06d54c0..fae8b7630 100644 --- a/base/serial/psb_zspgetrow.f90 +++ b/base/serial/psb_zspgetrow.f90 @@ -87,21 +87,19 @@ subroutine psb_zspgetrow(irw,a,nz,ia,ja,val,info,iren,lrw,append,nzin) nzin_ = 0 endif - if (toupper(a%fida) == 'CSR') then - call csr_getrow(irw_,a,nz,ia,ja,val,nzin_,append_,lrw_,info,iren) - - else if (toupper(a%fida) == 'COO') then - call coo_getrow(irw_,a,nz,ia,ja,val,nzin_,append_,lrw_,info,iren) - - else if (toupper(a%fida) == 'JAD') then - call jad_getrow(irw_,a,nz,ia,ja,val,nzin_,append_,lrw_,info,iren) - - else - info=136 - ch_err=a%fida(1:3) - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if + select case (tolower(a%fida)) + case ('csr') + call csr_getrow(irw_,a,nz,ia,ja,val,nzin_,append_,lrw_,info,iren) + case ('coo') + call coo_getrow(irw_,a,nz,ia,ja,val,nzin_,append_,lrw_,info,iren) + case ('jad') + call jad_getrow(irw_,a,nz,ia,ja,val,nzin_,append_,lrw_,info,iren) + case default + info=136 + ch_err=a%fida(1:3) + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end select if (info /= 0) goto 9999 !!$ call psb_erractionrestore(err_act) diff --git a/base/serial/psb_ztransc.f90 b/base/serial/psb_ztransc.f90 index 0bf1a6c2c..80b61651b 100644 --- a/base/serial/psb_ztransc.f90 +++ b/base/serial/psb_ztransc.f90 @@ -36,11 +36,11 @@ subroutine psb_ztransc(a,b,c,fmt) use psb_spmat_type use psb_tools_mod use psb_string_mod - use psb_realloc_mod - use psb_serial_mod, only : psb_ipcoo2csr, psb_ipcsr2coo, psb_fixcoo, psb_csdp + use psb_serial_mod, psb_protect_name => psb_ztransc implicit none - type(psb_zspmat_type) :: a,b + type(psb_zspmat_type), intent(inout) :: a + type(psb_zspmat_type), intent(out) :: b integer, optional :: c character(len=*), optional :: fmt @@ -59,55 +59,26 @@ subroutine psb_ztransc(a,b,c,fmt) else fmt_='CSR' endif - if (.true.) then - if (allocated(b%aspk)) call psb_sp_free(b,info) - b%fida = 'COO' - b%descra = 'GUN' - call psb_csdp(a,b,info) -!!$ write(0,*) 'Check from CSDP',b%m,b%k,b%fida,b%descra,b%infoa(psb_nnz_) - if (info /= 0) then - write(0,*) 'transp: info from CSDP ',info - return - end if - else - if (allocated(b%aspk)) call psb_sp_free(b,info) - call psb_sp_clone(a,b,info) - - if (b%fida=='CSR') then - call psb_ipcsr2coo(b,info) - else if (b%fida=='COO') then - ! do nothing - else - write(0,*) 'Unimplemented case in TRANSC ' - endif - endif + call psb_nullify_sp(b) + + call psb_spcnv(a,b,info,afmt='coo') + + if (info /= 0) then + write(0,*) 'transp: info from CSDP ',info + return + end if call psb_transfer(b%ia1,itmp,info) call psb_transfer(b%ia2,b%ia1,info) call psb_transfer(itmp,b%ia2,info) - b%m = a%k - b%k = a%m - do i=1, b%infoa(psb_nnz_) b%aspk(i) = conjg(b%aspk(i)) end do - if (fmt_=='CSR') then - call psb_ipcoo2csr(b,info) - b%fida='CSR' - else if (fmt_=='COO') then - call psb_fixcoo(b,info) - b%fida='COO' - else - call psb_nullify_sp(tmp) - call psb_sp_clone(b,tmp,info) - b%fida=fmt_ - call psb_csdp(tmp,b,info) - !!!!!! ADD HERE ERRPUSH!!! - call psb_sp_free(tmp,info) - - endif + b%m = a%k + b%k = a%m + call psb_spcnv(b,info,afmt=fmt_) return end subroutine psb_ztransc diff --git a/base/serial/psb_ztransp.f90 b/base/serial/psb_ztransp.f90 index cb831fad3..d5d57e5e6 100644 --- a/base/serial/psb_ztransp.f90 +++ b/base/serial/psb_ztransp.f90 @@ -36,11 +36,11 @@ subroutine psb_ztransp(a,b,c,fmt) use psb_spmat_type use psb_tools_mod use psb_string_mod - use psb_realloc_mod - use psb_serial_mod, only : psb_ipcoo2csr, psb_ipcsr2coo, psb_fixcoo, psb_csdp + use psb_serial_mod, psb_protect_name => psb_ztransp implicit none - type(psb_zspmat_type) :: a,b + type(psb_zspmat_type), intent(inout) :: a + type(psb_zspmat_type), intent(out) :: b integer, optional :: c character(len=*), optional :: fmt @@ -60,51 +60,21 @@ subroutine psb_ztransp(a,b,c,fmt) fmt_='CSR' endif - if (.true.) then - if (allocated(b%aspk)) call psb_sp_free(b,info) - b%fida = 'COO' - b%descra = 'GUN' - call psb_csdp(a,b,info) -!!$ write(0,*) 'Check from CSDP',b%m,b%k,b%fida,b%descra,b%infoa(psb_nnz_) - if (info /= 0) then - write(0,*) 'transp: info from CSDP ',info - return - end if - else - if (allocated(b%aspk)) call psb_sp_free(b,info) - call psb_sp_clone(a,b,info) - - if (b%fida=='CSR') then - call psb_ipcsr2coo(b,info) - else if (b%fida=='COO') then - ! do nothing - else - write(0,*) 'Unimplemented case in TRANSP ' - endif - endif - + call psb_nullify_sp(b) + + call psb_spcnv(a,b,info,afmt='coo') + + if (info /= 0) then + write(0,*) 'transp: info from CSDP ',info + return + end if call psb_transfer(b%ia1,itmp,info) call psb_transfer(b%ia2,b%ia1,info) call psb_transfer(itmp,b%ia2,info) b%m = a%k b%k = a%m - - if (fmt_=='CSR') then - call psb_ipcoo2csr(b,info) - b%fida='CSR' - else if (fmt_=='COO') then - call psb_fixcoo(b,info) - b%fida='COO' - else - call psb_nullify_sp(tmp) - call psb_sp_clone(b,tmp,info) - b%fida=fmt_ - call psb_csdp(tmp,b,info) - !!!!!! ADD HERE ERRPUSH!!! - call psb_sp_free(tmp,info) - - endif + call psb_spcnv(b,info,afmt=fmt_) return end subroutine psb_ztransp diff --git a/base/tools/Makefile b/base/tools/Makefile index 15ce1c7be..f7819d505 100644 --- a/base/tools/Makefile +++ b/base/tools/Makefile @@ -6,11 +6,11 @@ FOBJS = psb_dallc.o psb_dasb.o psb_dcsrp.o psb_cdprt.o \ psb_cdfree.o psb_cdins.o \ psb_cdren.o psb_cdrep.o psb_cdtransfer.o psb_get_overlap.o\ psb_dspalloc.o psb_dspasb.o \ - psb_dspcnv.o psb_dspfree.o psb_dspins.o psb_dsprn.o \ + psb_dspfree.o psb_dspins.o psb_dsprn.o \ psb_glob_to_loc.o psb_ialloc.o psb_iasb.o \ psb_ifree.o psb_iins.o psb_loc_to_glob.o\ psb_zallc.o psb_zasb.o psb_zfree.o psb_zins.o \ - psb_zspalloc.o psb_zspasb.o psb_zspcnv.o psb_zspfree.o\ + psb_zspalloc.o psb_zspasb.o psb_zspfree.o\ psb_zspins.o psb_zsprn.o psb_zcdovr.o psb_zgelp.o MPFOBJS = psb_dsphalo.o psb_zsphalo.o psb_icdasb.o psb_dcdovr.o psb_zcdovr.o diff --git a/base/tools/psb_dspalloc.f90 b/base/tools/psb_dspalloc.f90 index ec9105a17..facc5eefa 100644 --- a/base/tools/psb_dspalloc.f90 +++ b/base/tools/psb_dspalloc.f90 @@ -117,16 +117,6 @@ subroutine psb_dspalloc(a, desc_a, info, nnz) goto 9999 end if - ! set permutation matrices - a%pl(1)=0 - a%pr(1)=0 - ! set infoa fields - a%fida = 'COO' - a%descra = 'GUN' - a%infoa(psb_nnz_) = 0 - a%infoa(psb_srtd_) = 0 - a%infoa(psb_state_) = psb_spmat_bld_ - if (debug) write(0,*) 'spall: ', & & psb_cd_get_dectype(desc_a),psb_desc_bld_ diff --git a/base/tools/psb_dspasb.f90 b/base/tools/psb_dspasb.f90 index d9233ab10..3022898d2 100644 --- a/base/tools/psb_dspasb.f90 +++ b/base/tools/psb_dspasb.f90 @@ -60,12 +60,12 @@ subroutine psb_dspasb(a,desc_a, info, afmt, upd, dupl) type(psb_desc_type), intent(in) :: desc_a integer, intent(out) :: info integer,optional, intent(in) :: dupl, upd - character, optional, intent(in) :: afmt*5 + character(len=*), optional, intent(in) :: afmt !....Locals.... integer :: int_err(5) type(psb_dspmat_type) :: atemp integer :: np,me,n_col,iout, err_act - integer :: dscstate, spstate + integer :: spstate integer :: upd_, dupl_ integer :: ictxt,n_row logical, parameter :: debug=.false., debugwrt=.false. @@ -77,7 +77,6 @@ subroutine psb_dspasb(a,desc_a, info, afmt, upd, dupl) call psb_erractionsave(err_act) ictxt = psb_cd_get_context(desc_a) - dscstate = psb_cd_get_dectype(desc_a) n_row = psb_cd_get_local_rows(desc_a) n_col = psb_cd_get_local_cols(desc_a) @@ -89,9 +88,9 @@ subroutine psb_dspasb(a,desc_a, info, afmt, upd, dupl) goto 9999 endif - if (.not.psb_is_asb_dec(dscstate)) then + if (.not.psb_is_asb_desc(desc_a)) then info = 600 - int_err(1) = dscstate + int_err(1) = psb_cd_get_dectype(desc_a) call psb_errpush(info,name) goto 9999 endif @@ -105,121 +104,21 @@ subroutine psb_dspasb(a,desc_a, info, afmt, upd, dupl) ! ! First case: we come from a fresh build. ! + n_row = psb_cd_get_local_rows(desc_a) n_col = psb_cd_get_local_cols(desc_a) - - - ! - ! Second step: handle the local matrix part. - ! - if (present(upd)) then - upd_=upd - else - upd_ = psb_upd_dflt_ - endif - - if (present(dupl)) then - select case(dupl) - case (psb_dupl_ovwrt_,psb_dupl_add_,psb_dupl_err_) - dupl_ = dupl - case default - dupl_ = psb_dupl_def_ - end select - else - dupl_ = psb_dupl_def_ - endif - a%m = n_row a%k = n_col + end if - call psb_sp_clone(a,atemp,info) - if(info /= psb_no_err_) then - info=4010 - ch_err='psb_sp_clone' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - ! convert to user requested format after the temp copy - end if - - if (present(afmt)) then - a%fida = afmt - else - a%fida = '???' - endif - - if (debugwrt) then - iout = 30+me - open(iout) - call psb_csprt(iout,atemp,head='Input mat') - close(iout) - endif - - ! Do the real conversion into the requested storage format - ! result is put in A - call psb_csdp(atemp,a,info,ifc=2,upd=upd_,dupl=dupl_) - - IF (debug) WRITE (*, *) me,' ASB: From DCSDP',info,' ',A%FIDA - if (info /= psb_no_err_) then - info=4010 - ch_err='psb_csdp' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - endif - - if (debugwrt) then - iout = 60+me - open(iout) - call psb_csprt(iout,a,head='Output mat') - close(iout) - endif - - call psb_sp_free(atemp,info) - - - else if (spstate == psb_spmat_upd_) then - ! - ! Second case: we come from an update loop. - ! - - - ! Right now, almost nothing to be done, but this - ! may change in the future - ! as we revise the implementation of the update routine. - call psb_sp_all(atemp,1,info) - atemp%m=a%m - atemp%k=a%k - ! check on allocation - if (info /= psb_no_err_) then - info=4010 - ch_err='psb_sp_all' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - endif - - call psb_csdp(atemp,a,info,check='R') - ! check on error retuned by dcsdp - if (info /= psb_no_err_) then - info = 4010 - ch_err='psb_csdp90' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - - call psb_sp_free(atemp,info) - if (info /= psb_no_err_) then - info = 4010 - ch_err='sp_free' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - - else + call psb_spcnv(a,info,afmt=afmt,upd=upd,dupl=dupl) - info = 600 - call psb_errpush(info,name) + IF (debug) WRITE (*, *) me,' ASB: From DCSDP',info,' ',A%FIDA + if (info /= psb_no_err_) then + info=4010 + ch_err='psb_spcnv' + call psb_errpush(info,name,a_err=ch_err) goto 9999 - if (debug) write(0,*) 'Sparse matrix state:',spstate,psb_spmat_bld_,psb_spmat_upd_ - endif call psb_erractionrestore(err_act) diff --git a/base/tools/psb_dspcnv.f90 b/base/tools/psb_dspcnv.f90 deleted file mode 100644 index 96a99ea89..000000000 --- a/base/tools/psb_dspcnv.f90 +++ /dev/null @@ -1,242 +0,0 @@ -!!$ -!!$ Parallel Sparse BLAS v2.0 -!!$ (C) Copyright 2006 Salvatore Filippone University of Rome Tor Vergata -!!$ Alfredo Buttari University of Rome Tor Vergata -!!$ -!!$ Redistribution and use in source and binary forms, with or without -!!$ modification, are permitted provided that the following conditions -!!$ are met: -!!$ 1. Redistributions of source code must retain the above copyright -!!$ notice, this list of conditions and the following disclaimer. -!!$ 2. Redistributions in binary form must reproduce the above copyright -!!$ notice, this list of conditions, and the following disclaimer in the -!!$ documentation and/or other materials provided with the distribution. -!!$ 3. The name of the PSBLAS group or the names of its contributors may -!!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. -!!$ -!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -!!$ POSSIBILITY OF SUCH DAMAGE. -!!$ -!!$ -! File: psb_dspcnv.f90 -! -! Subroutine: psb_dspcnv -! converts sparse matrix a into b -! -! Parameters: -! a - type(). The sparse input matrix. -! b - type(). The sparse output matrix. -! desc_a - type(). The communication descriptor. -! info - integer. Eventually returns an error code. -! -subroutine psb_dspcnv(a,b,desc_a,info) - - use psb_descriptor_type - use psb_spmat_type - use psb_realloc_mod - use psb_serial_mod - use psb_const_mod - use psb_error_mod - use psb_penv_mod - implicit none - interface dcsdp - - subroutine dcsdp(check,trans,m,n,unitd,d,& - & fida,descra,a,ia1,ia2,infoa,& - & pl,fidh,descrh,h,ih1,ih2,infoh,pr,lh,lh1,lh2,& - & work,lwork,ierror) - integer, intent(in) :: lh, lwork, lh1, lh2, m, n - integer, intent(out) :: ierror - character, intent(in) :: check, trans, unitd - real(kind(1.d0)), intent(in) :: d(*), a(*) - real(kind(1.d0)), intent(out) :: h(*) - real(kind(1.d0)), intent(inout) :: work(*) - integer, intent(in) :: ia1(*), ia2(*), infoa(*) - integer, intent(out) :: ih1(*), ih2(*), pl(*),pr(*), infoh(*) - character, intent(in) :: fida*5, descra*11 - character, intent(out) :: fidh*5, descrh*11 - end subroutine dcsdp - end interface - - - interface dcsrp - - subroutine dcsrp(trans,m,n,fida,descra,ia1,ia2,& - & infoa,p,work,lwork,ierror) - integer, intent(in) :: m, n, lwork - integer, intent(out) :: ierror - character, intent(in) :: trans - real(kind(1.d0)), intent(inout) :: work(*) - integer, intent(in) :: p(*) - integer, intent(inout) :: ia1(*), ia2(*), infoa(*) - character, intent(in) :: fida*5, descra*11 - end subroutine dcsrp - end interface - - interface dcsprt - subroutine dcsprt(m,n,fida,descra,a,ia1,ia2,infoa ,iout,ierror) - integer, intent(in) :: iout,m, n - integer, intent(out) :: ierror - real(kind(1.d0)), intent(in) :: a(*) - integer, intent(in) :: ia1(*), ia2(*), infoa(*) - character, intent(in) :: fida*5, descra*11 - end subroutine dcsprt - end interface - - !...parameters.... - type(psb_dspmat_type), intent(in) :: a - type(psb_dspmat_type), intent(out) :: b - type(psb_desc_type), intent(in) :: desc_a - integer, intent(out) :: info - !....locals.... - integer :: int_err(5) - real(kind(1.d0)) :: d(1) - integer,allocatable :: i_temp(:) - real(kind(1.d0)),allocatable :: work_dcsdp(:) - integer :: ia1_size,ia2_size,aspk_size,& - & err_act,i,np,me,n_col,l_dcsdp - integer :: lwork_dcsdp,dectype - integer :: ictxt,n_row - character :: check*1, trans*1, unitd*1 - - logical, parameter :: debug=.false. - character(len=20) :: name, ch_err - - if(psb_get_errstatus() /= 0) return - info=0 - name = 'psb_dspcnv' - call psb_erractionsave(err_act) - - - ictxt = psb_cd_get_context(desc_a) - dectype = psb_cd_get_dectype(desc_a) - n_row = psb_cd_get_local_rows(desc_a) - n_col = psb_cd_get_local_cols(desc_a) - - ! check on blacs grid - call psb_info(ictxt, me, np) - if (np == -1) then - info = 2010 - call psb_errpush(info,name) - goto 9999 - endif - - if (.not.psb_is_ok_dec((dectype))) then - info = 600 - int_err(1) = dectype - call psb_errpush(info,name,i_err=int_err) - goto 9999 - endif - - if (debug) write (0, *) name,' begin matrix assembly...' - - ia1_size = size(a%ia1) - ia2_size = size(a%ia2) - aspk_size = size(a%aspk) - - if (debug) write (0, *) name,' sizes',ia1_size,ia2_size,aspk_size - - ! convert only without check - check='N' - trans='N' - unitd='U' - - ! l_dcsdp is the size requested for dcsdp procedure - l_dcsdp=(ia1_size+100) - - b%m=n_row - b%k=n_col - call psb_sp_all(b,ia1_size,ia2_size,aspk_size,info) - allocate(work_dcsdp(l_dcsdp),stat=info) - if (info /= 0) then - info=4025 - int_err(1)=l_dcsdp - call psb_errpush(info, name, i_err=int_err,a_err='real(kind(1.d0))') - goto 9999 - endif - - lwork_dcsdp=size(work_dcsdp) - ! set infoa(1) to nnzero - b%pl(:) = 0 - b%pr(:) = 0 - - if (debug) write (0, *) name,' calling dcsdp',lwork_dcsdp,& - &size(work_dcsdp) - ! convert aspk,ia1,ia2 in requested representation mode - if (debug) then - - endif - ! result is put in b - call dcsdp(check,trans,n_row,n_col,unitd,d,a%fida,a%descra,& - & a%aspk,a%ia1,a%ia2,a%infoa,& - & b%pl,b%fida,b%descra,b%aspk,b%ia1,b%ia2,b%infoa,b%pr,& - & size(b%aspk),size(b%ia1),size(b%ia2),& - & work_dcsdp,size(work_dcsdp),info) - - if(info /= psb_no_err_) then - info=4010 - ch_err='dcsdp' - call psb_errpush(info, name, a_err=ch_err) - goto 9999 - end if - - ! - ! hmmm, have to fix b%pl and b%pr according to a%pl and a%pr!!! - ! should work (crossed fingers :-) - if (a%pr(1) /= 0) then - if (b%pr(1) /= 0) then - allocate(i_temp(n_col)) - do i=1, n_col - i_temp(i) = b%pr(a%pr(i)) - enddo - call psb_transfer(i_temp,b%pr,info) - else - allocate(i_temp(n_col)) - do i=1, n_col - i_temp(i) = a%pr(i) - enddo - call psb_transfer(i_temp,b%pr,info) - endif - endif - if (a%pl(1) /= 0) then - if (b%pr(1) /= 0) then - allocate(i_temp(n_row)) - do i=1, n_row - i_temp(i) = a%pl(b%pl(i)) - enddo - call psb_transfer(i_temp,b%pl,info) - else - allocate(i_temp(n_row)) - do i=1, n_row - i_temp(i) = a%pl(i) - enddo - call psb_transfer(i_temp,b%pl,info) - endif - endif - - - if (debug) write (0, *) me,name,' from dcsdp ',& - &b%fida,' pl ', b%pl(:),'pr',b%pr(:) - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error(ictxt) - return - end if - return - -end subroutine psb_dspcnv diff --git a/base/tools/psb_zspalloc.f90 b/base/tools/psb_zspalloc.f90 index a61e0cb35..dad3d5dbc 100644 --- a/base/tools/psb_zspalloc.f90 +++ b/base/tools/psb_zspalloc.f90 @@ -115,16 +115,6 @@ subroutine psb_zspalloc(a, desc_a, info, nnz) goto 9999 end if - ! set permutation matrices - a%pl(1)=0 - a%pr(1)=0 - ! set infoa fields - a%fida = 'COO' - a%descra = 'GUN' - a%infoa(psb_nnz_) = 0 - a%infoa(psb_srtd_) = 0 - a%infoa(psb_state_) = psb_spmat_bld_ - if (debug) write(0,*) 'spall: ', & & psb_cd_get_dectype(desc_a),psb_desc_bld_ diff --git a/base/tools/psb_zspasb.f90 b/base/tools/psb_zspasb.f90 index c6f0378b2..ac56281b0 100644 --- a/base/tools/psb_zspasb.f90 +++ b/base/tools/psb_zspasb.f90 @@ -60,7 +60,7 @@ subroutine psb_zspasb(a,desc_a, info, afmt, upd, dupl) type(psb_desc_type), intent(in) :: desc_a integer, intent(out) :: info integer,optional, intent(in) :: dupl, upd - character, optional, intent(in) :: afmt*5 + character(len=*), optional, intent(in) :: afmt !....Locals.... integer :: int_err(5) type(psb_zspmat_type) :: atemp @@ -107,118 +107,18 @@ subroutine psb_zspasb(a,desc_a, info, afmt, upd, dupl) n_row = psb_cd_get_local_rows(desc_a) n_col = psb_cd_get_local_cols(desc_a) - - ! - ! Second step: handle the local matrix part. - ! - if (present(upd)) then - upd_=upd - else - upd_ = psb_upd_dflt_ - endif - - if (present(dupl)) then - select case(dupl) - case (psb_dupl_ovwrt_,psb_dupl_add_,psb_dupl_err_) - dupl_ = dupl - case default - dupl_ = psb_dupl_def_ - end select - else - dupl_ = psb_dupl_def_ - endif - a%m = n_row a%k = n_col + end if - call psb_sp_clone(a,atemp,info) - if(info /= psb_no_err_) then - info=4010 - ch_err='psb_sp_clone' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - ! convert to user requested format after the temp copy - end if - - if (present(afmt)) then - a%fida = afmt - else - a%fida = '???' - endif - - if (debugwrt) then - iout = 30+me - open(iout) - call psb_csprt(iout,atemp,head='Input mat') - close(iout) - endif - - ! Do the real conversion into the requested storage format - ! result is put in A - call psb_csdp(atemp,a,info,ifc=2,upd=upd_,dupl=dupl_) - - IF (debug) WRITE (*, *) me,' ASB: From ZCSDP',info,' ',A%FIDA - if (info /= psb_no_err_) then - info=4010 - ch_err='psb_csdp' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - endif - - if (debugwrt) then - iout = 60+me - open(iout) - call psb_csprt(iout,a,head='Output mat') - close(iout) - endif - - call psb_sp_free(atemp,info) - - - else if (spstate == psb_spmat_upd_) then - ! - ! Second case: we come from an update loop. - ! - - - ! Right now, almost nothing to be done, but this - ! may change in the future - ! as we revise the implementation of the update routine. - call psb_sp_all(atemp,1,info) - atemp%m=a%m - atemp%k=a%k - ! check on allocation - if (info /= psb_no_err_) then - info=4010 - ch_err='psb_sp_all' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - endif - - call psb_csdp(atemp,a,info,check='R') - ! check on error retuned by zcsdp - if (info /= psb_no_err_) then - info = 4010 - ch_err='psb_csdp90' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - - call psb_sp_free(atemp,info) - if (info /= psb_no_err_) then - info = 4010 - ch_err='sp_free' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - - else + call psb_spcnv(a,info,afmt=afmt,upd=upd,dupl=dupl) - info = 600 - call psb_errpush(info,name) + IF (debug) WRITE (*, *) me,' ASB: From DCSDP',info,' ',A%FIDA + if (info /= psb_no_err_) then + info=4010 + ch_err='psb_spcnv' + call psb_errpush(info,name,a_err=ch_err) goto 9999 - if (debug) write(0,*) 'Sparse matrix state:',spstate,psb_spmat_bld_,psb_spmat_upd_ - endif call psb_erractionrestore(err_act) diff --git a/base/tools/psb_zspcnv.f90 b/base/tools/psb_zspcnv.f90 deleted file mode 100644 index 96b1f6a14..000000000 --- a/base/tools/psb_zspcnv.f90 +++ /dev/null @@ -1,243 +0,0 @@ -!!$ -!!$ Parallel Sparse BLAS v2.0 -!!$ (C) Copyright 2006 Salvatore Filippone University of Rome Tor Vergata -!!$ Alfredo Buttari University of Rome Tor Vergata -!!$ -!!$ Redistribution and use in source and binary forms, with or without -!!$ modification, are permitted provided that the following conditions -!!$ are met: -!!$ 1. Redistributions of source code must retain the above copyright -!!$ notice, this list of conditions and the following disclaimer. -!!$ 2. Redistributions in binary form must reproduce the above copyright -!!$ notice, this list of conditions, and the following disclaimer in the -!!$ documentation and/or other materials provided with the distribution. -!!$ 3. The name of the PSBLAS group or the names of its contributors may -!!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. -!!$ -!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -!!$ POSSIBILITY OF SUCH DAMAGE. -!!$ -!!$ -! File: psb_zspcnv.f90 -! -! Subroutine: psb_zspcnv -! converts sparse matrix a into b -! -! Parameters: -! a - type(). The sparse input matrix. -! b - type(). The sparse output matrix. -! desc_a - type(). The communication descriptor. -! info - integer. Eventually returns an error code. -! -subroutine psb_zspcnv(a,b,desc_a,info) - - use psb_descriptor_type - use psb_spmat_type - use psb_realloc_mod - use psb_serial_mod - use psb_const_mod - use psb_error_mod - use psb_penv_mod - implicit none - - interface zcsdp - - subroutine zcsdp(check,trans,m,n,unitd,d,& - & fida,descra,a,ia1,ia2,infoa,& - & pl,fidh,descrh,h,ih1,ih2,infoh,pr,lh,lh1,lh2,& - & work,lwork,ierror) - integer, intent(in) :: lh, lwork, lh1, lh2, m, n - integer, intent(out) :: ierror - character, intent(in) :: check, trans, unitd - complex(kind(1.d0)), intent(in) :: d(*), a(*) - complex(kind(1.d0)), intent(out) :: h(*) - complex(kind(1.d0)), intent(inout) :: work(*) - integer, intent(in) :: ia1(*), ia2(*), infoa(*) - integer, intent(out) :: ih1(*), ih2(*), pl(*),pr(*), infoh(*) - character, intent(in) :: fida*5, descra*11 - character, intent(out) :: fidh*5, descrh*11 - end subroutine zcsdp - end interface - - - interface zcsrp - - subroutine zcsrp(trans,m,n,fida,descra,ia1,ia2,& - & infoa,p,work,lwork,ierror) - integer, intent(in) :: m, n, lwork - integer, intent(out) :: ierror - character, intent(in) :: trans - complex(kind(1.d0)), intent(inout) :: work(*) - integer, intent(in) :: p(*) - integer, intent(inout) :: ia1(*), ia2(*), infoa(*) - character, intent(in) :: fida*5, descra*11 - end subroutine zcsrp - end interface - - interface zcsprt - subroutine zcsprt(m,n,fida,descra,a,ia1,ia2,infoa ,iout,ierror) - integer, intent(in) :: iout,m, n - integer, intent(out) :: ierror - complex(kind(1.d0)), intent(in) :: a(*) - integer, intent(in) :: ia1(*), ia2(*), infoa(*) - character, intent(in) :: fida*5, descra*11 - end subroutine zcsprt - end interface - - !...parameters.... - type(psb_zspmat_type), intent(in) :: a - type(psb_zspmat_type), intent(out) :: b - type(psb_desc_type), intent(in) :: desc_a - integer, intent(out) :: info - !....locals.... - integer :: int_err(5) - complex(kind(1.d0)) :: d(1) - integer,allocatable :: i_temp(:) - complex(kind(1.d0)),allocatable :: work_dcsdp(:) - integer :: ia1_size,ia2_size,aspk_size,err_act& - & ,i,err,np,me,n_col,l_dcsdp - integer :: lwork_dcsdp,dectype - integer :: ictxt,n_row - character :: check*1, trans*1, unitd*1 - - logical, parameter :: debug=.false. - character(len=20) :: name, ch_err - - if(psb_get_errstatus() /= 0) return - info=0 - name = 'psb_zspcnv' - call psb_erractionsave(err_act) - - - ictxt = psb_cd_get_context(desc_a) - dectype = psb_cd_get_dectype(desc_a) - n_row = psb_cd_get_local_rows(desc_a) - n_col = psb_cd_get_local_cols(desc_a) - - ! check on blacs grid - call psb_info(ictxt, me, np) - if (np == -1) then - info = 2010 - call psb_errpush(info,name) - goto 9999 - endif - - if (.not.psb_is_ok_dec((dectype))) then - info = 600 - int_err(1) = dectype - call psb_errpush(info,name,i_err=int_err) - goto 9999 - endif - - if (debug) write (0, *) name,' begin matrix assembly...' - - ia1_size = size(a%ia1) - ia2_size = size(a%ia2) - aspk_size = size(a%aspk) - - if (debug) write (0, *) name,' sizes',ia1_size,ia2_size,aspk_size - - ! convert only without check - check='N' - trans='N' - unitd='U' - - ! l_dcsdp is the size requested for dcsdp procedure - l_dcsdp=(ia1_size+100) - - b%m=n_row - b%k=n_col - call psb_sp_all(b,ia1_size,ia2_size,aspk_size,info) - allocate(work_dcsdp(l_dcsdp),stat=info) - if (info /= 0) then - info=4025 - int_err(1)=l_dcsdp - call psb_errpush(info, name, i_err=int_err,a_err='real(kind(1.d0))') - goto 9999 - endif - - lwork_dcsdp=size(work_dcsdp) - ! set infoa(1) to nnzero - b%pl(:) = 0 - b%pr(:) = 0 - - if (debug) write (0, *) name,' calling dcsdp',lwork_dcsdp,& - &size(work_dcsdp) - ! convert aspk,ia1,ia2 in requested representation mode - if (debug) then - - endif - ! result is put in b - call zcsdp(check,trans,n_row,n_col,unitd,d,a%fida,a%descra,& - & a%aspk,a%ia1,a%ia2,a%infoa,& - & b%pl,b%fida,b%descra,b%aspk,b%ia1,b%ia2,b%infoa,b%pr,& - & size(b%aspk),size(b%ia1),size(b%ia2),& - & work_dcsdp,size(work_dcsdp),info) - - if(info /= psb_no_err_) then - info=4010 - ch_err='zcsdp' - call psb_errpush(info, name, a_err=ch_err) - goto 9999 - end if - - ! - ! hmmm, have to fix b%pl and b%pr according to a%pl and a%pr!!! - ! should work (crossed fingers :-) - if (a%pr(1) /= 0) then - if (b%pr(1) /= 0) then - allocate(i_temp(n_col)) - do i=1, n_col - i_temp(i) = b%pr(a%pr(i)) - enddo - call psb_transfer(i_temp,b%pr,info) - else - allocate(i_temp(n_col)) - do i=1, n_col - i_temp(i) = a%pr(i) - enddo - call psb_transfer(i_temp,b%pr,info) - endif - endif - if (a%pl(1) /= 0) then - if (b%pr(1) /= 0) then - allocate(i_temp(n_row)) - do i=1, n_row - i_temp(i) = a%pl(b%pl(i)) - enddo - call psb_transfer(i_temp,b%pl,info) - else - allocate(i_temp(n_row)) - do i=1, n_row - i_temp(i) = a%pl(i) - enddo - call psb_transfer(i_temp,b%pl,info) - endif - endif - - - if (debug) write (0, *) me,name,' from zcsdp ',& - &b%fida,' pl ', b%pl(:),'pr',b%pr(:) - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error(ictxt) - return - end if - return - -end subroutine psb_zspcnv diff --git a/krylov/psb_zgmresr.f90 b/krylov/psb_zgmresr.f90 index 5ab6ed799..237ac9435 100644 --- a/krylov/psb_zgmresr.f90 +++ b/krylov/psb_zgmresr.f90 @@ -437,138 +437,122 @@ Subroutine psb_zgmresr(a,prec,b,x,eps,desc_a,info,& contains - function safe_dn2(a,b) - real(kind(1.d0)), intent(in) :: a, b - real(kind(1.d0)) :: safe_dn2 - real(kind(1.d0)) :: t - - t = max(abs(a),abs(b)) - if (t==0.d0) then - safe_dn2 = 0.d0 - else - safe_dn2 = t * sqrt(abs(a/t)**2 + abs(b/t)**2) - endif - return - end function safe_dn2 - -End Subroutine psb_zgmresr - - -subroutine zrot( n, cx, incx, cy, incy, c, s ) - ! - ! -- lapack auxiliary routine (version 3.0) -- - ! univ. of tennessee, univ. of california berkeley, nag ltd., - ! courant institute, argonne national lab, and rice university - ! october 31, 1992 - ! - ! .. scalar arguments .. - integer incx, incy, n - real(kind(1.d0)) c - complex(kind(1.d0)) s - ! .. - ! .. array arguments .. - complex(kind(1.d0)) cx( * ), cy( * ) - ! .. - ! - ! purpose - ! ======= - ! - ! zrot applies a plane rotation, where the cos (c) is real and the - ! sin (s) is complex, and the vectors cx and cy are complex. - ! - ! arguments - ! ========= - ! - ! n (input) integer - ! the number of elements in the vectors cx and cy. - ! - ! cx (input/output) complex*16 array, dimension (n) - ! on input, the vector x. - ! on output, cx is overwritten with c*x + s*y. - ! - ! incx (input) integer - ! the increment between successive values of cy. incx <> 0. - ! - ! cy (input/output) complex*16 array, dimension (n) - ! on input, the vector y. - ! on output, cy is overwritten with -conjg(s)*x + c*y. - ! - ! incy (input) integer - ! the increment between successive values of cy. incx <> 0. - ! - ! c (input) double precision - ! s (input) complex*16 - ! c and s define a rotation - ! [ c s ] - ! [ -conjg(s) c ] - ! where c*c + s*conjg(s) = 1.0. - ! - ! ===================================================================== - ! - ! .. local scalars .. - integer i, ix, iy - complex(kind(1.d0)) stemp - ! .. - ! .. intrinsic functions .. - intrinsic dconjg - ! .. - ! .. executable statements .. - ! - if( n.le.0 ) return - if( incx.eq.1 .and. incy.eq.1 ) then + subroutine zrot( n, cx, incx, cy, incy, c, s ) ! - ! code for both increments equal to 1 + ! -- lapack auxiliary routine (version 3.0) -- + ! univ. of tennessee, univ. of california berkeley, nag ltd., + ! courant institute, argonne national lab, and rice university + ! october 31, 1992 ! - do i = 1, n - stemp = c*cx(i) + s*cy(i) - cy(i) = c*cy(i) - dconjg(s)*cx(i) - cx(i) = stemp - end do - else + ! .. scalar arguments .. + integer incx, incy, n + real(kind(1.d0)) c + complex(kind(1.d0)) s + ! .. + ! .. array arguments .. + complex(kind(1.d0)) cx( * ), cy( * ) + ! .. ! - ! code for unequal increments or equal increments not equal to 1 + ! purpose + ! ======= ! - ix = 1 - iy = 1 - if( incx.lt.0 )ix = ( -n+1 )*incx + 1 - if( incy.lt.0 )iy = ( -n+1 )*incy + 1 - do i = 1, n - stemp = c*cx(ix) + s*cy(iy) - cy(iy) = c*cy(iy) - dconjg(s)*cx(ix) - cx(ix) = stemp - ix = ix + incx - iy = iy + incy - end do - end if - return - return -end subroutine zrot -! -! -subroutine zrotg(ca,cb,c,s) - complex(kind(1.d0)) ca,cb,s - real(kind(1.d0)) c - real(kind(1.d0)) norm,scale - complex(kind(1.d0)) alpha - ! - if (cdabs(ca) == 0.0d0) then + ! zrot applies a plane rotation, where the cos (c) is real and the + ! sin (s) is complex, and the vectors cx and cy are complex. + ! + ! arguments + ! ========= ! - c = 0.0d0 - s = (1.0d0,0.0d0) - ca = cb + ! n (input) integer + ! the number of elements in the vectors cx and cy. + ! + ! cx (input/output) complex*16 array, dimension (n) + ! on input, the vector x. + ! on output, cx is overwritten with c*x + s*y. + ! + ! incx (input) integer + ! the increment between successive values of cy. incx <> 0. + ! + ! cy (input/output) complex*16 array, dimension (n) + ! on input, the vector y. + ! on output, cy is overwritten with -conjg(s)*x + c*y. + ! + ! incy (input) integer + ! the increment between successive values of cy. incx <> 0. + ! + ! c (input) double precision + ! s (input) complex*16 + ! c and s define a rotation + ! [ c s ] + ! [ -conjg(s) c ] + ! where c*c + s*conjg(s) = 1.0. + ! + ! ===================================================================== + ! + ! .. local scalars .. + integer i, ix, iy + complex(kind(1.d0)) stemp + ! .. + ! .. intrinsic functions .. + intrinsic dconjg + ! .. + ! .. executable statements .. + ! + if( n.le.0 ) return + if( incx.eq.1 .and. incy.eq.1 ) then + ! + ! code for both increments equal to 1 + ! + do i = 1, n + stemp = c*cx(i) + s*cy(i) + cy(i) = c*cy(i) - dconjg(s)*cx(i) + cx(i) = stemp + end do + else + ! + ! code for unequal increments or equal increments not equal to 1 + ! + ix = 1 + iy = 1 + if( incx.lt.0 )ix = ( -n+1 )*incx + 1 + if( incy.lt.0 )iy = ( -n+1 )*incy + 1 + do i = 1, n + stemp = c*cx(ix) + s*cy(iy) + cy(iy) = c*cy(iy) - dconjg(s)*cx(ix) + cx(ix) = stemp + ix = ix + incx + iy = iy + incy + end do + end if return - end if + return + end subroutine zrot ! - - scale = cdabs(ca) + cdabs(cb) - norm = scale*dsqrt((cdabs(ca/dcmplx(scale,0.0d0)))**2 +& - & (cdabs(cb/dcmplx(scale,0.0d0)))**2) - alpha = ca /cdabs(ca) - c = cdabs(ca) / norm - s = alpha * dconjg(cb) / norm - ca = alpha * norm ! + subroutine zrotg(ca,cb,c,s) + complex(kind(1.d0)) ca,cb,s + real(kind(1.d0)) c + real(kind(1.d0)) norm,scale + complex(kind(1.d0)) alpha + ! + if (cdabs(ca) == 0.0d0) then + ! + c = 0.0d0 + s = (1.0d0,0.0d0) + ca = cb + return + end if + ! - return -end subroutine zrotg + scale = cdabs(ca) + cdabs(cb) + norm = scale*dsqrt((cdabs(ca/dcmplx(scale,0.0d0)))**2 +& + & (cdabs(cb/dcmplx(scale,0.0d0)))**2) + alpha = ca /cdabs(ca) + c = cdabs(ca) / norm + s = alpha * dconjg(cb) / norm + ca = alpha * norm + ! + + return + end subroutine zrotg +End Subroutine psb_zgmresr